Changeset 15477


Ignore:
Timestamp:
Oct 10, 2012, 2:35:06 AM (7 years ago)
Author:
gb
Message:

COPY-LIST: if we find that the list is "fairly long", check to see
if it's "very long" and change algorithm if so.

CHECK-SEQUENCE-BOUNDS: take length as an &optional arg, since some
callers may want to avoid doing LENGTH multiple times.

CONSTANTLY: return #'TRUE or #'FALSE if appropriate.

REMOVE, REMOVE-IF, REMOVE-IF-NOT: build result, don't do destructive
operations on copy. (Fixes ticket:1015 in the trunk, though other
sequence functions may do similar things.)

Location:
trunk/source
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-aprims.lisp

    r15466 r15477  
    147147    (let ((result (cons (car list) '()) ))
    148148      (do ((x (cdr list) (cdr x))
     149           (i 0 (1+ i))
     150           (len)
    149151           (splice result
    150152                   (%cdr (%rplacd splice (cons (%car x) '() ))) ))
    151           ((atom x) (unless (null x)
    152                       (%rplacd splice x)) result)))))
     153          ((atom x)
     154           (unless (null x)
     155             (%rplacd splice x))
     156           result)
     157        (declare (fixnum i))
     158        ;; If the argument is "moderately long", check to see if it's
     159        ;; "very long"; if so, it may be much faster to replace the
     160        ;; elements of a list allocated in a single operation than it
     161        ;; is to repeatedly CONS (since the latter tends to fight with
     162        ;; the EGC.)
     163        ;; The definitions of "moderately long" and "very long" are
     164        ;; both somewhat arbitrary.
     165        (when (and (= i 1024)
     166                   (> (setq len (alt-list-length x)) (ash 1 16)))
     167          (do* ((tail (setf (%cdr splice) (%allocate-list 0 len)))
     168                (x x (cdr x)))
     169               ((atom x)
     170                (unless (null x)
     171                  (%rplacd tail x))
     172                (return-from copy-list result))
     173            (%rplaca tail (%car x))
     174            (unless (atom (%cdr x))
     175              (setq tail (cdr tail)))))))))
     176         
    153177
    154178(defun alt-list-length (l)
     
    400424  (seq-dispatch seq (list-reverse seq) (vector-reverse seq)))
    401425
    402 (defun check-sequence-bounds (seq start end)
     426(defun check-sequence-bounds (seq start end &optional (length (length seq)))
     427  (declare (fixnum length))
    403428  (flet ((bad-sequence-interval (seq start end)
    404429           (unless (typep start 'unsigned-byte)
     
    407432             (report-bad-arg end '(or null unsigned-byte)))
    408433           (error "Bad interval for sequence operation on ~s : start = ~s, end = ~s" seq start end)))
    409   (let* ((length (length seq)))
    410     (declare (fixnum length))
    411434    (if (and (typep start 'fixnum)
    412435             (<= 0 (the fixnum start))
     
    418441
    419442      end
    420       (bad-sequence-interval seq start end)))))
     443      (bad-sequence-interval seq start end))))
    421444
    422445 
  • trunk/source/level-1/l1-clos-boot.lisp

    r15474 r15477  
    21892189  (defun constantly (x)
    21902190    "Return a function that always returns VALUE."
    2191     #'(lambda (&rest ignore)
    2192         (declare (dynamic-extent ignore)
    2193                  (ignore ignore))
    2194         x))
     2191    (cond ((null x) #'false)
     2192          ((eq x t) #'true)
     2193          (t
     2194           #'(lambda (&rest ignore)
     2195               (declare (dynamic-extent ignore)
     2196                        (ignore ignore))
     2197               x))))
    21952198
    21962199  (defun %register-type-ordinal-class (foreign-type class-name)
  • trunk/source/lib/sequences.lisp

    r14788 r15477  
    10401040  (do* ((handle (cons nil list))
    10411041        (splice handle)
    1042         (numdeleted 0)
     1042v        (numdeleted 0)
    10431043        (i 0 (1+ i)))
    10441044       ((or (= i end) (null (cdr splice)) (= numdeleted count))
     
    12171217;;; Remove:
    12181218
     1219(defun list-remove (item sequence test test-not start end count from-end key)
     1220  (collect ((new))
     1221    (dotimes (i start)
     1222      (new (pop sequence)))
     1223    (let* ((i start)
     1224           (removed 0))
     1225      (declare (fixnum i removed))
     1226      (if key
     1227        (cond (test
     1228               (do* ()
     1229                    ((or (= i end) (= removed count)))
     1230                 (let* ((element (pop sequence)))
     1231                   (if (funcall test item (funcall key element))
     1232                     (incf removed)
     1233                     (new element)))
     1234                 (incf i)))
     1235              (test-not
     1236               (do* ()
     1237                    ((or (= i end) (= removed count)))
     1238                 (let* ((element (pop sequence)))
     1239                   (if (not (funcall test-not item (funcall key element)))
     1240                     (incf removed)
     1241                     (new element)))
     1242                 (incf i)))
     1243              (t
     1244               (do* ()
     1245                    ((or (= i end) (= removed count)))
     1246                 (let* ((element (pop sequence)))
     1247                   (if (eql item (funcall key element))
     1248                     (incf removed)
     1249                     (new element)))
     1250                 (incf i))))
     1251        (cond (test
     1252               (do* ()
     1253                    ((or (= i end) (= removed count)))
     1254                 (let* ((element (pop sequence)))
     1255                   (if (funcall test item element)
     1256                     (incf removed)
     1257                     (new element)))
     1258                 (incf i)))
     1259              (test-not
     1260               (do* ()
     1261                    ((or (= i end) (= removed count)))
     1262                 (let* ((element (pop sequence)))
     1263                   (if (not (funcall test-not item element))
     1264                     (incf removed)
     1265                     (new element)))
     1266                 (incf i)))
     1267              (t
     1268               (do* ()
     1269                    ((or (= i end) (= removed count)))
     1270                 (let* ((element (pop sequence)))
     1271                   (if (eql item element)
     1272                     (incf removed)
     1273                     (new element)))
     1274                 (incf i)))))
     1275      (do* ()
     1276           ((null sequence)
     1277            (if from-end
     1278              (nreverse (new))
     1279              (new)))
     1280        (new (pop sequence))))))
     1281
     1282(defun list-remove-conditional (sequence test test-not start end count from-end key)
     1283  (collect ((new))
     1284    (dotimes (i start)
     1285      (new (pop sequence)))
     1286    (let* ((i start)
     1287           (removed 0))
     1288      (declare (fixnum i removed))
     1289      (if key
     1290        (cond (test
     1291               (do* ()
     1292                    ((or (= i end) (= removed count)))
     1293                 (let* ((element (pop sequence)))
     1294                   (if (funcall test (funcall key element))
     1295                     (incf removed)
     1296                     (new element)))
     1297                 (incf i)))
     1298              (test-not
     1299               (do* ()
     1300                    ((or (= i end) (= removed count)))
     1301                 (let* ((element (pop sequence)))
     1302                   (if (not (funcall test-not (funcall key element)))
     1303                     (incf removed)
     1304                     (new element)))
     1305                 (incf i))))
     1306        (cond (test
     1307               (do* ()
     1308                    ((or (= i end) (= removed count)))
     1309                 (let* ((element (pop sequence)))
     1310                   (if (funcall test element)
     1311                     (incf removed)
     1312                     (new element)))
     1313                 (incf i)))
     1314              (test-not
     1315               (do* ()
     1316                    ((or (= i end) (= removed count)))
     1317                 (let* ((element (pop sequence)))
     1318                   (if (not (funcall test-not element))
     1319                     (incf removed)
     1320                     (new element)))
     1321                 (incf i)))))
     1322      (do* ()
     1323           ((null sequence)
     1324            (if from-end
     1325              (nreverse (new))
     1326              (new)))
     1327        (new (pop sequence))))))
     1328
     1329
    12191330
    12201331
     
    12231334  "Return a copy of SEQUENCE with elements satisfying the test (default is
    12241335   EQL) with ITEM removed."
     1336  (if (or (eq test 'identity)
     1337          (eq test #'identity))
     1338    (setq key nil))
     1339  (setq count (check-count count))
     1340
     1341  (seq-dispatch
     1342   sequence
     1343   (let* ((len (length sequence))
     1344          (reversed nil))
     1345     (setq end (check-sequence-bounds sequence start end len))
     1346     (when (and (< count len) from-end)
     1347       (psetq sequence (reverse sequence)
     1348              reversed t
     1349              start (- len end)
     1350              end (- len start)))
     1351     (if test
     1352       (if test-not
     1353         (error "Both ~s and ~s keywords supplied" :test :test-not)
     1354         (setq test (coerce-to-function test)))
     1355       (if test-not
     1356         (setq test-not (coerce-to-function test-not))
     1357         (setq test #'eql)))
     1358     (list-remove item
     1359                  sequence
     1360                  test
     1361                  test-not
     1362                  start
     1363                  end
     1364                  count
     1365                  reversed
     1366                  key))
     1367  (simple-vector-delete item
     1368                        sequence
     1369                        test
     1370                        test-not
     1371                        key
     1372                        start
     1373                        end
     1374                        (if from-end -1 1)
     1375                        count)))
     1376
     1377
     1378
     1379
     1380(defun remove-if (test sequence &key from-end (start 0)
     1381                       end count key)
     1382  "Return a copy of sequence with elements such that predicate(element)
     1383   is non-null removed"
    12251384  (setq count (check-count count))
    12261385  (seq-dispatch
    12271386   sequence
    1228    (list-delete-1 item
    1229                 (copy-list sequence)
    1230                 from-end
    1231                 test
    1232                 test-not
    1233                 start
    1234                 end
    1235                 count
    1236                 key)
    1237    (simple-vector-delete item
    1238                          sequence
    1239                          test
    1240                          test-not
    1241                          key
    1242                          start
    1243                          end
    1244                          (if from-end -1 1)
    1245                          count)))
    1246 
    1247 
    1248 
    1249 
    1250 (defun remove-if (test sequence &key from-end (start 0)
    1251                          end count key)
    1252   "Return a copy of sequence with elements such that predicate(element)
    1253    is non-null removed"
    1254   (setq count (check-count count))
    1255   (remove test sequence
    1256           :test #'funcall
    1257           :from-end from-end
    1258           :start start
    1259           :end end
    1260           :count count
    1261           :key key))
     1387   (let* ((len (length sequence))
     1388          (reversed nil))
     1389     (setq end (check-sequence-bounds sequence start end len))
     1390     (when (and (< count len) from-end)
     1391       (psetq sequence (reverse sequence)
     1392              reversed t
     1393              start (- len end)
     1394              end (- len start)))
     1395     (list-remove-conditional sequence
     1396                              (coerce-to-function test )
     1397                              nil
     1398                              start
     1399                              end
     1400                              count
     1401                              reversed
     1402                              key))
     1403   (remove test sequence
     1404           :test #'funcall
     1405           :from-end from-end
     1406           :start start
     1407           :end end
     1408           :count count
     1409           :key key)))
    12621410
    12631411(defun remove-if-not (test sequence &key from-end (start 0)
    1264                          end count key)
     1412                           end count key)
    12651413  "Return a copy of sequence with elements such that predicate(element)
    12661414   is null removed"
    12671415  (setq count (check-count count))
    1268   (remove test sequence
    1269           :test-not #'funcall
    1270           :from-end from-end
    1271           :start start
    1272           :end end
    1273           :count count
    1274           :key key))
     1416  (seq-dispatch
     1417   sequence
     1418   (let* ((len (length sequence))
     1419          (reversed nil))
     1420     (setq end (check-sequence-bounds sequence start end len))
     1421     (when (and (< count len) from-end)
     1422       (psetq sequence (reverse sequence)
     1423              reversed t
     1424              start (- len end)
     1425              end (- len start)))
     1426     (list-remove-conditional sequence
     1427                              nil
     1428                              (coerce-to-function test)
     1429                              start
     1430                              end
     1431                              count
     1432                              reversed
     1433                              key))
     1434   (remove test sequence
     1435           :test-not #'funcall
     1436           :from-end from-end
     1437           :start start
     1438           :end end
     1439           :count count
     1440           :key key)))
    12751441
    12761442;;; Remove-Duplicates:
Note: See TracChangeset for help on using the changeset viewer.