/[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.113 by rtoy, Thu Jun 18 17:34:58 2009 UTC revision 1.113.10.7 by rtoy, Tue Mar 2 00:39:16 2010 UTC
# Line 16  Line 16 
16  ;;; Modified by Bill Chiles to adhere to the wall.  ;;; Modified by Bill Chiles to adhere to the wall.
17  ;;;  ;;;
18  (in-package "LISP")  (in-package "LISP")
19    (intl:textdomain "cmucl")
20    
21  (export '(defvar defparameter defconstant when unless setf  (export '(defvar defparameter defconstant when unless setf
22            defsetf psetf shiftf rotatef push pushnew pop            defsetf psetf shiftf rotatef push pushnew pop
23            incf decf remf case typecase with-open-file            incf decf remf case typecase with-open-file
# Line 39  Line 41 
41  ;;; into declarations anymore.  ;;; into declarations anymore.
42  ;;;  ;;;
43  (defun parse-body (body environment &optional (doc-string-allowed t))  (defun parse-body (body environment &optional (doc-string-allowed t))
44    "This function is to parse the declarations and doc-string out of the body of    _N"This function is to parse the declarations and doc-string out of the body of
45    a defun-like form.  Body is the list of stuff which is to be parsed.    a defun-like form.  Body is the list of stuff which is to be parsed.
46    Environment is ignored.  If Doc-String-Allowed is true, then a doc string    Environment is ignored.  If Doc-String-Allowed is true, then a doc string
47    will be parsed out of the body and returned.  If it is false then a string    will be parsed out of the body and returned.  If it is false then a string
# Line 85  Line 87 
87              (restart-case              (restart-case
88                  (error 'lisp::package-locked-error                  (error 'lisp::package-locked-error
89                         :package package                         :package package
90                         :format-control "defining macro ~A"                         :format-control _"defining macro ~A"
91                         :format-arguments (list name))                         :format-arguments (list name))
92                (continue ()                (continue ()
93                  :report "Ignore the lock and continue")                  :report (lambda (stream)
94                              (write-string _"Ignore the lock and continue" stream)))
95                (unlock-package ()                (unlock-package ()
96                  :report "Disable the package's definition-lock then continue"                  :report (lambda (stream)
97                              (write-string _"Disable the package's definition-lock then continue" stream))
98                  (setf (ext:package-definition-lock package) nil))                  (setf (ext:package-definition-lock package) nil))
99                (unlock-all ()                (unlock-all ()
100                  :report "Unlock all packages, then continue"                  :report (lambda (stream)
101                              (write-string _"Unlock all packages, then continue" stream))
102                  (lisp::unlock-all-packages))))))))                  (lisp::unlock-all-packages))))))))
103    (let ((whole (gensym "WHOLE-"))    (let ((whole (gensym "WHOLE-"))
104          (environment (gensym "ENV-")))          (environment (gensym "ENV-")))
# Line 140  Line 145 
145  ;;;; DEFINE-COMPILER-MACRO  ;;;; DEFINE-COMPILER-MACRO
146    
147  (defmacro define-compiler-macro (name lambda-list &body body)  (defmacro define-compiler-macro (name lambda-list &body body)
148    "Define a compiler-macro for NAME."    _N"Define a compiler-macro for NAME."
149    (let ((whole (gensym "WHOLE-"))    (let ((whole (gensym "WHOLE-"))
150          (environment (gensym "ENV-")))          (environment (gensym "ENV-")))
151      (multiple-value-bind      (multiple-value-bind
# Line 184  Line 189 
189  (defun %define-symbol-macro (name expansion)  (defun %define-symbol-macro (name expansion)
190    (unless (symbolp name)    (unless (symbolp name)
191      (error 'simple-type-error :datum name :expected-type 'symbol      (error 'simple-type-error :datum name :expected-type 'symbol
192             :format-control "Symbol macro name is not a symbol: ~S."             :format-control _"Symbol macro name is not a symbol: ~S."
193             :format-arguments (list name)))             :format-arguments (list name)))
194    (ecase (info variable kind name)    (ecase (info variable kind name)
195      ((:macro :global nil)      ((:macro :global nil)
# Line 192  Line 197 
197       (setf (info variable macro-expansion name) expansion))       (setf (info variable macro-expansion name) expansion))
198      (:special      (:special
199       (error 'simple-program-error       (error 'simple-program-error
200              :format-control "Symbol macro name already declared special: ~S."              :format-control _"Symbol macro name already declared special: ~S."
201              :format-arguments (list name)))              :format-arguments (list name)))
202      (:constant      (:constant
203       (error 'simple-program-error       (error 'simple-program-error
204              :format-control "Symbol macro name already declared constant: ~S."              :format-control _"Symbol macro name already declared constant: ~S."
205              :format-arguments (list name))))              :format-arguments (list name))))
206    name)    name)
207    
# Line 204  Line 209 
209  ;;; DEFTYPE is a lot like DEFMACRO.  ;;; DEFTYPE is a lot like DEFMACRO.
210    
211  (defmacro deftype (name arglist &body body)  (defmacro deftype (name arglist &body body)
212    "Syntax like DEFMACRO, but defines a new type."    _N"Syntax like DEFMACRO, but defines a new type."
213    (unless (symbolp name)    (unless (symbolp name)
214      (simple-program-error "~S -- Type name not a symbol." name))      (simple-program-error _"~S -- Type name not a symbol." name))
215    (and lisp::*enable-package-locked-errors*    (and lisp::*enable-package-locked-errors*
216         (symbol-package name)         (symbol-package name)
217         (ext:package-definition-lock (symbol-package name))         (ext:package-definition-lock (symbol-package name))
218         (restart-case         (restart-case
219             (error 'lisp::package-locked-error             (error 'lisp::package-locked-error
220                    :package (symbol-package name)                    :package (symbol-package name)
221                    :format-control "defining type ~A"                    :format-control _"defining type ~A"
222                    :format-arguments (list name))                    :format-arguments (list name))
223           (continue ()           (continue ()
224             :report "Ignore the lock and continue")             :report (lambda (stream)
225                         (write-string _"Ignore the lock and continue" stream)))
226           (unlock-package ()           (unlock-package ()
227             :report "Disable package's definition-lock then continue"             :report (lambda (stream)
228                         (write-string _"Disable package's definition-lock then continue" stream))
229             (setf (ext:package-definition-lock (symbol-package name)) nil))             (setf (ext:package-definition-lock (symbol-package name)) nil))
230           (unlock-all ()           (unlock-all ()
231             :report "Unlock all packages, then continue"             :report (lambda (stream)
232                         (write-string _"Unlock all packages, then continue" stream))
233             (lisp::unlock-all-packages))))             (lisp::unlock-all-packages))))
234    (let ((whole (gensym "WHOLE-")))    (let ((whole (gensym "WHOLE-")))
235      (multiple-value-bind (body local-decs doc)      (multiple-value-bind (body local-decs doc)
# Line 236  Line 244 
244  ;;;  ;;;
245  (defun %deftype (name expander &optional doc)  (defun %deftype (name expander &optional doc)
246    (when (info declaration recognized name)    (when (info declaration recognized name)
247      (error "Deftype already names a declaration: ~S." name))      (error _"Deftype already names a declaration: ~S." name))
248    (ecase (info type kind name)    (ecase (info type kind name)
249      (:primitive      (:primitive
250       (when *type-system-initialized*       (when *type-system-initialized*
251         (error "Illegal to redefine standard type: ~S." name)))         (error _"Illegal to redefine standard type: ~S." name)))
252      (:instance      (:instance
253       (warn "Redefining class ~S to be a DEFTYPE." name)       (warn _"Redefining class ~S to be a DEFTYPE." name)
254       (undefine-structure (layout-info (%class-layout (kernel::find-class name))))       (undefine-structure (layout-info (%class-layout (kernel::find-class name))))
255       (setf (class-cell-class (find-class-cell name)) nil)       (setf (class-cell-class (find-class-cell name)) nil)
256       (setf (info type compiler-layout name) nil)       (setf (info type compiler-layout name) nil)
# Line 263  Line 271 
271    
272  ;;; And so is DEFINE-SETF-EXPANDER.  ;;; And so is DEFINE-SETF-EXPANDER.
273    
274  (defparameter defsetf-error-string "Setf expander for ~S cannot be called with ~S args.")  (defparameter defsetf-error-string _N"Setf expander for ~S cannot be called with ~S args.")
275    
276  (defmacro define-setf-expander (access-fn lambda-list &body body)  (defmacro define-setf-expander (access-fn lambda-list &body body)
277    "Syntax like DEFMACRO, but creates a Setf-Expansion generator.  The body    _N"Syntax like DEFMACRO, but creates a Setf-Expansion generator.  The body
278    must be a form that returns the five magical values."    must be a form that returns the five magical values."
279    (unless (symbolp access-fn)    (unless (symbolp access-fn)
280      (simple-program-error "~S -- Access-function name not a symbol in DEFINE-SETF-EXPANDER."      (simple-program-error _"~S -- Access-function name not a symbol in DEFINE-SETF-EXPANDER."
281             access-fn))             access-fn))
282    
283    (let ((whole (gensym "WHOLE-"))    (let ((whole (gensym "WHOLE-"))
# Line 288  Line 296 
296            ',doc)))))            ',doc)))))
297    
298  (defmacro define-setf-method (&rest stuff)  (defmacro define-setf-method (&rest stuff)
299    "Obsolete, use define-setf-expander."    _N"Obsolete, use define-setf-expander."
300    `(define-setf-expander ,@stuff))    `(define-setf-expander ,@stuff))
301    
302    
# Line 299  Line 307 
307  (defun %define-setf-macro (name expander inverse doc)  (defun %define-setf-macro (name expander inverse doc)
308    (cond ((not (fboundp `(setf ,name))))    (cond ((not (fboundp `(setf ,name))))
309          ((info function accessor-for name)          ((info function accessor-for name)
310           (warn "Defining setf macro for destruct slot accessor; redefining as ~           (warn _"Defining setf macro for destruct slot accessor; redefining as ~
311                  a normal function:~%  ~S"                  a normal function:~%  ~S"
312                 name)                 name)
313           (c::define-function-name name))           (c::define-function-name name))
314          ((not (eq (symbol-package name) (symbol-package 'aref)))          ((not (eq (symbol-package name) (symbol-package 'aref)))
315           (warn "Defining setf macro for ~S, but ~S is fbound."           (warn _"Defining setf macro for ~S, but ~S is fbound."
316                 name `(setf ,name))))                 name `(setf ,name))))
317    (when (or inverse (info setf inverse name))    (when (or inverse (info setf inverse name))
318      (setf (info setf inverse name) inverse))      (setf (info setf inverse name) inverse))
# Line 318  Line 326 
326  ;;;; Destructuring-bind  ;;;; Destructuring-bind
327    
328  (defmacro destructuring-bind (lambda-list arg-list &rest body)  (defmacro destructuring-bind (lambda-list arg-list &rest body)
329    "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST."    _N"Bind the variables in LAMBDA-LIST to the contents of ARG-LIST."
330    (let* ((arg-list-name (gensym "ARG-LIST-")))    (let* ((arg-list-name (gensym "ARG-LIST-")))
331      (multiple-value-bind      (multiple-value-bind
332          (body local-decls)          (body local-decls)
# Line 381  Line 389 
389  ;;; DEFCONSTANT  --  Public  ;;; DEFCONSTANT  --  Public
390  ;;;  ;;;
391  (defmacro defconstant (var val &optional doc)  (defmacro defconstant (var val &optional doc)
392    "For defining global constants at top level.  The DEFCONSTANT says that the    _N"For defining global constants at top level.  The DEFCONSTANT says that the
393    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
394    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
395    argument is an optional documentation string for the variable."    argument is an optional documentation string for the variable."
# Line 408  Line 416 
416      (setf (documentation name 'variable) doc))      (setf (documentation name 'variable) doc))
417    (when (boundp name)    (when (boundp name)
418      (unless (equalp (symbol-value name) value)      (unless (equalp (symbol-value name) value)
419        (cerror "Go ahead and change the value."        (cerror _"Go ahead and change the value."
420                "Constant ~S being redefined." name)))                _"Constant ~S being redefined." name)))
421    (setf (symbol-value name) value)    (setf (symbol-value name) value)
422    (setf (info variable kind name) :constant)    (setf (info variable kind name) :constant)
423    (clear-info variable constant-value name)    (clear-info variable constant-value name)
# Line 418  Line 426 
426    
427    
428  (defmacro defvar (var &optional (val nil valp) (doc nil docp))  (defmacro defvar (var &optional (val nil valp) (doc nil docp))
429    "For defining global variables at top level.  Declares the variable    _N"For defining global variables at top level.  Declares the variable
430    SPECIAL and, optionally, initializes it.  If the variable already has a    SPECIAL and, optionally, initializes it.  If the variable already has a
431    value, the old value is not clobbered.  The third argument is an optional    value, the old value is not clobbered.  The third argument is an optional
432    documentation string for the variable."    documentation string for the variable."
# Line 428  Line 436 
436           `((unless (boundp ',var)           `((unless (boundp ',var)
437               (setq ,var ,val))))               (setq ,var ,val))))
438      ,@(when docp      ,@(when docp
439          `((setf (documentation ',var 'variable) ',doc)))          `((setf (documentation ',var 'variable) ',doc)
440              (eval-when (:load-toplevel :execute)
441               (setf (c::info variable textdomain ',var) ,intl::*default-domain*))))
442      (set-defvar-source-location ',var (c::source-location))      (set-defvar-source-location ',var (c::source-location))
443      ',var))      ',var))
444    
445  (defmacro defparameter (var val &optional (doc nil docp))  (defmacro defparameter (var val &optional (doc nil docp))
446    "Defines a parameter that is not normally changed by the program,    _N"Defines a parameter that is not normally changed by the program,
447    but that may be changed without causing an error.  Declares the    but that may be changed without causing an error.  Declares the
448    variable special and sets its value to VAL.  The third argument is    variable special and sets its value to VAL.  The third argument is
449    an optional documentation string for the parameter."    an optional documentation string for the parameter."
# Line 441  Line 451 
451      (declaim (special ,var))      (declaim (special ,var))
452      (setq ,var ,val)      (setq ,var ,val)
453      ,@(when docp      ,@(when docp
454          `((setf (documentation ',var 'variable) ',doc)))          `((setf (documentation ',var 'variable) ',doc)
455              (eval-when (:load-toplevel :execute)
456               (setf (c::info variable textdomain ',var) ,intl::*default-domain*))))
457      (set-defvar-source-location ',var (c::source-location))      (set-defvar-source-location ',var (c::source-location))
458      ',var))      ',var))
459    
# Line 450  Line 462 
462    
463    
464  (defmacro when (test &body forms)  (defmacro when (test &body forms)
465    "First arg is a predicate.  If it is non-null, the rest of the forms are    _N"First arg is a predicate.  If it is non-null, the rest of the forms are
466    evaluated as a PROGN."    evaluated as a PROGN."
467    `(cond (,test nil ,@forms)))    `(cond (,test nil ,@forms)))
468    
469  (defmacro unless (test &rest forms)  (defmacro unless (test &rest forms)
470    "First arg is a predicate.  If it is null, the rest of the forms are    _N"First arg is a predicate.  If it is null, the rest of the forms are
471    evaluated as a PROGN."    evaluated as a PROGN."
472    `(cond ((not ,test) nil ,@forms)))    `(cond ((not ,test) nil ,@forms)))
473    
# Line 522  Line 534 
534        nil        nil
535        (let ((clause (first clauses)))        (let ((clause (first clauses)))
536          (when (atom clause)          (when (atom clause)
537            (error "Cond clause is not a list: ~S." clause))            (error _"Cond clause is not a list: ~S." clause))
538          (let ((test (first clause))          (let ((test (first clause))
539                (forms (rest clause)))                (forms (rest clause)))
540            (if (endp forms)            (if (endp forms)
# Line 545  Line 557 
557  ;;;  ;;;
558  (defmacro multiple-value-setq (varlist value-form)  (defmacro multiple-value-setq (varlist value-form)
559    (unless (and (listp varlist) (every #'symbolp varlist))    (unless (and (listp varlist) (every #'symbolp varlist))
560      (simple-program-error "Varlist is not a list of symbols: ~S." varlist))      (simple-program-error _"Varlist is not a list of symbols: ~S." varlist))
561    (if varlist    (if varlist
562        `(values (setf (values ,@varlist) ,value-form))        `(values (setf (values ,@varlist) ,value-form))
563        `(values ,value-form)))        `(values ,value-form)))
# Line 553  Line 565 
565  ;;;  ;;;
566  (defmacro multiple-value-bind (varlist value-form &body body)  (defmacro multiple-value-bind (varlist value-form &body body)
567    (unless (and (listp varlist) (every #'symbolp varlist))    (unless (and (listp varlist) (every #'symbolp varlist))
568      (simple-program-error  "Varlist is not a list of symbols: ~S." varlist))      (simple-program-error  _"Varlist is not a list of symbols: ~S." varlist))
569    (if (= (length varlist) 1)    (if (= (length varlist) 1)
570        `(let ((,(car varlist) ,value-form))        `(let ((,(car varlist) ,value-form))
571           ,@body)           ,@body)
# Line 568  Line 580 
580    
581    
582  (defmacro nth-value (n form)  (defmacro nth-value (n form)
583    "Evaluates FORM and returns the Nth value (zero based).  This involves no    _N"Evaluates FORM and returns the Nth value (zero based).  This involves no
584    consing when N is a trivial constant integer."    consing when N is a trivial constant integer."
585    (if (integerp n)    (if (integerp n)
586        (let ((dummy-list nil)        (let ((dummy-list nil)
# Line 612  Line 624 
624  ;;; and an accessing function.  ;;; and an accessing function.
625    
626  (defun get-setf-expansion (form &optional environment)  (defun get-setf-expansion (form &optional environment)
627    "Returns five values needed by the SETF machinery: a list of temporary    _N"Returns five values needed by the SETF machinery: a list of temporary
628     variables, a list of values with which to fill them, a list of temporaries     variables, a list of values with which to fill them, a list of temporaries
629     for the new values, the setting function, and the accessing function."     for the new values, the setting function, and the accessing function."
630    (let (temp)    (let (temp)
# Line 642  Line 654 
654             (expand-or-get-setf-inverse form environment)))))             (expand-or-get-setf-inverse form environment)))))
655    
656  (defun get-setf-method-multiple-value (form &optional env)  (defun get-setf-method-multiple-value (form &optional env)
657    "Obsolete: use GET-SETF-EXPANSION."    _N"Obsolete: use GET-SETF-EXPANSION."
658    (get-setf-expansion form env))    (get-setf-expansion form env))
659    
660  ;;;  ;;;
# Line 674  Line 686 
686    
687    
688  (defun get-setf-method (form &optional environment)  (defun get-setf-method (form &optional environment)
689    "Obsolete: use GET-SETF-EXPANSION and handle multiple store values."    _N"Obsolete: use GET-SETF-EXPANSION and handle multiple store values."
690    (multiple-value-bind    (multiple-value-bind
691        (temps value-forms store-vars store-form access-form)        (temps value-forms store-vars store-form access-form)
692        (get-setf-expansion form environment)        (get-setf-expansion form environment)
693      (when (cdr store-vars)      (when (cdr store-vars)
694        (error "GET-SETF-METHOD used for a form with multiple store ~        (error _"GET-SETF-METHOD used for a form with multiple store ~
695                variables:~%  ~S" form))                variables:~%  ~S" form))
696      (values temps value-forms store-vars store-form access-form)))      (values temps value-forms store-vars store-form access-form)))
697    
# Line 699  Line 711 
711    
712    
713  (defmacro defsetf (access-fn &rest rest)  (defmacro defsetf (access-fn &rest rest)
714    "Associates a SETF update function or macro with the specified access    _N"Associates a SETF update function or macro with the specified access
715    function or macro.  The format is complex.  See the manual for    function or macro.  The format is complex.  See the manual for
716    details."    details."
717    (cond ((not (listp (car rest)))    (cond ((not (listp (car rest)))
# Line 732  Line 744 
744                     nil                     nil
745                     ',doc))))))                     ',doc))))))
746          (t          (t
747           (error "Ill-formed DEFSETF for ~S." access-fn))))           (error _"Ill-formed DEFSETF for ~S." access-fn))))
748    
749  (defun %defsetf (orig-access-form num-store-vars expander)  (defun %defsetf (orig-access-form num-store-vars expander)
750    (collect ((subforms) (subform-vars) (subform-exprs) (store-vars))    (collect ((subforms) (subform-vars) (subform-exprs) (store-vars))
# Line 761  Line 773 
773  ;;; use of setf inverses without the full interpreter.  ;;; use of setf inverses without the full interpreter.
774  ;;;  ;;;
775  (defmacro setf (&rest args &environment env)  (defmacro setf (&rest args &environment env)
776    "Takes pairs of arguments like SETQ.  The first is a place and the second    _N"Takes pairs of arguments like SETQ.  The first is a place and the second
777    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
778    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
779    knows a corresponding setting form."    knows a corresponding setting form."
# Line 782  Line 794 
794                         (multiple-value-bind ,newval ,value-form                         (multiple-value-bind ,newval ,value-form
795                           ,setter))))))))                           ,setter))))))))
796       ((oddp nargs)       ((oddp nargs)
797        (error "Odd number of args to SETF."))        (error _"Odd number of args to SETF."))
798       (t       (t
799        (do ((a args (cddr a)) (l nil))        (do ((a args (cddr a)) (l nil))
800            ((null a) `(progn ,@(nreverse l)))            ((null a) `(progn ,@(nreverse l)))
801          (setq l (cons (list 'setf (car a) (cadr a)) l)))))))          (setq l (cons (list 'setf (car a) (cadr a)) l)))))))
802    
803  (defmacro psetf (&rest args &environment env)  (defmacro psetf (&rest args &environment env)
804    "This is to SETF as PSETQ is to SETQ.  Args are alternating place    _N"This is to SETF as PSETQ is to SETQ.  Args are alternating place
805    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
806    values are determined, left to right, and only then are the locations    values are determined, left to right, and only then are the locations
807    updated.  Returns NIL."    updated.  Returns NIL."
# Line 797  Line 809 
809      (do ((a args (cddr a)))      (do ((a args (cddr a)))
810          ((endp a))          ((endp a))
811        (if (endp (cdr a))        (if (endp (cdr a))
812            (simple-program-error "Odd number of args to PSETF."))            (simple-program-error _"Odd number of args to PSETF."))
813        (multiple-value-bind        (multiple-value-bind
814            (dummies vals newval setter getter)            (dummies vals newval setter getter)
815            (get-setf-expansion (car a) env)            (get-setf-expansion (car a) env)
# Line 814  Line 826 
826        (thunk (let*-bindings) (mv-bindings)))))        (thunk (let*-bindings) (mv-bindings)))))
827    
828  (defmacro shiftf (&rest args &environment env)  (defmacro shiftf (&rest args &environment env)
829    "One or more SETF-style place expressions, followed by a single    _N"One or more SETF-style place expressions, followed by a single
830     value expression.  Evaluates all of the expressions in turn, then     value expression.  Evaluates all of the expressions in turn, then
831     assigns the value of each expression to the place on its left,     assigns the value of each expression to the place on its left,
832     returning the value of the leftmost."     returning the value of the leftmost."
# Line 853  Line 865 
865              (values ,@(car (mv-bindings)))))))))              (values ,@(car (mv-bindings)))))))))
866    
867  (defmacro rotatef (&rest args &environment env)  (defmacro rotatef (&rest args &environment env)
868    "Takes any number of SETF-style place expressions.  Evaluates all of the    _N"Takes any number of SETF-style place expressions.  Evaluates all of the
869     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
870     its right.  The rightmost form gets the value of the leftmost.     its right.  The rightmost form gets the value of the leftmost.
871     Returns NIL."     Returns NIL."
# Line 884  Line 896 
896    
897    
898  (defmacro define-modify-macro (name lambda-list function &optional doc-string)  (defmacro define-modify-macro (name lambda-list function &optional doc-string)
899    "Creates a new read-modify-write macro like PUSH or INCF."    _N"Creates a new read-modify-write macro like PUSH or INCF."
900    (let ((other-args nil)    (let ((other-args nil)
901          (rest-arg nil)          (rest-arg nil)
902          (env (gensym "ENV-"))          (env (gensym "ENV-"))
# Line 899  Line 911 
911              ((eq arg '&rest)              ((eq arg '&rest)
912               (if (symbolp (cadr ll))               (if (symbolp (cadr ll))
913                   (setq rest-arg (cadr ll))                   (setq rest-arg (cadr ll))
914                   (error "Non-symbol &rest arg in definition of ~S." name))                   (error _"Non-symbol &rest arg in definition of ~S." name))
915               (if (null (cddr ll))               (if (null (cddr ll))
916                   (return nil)                   (return nil)
917                   (error "Illegal stuff after &rest arg in Define-Modify-Macro.")))                   (error _"Illegal stuff after &rest arg in Define-Modify-Macro.")))
918              ((memq arg '(&key &allow-other-keys &aux))              ((memq arg '(&key &allow-other-keys &aux))
919               (error "~S not allowed in Define-Modify-Macro lambda list." arg))               (error _"~S not allowed in Define-Modify-Macro lambda list." arg))
920              ((symbolp arg)              ((symbolp arg)
921               (push arg other-args))               (push arg other-args))
922              ((and (listp arg) (symbolp (car arg)))              ((and (listp arg) (symbolp (car arg)))
923               (push (car arg) other-args))               (push (car arg) other-args))
924              (t (error "Illegal stuff in lambda list of Define-Modify-Macro."))))              (t (error _"Illegal stuff in lambda list of Define-Modify-Macro."))))
925      (setq other-args (nreverse other-args))      (setq other-args (nreverse other-args))
926      `(defmacro ,name (,reference ,@lambda-list &environment ,env)      `(defmacro ,name (,reference ,@lambda-list &environment ,env)
927         ,doc-string         ,doc-string
# Line 929  Line 941 
941                   ,setter)))))))                   ,setter)))))))
942    
943  (defmacro push (obj place &environment env)  (defmacro push (obj place &environment env)
944    "Takes an object and a location holding a list.  Conses the object onto    _N"Takes an object and a location holding a list.  Conses the object onto
945    the list, returning the modified list.  OBJ is evaluated before PLACE."    the list, returning the modified list.  OBJ is evaluated before PLACE."
946    
947    ;; This special case for place being a symbol isn't strictly needed.    ;; This special case for place being a symbol isn't strictly needed.
# Line 963  Line 975 
975                 ,setter)))))))                 ,setter)))))))
976    
977  (defmacro pushnew (obj place &rest keys &environment env)  (defmacro pushnew (obj place &rest keys &environment env)
978    "Takes an object and a location holding a list.  If the object is already    _N"Takes an object and a location holding a list.  If the object is already
979    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
980    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."
981    (if (and (symbolp place)    (if (and (symbolp place)
# Line 995  Line 1007 
1007                  ,setter)))))))                  ,setter)))))))
1008    
1009  (defmacro pop (place &environment env)  (defmacro pop (place &environment env)
1010    "The argument is a location holding a list.  Pops one item off the front    _N"The argument is a location holding a list.  Pops one item off the front
1011    of the list and returns it."    of the list and returns it."
1012    (if (and (symbolp place)    (if (and (symbolp place)
1013             (eq place (macroexpand place env)))             (eq place (macroexpand place env)))
# Line 1017  Line 1029 
1029    
1030  ;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3  ;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3
1031  (defmacro incf (place &optional (delta 1) &environment env)  (defmacro incf (place &optional (delta 1) &environment env)
1032    "The first argument is some location holding a number. This number is    _N"The first argument is some location holding a number. This number is
1033    incremented by the second argument, DELTA, which defaults to 1."    incremented by the second argument, DELTA, which defaults to 1."
1034    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1035        (get-setf-method place env)        (get-setf-method place env)
# Line 1028  Line 1040 
1040           ,setter))))           ,setter))))
1041    
1042  (defmacro decf (place &optional (delta 1) &environment env)  (defmacro decf (place &optional (delta 1) &environment env)
1043    "The first argument is some location holding a number. This number is    _N"The first argument is some location holding a number. This number is
1044    decremented by the second argument, DELTA, which defaults to 1."    decremented by the second argument, DELTA, which defaults to 1."
1045    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1046        (get-setf-method place env)        (get-setf-method place env)
# Line 1039  Line 1051 
1051           ,setter))))           ,setter))))
1052    
1053  (defmacro remf (place indicator &environment env)  (defmacro remf (place indicator &environment env)
1054    "Place may be any place expression acceptable to SETF, and is expected    _N"Place may be any place expression acceptable to SETF, and is expected
1055    to hold a property list or ().  This list is destructively altered to    to hold a property list or ().  This list is destructively altered to
1056    remove the property specified by the indicator.  Returns T if such a    remove the property specified by the indicator.  Returns T if such a
1057    property was present, NIL if not."    property was present, NIL if not."
# Line 1060  Line 1072 
1072                    (,local2 nil ,local1))                    (,local2 nil ,local1))
1073                   ((atom ,local1) nil)                   ((atom ,local1) nil)
1074                 (cond ((atom (cdr ,local1))                 (cond ((atom (cdr ,local1))
1075                        (error "Odd-length property list in REMF."))                        (error _"Odd-length property list in REMF."))
1076                       ((eq (car ,local1) ,ind-temp)                       ((eq (car ,local1) ,ind-temp)
1077                        (cond (,local2                        (cond (,local2
1078                               (rplacd (cdr ,local2) (cddr ,local1))                               (rplacd (cdr ,local2) (cddr ,local1))
# Line 1198  Line 1210 
1210                 (= (list-length function) 2)                 (= (list-length function) 2)
1211                 (eq (first function) 'function)                 (eq (first function) 'function)
1212                 (symbolp (second function)))                 (symbolp (second function)))
1213      (error "Setf of Apply is only defined for function args like #'symbol."))      (error _"Setf of Apply is only defined for function args like #'symbol."))
1214    (let ((function (second function))    (let ((function (second function))
1215          (new-var (gensym))          (new-var (gensym))
1216          (vars nil))          (vars nil))
# Line 1213  Line 1225 
1225  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
1226  ;;;  ;;;
1227  (define-setf-expander ldb (bytespec place &environment env)  (define-setf-expander ldb (bytespec place &environment env)
1228    "The first argument is a byte specifier.  The second is any place form    _N"The first argument is a byte specifier.  The second is any place form
1229    acceptable to SETF.  Replaces the specified byte of the number in this    acceptable to SETF.  Replaces the specified byte of the number in this
1230    place with bits from the low-order end of the new value."    place with bits from the low-order end of the new value."
1231    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
# Line 1242  Line 1254 
1254    
1255    
1256  (define-setf-expander mask-field (bytespec place &environment env)  (define-setf-expander mask-field (bytespec place &environment env)
1257    "The first argument is a byte specifier.  The second is any place form    _N"The first argument is a byte specifier.  The second is any place form
1258    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
1259    with bits from the corresponding position in the new value."    with bits from the corresponding position in the new value."
1260    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
# Line 1314  Line 1326 
1326            (case (first case-list) (first case-list)))            (case (first case-list) (first case-list)))
1327           ((null case-list))           ((null case-list))
1328        (cond ((atom case)        (cond ((atom case)
1329               (error "~S -- Bad clause in ~S." case name))               (error _"~S -- Bad clause in ~S." case name))
1330              ((and (not allow-otherwise)              ((and (not allow-otherwise)
1331                    (memq (car case) '(t otherwise)))                    (memq (car case) '(t otherwise)))
1332               (cond ((null (cdr case-list))               (cond ((null (cdr case-list))
# Line 1322  Line 1334 
1334                      ;; only if it's the last case.  Otherwise, it's just a                      ;; only if it's the last case.  Otherwise, it's just a
1335                      ;; normal clause.                      ;; normal clause.
1336                      (if errorp                      (if errorp
1337                          (error "No default clause allowed in ~S: ~S" name case)                          (error _"No default clause allowed in ~S: ~S" name case)
1338                          (push `(t nil ,@(rest case)) clauses)))                          (push `(t nil ,@(rest case)) clauses)))
1339                     ((and (eq name 'case))                     ((and (eq name 'case))
1340                      (error "T and OTHERWISE may not be used as key designators for ~A" name))                      (error _"T and OTHERWISE may not be used as key designators for ~A" name))
1341                     ((eq (first case) t)                     ((eq (first case) t)
1342                      ;; The key T is normal clause, because it's not                      ;; The key T is normal clause, because it's not
1343                      ;; the last clause.                      ;; the last clause.
# Line 1342  Line 1354 
1354              (t              (t
1355               (when (and allow-otherwise               (when (and allow-otherwise
1356                          (memq (car case) '(t otherwise)))                          (memq (car case) '(t otherwise)))
1357                 (warn "Bad style to use T or OTHERWISE in ECASE or CCASE"))                 (warn _"Bad style to use T or OTHERWISE in ECASE or CCASE"))
1358               (push (first case) keys)               (push (first case) keys)
1359               (push `((,test ,keyform-value               (push `((,test ,keyform-value
1360                              ',(first case)) nil ,@(rest case)) clauses))))                              ',(first case)) nil ,@(rest case)) clauses))))
# Line 1398  Line 1410 
1410               :possibilities keys)               :possibilities keys)
1411      (store-value (value)      (store-value (value)
1412        :report (lambda (stream)        :report (lambda (stream)
1413                  (format stream "Supply a new value for ~S." keyform))                  (format stream _"Supply a new value for ~S." keyform))
1414        :interactive read-evaluated-form        :interactive read-evaluated-form
1415        value)))        value)))
1416    
1417    
1418  (defmacro case (keyform &body cases)  (defmacro case (keyform &body cases)
1419    "CASE Keyform {({(Key*) | Key} Form*)}*    _N"CASE Keyform {({(Key*) | Key} Form*)}*
1420    Evaluates the Forms in the first clause with a Key EQL to the value    Evaluates the Forms in the first clause with a Key EQL to the value
1421    of Keyform.  If a singleton key is T or Otherwise then the clause is    of Keyform.  If a singleton key is T or Otherwise then the clause is
1422    a default clause."    a default clause."
1423    (case-body 'case keyform cases t 'eql nil nil))    (case-body 'case keyform cases t 'eql nil nil))
1424    
1425  (defmacro ccase (keyform &body cases)  (defmacro ccase (keyform &body cases)
1426    "CCASE Keyform {({(Key*) | Key} Form*)}*    _N"CCASE Keyform {({(Key*) | Key} Form*)}*
1427    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
1428    Keyform.  If none of the keys matches then a correctable error is    Keyform.  If none of the keys matches then a correctable error is
1429    signalled."    signalled."
1430    (case-body 'ccase keyform cases t 'eql nil t t))    (case-body 'ccase keyform cases t 'eql nil t t))
1431    
1432  (defmacro ecase (keyform &body cases)  (defmacro ecase (keyform &body cases)
1433    "ECASE Keyform {({(Key*) | Key} Form*)}*    _N"ECASE Keyform {({(Key*) | Key} Form*)}*
1434    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
1435    Keyform.  If none of the keys matches then an error is signalled."    Keyform.  If none of the keys matches then an error is signalled."
1436    (case-body 'ecase keyform cases t 'eql nil nil t))    (case-body 'ecase keyform cases t 'eql nil nil t))
1437    
1438  (defmacro typecase (keyform &body cases)  (defmacro typecase (keyform &body cases)
1439    "TYPECASE Keyform {(Type Form*)}*    _N"TYPECASE Keyform {(Type Form*)}*
1440    Evaluates the Forms in the first clause for which TYPEP of Keyform    Evaluates the Forms in the first clause for which TYPEP of Keyform
1441    and Type is true.  If a singleton key is T or Otherwise then the    and Type is true.  If a singleton key is T or Otherwise then the
1442    clause is a default clause."    clause is a default clause."
1443    (case-body 'typecase keyform cases nil 'typep nil nil))    (case-body 'typecase keyform cases nil 'typep nil nil))
1444    
1445  (defmacro ctypecase (keyform &body cases)  (defmacro ctypecase (keyform &body cases)
1446    "CTYPECASE Keyform {(Type Form*)}*    _N"CTYPECASE Keyform {(Type Form*)}*
1447    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
1448    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."
1449    (case-body 'ctypecase keyform cases nil 'typep nil t t))    (case-body 'ctypecase keyform cases nil 'typep nil t t))
1450    
1451  (defmacro etypecase (keyform &body cases)  (defmacro etypecase (keyform &body cases)
1452    "ETYPECASE Keyform {(Type Form*)}*    _N"ETYPECASE Keyform {(Type Form*)}*
1453    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
1454    is true.  If no form is satisfied then an error is signalled."    is true.  If no form is satisfied then an error is signalled."
1455    (case-body 'etypecase keyform cases nil 'typep nil nil t))    (case-body 'etypecase keyform cases nil 'typep nil nil t))
# Line 1451  Line 1463 
1463  ;;; of whether they are needed.  ;;; of whether they are needed.
1464  ;;;  ;;;
1465  (defmacro assert (test-form &optional places datum &rest arguments)  (defmacro assert (test-form &optional places datum &rest arguments)
1466    "Signals an error if the value of test-form is nil.  Continuing from this    _N"Signals an error if the value of test-form is nil.  Continuing from this
1467     error using the CONTINUE restart will allow the user to alter the value of     error using the CONTINUE restart will allow the user to alter the value of
1468     some locations known to SETF, starting over with test-form.  Returns nil."     some locations known to SETF, starting over with test-form.  Returns nil."
1469    `(loop    `(loop
# Line 1467  Line 1479 
1479                     datum arguments                     datum arguments
1480                     'simple-error 'error)                     'simple-error 'error)
1481                    (make-condition 'simple-error                    (make-condition 'simple-error
1482                                    :format-control "The assertion ~S failed."                                    :format-control _"The assertion ~S failed."
1483                                    :format-arguments (list assertion)))))                                    :format-arguments (list assertion)))))
1484    (restart-case (error cond)    (restart-case (error cond)
1485      (continue ()      (continue ()
# Line 1476  Line 1488 
1488    
1489    
1490  (defun assert-report (names stream)  (defun assert-report (names stream)
1491    (format stream "Retry assertion")    (format stream _"Retry assertion")
1492    (if names    (if names
1493        (format stream " with new value~P for ~{~S~^, ~}."        (format stream (intl:ngettext " with new value for ~{~S~^, ~}."
1494                (length names) names)                                      " with new values for ~{~S~^, ~}."
1495                                        (length names))
1496                  names)
1497        (format stream ".")))        (format stream ".")))
1498    
1499  (defun assert-prompt (name value)  (defun assert-prompt (name value)
1500    (cond ((y-or-n-p "The old value of ~S is ~S.~    (cond ((y-or-n-p _"The old value of ~S is ~S.~
1501                    ~%Do you want to supply a new value? "                    ~%Do you want to supply a new value? "
1502                     name value)                     name value)
1503           (format *query-io* "~&Type a form to be evaluated:~%")           (format *query-io* _"~&Type a form to be evaluated:~%")
1504           (flet ((read-it () (eval (read *query-io*))))           (flet ((read-it () (eval (read *query-io*))))
1505             (if (symbolp name) ;help user debug lexical variables             (if (symbolp name) ;help user debug lexical variables
1506                 (progv (list name) (list value) (read-it))                 (progv (list name) (list value) (read-it))
# Line 1503  Line 1517 
1517  ;;;  ;;;
1518    
1519  (defmacro check-type (place type &optional type-string)  (defmacro check-type (place type &optional type-string)
1520    "Signals an error of type type-error if the contents of place are not of the    _N"Signals an error of type type-error if the contents of place are not of the
1521     specified type.  If an error is signaled, this can only return if     specified type.  If an error is signaled, this can only return if
1522     STORE-VALUE is invoked.  It will store into place and start over."     STORE-VALUE is invoked.  It will store into place and start over."
1523    (let ((place-value (gensym)))    (let ((place-value (gensym)))
# Line 1518  Line 1532 
1532                    (make-condition 'simple-type-error                    (make-condition 'simple-type-error
1533                                    :datum place-value :expected-type type                                    :datum place-value :expected-type type
1534                                    :format-control                                    :format-control
1535                                    "The value of ~S is ~S, which is not ~A."                                    _"The value of ~S is ~S, which is not ~A."
1536                                    :format-arguments                                    :format-arguments
1537                                    (list place place-value type-string))                                    (list place place-value type-string))
1538                    (make-condition 'simple-type-error                    (make-condition 'simple-type-error
1539                                    :datum place-value :expected-type type                                    :datum place-value :expected-type type
1540                                    :format-control                                    :format-control
1541                                    "The value of ~S is ~S, which is not of type ~S."                                    _"The value of ~S is ~S, which is not of type ~S."
1542                                    :format-arguments                                    :format-arguments
1543                                    (list place place-value type)))))                                    (list place place-value type)))))
1544      (restart-case (error cond)      (restart-case (error cond)
1545        (store-value (value)        (store-value (value)
1546          :report (lambda (stream)          :report (lambda (stream)
1547                    (format stream "Supply a new value of ~S."                    (format stream _"Supply a new value of ~S."
1548                            place))                            place))
1549          :interactive read-evaluated-form          :interactive read-evaluated-form
1550          value))))          value))))
# Line 1540  Line 1554 
1554  ;;; and by CHECK-TYPE.  ;;; and by CHECK-TYPE.
1555  ;;;  ;;;
1556  (defun read-evaluated-form ()  (defun read-evaluated-form ()
1557    (format *query-io* "~&Type a form to be evaluated:~%")    (format *query-io* _"~&Type a form to be evaluated:~%")
1558    (list (eval (read *query-io*))))    (list (eval (read *query-io*))))
1559    
1560    
1561  ;;;; With-XXX  ;;;; With-XXX
1562  (defmacro with-open-file ((var filespec &rest open-args) &parse-body (forms decls))  (defmacro with-open-file ((var filespec &rest open-args) &parse-body (forms decls))
1563    "The file whose name is Filespec is opened using the Open-args and    _N"The file whose name is Filespec is opened using the Open-args and
1564    bound to the variable Var. If the call to open is unsuccessful, the    bound to the variable Var. If the call to open is unsuccessful, the
1565    forms are not evaluated.  The Forms are executed, and when they    forms are not evaluated.  The Forms are executed, and when they
1566    terminate, normally or otherwise, the file is closed."    terminate, normally or otherwise, the file is closed."
# Line 1563  Line 1577 
1577    
1578    
1579  (defmacro with-open-stream ((var stream) &parse-body (forms decls))  (defmacro with-open-stream ((var stream) &parse-body (forms decls))
1580    "The form stream should evaluate to a stream.  VAR is bound    _N"The form stream should evaluate to a stream.  VAR is bound
1581     to the stream and the forms are evaluated as an implicit     to the stream and the forms are evaluated as an implicit
1582     progn.  The stream is closed upon exit."     progn.  The stream is closed upon exit."
1583    (let ((abortp (gensym)))    (let ((abortp (gensym)))
# Line 1580  Line 1594 
1594    
1595  (defmacro with-input-from-string ((var string &key index start end)  (defmacro with-input-from-string ((var string &key index start end)
1596                                    &parse-body (forms decls))                                    &parse-body (forms decls))
1597    "Binds the Var to an input stream that returns characters from String and    _N"Binds the Var to an input stream that returns characters from String and
1598    executes the body.  See manual for details."    executes the body.  See manual for details."
1599    ;; The once-only inhibits compiler note for unreachable code when 'end' is true.    ;; The once-only inhibits compiler note for unreachable code when 'end' is true.
1600    (once-only ((string string))    (once-only ((string string))
# Line 1604  Line 1618 
1618    
1619  (defmacro with-output-to-string ((var &optional string &key element-type)  (defmacro with-output-to-string ((var &optional string &key element-type)
1620                                   &parse-body (forms decls))                                   &parse-body (forms decls))
1621    "If STRING is specified, it must be a string with a fill pointer;    _N"If STRING is specified, it must be a string with a fill pointer;
1622     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
1623     VECTOR-PUSH-EXTEND)."     VECTOR-PUSH-EXTEND)."
1624    (declare (ignore element-type))    (declare (ignore element-type))
# Line 1724  Line 1738 
1738    
1739    
1740  (defmacro do (varlist endlist &parse-body (body decls))  (defmacro do (varlist endlist &parse-body (body decls))
1741    "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*    _N"DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
1742    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
1743    specified Init form.  On subsequent iterations, the Vars are assigned the    specified Init form.  On subsequent iterations, the Vars are assigned the
1744    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
# Line 1737  Line 1751 
1751    
1752    
1753  (defmacro do* (varlist endlist &parse-body (body decls))  (defmacro do* (varlist endlist &parse-body (body decls))
1754    "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*    _N"DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
1755    Iteration construct.  Each Var is initialized sequentially (like LET*) to the    Iteration construct.  Each Var is initialized sequentially (like LET*) to the
1756    value of the specified Init form.  On subsequent iterations, the Vars are    value of the specified Init form.  On subsequent iterations, the Vars are
1757    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
# Line 1751  Line 1765 
1765  ;;;; Miscellaneous macros:  ;;;; Miscellaneous macros:
1766    
1767  (defmacro psetq (&rest pairs)  (defmacro psetq (&rest pairs)
1768    "PSETQ {var value}*    _N"PSETQ {var value}*
1769     Set the variables to the values, like SETQ, except that assignments     Set the variables to the values, like SETQ, except that assignments
1770     happen in parallel, i.e. no assignments take place until all the     happen in parallel, i.e. no assignments take place until all the
1771     forms have been evaluated."     forms have been evaluated."
# Line 1762  Line 1776 
1776        ((endp pair) `(psetf ,@pairs))        ((endp pair) `(psetf ,@pairs))
1777      (unless (symbolp (car pair))      (unless (symbolp (car pair))
1778        (error 'simple-program-error        (error 'simple-program-error
1779               :format-control "variable ~S in PSETQ is not a SYMBOL"               :format-control _"variable ~S in PSETQ is not a SYMBOL"
1780               :format-arguments (list (car pair))))))               :format-arguments (list (car pair))))))
1781    
1782    
# Line 1814  Line 1828 
1828                (:global (member parent '(defun defmacro function)))                (:global (member parent '(defun defmacro function)))
1829                (:local (member parent '(labels flet)))                (:local (member parent '(labels flet)))
1830                (t                (t
1831                 (error "Unknown declaration context: ~S." context))))                 (error _"Unknown declaration context: ~S." context))))
1832            (case (first context)            (case (first context)
1833              (:or              (:or
1834               (loop for x in (rest context)               (loop for x in (rest context)
# Line 1835  Line 1849 
1849                    (loop for x in (rest context)                    (loop for x in (rest context)
1850                          thereis (eq (find-package (string x)) package))))                          thereis (eq (find-package (string x)) package))))
1851              (t              (t
1852               (error "Unknown declaration context: ~S." context)))))))               (error _"Unknown declaration context: ~S." context)))))))
1853    
1854    
1855  ;;; PROCESS-CONTEXT-DECLARATIONS  --  Internal  ;;; PROCESS-CONTEXT-DECLARATIONS  --  Internal
# Line 1848  Line 1862 
1862     (mapcar     (mapcar
1863      #'(lambda (decl)      #'(lambda (decl)
1864          (unless (>= (length decl) 2)          (unless (>= (length decl) 2)
1865            (error "Context declaration spec should have context and at ~            (error _"Context declaration spec should have context and at ~
1866            least one DECLARE form:~%  ~S" decl))            least one DECLARE form:~%  ~S" decl))
1867          #'(lambda (name parent)          #'(lambda (name parent)
1868              (when (evaluate-declaration-context (first decl) name parent)              (when (evaluate-declaration-context (first decl) name parent)
# Line 1860  Line 1874 
1874  ;;; With-Compilation-Unit  --  Public  ;;; With-Compilation-Unit  --  Public
1875  ;;;  ;;;
1876  (defmacro with-compilation-unit (options &body body)  (defmacro with-compilation-unit (options &body body)
1877    "WITH-COMPILATION-UNIT ({Key Value}*) Form*    _N"WITH-COMPILATION-UNIT ({Key Value}*) Form*
1878    This form affects compilations that take place within its dynamic extent.  It    This form affects compilations that take place within its dynamic extent.  It
1879    is intended to be wrapped around the compilation of all files in the same    is intended to be wrapped around the compilation of all files in the same
1880    system.  These keywords are defined:    system.  These keywords are defined:
# Line 1922  Line 1936 
1936          (n-fun (gensym))          (n-fun (gensym))
1937          (n-abort-p (gensym)))          (n-abort-p (gensym)))
1938      (when (oddp (length options))      (when (oddp (length options))
1939        (error "Odd number of key/value pairs: ~S." options))        (error _"Odd number of key/value pairs: ~S." options))
1940      (do ((opt options (cddr opt)))      (do ((opt options (cddr opt)))
1941          ((null opt))          ((null opt))
1942        (case (first opt)        (case (first opt)
# Line 1935  Line 1949 
1949          (:context-declarations          (:context-declarations
1950           (setq context-declarations (second opt)))           (setq context-declarations (second opt)))
1951          (t          (t
1952           (warn "Ignoring unknown option: ~S." (first opt)))))           (warn _"Ignoring unknown option: ~S." (first opt)))))
1953    
1954      `(flet ((,n-fun ()      `(flet ((,n-fun ()
1955                (let (,@(when optimize                (let (,@(when optimize

Legend:
Removed from v.1.113  
changed lines
  Added in v.1.113.10.7

  ViewVC Help
Powered by ViewVC 1.1.5