1.0.11.17: fixed dumb buglet in DEFMACRO NAMED-LET

[sbcl.git] / src / code / early-extensions.lisp

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 2281678..bfe8451 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -377,8 +377,8 @@
 
 ;;; 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
+;;; order as in all the other indexed 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)
@@ -395,11 +395,12 @@
 \f
 ;;;; miscellaneous iteration extensions
 
-;;; "the ultimate iteration macro"
+;;; like Scheme's named LET
 ;;;
-;;; note for Schemers: This seems to be identical to Scheme's "named LET".
+;;; (CMU CL called this ITERATE, and commented it as "the ultimate
+;;; iteration macro...". I (WHN) found the old name insufficiently
+;;; specific to remind me what the macro means, so I renamed it.)
 (defmacro named-let (name binds &body body)
-  #!+sb-doc
   (dolist (x binds)
     (unless (proper-list-of-length-p x 2)
       (error "malformed NAMED-LET variable spec: ~S" x)))
@@ -920,75 +921,24 @@
   (def-constantly-fun constantly-nil nil)
   (def-constantly-fun constantly-0 0))
 
-;;; If X is an atom, see whether it is present in *FEATURES*. Also
+;;; If X is a symbol, see whether it is present in *FEATURES*. Also
 ;;; handle arbitrary combinations of atoms using NOT, AND, OR.
 (defun featurep (x)
-  (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*)))))
-
-;;; 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))))))
-
-;;; 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. That is not the
-;;; behavior that we usually want. This function is a wrapper which
-;;; restores the behavior that 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))))))
+  (etypecase x
+    (cons
+     (case (car x)
+       ((:not not)
+        (cond
+          ((cddr x)
+           (error "too many subexpressions in feature expression: ~S" x))
+          ((null (cdr x))
+           (error "too few subexpressions in feature expression: ~S" x))
+          (t (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))))
+    (symbol (not (null (memq x *features*))))))
 \f
 ;;;; utilities for two-VALUES predicates
 
@@ -1306,3 +1256,4 @@ to :INTERPRET, an interpreter will be used.")
                                                 bind))
                                           bindings)))
        ,@forms)))
+