1 | ;;;This file only defines the minimum set of symbols and operators |
---|
2 | ;;;that is needed to make standard CL sequence functions refer to generic |
---|
3 | ;;;functions in the SEQUENCE package, without actually definining those |
---|
4 | ;;;generic functions and supporting code, which is in extensible-sequences.lisp. |
---|
5 | ;;; |
---|
6 | ;;;The rationale for splitting the code this way is that CLOS depends on |
---|
7 | ;;;some sequence functions, and if those in turn depend on CLOS we have |
---|
8 | ;;;a circular dependency. |
---|
9 | |
---|
10 | (in-package :sequence) |
---|
11 | |
---|
12 | (shadow '(ELT LENGTH COUNT "COUNT-IF" "COUNT-IF-NOT" |
---|
13 | "FIND" "FIND-IF" "FIND-IF-NOT" |
---|
14 | "POSITION" "POSITION-IF" "POSITION-IF-NOT" |
---|
15 | "SUBSEQ" "COPY-SEQ" "FILL" |
---|
16 | "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT" |
---|
17 | "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT" |
---|
18 | "REPLACE" "REVERSE" "NREVERSE" "REDUCE" |
---|
19 | "MISMATCH" "SEARCH" |
---|
20 | "DELETE" "DELETE-IF" "DELETE-IF-NOT" |
---|
21 | "REMOVE" "REMOVE-IF" "REMOVE-IF-NOT" |
---|
22 | "DELETE-DUPLICATES" "REMOVE-DUPLICATES" "SORT" "STABLE-SORT")) |
---|
23 | |
---|
24 | (export '(DOSEQUENCE |
---|
25 | |
---|
26 | MAKE-SEQUENCE-ITERATOR MAKE-SIMPLE-SEQUENCE-ITERATOR |
---|
27 | |
---|
28 | ITERATOR-STEP ITERATOR-ENDP ITERATOR-ELEMENT |
---|
29 | ITERATOR-INDEX ITERATOR-COPY |
---|
30 | |
---|
31 | WITH-SEQUENCE-ITERATOR WITH-SEQUENCE-ITERATOR-FUNCTIONS |
---|
32 | |
---|
33 | CANONIZE-TEST CANONIZE-KEY |
---|
34 | |
---|
35 | LENGTH ELT |
---|
36 | MAKE-SEQUENCE-LIKE ADJUST-SEQUENCE |
---|
37 | |
---|
38 | COUNT COUNT-IF COUNT-IF-NOT |
---|
39 | FIND FIND-IF FIND-IF-NOT |
---|
40 | POSITION POSITION-IF POSITION-IF-NOT |
---|
41 | SUBSEQ COPY-SEQ FILL |
---|
42 | NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT |
---|
43 | SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT |
---|
44 | REPLACE REVERSE NREVERSE REDUCE |
---|
45 | MISMATCH SEARCH |
---|
46 | DELETE DELETE-IF DELETE-IF-NOT |
---|
47 | REMOVE REMOVE-IF REMOVE-IF-NOT |
---|
48 | DELETE-DUPLICATES REMOVE-DUPLICATES SORT STABLE-SORT)) |
---|
49 | |
---|
50 | ;;; Adapted from SBCL |
---|
51 | ;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE. |
---|
52 | ;;; |
---|
53 | ;;; FIXME: It might be worth making three cases here, LIST, |
---|
54 | ;;; SIMPLE-VECTOR, and VECTOR, instead of the current LIST and VECTOR. |
---|
55 | ;;; It tends to make code run faster but be bigger; some benchmarking |
---|
56 | ;;; is needed to decide. |
---|
57 | (defmacro seq-dispatch |
---|
58 | (sequence list-form array-form &optional other-form) |
---|
59 | `(if (listp ,sequence) |
---|
60 | (let ((,sequence (ext:truly-the list ,sequence))) |
---|
61 | (declare (ignorable ,sequence)) |
---|
62 | ,list-form) |
---|
63 | ,@(if other-form |
---|
64 | `((if (arrayp ,sequence) |
---|
65 | (let ((,sequence (ext:truly-the vector ,sequence))) |
---|
66 | (declare (ignorable ,sequence)) |
---|
67 | ,array-form) |
---|
68 | (if (typep ,sequence 'sequence) |
---|
69 | ,other-form |
---|
70 | (error 'type-error |
---|
71 | :datum ,sequence :expected-type 'sequence)))) |
---|
72 | `((let ((,sequence (ext:truly-the vector ,sequence))) |
---|
73 | (declare (ignorable ,sequence)) |
---|
74 | ,array-form))))) |
---|
75 | |
---|
76 | (defun %check-generic-sequence-bounds (seq start end) |
---|
77 | (let ((length (sequence:length seq))) |
---|
78 | (if (<= 0 start (or end length) length) |
---|
79 | (or end length) |
---|
80 | (sequence-bounding-indices-bad-error seq start end)))) |
---|
81 | |
---|
82 | (defun sequence-bounding-indices-bad-error (sequence start end) |
---|
83 | (let ((size (length sequence))) |
---|
84 | (error "The bounding indices ~S and ~S are bad for a sequence of length ~S" |
---|
85 | start end size))) |
---|
86 | |
---|
87 | (defun %set-elt (sequence index value) |
---|
88 | (seq-dispatch sequence |
---|
89 | (sys::%set-elt sequence index value) |
---|
90 | (sys::%set-elt sequence index value) |
---|
91 | (setf (sequence:elt sequence index) value))) |
---|
92 | |
---|
93 | (defsetf cl:elt %set-elt) |
---|
94 | |
---|
95 | #| |
---|
96 | (error 'bounding-indices-bad-error |
---|
97 | :datum (cons start end) |
---|
98 | :expected-type `(cons (integer 0 ,size) |
---|
99 | (integer ,start ,size)) |
---|
100 | :object sequence)))|# |
---|
101 | |
---|
102 | (provide "EXTENSIBLE-SEQUENCES-BASE") |
---|