Changeset 13873


Ignore:
Timestamp:
02/13/12 10:02:35 (9 years ago)
Author:
Mark Evenson
Message:

Restore autoload CL:MERGE as part of ANSI sort triage (See #196).

This was mistakenly removed as part of Jorge Tavares' last commit.

As an optimization, we attempt to invoke the original quicksort
implementation if the new one fails while emitting a warning to the
user.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/sort.lisp

    r13870 r13873  
    305305        (if (eq list-1 (cdr head))
    306306            (return list-1))))))
    307 
     307;;;
     308;;; MERGE
     309;;;
     310
     311;;; From ECL. Should already be user-extensible as it does no type dispatch
     312;;; and uses only user-extensible functions.
     313(defun merge (result-type sequence1 sequence2 predicate
     314                          &key key
     315                          &aux (l1 (length sequence1)) (l2 (length sequence2)))
     316  (unless key (setq key #'identity))
     317  (do ((newseq (make-sequence result-type (+ l1 l2)))
     318       (j 0 (1+ j))
     319       (i1 0)
     320       (i2 0))
     321    ((and (= i1 l1) (= i2 l2)) newseq)
     322    (cond ((and (< i1 l1) (< i2 l2))
     323           (cond ((funcall predicate
     324                           (funcall key (elt sequence1 i1))
     325                           (funcall key (elt sequence2 i2)))
     326                  (setf (elt newseq j) (elt sequence1 i1))
     327                  (incf i1))
     328                 ((funcall predicate
     329                           (funcall key (elt sequence2 i2))
     330                           (funcall key (elt sequence1 i1)))
     331                  (setf (elt newseq j) (elt sequence2 i2))
     332                  (incf i2))
     333                 (t
     334                  (setf (elt newseq j) (elt sequence1 i1))
     335                  (incf i1))))
     336          ((< i1 l1)
     337           (setf (elt newseq j) (elt sequence1 i1))
     338           (incf i1))
     339          (t
     340           (setf (elt newseq j) (elt sequence2 i2))
     341           (incf i2)))))
    308342
    309343;;;
     
    377411
    378412(defun quicksort (sequence predicate key)
    379   (let ((end (1- (length sequence))))
    380     (typecase sequence
    381       (simple-vector
    382        (if key
    383      (quicksort-body simple-vector svref predicate key sequence 0 end)
    384      (quicksort-body simple-vector svref predicate nil sequence 0 end)))
    385       (vector
    386        (if key
    387      (quicksort-body vector aref predicate key sequence 0 end)
    388      (quicksort-body vector aref predicate nil sequence 0 end))))
    389     sequence))
    390 
     413  (handler-case
     414      (let ((end (1- (length sequence))))
     415        (typecase sequence
     416          (simple-vector
     417           (if key
     418               (quicksort-body simple-vector svref predicate key sequence 0 end)
     419               (quicksort-body simple-vector svref predicate nil sequence 0 end)))
     420          (vector
     421           (if key
     422               (quicksort-body vector aref predicate key sequence 0 end)
     423               (quicksort-body vector aref predicate nil sequence 0 end))))
     424        sequence)
     425    (t (e)
     426      (warn "~&New quicksort implementation failed with~&'~A'.~&Trying stable implementation...~&" e)
     427      (quick-sort sequence 0 (length sequence) predicate key))))
     428
     429;;; DEPRECATED -- to be removed in abcl-1.4
     430;;; From ECL.
     431;;; Alternative implementation for quick-sort SORT
     432(defun quick-sort (seq start end pred key)
     433  (unless key (setq key #'identity))
     434  (if (<= end (1+ start))
     435      seq
     436      (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
     437        (block outer-loop
     438          (loop (loop (decf k)
     439                  (unless (< j k) (return-from outer-loop))
     440                  (when (funcall pred (funcall key (elt seq k)) kd)
     441                    (return)))
     442            (loop (incf j)
     443              (unless (< j k) (return-from outer-loop))
     444              (unless (funcall pred (funcall key (elt seq j)) kd)
     445                (return)))
     446            (let ((temp (elt seq j)))
     447              (setf (elt seq j) (elt seq k)
     448                    (elt seq k) temp))))
     449        (setf (elt seq start) (elt seq j)
     450              (elt seq j) d)
     451        (quick-sort seq start j pred key)
     452        (quick-sort seq (1+ j) end pred key))))
    391453
    392454;;;
Note: See TracChangeset for help on using the changeset viewer.