X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=b73ac29033f7c44aa273907cbd28a163c7728f1e;hb=83ff95b8a70b1dc7cfffdf0a6bb7f4500ebe1ca1;hp=7db471f279fd9ed57cec4f2f72b64f40d27f6050;hpb=492dce07cf27b3cbee8ce4800c938fcb884aa53e;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 7db471f..b73ac29 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -30,18 +30,23 @@
 (def!type hash ()
   `(integer 0 ,max-hash))
 
-;;; a type used for indexing into arrays, and for related quantities
-;;; like lengths of lists
+;;; a type used for indexing into sequences, and for related
+;;; quantities like lengths of lists and other sequences.
 ;;;
-;;; It's intentionally limited to one less than the
-;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
-;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
-;;; that lets the system know it can increment a value of this type
-;;; without having to worry about using a bignum to represent the
-;;; result.
+;;; A more correct value for the exclusive upper bound for indexing
+;;; would be (1- ARRAY-DIMENSION-LIMIT) since ARRAY-DIMENSION-LIMIT is
+;;; the exclusive maximum *size* of one array dimension (As specified
+;;; in CLHS entries for MAKE-ARRAY and "valid array dimensions"). The
+;;; current value is maintained to avoid breaking existing code that
+;;; also uses that type for upper bounds on indices (e.g. sequence
+;;; length).
 ;;;
-;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
-;;; bound because ANSI specifies it as an exclusive bound.)
+;;; In SBCL, ARRAY-DIMENSION-LIMIT is arranged to be a little smaller
+;;; than MOST-POSITIVE-FIXNUM, for implementation (see comment above
+;;; ARRAY-DIMENSION-LIMIT) and efficiency reasons: staying below
+;;; MOST-POSITIVE-FIXNUM lets the system know it can increment a value
+;;; of type INDEX without having to worry about using a bignum to
+;;; represent the result.
 (def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
 
 ;;; like INDEX, but only up to half the maximum. Used by hash-table
@@ -430,7 +435,6 @@
                                     (eq (car clause) 'ignore))))
                          (cdr decl))))
           decls))
-
 ;;; just like DOLIST, but with one-dimensional arrays
 (defmacro dovector ((elt vector &optional result) &body body)
   (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
@@ -464,6 +468,19 @@
                 `(with-locked-system-table (,n-table)
                    ,iter-form)
                 iter-form))))))
+
+;;; Executes BODY for all entries of PLIST with KEY and VALUE bound to
+;;; the respective keys and values.
+(defmacro doplist ((key val) plist &body body)
+  (with-unique-names (tail)
+    `(let ((,tail ,plist) ,key ,val)
+       (loop (when (null ,tail) (return nil))
+             (setq ,key (pop ,tail))
+             (when (null ,tail)
+               (error "malformed plist, odd number of elements"))
+             (setq ,val (pop ,tail))
+             (progn ,@body)))))
+
 
 ;;;; hash cache utility
 
@@ -698,13 +715,13 @@
 ;;; our equality tests, because MEMBER and friends refer to EQLity.
 ;;; So:
 (defun equal-but-no-car-recursion (x y)
-  (cond
-    ((eql x y) t)
-    ((consp x)
-     (and (consp y)
-          (eql (car x) (car y))
-          (equal-but-no-car-recursion (cdr x) (cdr y))))
-    (t nil)))
+  (do () (())
+    (cond ((eql x y) (return t))
+          ((and (consp x)
+                (consp y)
+                (eql (pop x) (pop y))))
+          (t
+           (return)))))
 
 ;;;; package idioms
 
@@ -1419,3 +1436,16 @@ to :INTERPRET, an interpreter will be used.")
                        (list (list :line lineno)
                              (list :column colno)
                              (list :file-position pos)))))))
+
+(declaim (inline schwartzian-stable-sort-list))
+(defun schwartzian-stable-sort-list (list comparator &key key)
+  (if (null key)
+      (stable-sort (copy-list list) comparator)
+      (let* ((key (if (functionp key)
+                      key
+                      (symbol-function key)))
+             (wrapped (mapcar (lambda (x)
+                                (cons x (funcall key x)))
+                              list))
+             (sorted (stable-sort wrapped comparator :key #'cdr)))
+        (map-into sorted #'car sorted))))