Changeset 12246


Ignore:
Timestamp:
Jun 10, 2009, 9:12:14 PM (10 years ago)
Author:
gz
Message:

r11545 and r12132 from trunk

File:
1 edited

Legend:

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

    r12048 r12246  
    447447       (setq total-length (+ total-length length)))))
    448448
     449(defun concat-to-string (&rest sequences)
     450  (declare (dynamic-extent sequences))
     451  (let* ((size 0))
     452    (declare (fixnum size))
     453    (dolist (seq sequences)
     454      (setq size (+ size (the fixnum (length seq)))))
     455    (let* ((result (make-string size))
     456           (out 0))
     457      (declare (simple-string result) (fixnum out))
     458      (dolist (seq sequences result)
     459        (etypecase seq
     460          (simple-string
     461           (let* ((n (length seq)))
     462             (declare (fixnum n))
     463             (%copy-ivector-to-ivector seq
     464                                       0
     465                                       result
     466                                       (the fixnum (ash out 2))
     467                                       (the fixnum (ash n 2)))
     468             (incf out n)))
     469          (string
     470           (let* ((n (length seq)))
     471             (declare (fixnum n))
     472             (multiple-value-bind (data offset) (array-data-and-offset seq)
     473               (declare (fixnum offset))
     474               (%copy-ivector-to-ivector data
     475                                         (the fixnum (ash offset 2))
     476                                         result
     477                                         (the fixnum (ash out 2))
     478                                         (the fixnum (ash n 2)))
     479               (incf out n))))
     480          (vector
     481           (dotimes (i (length seq))
     482             (setf (schar result out) (aref seq i))
     483             (incf out)))
     484          (list
     485           (dolist (elt seq)
     486             (setf (schar result out) elt))))))))
    449487
    450488;This one doesn't choke on circular lists, doesn't cons as much, and is
     
    12561294;;; Delete-Duplicates:
    12571295
     1296(defparameter *delete-duplicates-hash-threshold*  200)
     1297
    12581298(defun list-delete-duplicates* (list test test-not key from-end start end)
    12591299  ;;(%print "test:" test "test-not:" test-not "key:" key)
    1260   (let ((handle (cons nil list)))
    1261     (do ((current  (nthcdr start list) (cdr current))
    1262          (previous (nthcdr start handle))
    1263          (index start (1+ index)))
    1264         ((or (= index end) (null current))
    1265          (cdr handle))
    1266       ;;(%print "outer loop top current:" current "previous:" previous)
    1267       (if (do ((x (if from-end
    1268                     (nthcdr (1+ start) handle)
    1269                     (cdr current))
    1270                   (cdr x))
    1271                (i (1+ index) (1+ i)))
    1272               ((or (null x)
    1273                    (and (not from-end) (= i end))
    1274                    (eq x current))
    1275                nil)
    1276             ;;(%print "inner loop top x:" x "i:" i)
    1277             (if (list-delete-duplicates*-aux current x test test-not key)
    1278               (return t)))
    1279         (rplacd previous (cdr current))
    1280         (setq previous (cdr previous))))))
     1300  (let* ((len (- end start))
     1301         (handle (cons nil list))
     1302         (previous (nthcdr start handle)))
     1303    (declare (dynamic-extent handle))
     1304    (if (and (> len *delete-duplicates-hash-threshold*)
     1305             (or (eq test 'eq) (eq test 'eql) (eq test 'equal) (eq test 'equalp)
     1306                 (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp)))
     1307      (let ((hash (make-hash-table :size len :test test :shared nil)))
     1308        (loop for i from start below end as obj in (cdr previous)
     1309          do (incf (gethash (funcall key obj) hash 0)))
     1310        (loop for i from start below end while (cdr previous)
     1311          do (let* ((current (cdr previous))
     1312                    (obj (car current))
     1313                    (obj-key (funcall key obj)))
     1314               (if (if from-end
     1315                     ;; Keep first ref
     1316                     (prog1 (gethash obj-key hash) (setf (gethash obj-key hash) nil))
     1317                     ;; Keep last ref
     1318                     (eql (decf (gethash obj-key hash)) 0))
     1319                 (setq previous current)
     1320                 (rplacd previous (cdr current))))))
     1321      (do ((current (cdr previous) (cdr current))
     1322           (index start (1+ index)))
     1323          ((or (= index end) (null current)))
     1324        ;;(%print "outer loop top current:" current "previous:" previous)
     1325        (if (do ((x (if from-end
     1326                      (nthcdr (1+ start) handle)
     1327                      (cdr current))
     1328                    (cdr x))
     1329                 (i (1+ index) (1+ i)))
     1330                ((or (null x)
     1331                     (and (not from-end) (= i end))
     1332                     (eq x current))
     1333                 nil)
     1334              ;;(%print "inner loop top x:" x "i:" i)
     1335              (if (list-delete-duplicates*-aux current x test test-not key)
     1336                (return t)))
     1337          (rplacd previous (cdr current))
     1338          (setq previous (cdr previous)))))
     1339    (cdr handle)))
    12811340
    12821341(defun list-delete-duplicates*-aux (current x test test-not key)
     
    12931352                                         &optional (length (length vector)))
    12941353  (declare (vector vector))
    1295   (do ((index start (1+ index))
    1296        (jndex start))
    1297       ((= index end)
    1298        (do ((index index (1+ index))            ; copy the rest of the vector
    1299             (jndex jndex (1+ jndex)))
    1300            ((= index length)
    1301             (setq vector (shrink-vector vector jndex)))
    1302             (aset vector jndex (aref vector index))))
    1303       (aset vector jndex (aref vector index))
    1304       (unless (position (funcall key (aref vector index)) vector :key key
    1305                              :start (if from-end start (1+ index)) :test test
    1306                                            :end (if from-end jndex end) :test-not test-not)
    1307               (setq jndex (1+ jndex)))))
     1354  (let* ((len (- end start))
     1355         (index start)
     1356         (jndex start))
     1357    (if (and (not test-not)
     1358             (> len *delete-duplicates-hash-threshold*)
     1359             (or (eq test 'eq) (eq test 'eql) (eq test 'equal) (eq test 'equalp)
     1360                 (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp)))
     1361        (let ((hash (make-hash-table :size len :test test :shared nil)))
     1362          (loop for i from start below end as obj = (aref vector i)
     1363             do (incf (gethash (funcall key obj) hash 0)))
     1364          (loop while (< index end) as obj = (aref vector index) as obj-key = (funcall key obj)
     1365             do (incf index)
     1366             do (when (if from-end
     1367                          (prog1 (gethash obj-key hash) (setf (gethash obj-key hash) nil))
     1368                          (eql (decf (gethash obj-key hash)) 0))
     1369                  (aset vector jndex obj)
     1370                  (incf jndex))))
     1371        (loop while (< index end) as obj = (aref vector index)
     1372           do (incf index)
     1373           do (unless (position (funcall key obj) vector :key key
     1374                                :start (if from-end start index) :test test
     1375                                :end (if from-end jndex end) :test-not test-not)
     1376                (aset vector jndex obj)
     1377                (incf jndex))))
     1378    (do ((index index (1+ index))       ; copy the rest of the vector
     1379         (jndex jndex (1+ jndex)))
     1380        ((= index length)
     1381         (setq vector (shrink-vector vector jndex)))
     1382      (aset vector jndex (aref vector index)))))
     1383
    13081384
    13091385(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end end key)
Note: See TracChangeset for help on using the changeset viewer.