X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=9e528e86cdeced0711da66693074dcd68a27daef;hb=5edd74f6911093805a009a152b32216b3dba59f7;hp=7663514f90b4815021793d0783ee31c7c173c993;hpb=913e06f191acb65c1d99d42234704bec38500ff4;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 7663514..9e528e8 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))
@@ -380,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))
@@ -396,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)
@@ -455,8 +462,8 @@
 		  (,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)))))
@@ -472,8 +479,8 @@
 		  (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)))
@@ -625,7 +632,7 @@
 
 
 ;;; 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) ..)))
@@ -638,7 +645,12 @@
    "~@<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))))
 
 ;;;; ONCE-ONLY
 ;;;;
@@ -682,10 +694,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
@@ -699,16 +711,15 @@
 ;;; 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))
 (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~:>"
@@ -947,3 +958,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))