X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-extensions.lisp;h=4d0e08bbb715ef145092b12d735dd6753164b591;hb=3c7a9b188472ae8381e50a3dfbed1c6631219893;hp=4c67532b555179c87014d17cb10bba95689cf0b2;hpb=c8af15e61b030c8d4b0e950bc9b7618530044618;p=sbcl.git

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 4c67532..4d0e08b 100644
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -1,3 +1,9 @@
+;;;; various extensions (including SB-INT "internal extensions")
+;;;; available both in the cross-compilation host Lisp and in the
+;;;; target SBCL, but which can't be defined on the target until until
+;;;; some significant amount of machinery (e.g. error-handling) is
+;;;; defined
+
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
 ;;;;
@@ -9,73 +15,33 @@
 
 (in-package "SB!IMPL")
 
-(defun featurep (x)
-  #!+sb-doc
-  "If X is an atom, see whether it is present in *FEATURES*. Also
-  handle arbitrary combinations of atoms using NOT, AND, OR."
-  (if (consp x)
-    (case (car x)
-      ((:not not)
-       (if (cddr x)
-	 (error "too many subexpressions in feature expression: ~S" x)
-	 (not (featurep (cadr x)))))
-      ((:and and) (every #'featurep (cdr x)))
-      ((:or or) (some #'featurep (cdr x)))
-      (t
-       (error "unknown operator in feature expression: ~S." x)))
-    (not (null (memq x *features*)))))
+;;; Is X a list for which LENGTH is meaningful, i.e. a list which is
+;;; not improper and which is not circular?
+(defun list-with-length-p (x)
+  (values (ignore-errors (list-length x))))
 
-;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
-;;; &KEY-argument-list-style list of alternating keywords and
-;;; arbitrary values, return a new &KEY-argument-list-style list with
-;;; all substitutions applied to it.
-;;;
-;;; Note: If efficiency mattered, we could do less consing. (But if
-;;; efficiency mattered, why would we be using &KEY arguments at
-;;; all, much less renaming &KEY arguments?)
-;;;
-;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
-(defun rename-key-args (rename-list key-args)
-  (declare (type list rename-list key-args))
-  ;; Walk through RENAME-LIST modifying RESULT as per each element in
-  ;; RENAME-LIST.
-  (do ((result (copy-list key-args))) ; may be modified below
-      ((null rename-list) result)
-    (destructuring-bind (old new) (pop rename-list)
-      ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
-      (declare (type symbol old new))
-      ;; Walk through RESULT renaming any OLD key argument to NEW.
-      (do ((in-result result (cddr in-result)))
-	  ((null in-result))
-	(declare (type list in-result))
-	(when (eq (car in-result) old)
-	  (setf (car in-result) new))))))
+;;; not used in 0.7.8, but possibly useful for defensive programming
+;;; in e.g. (COERCE ... 'VECTOR)
+;;;(defun list-length-or-die (x)
+;;;  (or (list-length x)
+;;;      ;; not clear how to do this best:
+;;;      ;;   * Should this be a TYPE-ERROR? Colloquially that'd make
+;;;      ;;     lots of sense, but since I'm not sure how to express
+;;;      ;;     "noncircular list" as a Lisp type expression, coding
+;;;      ;;     it seems awkward.
+;;;      ;;   * Should the ERROR object include the offending value?
+;;;      ;;     Ordinarily that's helpful, but if the user doesn't have
+;;;      ;;     his printer set up to deal with cyclicity, we might not
+;;;      ;;     be doing him a favor by printing the object here.
+;;;      ;; -- WHN 2002-10-19
+;;;      (error "can't calculate length of cyclic list")))
 
-;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
-;;; other ANSI input functions, is defined to communicate end of file
-;;; status with its return value, not by signalling. This is not the
-;;; behavior we usually want. This is a wrapper which give the
-;;; behavior we usually want, causing READ-SEQUENCE to communicate
-;;; end-of-file status by signalling.
-(defun read-sequence-or-die (sequence stream &key start end)
-  ;; implementation using READ-SEQUENCE
-  #-no-ansi-read-sequence
-  (let ((read-end (read-sequence sequence
-				 stream
-				 :start start
-				 :end end)))
-    (unless (= read-end end)
-      (error 'end-of-file :stream stream))
-    (values))
-  ;; workaround for broken READ-SEQUENCE
-  #+no-ansi-read-sequence
-  (progn
-    (aver (<= start end))
-    (let ((etype (stream-element-type stream)))
-    (cond ((equal etype '(unsigned-byte 8))
-	   (do ((i start (1+ i)))
-	       ((>= i end)
-		(values))
-	     (setf (aref sequence i)
-		   (read-byte stream))))
-	  (t (error "unsupported element type ~S" etype))))))
+;;; This is used in constructing arg lists for debugger printing,
+;;; and when needing to print unbound slots in PCL.
+(defstruct (unprintable-object
+            (:constructor make-unprintable-object (string))
+            (:print-object (lambda (x s)
+                             (print-unreadable-object (x s)
+                               (write-string (unprintable-object-string x) s))))
+            (:copier nil))
+  string)