- (let ((expr-tmp (gensym "EXPR-TMP-")))
- `(progn
- ;; When we're building the cross-compiler, and in most
- ;; situations even when we're running the cross-compiler,
- ;; all we need is a nice portable definition in terms of the
- ;; ANSI Common Lisp operations.
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (let ((,expr-tmp ,expr))
- (cond ((boundp ',symbol)
- (unless (and (constantp ',symbol)
- (funcall ,eqx
- (symbol-value ',symbol)
- ,expr-tmp))
- (error "already bound differently: ~S")))
- (t
- (defconstant ,symbol
- ;; KLUDGE: This is a very ugly hack, to be able to
- ;; build SBCL with CMU CL (2.4.19), because there
- ;; seems to be some confusion in CMU CL about
- ;; ,EXPR-TEMP at EVAL-WHEN time ... -- MNA 2000-02-23
- #-cmu ,expr-tmp
- #+cmu ,expr
- ,@(when doc `(,doc)))))))
- ;; The #+SB-XC :COMPILE-TOPLEVEL situation is special, since we
- ;; want to define the symbol not just in the cross-compilation
- ;; host Lisp (which was handled above) but also in the
- ;; cross-compiler (which we will handle now).
- ;;
- ;; KLUDGE: It would probably be possible to do this fairly
- ;; cleanly, in a way parallel to the code above, if we had
- ;; SB!XC:FOO versions of all the primitives CL:FOO used above
- ;; (e.g. SB!XC:BOUNDP, SB!XC:SYMBOL-VALUE, and
- ;; SB!XC:DEFCONSTANT), and took care to call them. But right
- ;; now we just hack around in the guts of the cross-compiler
- ;; instead. -- WHN 2000-11-03
- #+sb-xc
- (eval-when (:compile-toplevel)
- (let ((,expr-tmp ,symbol))
- (unless (and (eql (info :variable :kind ',symbol) :constant)
- (funcall ,eqx
- (info :variable :constant-value ',symbol)
- ,expr-tmp))
- (sb!c::%defconstant ',symbol ,expr-tmp ,doc)))))))
+ `(def!constant ,symbol
+ (%defconstant-eqx-value ',symbol ,expr ,eqx)
+ ,@(when doc (list doc))))
+(defun %defconstant-eqx-value (symbol expr eqx)
+ (declare (type function eqx))
+ (flet ((bummer (explanation)
+ (error "~@<bad DEFCONSTANT-EQX ~S ~2I~_~S: ~2I~_~A ~S~:>"
+ symbol
+ expr
+ explanation
+ (symbol-value symbol))))
+ (cond ((not (boundp symbol))
+ expr)
+ ((not (constantp symbol))
+ (bummer "already bound as a non-constant"))
+ ((not (funcall eqx (symbol-value symbol) expr))
+ (bummer "already bound as a different constant value"))
+ (t
+ (symbol-value symbol)))))
+\f
+;;; a helper function for various macros which expect clauses of a
+;;; given length, etc.
+;;;
+;;; Return true if X is a proper list whose length is between MIN and
+;;; MAX (inclusive).
+(defun proper-list-of-length-p (x min &optional (max min))
+ ;; FIXME: This implementation will hang on circular list
+ ;; structure. Since this is an error-checking utility, i.e. its
+ ;; job is to deal with screwed-up input, it'd be good style to fix
+ ;; it so that it can deal with circular list structure.
+ (cond ((minusp max) nil)
+ ((null x) (zerop min))
+ ((consp x)
+ (and (plusp max)
+ (proper-list-of-length-p (cdr x)
+ (if (plusp (1- min))
+ (1- min)
+ 0)
+ (1- max))))
+ (t nil)))
+
+;;; Helpers for defining error-signalling NOP's for "not supported
+;;; here" operations.
+(defmacro define-unsupported-fun (name &optional
+ (doc "Unsupported on this platform.")
+ (control
+ "~S is unsupported on this platform ~
+ (OS, CPU, whatever)."
+ controlp)
+ arguments)
+ `(defun ,name (&rest args)
+ ,doc
+ (declare (ignore args))
+ (error 'unsupported-operator
+ :format-control ,control
+ :format-arguments (if ,controlp ',arguments (list ',name)))))