-;;; Is X a (possibly-improper) list of at least N elements?
-(declaim (ftype (function (t index)) list-of-length-at-least-p))
-(defun list-of-length-at-least-p (x n)
- (or (zerop n) ; since anything can be considered an improper list of length 0
- (and (consp x)
- (list-of-length-at-least-p (cdr x) (1- n)))))
-
-;;; Return a list of N gensyms. (This is a common suboperation in
-;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
- (loop repeat n collect (gensym)))
-
-;;; ANSI guarantees that some symbols are self-evaluating. This
-;;; function is to be called just before a change which would affect
-;;; that. (We don't absolutely have to call this function before such
-;;; changes, since such changes are given as undefined behavior. In
-;;; particular, we don't if the runtime cost would be annoying. But
-;;; otherwise it's nice to do so.)
-(defun about-to-modify (symbol)
- (declare (type symbol symbol))
- (cond ((eq symbol t)
- (error "Veritas aeterna. (can't change T)"))
- ((eq symbol nil)
- (error "Nihil ex nihil. (can't change NIL)"))
- ((keywordp symbol)
- (error "Keyword values can't be changed."))
- ;; (Just because a value is CONSTANTP is not a good enough
- ;; reason to complain here, because we want DEFCONSTANT to
- ;; be able to use this function, and it's legal to DEFCONSTANT
- ;; a constant as long as the new value is EQL to the old
- ;; value.)
- ))
+(deftype function-name () '(satisfies legal-fun-name-p))
+
+;;; Signal an error unless NAME is a legal function name.
+(defun legal-fun-name-or-type-error (name)
+ (unless (legal-fun-name-p name)
+ (error 'simple-type-error
+ :datum name
+ :expected-type 'function-name
+ :format-control "invalid function name: ~S"
+ :format-arguments (list name))))
+
+;;; Given a function name, return the symbol embedded in it.
+;;;
+;;; The ordinary use for this operator (and the motivation for the
+;;; name of this operator) is to convert from a function name to the
+;;; name of the BLOCK which encloses its body.
+;;;
+;;; Occasionally the operator is useful elsewhere, where the operator
+;;; name is less mnemonic. (Maybe it should be changed?)
+(declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name))
+(defun fun-name-block-name (fun-name)
+ (cond ((symbolp fun-name)
+ fun-name)
+ ((consp fun-name)
+ (multiple-value-bind (legalp block-name)
+ (valid-function-name-p fun-name)
+ (if legalp
+ block-name
+ (error "not legal as a function name: ~S" fun-name))))
+ (t
+ (error "not legal as a function name: ~S" fun-name))))
+
+(defun looks-like-name-of-special-var-p (x)
+ (and (symbolp x)
+ (let ((name (symbol-name x)))
+ (and (> (length name) 2) ; to exclude '* and '**
+ (char= #\* (aref name 0))
+ (char= #\* (aref name (1- (length name))))))))
+
+;;; 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) bind)
+ (declare (symbol symbol))
+ (flet ((describe-action ()
+ (ecase action
+ (set "set SYMBOL-VALUE of ~S")
+ (progv "bind ~S")
+ (compare-and-swap "compare-and-swap SYMBOL-VALUE of ~S")
+ (defconstant "define ~S as a constant")
+ (makunbound "make ~S unbound"))))
+ (let ((kind (info :variable :kind symbol)))
+ (multiple-value-bind (what continue)
+ (cond ((eq :constant kind)
+ (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))))
+ ((and bind (eq :global kind))
+ (values "Can't ~@? (global variable)." nil)))
+ (when what
+ (if continue
+ (cerror "Modify the constant." what (describe-action) symbol)
+ (error what (describe-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 nil)
+ (let ((spec (type-specifier type)))
+ (error 'simple-type-error
+ :format-control "~@<Cannot ~@? to ~S, not of type ~S.~:@>"
+ :format-arguments (list (describe-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."))