changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/std/macs/const.lisp

changeset 698: 96958d3eb5b0
parent: a0dfde3cb3c4
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; std/macs/const.lisp --- DEFINE-CONSTANT and friends
     2 
     3 ;;
     4 
     5 ;;; Code:
     6 (in-package :std/macs)
     7 ;; (reexport-from :sb-c
     8 ;; 	       :include '(:define-source-transformation
     9 ;; 			  :parse-eval-when-situations
    10 ;; 			  :source-location))
    11 ;;; Definitions
    12 (defun %reevaluate-constant (name value test)
    13   (if (not (boundp name))
    14       value
    15       (let ((old (symbol-value name))
    16             (new value))
    17         (if (not (constantp name))
    18             (prog1 new
    19               (cerror "Try to redefine the variable as a constant."
    20                       "~@<~S is an already bound non-constant variable ~
    21                        whose value is ~S.~:@>" name old))
    22             (if (funcall test old new)
    23                 old
    24                 (restart-case
    25                     (error "~@<~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                   (ignore ()
    29                     :report "Retain the current value."
    30                     old)
    31                   (continue ()
    32                     :report "Try to redefine the constant."
    33                     new)))))))
    34 
    35 (defmacro define-constant (name initial-value &key (test #'eql) documentation)
    36   "Ensures that the global variable named by NAME is a constant with a value
    37 that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
    38 /function designator/ that defaults to EQL. If DOCUMENTATION is given, it
    39 becomes the documentation string of the constant.
    40 
    41 Signals an error if NAME is already a bound non-constant variable.
    42 
    43 Signals an error if NAME is already a constant variable whose value is not
    44 equal under TEST to result of evaluating INITIAL-VALUE."
    45   `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
    46      ,@(when documentation `(,documentation))))