X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=e2782a21bea3d798b7edb8b34d4834d47c16bab1;hb=cd176690400f8b6fa23faa4dc6fa8494bcbce480;hp=f2c3adf7ff451c982e6f31d369f01bc868c085b9;hpb=dec94b039e8ec90baf21463df839a6181de606f6;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index f2c3adf..e2782a2 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -110,8 +110,8 @@
 					 (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))
@@ -146,6 +146,13 @@
 	       ((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 *))))
 
 ;;;; the COLLECT macro
 ;;;;
@@ -193,7 +200,7 @@
 ;;; 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)
@@ -201,7 +208,7 @@
 	(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))
@@ -232,7 +239,7 @@
 ;;; 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
@@ -289,6 +296,15 @@
 (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))
 
 ;;;; miscellaneous iteration extensions
 
@@ -371,7 +387,7 @@
 ;;;   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))
@@ -387,7 +403,7 @@
 	 (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)
@@ -555,7 +571,7 @@
 ;;;; 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)
@@ -565,16 +581,16 @@
 
 ;;; 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)
@@ -583,26 +599,37 @@
 	      (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
@@ -662,10 +689,10 @@
 ;;; 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
@@ -927,3 +954,8 @@
   (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))