;;; (or just find a nicer way of expressing characters portably?) --
;;; WHN 19990713
(defconstant bell-char-code 7)
+(defconstant backspace-char-code 8)
(defconstant tab-char-code 9)
+(defconstant line-feed-char-code 10)
(defconstant form-feed-char-code 12)
(defconstant return-char-code 13)
(defconstant escape-char-code 27)
(1- max))))
(t nil))))
-;;; Is X a circular list?
-(defun circular-list-p (x)
+;;; Is X a list containing a cycle?
+(defun cyclic-list-p (x)
(and (listp x)
(labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x))))
(do ((y x (safe-cddr y))
((or (= r 0) (> d q)) (/= r 0))
(declare (fixnum inc))
(multiple-value-setq (q r) (truncate x d))))))
+
+;;; Could this object contain other objects? (This is important to
+;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
+(defun compound-object-p (x)
+ (or (consp x)
+ (typep x 'instance)
+ (typep x '(array t *))))
\f
;;;; the COLLECT macro
;;;;
;;; the function is made the new value for the collection. As a
;;; totally magical special-case, FUNCTION may be COLLECT, which tells
;;; us to build a list in forward order; this is the default. If an
-;;; INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd
+;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd
;;; onto the end. Note that FUNCTION may be anything that can appear
;;; in the functional position, including macros and lambdas.
(defmacro collect (collections &body body)
(binds ()))
(dolist (spec collections)
(unless (proper-list-of-length-p spec 1 3)
- (error "malformed collection specifier: ~S." spec))
+ (error "malformed collection specifier: ~S" spec))
(let* ((name (first spec))
(default (second spec))
(kind (or (third spec) 'collect))
;;; like (MEMBER ITEM LIST :TEST #'EQ)
(defun memq (item list)
#!+sb-doc
- "Returns tail of LIST beginning with first element EQ to ITEM."
+ "Return tail of LIST beginning with first element EQ to ITEM."
;; KLUDGE: These could be and probably should be defined as
;; (MEMBER ITEM LIST :TEST #'EQ)),
;; but when I try to cross-compile that, I get an error from
(declaim (inline neq))
(defun neq (x y)
(not (eq x y)))
+
+;;; not really an old-fashioned function, but what the calling
+;;; convention should've been: like NTH, but with the same argument
+;;; order as in all the other dereferencing functions, with the
+;;; collection first and the index second
+(declaim (inline nth-but-with-sane-arg-order))
+(declaim (ftype (function (list index) t) nth-but-with-sane-arg-order))
+(defun nth-but-with-sane-arg-order (list index)
+ (nth index list))
\f
;;;; miscellaneous iteration extensions
;;; The code for initializing the cache is wrapped in a form with
;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
;;; in type system definitions so that caches will be created
-;;; before top-level forms run.)
+;;; before top level forms run.)
(defmacro define-hash-cache (name args &key hash-function hash-bits default
(init-wrapper 'progn)
(values 1))
(n-cache (gensym)))
(unless (= (length default-values) values)
- (error "The number of default values ~S differs from :VALUES ~D."
+ (error "The number of default values ~S differs from :VALUES ~W."
default values))
(collect ((inlines)
(,n-cache ,var-name))
(declare (type fixnum ,n-index))
,@(sets)
- ,@(mapcar #'(lambda (i val)
- `(setf (svref ,n-cache ,i) ,val))
+ ,@(mapcar (lambda (i val)
+ `(setf (svref ,n-cache ,i) ,val))
(values-indices)
(values-names))
(values)))))
(dotimes (i nargs)
(arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
(arg-sets))
- ,@(mapcar #'(lambda (i val)
- `(setf (svref ,n-cache ,i) ,val))
+ ,@(mapcar (lambda (i val)
+ `(setf (svref ,n-cache ,i) ,val))
(values-indices)
default-values))
(values)))
;;;; various operations on names
;;; Is NAME a legal function name?
-(defun legal-function-name-p (name)
+(defun legal-fun-name-p (name)
(or (symbolp name)
(and (consp name)
(eq (car name) 'setf)
;;; Given a function name, return the name for the BLOCK which
;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
-(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
-(defun function-name-block-name (function-name)
- (cond ((symbolp function-name)
- function-name)
- ((and (consp function-name)
- (= (length function-name) 2)
- (eq (first function-name) 'setf))
- (second function-name))
+(declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name))
+(defun fun-name-block-name (fun-name)
+ (cond ((symbolp fun-name)
+ fun-name)
+ ((and (consp fun-name)
+ (= (length fun-name) 2)
+ (eq (first fun-name) 'setf))
+ (second fun-name))
(t
- (error "not legal as a function name: ~S" function-name))))
+ (error "not legal as a function name: ~S" fun-name))))
(defun looks-like-name-of-special-var-p (x)
(and (symbolp x)
(char= #\* (aref name 0))
(char= #\* (aref name (1- (length name))))))))
-;;; 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)
+;;; Some symbols are defined by ANSI to be self-evaluating. Return
+;;; non-NIL for such symbols (and make the non-NIL value a traditional
+;;; message, for use in contexts where the user asks us to change such
+;;; a symbol).
+(defun symbol-self-evaluating-p (symbol)
(declare (type symbol symbol))
(cond ((eq symbol t)
- (error "Veritas aeterna. (can't change T)"))
+ "Veritas aeterna. (can't change T)")
((eq symbol nil)
- (error "Nihil ex nihil. (can't change NIL)"))
+ "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.)
- ))
+ "Keyword values can't be changed.")
+ (t
+ nil)))
+
+;;; 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 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-value (symbol)
+ (declare (type symbol symbol))
+ (let ((reason (symbol-self-evaluating-p symbol)))
+ (when reason
+ (error reason)))
+ ;; (Note: 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.)
+ (values))
+
;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
-;;; assignment. That way things like
+;;; 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) ..)))
"~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
(SETF FDEFINITION)~:@>"
name)
- `(setf (fdefinition ',name) ,lambda))
+ ;; 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
;;;;
;;; 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) required-argument))
-(defun required-argument ()
+(declaim (ftype (function () nil) missing-arg))
+(defun missing-arg ()
#!+sb-doc
- (/show0 "entering REQUIRED-ARGUMENT")
+ (/show0 "entering MISSING-ARG")
(error "A required &KEY or &OPTIONAL argument was not supplied."))
;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
;;; guts of complex systems anyway, I replaced it too.)
(defmacro aver (expr)
`(unless ,expr
- (%failed-aver ,(let ((*package* (find-package :keyword)))
- (format nil "~S" expr)))))
+ (%failed-aver ,(format nil "~A" expr))))
+
(defun %failed-aver (expr-as-string)
- (error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
+ (bug "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
+
+;;; We need a definition of BUG here for the host compiler to be able
+;;; to deal with BUGs in sbcl. This should never affect an end-user,
+;;; who will pick up the definition that signals a CONDITION of
+;;; condition-class BUG; however, this is not defined on the host
+;;; lisp, but for the target. SBCL developers sometimes trigger BUGs
+;;; in their efforts, and it is useful to get the details of the BUG
+;;; rather than an undefined function error. - CSR, 2002-04-12
+#+sb-xc-host
+(defun bug (format-control &rest format-arguments)
+ (error 'simple-error
+ :format-control "~@< ~? ~:@_~?~:>"
+ :format-arguments `(,format-control
+ ,format-arguments
+ "~@<If you see this and are an SBCL ~
+developer, then it is probable that you have made a change to the ~
+system that has broken the ability for SBCL to compile, usually by ~
+removing an assumed invariant of the system, but sometimes by making ~
+an averrance that is violated (check your code!). If you are a user, ~
+please submit a bug report to the developers' mailing list, details of ~
+which can be found at <http://sbcl.sourceforge.net/>.~:@>"
+ ())))
+
(defmacro enforce-type (value type)
(once-only ((value value))
`(unless (typep ,value ',type)
(%failed-enforce-type ,value ',type))))
+
(defun %failed-enforce-type (value type)
- (error 'simple-type-error
+ (error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG?
:value value
:expected-type type
:format-string "~@<~S ~_is not a ~_~S~:>"
(t
(error "bad option: ~S" (first option)))))))))))
`(def!method print-object ((structure ,name) ,stream)
- ;; FIXME: should probably be byte-compiled
(pprint-logical-block (,stream nil)
(print-unreadable-object (structure
,stream
(if (typep possibly-logical-pathname 'logical-pathname)
(translate-logical-pathname possibly-logical-pathname)
possibly-logical-pathname))
+
+(defun deprecation-warning (bad-name &optional good-name)
+ (warn "using deprecated ~S~@[, should use ~S instead~]"
+ bad-name
+ good-name))
projects / sbcl.git / blobdiff