+;;; This function is to be called just before a change which would affect the
+;;; symbol value. We don't absolutely have to call this function before such
+;;; changes, since such changes to constants are given as undefined behavior,
+;;; it's nice to do so. To circumvent this you need code like this:
+;;;
+;;; (defvar foo)
+;;; (defun set-foo (x) (setq foo x))
+;;; (defconstant foo 42)
+;;; (set-foo 13)
+;;; foo => 13, (constantp 'foo) => t
+;;;
+;;; ...in which case you frankly deserve to lose.
+(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep))
+ (declare (symbol symbol))
+ (multiple-value-bind (what continue)
+ (when (eq :constant (info :variable :kind symbol))
+ (cond ((eq symbol t)
+ (values "Veritas aeterna. (can't ~@?)" nil))
+ ((eq symbol nil)
+ (values "Nihil ex nihil. (can't ~@?)" nil))
+ ((keywordp symbol)
+ (values "Can't ~@?." nil))
+ (t
+ (values "Constant modification: attempt to ~@?." t))))
+ (when what
+ (if continue
+ (cerror "Modify the constant." what action symbol)
+ (error what action symbol)))
+ (when valuep
+ ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
+ ;; check.
+ (let ((type (info :variable :type symbol)))
+ (unless (sb!kernel::%%typep new-value type)
+ (let ((spec (type-specifier type)))
+ (error 'simple-type-error
+ :format-control "Cannot ~@? to ~S (not of type ~S.)"
+ :format-arguments (list action symbol new-value spec)
+ :datum new-value
+ :expected-type spec))))))
+ (values))
+
+;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
+;;; assignment instead of doing cold static linking. That way things like
+;;; (FLET ((FROB (X) ..))
+;;; (DEFUN FOO (X Y) (FROB X) ..)
+;;; (DEFUN BAR (Z) (AND (FROB X) ..)))
+;;; can still "work" for cold init: they don't do magical static
+;;; linking the way that true toplevel DEFUNs do, but at least they do
+;;; the linking eventually, so as long as #'FOO and #'BAR aren't
+;;; needed until "cold toplevel forms" have executed, it's OK.
+(defmacro cold-fset (name lambda)
+ (style-warn
+ "~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
+(SETF FDEFINITION)~:@>"
+ name)
+ ;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA
+ ;; expression so that the compiler can use NAME in debug names etc.
+ (destructuring-bind (lambda-symbol &rest lambda-rest) lambda
+ (assert (eql lambda-symbol 'lambda)) ; else dunno how to do conversion
+ `(setf (fdefinition ',name)
+ (named-lambda ,name ,@lambda-rest))))
+\f
+;;;; ONCE-ONLY
+;;;;
+;;;; "The macro ONCE-ONLY has been around for a long time on various
+;;;; systems [..] if you can understand how to write and when to use
+;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
+;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
+;;;; in Common Lisp_, p. 853
+
+;;; ONCE-ONLY is a utility useful in writing source transforms and
+;;; macros. It provides a concise way to wrap a LET around some code
+;;; to ensure that some forms are only evaluated once.
+;;;
+;;; Create a LET* which evaluates each value expression, binding a
+;;; temporary variable to the result, and wrapping the LET* around the
+;;; result of the evaluation of BODY. Within the body, each VAR is
+;;; bound to the corresponding temporary variable.
+(defmacro once-only (specs &body body)
+ (named-let frob ((specs specs)
+ (body body))
+ (if (null specs)
+ `(progn ,@body)
+ (let ((spec (first specs)))
+ ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
+ (unless (proper-list-of-length-p spec 2)
+ (error "malformed ONCE-ONLY binding spec: ~S" spec))
+ (let* ((name (first spec))
+ (exp-temp (gensym "ONCE-ONLY")))
+ `(let ((,exp-temp ,(second spec))
+ (,name (gensym ,(symbol-name name))))
+ `(let ((,,name ,,exp-temp))
+ ,,(frob (rest specs) body))))))))
+\f
+;;;; various error-checking utilities
+
+;;; This function can be used as the default value for keyword
+;;; arguments that must be always be supplied. Since it is known by
+;;; the compiler to never return, it will avoid any compile-time type
+;;; warnings that would result from a default value inconsistent with
+;;; the declared type. When this function is called, it signals an
+;;; error indicating that a required &KEY argument was not supplied.
+;;; This function is also useful for DEFSTRUCT slot defaults
+;;; corresponding to required arguments.
+(declaim (ftype (function () nil) missing-arg))
+(defun missing-arg ()
+ #!+sb-doc
+ (/show0 "entering MISSING-ARG")
+ (error "A required &KEY or &OPTIONAL argument was not supplied."))
+
+;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
+;;;
+;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
+;;; The CL:ASSERT restarts and whatnot expand into a significant
+;;; amount of code when you multiply them by 400, so replacing them
+;;; with this should reduce the size of the system by enough to be
+;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
+;;; worthwhile, and since I don't really like CERROR stuff deep in the
+;;; guts of complex systems anyway, I replaced it too.)
+(defmacro aver (expr)
+ `(unless ,expr
+ (%failed-aver ,(format nil "~A" expr))))
+
+(defun %failed-aver (expr-as-string)
+ ;; hackish way to tell we're in a cold sbcl and output the
+ ;; message before signallign error, as it may be this is too
+ ;; early in the cold init.
+ (when (find-package "SB!C")
+ (fresh-line)
+ (write-line "failed AVER:")
+ (write-line expr-as-string)
+ (terpri))
+ (bug "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
+
+(defun bug (format-control &rest format-arguments)
+ (error 'bug
+ :format-control format-control
+ :format-arguments format-arguments))
+
+(defmacro enforce-type (value type)
+ (once-only ((value value))
+ `(unless (typep ,value ',type)
+ (%failed-enforce-type ,value ',type))))
+
+(defun %failed-enforce-type (value type)
+ ;; maybe should be TYPE-BUG, subclass of BUG? If it is changed,
+ ;; check uses of it in user-facing code (e.g. WARN)
+ (error 'simple-type-error
+ :datum value
+ :expected-type type
+ :format-control "~@<~S ~_is not a ~_~S~:>"
+ :format-arguments (list value type)))
+\f