3rdparties/software/split-sequence-v2.0.0/extended-sequence.lisp (5232 bytes)
1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 3 (in-package :split-sequence) 4 5 ;;; For extended sequences, we make the assumption that all extended sequences 6 ;;; can be at most ARRAY-DIMENSION-LIMIT long. This seems to match what SBCL 7 ;;; assumes about them. 8 9 ;;; TODO test this code. This will require creating such an extended sequence. 10 11 (deftype extended-sequence () 12 '(and sequence (not list) (not vector))) 13 14 (declaim (inline 15 split-extended-sequence split-extended-sequence-if split-extended-sequence-if-not 16 split-extended-sequence-from-end split-extended-sequence-from-start)) 17 18 (declaim (ftype (function (&rest t) (values list unsigned-byte)) 19 split-extended-sequence split-extended-sequence-if split-extended-sequence-if-not)) 20 21 (declaim (ftype (function (function extended-sequence array-index 22 (or null fixnum) (or null fixnum) boolean) 23 (values list fixnum)) 24 split-extended-sequence-from-start split-extended-sequence-from-end)) 25 26 (defun split-extended-sequence 27 (delimiter sequence start end from-end count remove-empty-subseqs test test-not key) 28 (cond 29 ((and (not from-end) (null test-not)) 30 (split-extended-sequence-from-start (lambda (sequence start) 31 (position delimiter sequence :start start :key key :test test)) 32 sequence start end count remove-empty-subseqs)) 33 ((and (not from-end) test-not) 34 (split-extended-sequence-from-start (lambda (sequence start) 35 (position delimiter sequence :start start :key key :test-not test-not)) 36 sequence start end count remove-empty-subseqs)) 37 ((and from-end (null test-not)) 38 (split-extended-sequence-from-end (lambda (sequence end) 39 (position delimiter sequence :end end :from-end t :key key :test test)) 40 sequence start end count remove-empty-subseqs)) 41 (t 42 (split-extended-sequence-from-end (lambda (sequence end) 43 (position delimiter sequence :end end :from-end t :key key :test-not test-not)) 44 sequence start end count remove-empty-subseqs)))) 45 46 (defun split-extended-sequence-if 47 (predicate sequence start end from-end count remove-empty-subseqs key) 48 (if from-end 49 (split-extended-sequence-from-end (lambda (sequence end) 50 (position-if predicate sequence :end end :from-end t :key key)) 51 sequence start end count remove-empty-subseqs) 52 (split-extended-sequence-from-start (lambda (sequence start) 53 (position-if predicate sequence :start start :key key)) 54 sequence start end count remove-empty-subseqs))) 55 56 (defun split-extended-sequence-if-not 57 (predicate sequence start end from-end count remove-empty-subseqs key) 58 (if from-end 59 (split-extended-sequence-from-end (lambda (sequence end) 60 (position-if-not predicate sequence :end end :from-end t :key key)) 61 sequence start end count remove-empty-subseqs) 62 (split-extended-sequence-from-start (lambda (sequence start) 63 (position-if-not predicate sequence :start start :key key)) 64 sequence start end count remove-empty-subseqs))) 65 66 (defun split-extended-sequence-from-end (position-fn sequence start end count remove-empty-subseqs) 67 (declare (optimize (speed 3) (debug 0)) 68 (type (function (extended-sequence fixnum) (or null fixnum)) position-fn)) 69 (loop 70 :with length = (length sequence) 71 :with end = (or end length) 72 :for right := end :then left 73 :for left := (max (or (funcall position-fn sequence right) -1) 74 (1- start)) 75 :unless (and (= right (1+ left)) remove-empty-subseqs) 76 :if (and count (>= nr-elts count)) 77 :return (values (nreverse subseqs) right) 78 :else 79 :collect (subseq sequence (1+ left) right) into subseqs 80 :and :sum 1 :into nr-elts :of-type fixnum 81 :until (< left start) 82 :finally (return (values (nreverse subseqs) (1+ left))))) 83 84 (defun split-extended-sequence-from-start (position-fn sequence start end count remove-empty-subseqs) 85 (declare (optimize (speed 3) (debug 0)) 86 (type (function (extended-sequence fixnum) (or null fixnum)) position-fn)) 87 (loop 88 :with length = (length sequence) 89 :with end = (or end length) 90 :for left := start :then (1+ right) 91 :for right := (min (or (funcall position-fn sequence left) length) 92 end) 93 :unless (and (= right left) remove-empty-subseqs) 94 :if (and count (>= nr-elts count)) 95 :return (values subseqs left) 96 :else 97 :collect (subseq sequence left right) :into subseqs 98 :and :sum 1 :into nr-elts :of-type fixnum 99 :until (>= right end) 100 :finally (return (values subseqs right))))