- Timestamp:
- Jun 20, 2008, 2:24:52 AM (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/1.2/source/lib/sequences.lisp
r8482 r9796 1240 1240 1241 1241 (defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) 1242 from-end (end (length sequence))key)1242 from-end end key) 1243 1243 "The elements of SEQUENCE are compared pairwise, and if any two match, 1244 1244 the one occurring earlier is discarded, unless FROM-END is true, in … … 1247 1247 1248 1248 The :TEST-NOT argument is deprecated." 1249 (setq end (check-sequence-bounds sequence start end)) 1249 1250 (delete-duplicates (copy-seq sequence) :from-end from-end :test test 1250 1251 :test-not test-not :start start :end end :key key)) … … 1252 1253 ;;; Delete-Duplicates: 1253 1254 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 1266 1255 (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)))))) 1312 1278 1313 1279 (defun list-delete-duplicates*-aux (current x test test-not key) 1314 1315 1316 1317 1318 1319 1320 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))))) 1321 1287 1322 1288 … … 1343 1309 given sequence, is returned. 1344 1310 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)) 1346 1312 (unless key (setq key #'identity)) 1347 1313 (seq-dispatch sequence 1348 1314 (if sequence 1349 1315 (list-delete-duplicates* sequence test test-not key from-end start end)) 1350 1316 (vector-delete-duplicates* sequence test test-not key from-end start end))) 1351 1317
Note: See TracChangeset
for help on using the changeset viewer.