definitions.lisp

   1 (in-package :alexandria)
   2
   3 (defun extract-function-name (spec)
   4   "Useful for macros that want to mimic 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 (defun %reevaluate-constant (name value &key (test 'eql))
  12   (if (not (boundp name))
  13       value
  14       (let ((old (symbol-value name))
  15             (new value))
  16         (if (not (constantp name))
  17             (prog1 new
  18               (cerror "Try to redefine the variable as a constant."
  19                       "~@<~S is an already bound non-constant variable ~
  20                        whose value is ~S.~:@>" name old))
  21             (if (funcall test old new)
  22                 old
  23                 (prog1 new
  24                   (cerror "Try to redefine the constant."
  25                           "~@<~S is an already defined constant whose value ~
  26                            ~S is not equal to the provided initial value ~S ~
  27                            under ~S.~:@>" name old new test)))))))
  28
  29 (defmacro define-constant (name initial-value &key (test ''eql) documentation)
  30   "Ensures that the global variable named by NAME is a constant with a
  31 value that is equal under TEST to the result of evaluating
  32 INITIAL-VALUE. TEST is a /function designator/ that defaults to
  33 EQL. If DOCUMENTATION is given, it becomes the documentation string of
  34 the constant.
  35
  36 Signals an error if NAME is already a bound non-constant variable.
  37
  38 Signals an error if NAME is already a constant variable whose value is not
  39 equal under TEST to result of evaluating INITIAL-VALUE."
  40   `(defconstant ,name (%reevaluate-constant ',name
  41                                             ,initial-value
  42                                             :test ,test)
  43      ,@(when documentation `(,documentation))))