Changeset 9796 for release/1.2/source


Ignore:
Timestamp:
Jun 20, 2008, 2:24:52 AM (11 years ago)
Author:
rme
Message:

Port r9786 here (fix for ticket:310 delete-/remove-duplicates bug).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/1.2/source/lib/sequences.lisp

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