definitions.lisp

   1 (in-package :alexandria)
   2
   3 (defun extract-function-name (spec)
   4   "Useful for macros that want to emulate the functional interface for functions
   5 like #'eq and 'eq."
   6   (if (and (consp spec)
   7            (member (first spec) '(quote function)))
   8       (second spec)
   9       spec))
  10
  11 (defmacro define-constant (name initial-value &key (test 'eql) documentation)
  12   "Ensures that the global variable named by NAME is a constant with a value
  13 that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST
  14 defaults to EQL, and if given it must be a symbol naming a function. If
  15 DOCUMENTATION is given, it becomes the documentation string of the constant.
  16
  17 Signals an error if NAME is already a bound non-constant variable.
  18
  19 Signals an error if NAME is already a constant variable whose value is not
  20 equal under TEST to result of evaluating INITIAL-VALUE."
  21   (setf test (extract-function-name test))
  22   `(defconstant ,name
  23      (let ((new ,initial-value))
  24        (if (boundp ',name)
  25            (let ((old (symbol-value ',name)))
  26              (cond
  27                ((constantp ',name)
  28                 (cond
  29                   ((,test old new)
  30                    old)
  31                   (t
  32                    (cerror "Try to redefine the constant."
  33                            "~@<~S is an already defined constant whose value ~
  34                             ~S is not equal to the provided initial value ~S ~
  35                             under ~S.~:@>" ',name old new ',test)
  36                    new)))
  37                (t
  38                 (cerror "Try to redefine the variable as a constant."
  39                         "~@<~S is an already bound non-constant variable ~
  40                          whose value is ~S.~:@>" ',name old)
  41                 new)))
  42            new))
  43      ,@(when documentation `(,documentation))))