Changeset 9868


Ignore:
Timestamp:
Jul 1, 2008, 9:15:44 PM (11 years ago)
Author:
gz
Message:

Propagate r9786 here from trunk

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/sequences.lisp

    r9620 r9868  
    12361236
    12371237(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0)
    1238       from-end (end (length sequence)) key)
     1238      from-end end key)
    12391239  "The elements of SEQUENCE are compared pairwise, and if any two match,
    12401240   the one occurring earlier is discarded, unless FROM-END is true, in
     
    12431243
    12441244   The :TEST-NOT argument is deprecated."
     1245  (setq end (check-sequence-bounds sequence start end))
    12451246  (delete-duplicates (copy-seq sequence) :from-end from-end :test test
    12461247                     :test-not test-not :start start :end end :key key))
     
    12481249;;; Delete-Duplicates:
    12491250
    1250 (defresource *eq-hash-resource* :constructor (make-hash-table :test #'eq)
    1251   :destructor #'clrhash)
    1252 
    1253 (defresource *eql-hash-resource* :constructor (make-hash-table :test #'eql)
    1254   :destructor #'clrhash)
    1255 
    1256 (defresource *equal-hash-resource* :constructor (make-hash-table :test #'equal)
    1257   :destructor #'clrhash)
    1258 
    1259 (defresource *equalp-hash-resource* :constructor (make-hash-table :test #'equalp)
    1260   :destructor #'clrhash)
    1261 
    12621251(defun list-delete-duplicates* (list test test-not key from-end start end)
    1263   ;(%print "test:" test "test-not:" test-not "key:" key)
    1264   (let (res)
    1265     (cond
    1266      ((and (> (- end start) 10) (not test-not) ;(eq key #'identity)
    1267            (cond ((or (eq test 'eq)(eq test #'eq))(setq res *eq-hash-resource*))
    1268                  ((or (eq test 'eql)(eq test #'eql))(setq res *eql-hash-resource*))
    1269                  ((or (eq test 'equal)(eq test  #'equal))
    1270                   (setq res *equal-hash-resource*))
    1271                  ((or (eq test 'equalp)(eq test #'equalp))
    1272                   (setq res *equalp-hash-resource*))))
    1273       (when (not from-end)(setq list (nreverse list))) ; who cares about which end?
    1274       (let* (prev)
    1275         (using-resource (table res)
    1276           (do* ((rest (nthcdr start list) (%cdr rest))
    1277                 (index start (%i+ 1 index)))
    1278                ((or (eq index end)(null rest)))
    1279             (declare (fixnum index start end))
    1280             (let ((thing (funcall key (%car rest))))
    1281               (cond ((gethash thing table)
    1282                      (%rplacd prev (%cdr rest)))
    1283                     (t (setf (gethash thing table) t)
    1284                        (setq prev rest))))))
    1285         (if from-end list (nreverse list))))
    1286      (T
    1287       (let ((handle (cons nil list)))
    1288         (do ((current  (nthcdr start list) (cdr current))
    1289              (previous (nthcdr start handle))
    1290              (index start (1+ index)))
    1291             ((or (= index end) (null current))
    1292              (cdr handle))
    1293           ;(%print "outer loop top current:" current "previous:" previous)
    1294           (if (do ((x (if from-end
    1295                         (nthcdr (1+ start) handle)
    1296                         (cdr current))
    1297                       (cdr x))
    1298                    (i (1+ index) (1+ i)))
    1299                   ((or (null x)
    1300                        (and (not from-end) (= i end))
    1301                        (eq x current))
    1302                    nil)
    1303                 ;(%print "inner loop top x:" x "i:" i)
    1304                 (if (list-delete-duplicates*-aux current x test test-not key)                                   
    1305                   (return t)))
    1306             (rplacd previous (cdr current))
    1307             (setq previous (cdr previous)))))))))
     1252  ;;(%print "test:" test "test-not:" test-not "key:" key)
     1253  (let ((handle (cons nil list)))
     1254    (do ((current  (nthcdr start list) (cdr current))
     1255         (previous (nthcdr start handle))
     1256         (index start (1+ index)))
     1257        ((or (= index end) (null current))
     1258         (cdr handle))
     1259      ;;(%print "outer loop top current:" current "previous:" previous)
     1260      (if (do ((x (if from-end
     1261                    (nthcdr (1+ start) handle)
     1262                    (cdr current))
     1263                  (cdr x))
     1264               (i (1+ index) (1+ i)))
     1265              ((or (null x)
     1266                   (and (not from-end) (= i end))
     1267                   (eq x current))
     1268               nil)
     1269            ;;(%print "inner loop top x:" x "i:" i)
     1270            (if (list-delete-duplicates*-aux current x test test-not key)
     1271              (return t)))
     1272        (rplacd previous (cdr current))
     1273        (setq previous (cdr previous))))))
    13081274
    13091275(defun list-delete-duplicates*-aux (current x test test-not key)
    1310      (if test-not
    1311        (not (funcall test-not
    1312                      (funcall key (car current))
    1313                      (funcall key (car x))))
    1314        (funcall test
    1315                 (funcall key (car current))
    1316                 (funcall key (car x)))))
     1276  (if test-not
     1277    (not (funcall test-not
     1278                  (funcall key (car current))
     1279                  (funcall key (car x))))
     1280    (funcall test
     1281             (funcall key (car current))
     1282             (funcall key (car x)))))
    13171283
    13181284
     
    13391305   given sequence, is returned.
    13401306   Sequences of type STR have a NEW str returned."
    1341   (unless end (setq end (length sequence)))
     1307  (setq end (check-sequence-bounds sequence start end))
    13421308  (unless key (setq key #'identity))
    13431309  (seq-dispatch sequence
    13441310    (if sequence
    1345               (list-delete-duplicates* sequence test test-not key from-end start end))
     1311      (list-delete-duplicates* sequence test test-not key from-end start end))
    13461312    (vector-delete-duplicates* sequence test test-not key from-end start end)))
    13471313
Note: See TracChangeset for help on using the changeset viewer.