[armedbear-cvs] r12516 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Wed Mar 3 21:05:43 UTC 2010
Author: astalla
Date: Wed Mar 3 16:05:41 2010
New Revision: 12516
Log:
Support for user-extensible sequences, adapted from SBCL.
Added:
trunk/abcl/src/org/armedbear/lisp/extensible-sequences-base.lisp
trunk/abcl/src/org/armedbear/lisp/extensible-sequences.lisp
Modified:
trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java
trunk/abcl/src/org/armedbear/lisp/Cons.java
trunk/abcl/src/org/armedbear/lisp/Lisp.java
trunk/abcl/src/org/armedbear/lisp/Primitives.java
trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
trunk/abcl/src/org/armedbear/lisp/boot.lisp
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/concatenate.lisp
trunk/abcl/src/org/armedbear/lisp/copy-seq.lisp
trunk/abcl/src/org/armedbear/lisp/count.lisp
trunk/abcl/src/org/armedbear/lisp/delete-duplicates.lisp
trunk/abcl/src/org/armedbear/lisp/delete.lisp
trunk/abcl/src/org/armedbear/lisp/fill.lisp
trunk/abcl/src/org/armedbear/lisp/find.lisp
trunk/abcl/src/org/armedbear/lisp/make-sequence.lisp
trunk/abcl/src/org/armedbear/lisp/mismatch.lisp
trunk/abcl/src/org/armedbear/lisp/reduce.lisp
trunk/abcl/src/org/armedbear/lisp/remove-duplicates.lisp
trunk/abcl/src/org/armedbear/lisp/remove.lisp
trunk/abcl/src/org/armedbear/lisp/replace.lisp
trunk/abcl/src/org/armedbear/lisp/search.lisp
trunk/abcl/src/org/armedbear/lisp/sequences.lisp
trunk/abcl/src/org/armedbear/lisp/setf.lisp
trunk/abcl/src/org/armedbear/lisp/sort.lisp
trunk/abcl/src/org/armedbear/lisp/substitute.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Wed Mar 3 16:05:41 2010
@@ -119,7 +119,6 @@
public static final BuiltInClass READTABLE = addClass(Symbol.READTABLE);
public static final BuiltInClass REAL = addClass(Symbol.REAL);
public static final BuiltInClass RESTART = addClass(Symbol.RESTART);
- public static final BuiltInClass SEQUENCE = addClass(Symbol.SEQUENCE);
public static final BuiltInClass SIMPLE_ARRAY = addClass(Symbol.SIMPLE_ARRAY);
public static final BuiltInClass SIMPLE_BASE_STRING = addClass(Symbol.SIMPLE_BASE_STRING);
public static final BuiltInClass SIMPLE_BIT_VECTOR = addClass(Symbol.SIMPLE_BIT_VECTOR);
@@ -139,6 +138,10 @@
(StructureClass)addClass(Symbol.STRUCTURE_OBJECT,
new StructureClass(Symbol.STRUCTURE_OBJECT, list(CLASS_T)));
+ public static final SlotClass SEQUENCE =
+ (SlotClass) addClass(Symbol.SEQUENCE,
+ new SlotClass(Symbol.SEQUENCE, list(CLASS_T)));
+
/* All the stream classes below are being defined as structure classes
but won't be available as such until further action is taken:
the 'defstruct' internal administration is missing.
Modified: trunk/abcl/src/org/armedbear/lisp/Cons.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Cons.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Cons.java Wed Mar 3 16:05:41 2010
@@ -87,7 +87,7 @@
if (typeSpecifier == T)
return T;
}
- else if (typeSpecifier instanceof BuiltInClass)
+ else if (typeSpecifier instanceof LispClass)
{
if (typeSpecifier == BuiltInClass.LIST)
return T;
Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Mar 3 16:05:41 2010
@@ -87,6 +87,8 @@
Packages.createPackage("XP");
public static final Package PACKAGE_PRECOMPILER =
Packages.createPackage("PRECOMPILER");
+ public static final Package PACKAGE_SEQUENCE =
+ Packages.createPackage("SEQUENCE");
// ### nil
@@ -134,6 +136,7 @@
PACKAGE_PRECOMPILER.usePackage(PACKAGE_CL);
PACKAGE_PRECOMPILER.usePackage(PACKAGE_EXT);
PACKAGE_PRECOMPILER.usePackage(PACKAGE_SYS);
+ PACKAGE_SEQUENCE.usePackage(PACKAGE_CL);
}
// End-of-file marker.
Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Wed Mar 3 16:05:41 2010
@@ -462,7 +462,7 @@
private static final Primitive LENGTH = new pf_length();
private static final class pf_length extends Primitive {
pf_length() {
- super(Symbol.LENGTH, "sequence");
+ super("%LENGTH", PACKAGE_SYS, false, "sequence");
}
@Override
@@ -475,7 +475,7 @@
private static final Primitive ELT = new pf_elt();
private static final class pf_elt extends Primitive {
pf_elt() {
- super(Symbol.ELT, "sequence index");
+ super("%ELT", PACKAGE_SYS, false, "sequence index");
}
@Override
@@ -4159,7 +4159,7 @@
}
};
- // ### call-count
+ // ### hot-count
private static final Primitive HOT_COUNT = new pf_hot_count();
private static final class pf_hot_count extends Primitive {
pf_hot_count() {
@@ -4172,7 +4172,7 @@
}
};
- // ### set-call-count
+ // ### set-hot-count
private static final Primitive SET_HOT_COUNT = new pf_set_hot_count();
private static final class pf_set_hot_count extends Primitive {
pf_set_hot_count() {
@@ -4253,7 +4253,7 @@
private static final Primitive SUBSEQ = new pf_subseq();
private static final class pf_subseq extends Primitive {
pf_subseq() {
- super(Symbol.SUBSEQ, "sequence start &optional end");
+ super(PACKAGE_SYS.intern("%SUBSEQ"), "sequence start &optional end");
}
@Override
@@ -4420,7 +4420,7 @@
public static final Primitive NREVERSE = new pf_nreverse();
private static final class pf_nreverse extends Primitive {
pf_nreverse() {
- super(Symbol.NREVERSE, "sequence");
+ super("%NREVERSE", PACKAGE_SYS, false, "sequence");
}
@Override
@@ -4475,7 +4475,7 @@
private static final Primitive REVERSE = new pf_reverse();
private static final class pf_reverse extends Primitive {
pf_reverse() {
- super(Symbol.REVERSE, "sequence");
+ super("%reverse", PACKAGE_SYS, false, "sequence");
}
@Override
Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Wed Mar 3 16:05:41 2010
@@ -83,8 +83,10 @@
(autoload '(assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not
acons pairlis copy-alist)
"assoc")
+(autoload-macro 'sequence::seq-dispatch "extensible-sequences-base")
(autoload '(mapcan mapl maplist mapcon) "map1")
(autoload 'make-sequence)
+;(autoload 'sequence::fill "extensible-sequences")
(autoload '(copy-seq fill replace))
(autoload '(map map-into))
(autoload 'reduce)
Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/boot.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/boot.lisp Wed Mar 3 16:05:41 2010
@@ -130,6 +130,22 @@
(sys::%format t "~A~%" condition)
(ext:quit))
+;;Redefined in extensible-sequences.lisp
+(defun length (sequence)
+ (%length sequence))
+
+(defun elt (sequence index)
+ (%elt sequence index))
+
+(defun subseq (sequence start &optional end)
+ (sys::%subseq sequence start end))
+
+(defun reverse (sequence)
+ (sys::%reverse sequence))
+
+(defun nreverse (sequence)
+ (sys::%nreverse sequence))
+
(load-system-file "autoloads")
(load-system-file "early-defuns")
(load-system-file "backquote")
@@ -161,11 +177,12 @@
(load-system-file "typep")
(load-system-file "signal")
(load-system-file "list")
+(load-system-file "require")
+(load-system-file "extensible-sequences-base")
(load-system-file "sequences")
(load-system-file "error")
(load-system-file "defpackage")
(load-system-file "define-modify-macro")
-(load-system-file "require")
(load-system-file "defstruct")
;; The actual stream and system-stream classes
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 3 16:05:41 2010
@@ -2393,5 +2393,16 @@
;; FIXME
(defgeneric function-keywords (method))
+(defgeneric class-prototype (class))
+
+(defmethod class-prototype :before (class)
+ (unless (class-finalized-p class)
+ (error "~@<~S is not finalized.~:@>" class)))
+
+(defmethod class-prototype ((class standard-class))
+ (allocate-instance class))
+
+(defmethod class-prototype ((class structure-class))
+ (allocate-instance class))
(provide 'clos)
Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Wed Mar 3 16:05:41 2010
@@ -102,6 +102,8 @@
(load (do-compile "compiler-macro.lisp"))
(load (do-compile "opcodes.lisp"))
(load (do-compile "setf.lisp"))
+ (load (do-compile "extensible-sequences-base.lisp"))
+ (load (do-compile "require.lisp"))
(load (do-compile "substitute.lisp"))
(load (do-compile "clos.lisp"))
;; Order matters for these files.
@@ -173,6 +175,7 @@
"enough-namestring.lisp"
"ensure-directories-exist.lisp"
"error.lisp"
+ "extensible-sequences.lisp"
"featurep.lisp"
"fdefinition.lisp"
"fill.lisp"
@@ -230,7 +233,6 @@
"remove-duplicates.lisp"
"remove.lisp"
"replace.lisp"
- "require.lisp"
"restart.lisp"
"revappend.lisp"
"rotatef.lisp"
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Mar 3 16:05:41 2010
@@ -2573,7 +2573,7 @@
(COMPLEXP "COMPLEXP")
(DENOMINATOR "DENOMINATOR")
(FIRST "car")
- (LENGTH "LENGTH")
+ (SYS::%LENGTH "LENGTH")
(NREVERSE "nreverse")
(NUMERATOR "NUMERATOR")
(REST "cdr")
@@ -8588,7 +8588,6 @@
(with-saved-compiler-policy
;; Pass 1.
(p1-compiland compiland)
-
;; *all-variables* doesn't contain variables which
;; are in an enclosing lexical environment (variable-environment)
;; so we don't need to filter them out
@@ -8896,7 +8895,7 @@
(install-p2-handler 'gethash1 'p2-gethash)
(install-p2-handler 'go 'p2-go)
(install-p2-handler 'if 'p2-if)
- (install-p2-handler 'length 'p2-length)
+ (install-p2-handler 'sys::%length 'p2-length)
(install-p2-handler 'list 'p2-list)
(install-p2-handler 'sys::backq-list 'p2-list)
(install-p2-handler 'list* 'p2-list*)
Modified: trunk/abcl/src/org/armedbear/lisp/concatenate.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/concatenate.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/concatenate.lisp Wed Mar 3 16:05:41 2010
@@ -51,6 +51,7 @@
(setf (schar result i) (elt seq j))
(incf i)))))))
+;;It uses make-sequence: it should already be user-extensible as-is
(defun concatenate (result-type &rest sequences)
(case result-type
(LIST
Modified: trunk/abcl/src/org/armedbear/lisp/copy-seq.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/copy-seq.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/copy-seq.lisp Wed Mar 3 16:05:41 2010
@@ -29,6 +29,8 @@
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
(in-package "SYSTEM")
;; From CMUCL.
@@ -51,6 +53,8 @@
result)))))
(defun copy-seq (sequence)
- (if (listp sequence)
- (list-copy-seq sequence)
- (vector-copy-seq sequence (type-of sequence))))
+ "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
+ (sequence::seq-dispatch sequence
+ (list-copy-seq sequence)
+ (vector-copy-seq sequence (type-of sequence))
+ (sequence:copy-seq sequence)))
\ No newline at end of file
Modified: trunk/abcl/src/org/armedbear/lisp/count.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/count.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/count.lisp Wed Mar 3 16:05:41 2010
@@ -31,6 +31,8 @@
(in-package "COMMON-LISP")
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
;;; From CMUCL.
(defmacro vector-count-if (not-p from-end-p predicate sequence)
@@ -56,7 +58,7 @@
(,(if not-p 'unless 'when) ,pred
(setq count (1+ count)))))))
-(defun count (item sequence &key from-end (test #'eql test-p) (test-not nil test-not-p)
+(defun count (item sequence &rest args &key from-end (test #'eql test-p) (test-not nil test-not-p)
(start 0) end key)
(when (and test-p test-not-p)
(error "test and test-not both supplied"))
@@ -67,32 +69,35 @@
(not (funcall test-not item x)))
(lambda (x)
(funcall test item x)))))
- (if (listp sequence)
- (if from-end
- (list-count-if nil t %test sequence)
- (list-count-if nil nil %test sequence))
- (if from-end
- (vector-count-if nil t %test sequence)
- (vector-count-if nil nil %test sequence))))))
+ (sequence::seq-dispatch sequence
+ (if from-end
+ (list-count-if nil t %test sequence)
+ (list-count-if nil nil %test sequence))
+ (if from-end
+ (vector-count-if nil t %test sequence)
+ (vector-count-if nil nil %test sequence))
+ (apply #'sequence:count item sequence args)))))
-(defun count-if (test sequence &key from-end (start 0) end key)
+(defun count-if (test sequence &rest args &key from-end (start 0) end key)
(let* ((length (length sequence))
(end (or end length)))
- (if (listp sequence)
+ (sequence::seq-dispatch sequence
(if from-end
(list-count-if nil t test sequence)
(list-count-if nil nil test sequence))
(if from-end
(vector-count-if nil t test sequence)
- (vector-count-if nil nil test sequence)))))
+ (vector-count-if nil nil test sequence))
+ (apply #'sequence:count-if test sequence args))))
-(defun count-if-not (test sequence &key from-end (start 0) end key)
+(defun count-if-not (test sequence &rest args &key from-end (start 0) end key)
(let* ((length (length sequence))
(end (or end length)))
- (if (listp sequence)
+ (sequence::seq-dispatch sequence
(if from-end
(list-count-if t t test sequence)
(list-count-if t nil test sequence))
(if from-end
(vector-count-if t t test sequence)
- (vector-count-if t nil test sequence)))))
+ (vector-count-if t nil test sequence))
+ (apply #'sequence:count-if-not test sequence args))))
Modified: trunk/abcl/src/org/armedbear/lisp/delete-duplicates.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/delete-duplicates.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/delete-duplicates.lisp Wed Mar 3 16:05:41 2010
@@ -31,6 +31,8 @@
(in-package "SYSTEM")
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
;;; From CMUCL.
(defun list-delete-duplicates* (list test test-not key from-end start end)
@@ -79,10 +81,10 @@
:end (if from-end jndex end) :test-not test-not)
(setq jndex (1+ jndex)))))
-
-(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end
- end key)
- (if (listp sequence)
- (if sequence
- (list-delete-duplicates* sequence test test-not key from-end start end))
- (vector-delete-duplicates* sequence test test-not key from-end start end)))
+(defun delete-duplicates (sequence &rest args &key (test #'eql) test-not
+ (start 0) from-end end key)
+ (sequence::seq-dispatch sequence
+ (if sequence
+ (list-delete-duplicates* sequence test test-not key from-end start end))
+ (vector-delete-duplicates* sequence test test-not key from-end start end)
+ (apply #'sequence:delete-duplicates sequence args)))
Modified: trunk/abcl/src/org/armedbear/lisp/delete.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/delete.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/delete.lisp Wed Mar 3 16:05:41 2010
@@ -31,6 +31,8 @@
(in-package "SYSTEM")
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
;;; From CMUCL.
(defmacro real-count (count)
@@ -133,20 +135,21 @@
(not (funcall test-not item (funcall-key key (car current))))
(funcall test item (funcall-key key (car current))))))
-(defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
- end count key)
+(defun delete (item sequence &rest args &key from-end (test #'eql) test-not
+ (start 0) end count key)
(when key
(setq key (coerce-to-function key)))
(let* ((length (length sequence))
(end (or end length))
(count (real-count count)))
- (if (listp sequence)
- (if from-end
- (normal-list-delete-from-end)
- (normal-list-delete))
- (if from-end
- (normal-mumble-delete-from-end)
- (normal-mumble-delete)))))
+ (sequence::seq-dispatch sequence
+ (if from-end
+ (normal-list-delete-from-end)
+ (normal-list-delete))
+ (if from-end
+ (normal-mumble-delete-from-end)
+ (normal-mumble-delete))
+ (apply #'sequence:delete item sequence args))))
(defmacro if-mumble-delete ()
`(mumble-delete
@@ -164,19 +167,21 @@
'(list-delete-from-end
(funcall predicate (funcall-key key (car current)))))
-(defun delete-if (predicate sequence &key from-end (start 0) key end count)
+(defun delete-if (predicate sequence &rest args &key from-end (start 0)
+ key end count)
(when key
(setq key (coerce-to-function key)))
(let* ((length (length sequence))
(end (or end length))
(count (real-count count)))
- (if (listp sequence)
- (if from-end
- (if-list-delete-from-end)
- (if-list-delete))
- (if from-end
- (if-mumble-delete-from-end)
- (if-mumble-delete)))))
+ (sequence::seq-dispatch sequence
+ (if from-end
+ (if-list-delete-from-end)
+ (if-list-delete))
+ (if from-end
+ (if-mumble-delete-from-end)
+ (if-mumble-delete))
+ (apply #'sequence:delete-if predicate sequence args))))
(defmacro if-not-mumble-delete ()
`(mumble-delete
@@ -194,16 +199,18 @@
'(list-delete-from-end
(not (funcall predicate (funcall-key key (car current))))))
-(defun delete-if-not (predicate sequence &key from-end (start 0) end key count)
+(defun delete-if-not (predicate sequence &rest args &key from-end (start 0)
+ end key count)
(when key
(setq key (coerce-to-function key)))
(let* ((length (length sequence))
(end (or end length))
(count (real-count count)))
- (if (listp sequence)
- (if from-end
- (if-not-list-delete-from-end)
- (if-not-list-delete))
- (if from-end
- (if-not-mumble-delete-from-end)
- (if-not-mumble-delete)))))
+ (sequence::seq-dispatch sequence
+ (if from-end
+ (if-not-list-delete-from-end)
+ (if-not-list-delete))
+ (if from-end
+ (if-not-mumble-delete-from-end)
+ (if-not-mumble-delete))
+ (apply #'sequence:delete-if-not predicate sequence args))))
Added: trunk/abcl/src/org/armedbear/lisp/extensible-sequences-base.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/src/org/armedbear/lisp/extensible-sequences-base.lisp Wed Mar 3 16:05:41 2010
@@ -0,0 +1,102 @@
+;;;This file only defines the minimum set of symbols and operators
+;;;that is needed to make standard CL sequence functions refer to generic
+;;;functions in the SEQUENCE package, without actually definining those
+;;;generic functions and supporting code, which is in extensible-sequences.lisp.
+;;;
+;;;The rationale for splitting the code this way is that CLOS depends on
+;;;some sequence functions, and if those in turn depend on CLOS we have
+;;;a circular dependency.
+
+(in-package :sequence)
+
+(shadow '(ELT LENGTH COUNT "COUNT-IF" "COUNT-IF-NOT"
+ "FIND" "FIND-IF" "FIND-IF-NOT"
+ "POSITION" "POSITION-IF" "POSITION-IF-NOT"
+ "SUBSEQ" "COPY-SEQ" "FILL"
+ "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT"
+ "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT"
+ "REPLACE" "REVERSE" "NREVERSE" "REDUCE"
+ "MISMATCH" "SEARCH"
+ "DELETE" "DELETE-IF" "DELETE-IF-NOT"
+ "REMOVE" "REMOVE-IF" "REMOVE-IF-NOT"
+ "DELETE-DUPLICATES" "REMOVE-DUPLICATES" "SORT" "STABLE-SORT"))
+
+(export '(DOSEQUENCE
+
+ MAKE-SEQUENCE-ITERATOR MAKE-SIMPLE-SEQUENCE-ITERATOR
+
+ ITERATOR-STEP ITERATOR-ENDP ITERATOR-ELEMENT
+ ITERATOR-INDEX ITERATOR-COPY
+
+ WITH-SEQUENCE-ITERATOR WITH-SEQUENCE-ITERATOR-FUNCTIONS
+
+ CANONIZE-TEST CANONIZE-KEY
+
+ LENGTH ELT
+ MAKE-SEQUENCE-LIKE ADJUST-SEQUENCE
+
+ COUNT COUNT-IF COUNT-IF-NOT
+ FIND FIND-IF FIND-IF-NOT
+ POSITION POSITION-IF POSITION-IF-NOT
+ SUBSEQ COPY-SEQ FILL
+ NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT
+ SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT
+ REPLACE REVERSE NREVERSE REDUCE
+ MISMATCH SEARCH
+ DELETE DELETE-IF DELETE-IF-NOT
+ REMOVE REMOVE-IF REMOVE-IF-NOT
+ DELETE-DUPLICATES REMOVE-DUPLICATES SORT STABLE-SORT))
+
+;;; Adapted from SBCL
+;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE.
+;;;
+;;; FIXME: It might be worth making three cases here, LIST,
+;;; SIMPLE-VECTOR, and VECTOR, instead of the current LIST and VECTOR.
+;;; It tends to make code run faster but be bigger; some benchmarking
+;;; is needed to decide.
+(defmacro seq-dispatch
+ (sequence list-form array-form &optional other-form)
+ `(if (listp ,sequence)
+ (let ((,sequence (ext:truly-the list ,sequence)))
+ (declare (ignorable ,sequence))
+ ,list-form)
+ ,@(if other-form
+ `((if (arrayp ,sequence)
+ (let ((,sequence (ext:truly-the vector ,sequence)))
+ (declare (ignorable ,sequence))
+ ,array-form)
+ (if (typep ,sequence 'sequence)
+ ,other-form
+ (error 'type-error
+ :datum ,sequence :expected-type 'sequence))))
+ `((let ((,sequence (ext:truly-the vector ,sequence)))
+ (declare (ignorable ,sequence))
+ ,array-form)))))
+
+(defun %check-generic-sequence-bounds (seq start end)
+ (let ((length (sequence:length seq)))
+ (if (<= 0 start (or end length) length)
+ (or end length)
+ (sequence-bounding-indices-bad-error seq start end))))
+
+(defun sequence-bounding-indices-bad-error (sequence start end)
+ (let ((size (length sequence)))
+ (error "The bounding indices ~S and ~S are bad for a sequence of length ~S"
+ start end size)))
+
+(defun %set-elt (sequence index value)
+ (seq-dispatch sequence
+ (sys::%set-elt sequence index value)
+ (sys::%set-elt sequence index value)
+ (setf (sequence:elt sequence index) value)))
+
+(defsetf cl:elt %set-elt)
+
+#|
+ (error 'bounding-indices-bad-error
+ :datum (cons start end)
+ :expected-type `(cons (integer 0 ,size)
+ (integer ,start ,size))
+ :object sequence)))|#
+
+(provide "EXTENSIBLE-SEQUENCES-BASE")
\ No newline at end of file
Added: trunk/abcl/src/org/armedbear/lisp/extensible-sequences.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/src/org/armedbear/lisp/extensible-sequences.lisp Wed Mar 3 16:05:41 2010
@@ -0,0 +1,982 @@
+;;;Extensible Sequences for ABCL based on the SBCL API
+
+(in-package :sequence)
+
+(require "CLOS")
+(require "EXTENSIBLE-SEQUENCES-BASE")
+(require "LOOP")
+
+#||
+We specify generic functions length, elt and (setf elt)
+to correspond to the Common Lisp functions with the same
+name. In each case, there are two primary methods with the
+sequence argument specialized on list and on vector, pro-
+viding the standard-defined behaviour for the Common Lisp
+operator, and a third method with the sequence argument
+specialized on sequence, which signals an error of type type-
+error, for compatibility with the standard requirement of
+the sequence argument to be a proper sequence.
+||#
+
+(fmakunbound 'length)
+(defgeneric length (sequence)
+ (:documentation "Extension point for user-defined sequences. Invoked by cl:length."))
+
+(defmethod length ((sequence sequence))
+ (error 'type-error :datum sequence :expected-type 'proper-sequence))
+
+(defmethod length ((sequence vector))
+ (sys::%length sequence))
+
+(defmethod length ((sequence list))
+ (sys::%length sequence))
+
+(defmethod length (sequence)
+ (error 'type-error :datum sequence :expected-type 'sequence))
+
+(defun cl:length (sequence)
+ (seq-dispatch sequence
+ (sys::%length sequence)
+ (sys::%length sequence)
+ (length sequence)))
+
+(defgeneric elt (sequence index))
+
+(defmethod elt ((sequence vector) index)
+ (sys::%elt sequence index))
+
+(defmethod elt ((sequence list) index)
+ (sys::%elt sequence index))
+
+(defmethod elt ((sequence sequence) index)
+ (declare (ignore index))
+ (error 'type-error :datum sequence :expected-type 'proper-sequence))
+
+(defmethod elt (sequence index)
+ (declare (ignore index))
+ (error 'type-error :datum sequence :expected-type 'sequence))
+
+(defun cl:elt (sequence index)
+ (seq-dispatch sequence
+ (sys::%elt sequence index)
+ (sys::%elt sequence index)
+ (elt sequence index)))
+
+(defgeneric (setf elt) (value sequence index))
+
+(defmethod (setf elt) (value (sequence vector) index)
+ (sys::%set-elt sequence index value))
+
+(defmethod (setf elt) (value (sequence list) index)
+ (sys::%set-elt sequence index value))
+
+(defmethod (setf elt) (value (sequence sequence) index)
+ (declare (ignore index value))
+ (error 'type-error :datum sequence :expected-type 'proper-sequence))
+
+(defmethod (setf elt) (value sequence index)
+ (declare (ignore index value))
+ (error 'type-error :datum sequence :expected-type 'sequence))
+
+(defun cl:subseq (sequence start &optional end)
+ "Return a copy of a subsequence of SEQUENCE starting with element number
+ START and continuing to the end of SEQUENCE or the optional END."
+ (seq-dispatch sequence
+ (sys::%subseq sequence start end)
+ (sys::%subseq sequence start end)
+ (sequence:subseq sequence start end)))
+
+(defun cl:reverse (sequence)
+ (seq-dispatch sequence
+ (sys::%reverse sequence)
+ (sys::%reverse sequence)
+ (sequence:reverse sequence)))
+
+(defun cl:nreverse (sequence)
+ (seq-dispatch sequence
+ (sys::%nreverse sequence)
+ (sys::%nreverse sequence)
+ (sequence:nreverse sequence)))
+
+;;;Adapted from SBCL
+(define-condition sequence::protocol-unimplemented (type-error)
+ ())
+
+(defun sequence::protocol-unimplemented (sequence)
+ (error 'sequence::protocol-unimplemented
+ :datum sequence :expected-type '(or list vector)))
+
+(defgeneric sequence:make-sequence-like
+ (sequence length &key initial-element initial-contents)
+ (:method ((s list) length &key
+ (initial-element nil iep) (initial-contents nil icp))
+ (cond
+ ((and icp iep) (error "Can't specify both :initial-element and :initial-contents"))
+ (iep (make-list length :initial-element initial-element))
+ (icp (unless (= (length initial-contents) length)
+ (error "initial-contents is of length ~S but should be of the same length of the input sequence (~S)" (length initial-contents) length))
+ (let ((result (make-list length)))
+ (replace result initial-contents)
+ result))
+ (t (make-list length))))
+ (:method ((s vector) length &key
+ (initial-element nil iep) (initial-contents nil icp))
+ (cond
+ ((and icp iep) (error "Can't specify both :initial-element and :initial-contents"))
+ (iep (make-array length :element-type (array-element-type s)
+ :initial-element initial-element))
+ (icp (make-array length :element-type (array-element-type s)
+ :initial-contents initial-contents))
+ (t (make-array length :element-type (array-element-type s)))))
+ (:method ((s sequence) length &key initial-element initial-contents)
+ (declare (ignore initial-element initial-contents))
+ (sequence::protocol-unimplemented s)))
+
+(defgeneric sequence:adjust-sequence
+ (sequence length &key initial-element initial-contents)
+ (:method ((s list) length &key initial-element (initial-contents nil icp))
+ (if (eql length 0)
+ nil
+ (let ((olength (length s)))
+ (cond
+ ((eql length olength) (if icp (replace s initial-contents) s))
+ ((< length olength)
+ (rplacd (nthcdr (1- length) s) nil)
+ (if icp (replace s initial-contents) s))
+ ((null s)
+ (let ((return (make-list length :initial-element initial-element)))
+ (if icp (replace return initial-contents) return)))
+ (t (rplacd (nthcdr (1- olength) s)
+ (make-list (- length olength)
+ :initial-element initial-element))
+ (if icp (replace s initial-contents) s))))))
+ (:method ((s vector) length &rest args &key (initial-contents nil icp) initial-element)
+ (declare (ignore initial-element))
+ (cond
+ ((and (array-has-fill-pointer-p s)
+ (>= (array-total-size s) length))
+ (setf (fill-pointer s) length)
+ (if icp (replace s initial-contents) s))
+ ((eql (length s) length)
+ (if icp (replace s initial-contents) s))
+ (t (apply #'adjust-array s length args))))
+ (:method (new-value (s sequence) &rest args)
+ (declare (ignore args))
+ (sequence::protocol-unimplemented s)))
+
+;;;; iterator protocol
+
+;;; The general protocol
+
+(defgeneric sequence:make-sequence-iterator (sequence &key from-end start end)
+ (:method ((s sequence) &key from-end (start 0) end)
+ (multiple-value-bind (iterator limit from-end)
+ (sequence:make-simple-sequence-iterator
+ s :from-end from-end :start start :end end)
+ (values iterator limit from-end
+ #'sequence:iterator-step #'sequence:iterator-endp
+ #'sequence:iterator-element #'(setf sequence:iterator-element)
+ #'sequence:iterator-index #'sequence:iterator-copy)))
+ (:method ((s t) &key from-end start end)
+ (declare (ignore from-end start end))
+ (error 'type-error
+ :datum s
+ :expected-type 'sequence)))
+
+;;; the simple protocol: the simple iterator returns three values,
+;;; STATE, LIMIT and FROM-END.
+
+;;; magic termination value for list :from-end t
+(defvar *exhausted* (cons nil nil))
+
+(defgeneric sequence:make-simple-sequence-iterator
+ (sequence &key from-end start end)
+ (:method ((s list) &key from-end (start 0) end)
+ (if from-end
+ (let* ((termination (if (= start 0) *exhausted* (nthcdr (1- start) s)))
+ (init (if (<= (or end (length s)) start)
+ termination
+ (if end (last s (- (length s) (1- end))) (last s)))))
+ (values init termination t))
+ (cond
+ ((not end) (values (nthcdr start s) nil nil))
+ (t (let ((st (nthcdr start s)))
+ (values st (nthcdr (- end start) st) nil))))))
+ (:method ((s vector) &key from-end (start 0) end)
+ (let ((end (or end (length s))))
+ (if from-end
+ (values (1- end) (1- start) t)
+ (values start end nil))))
+ (:method ((s sequence) &key from-end (start 0) end)
+ (let ((end (or end (length s))))
+ (if from-end
+ (values (1- end) (1- start) from-end)
+ (values start end nil)))))
+
+(defgeneric sequence:iterator-step (sequence iterator from-end)
+ (:method ((s list) iterator from-end)
+ (if from-end
+ (if (eq iterator s)
+ *exhausted*
+ (do* ((xs s (cdr xs)))
+ ((eq (cdr xs) iterator) xs)))
+ (cdr iterator)))
+ (:method ((s vector) iterator from-end)
+ (if from-end
+ (1- iterator)
+ (1+ iterator)))
+ (:method ((s sequence) iterator from-end)
+ (if from-end
+ (1- iterator)
+ (1+ iterator))))
+
+(defgeneric sequence:iterator-endp (sequence iterator limit from-end)
+ (:method ((s list) iterator limit from-end)
+ (eq iterator limit))
+ (:method ((s vector) iterator limit from-end)
+ (= iterator limit))
+ (:method ((s sequence) iterator limit from-end)
+ (= iterator limit)))
+
+(defgeneric sequence:iterator-element (sequence iterator)
+ (:method ((s list) iterator)
+ (car iterator))
+ (:method ((s vector) iterator)
+ (aref s iterator))
+ (:method ((s sequence) iterator)
+ (elt s iterator)))
+
+(defgeneric (setf sequence:iterator-element) (new-value sequence iterator)
+ (:method (o (s list) iterator)
+ (setf (car iterator) o))
+ (:method (o (s vector) iterator)
+ (setf (aref s iterator) o))
+ (:method (o (s sequence) iterator)
+ (setf (elt s iterator) o)))
+
+(defgeneric sequence:iterator-index (sequence iterator)
+ (:method ((s list) iterator)
+ ;; FIXME: this sucks. (In my defence, it is the equivalent of the
+ ;; Apple implementation in Dylan...)
+ (loop for l on s for i from 0 when (eq l iterator) return i))
+ (:method ((s vector) iterator) iterator)
+ (:method ((s sequence) iterator) iterator))
+
+(defgeneric sequence:iterator-copy (sequence iterator)
+ (:method ((s list) iterator) iterator)
+ (:method ((s vector) iterator) iterator)
+ (:method ((s sequence) iterator) iterator))
+
+(defmacro sequence:with-sequence-iterator
+ ((&rest vars) (s &rest args &key from-end start end) &body body)
+ (declare (ignore from-end start end))
+ `(multiple-value-bind (, at vars) (sequence:make-sequence-iterator ,s , at args)
+ (declare (type function ,@(nthcdr 3 vars)))
+ , at body))
+
+(defmacro sequence:with-sequence-iterator-functions
+ ((step endp elt setf index copy)
+ (s &rest args &key from-end start end)
+ &body body)
+ (declare (ignore from-end start end))
+ (let ((nstate (gensym "STATE")) (nlimit (gensym "LIMIT"))
+ (nfrom-end (gensym "FROM-END-")) (nstep (gensym "STEP"))
+ (nendp (gensym "ENDP")) (nelt (gensym "ELT"))
+ (nsetf (gensym "SETF")) (nindex (gensym "INDEX"))
+ (ncopy (gensym "COPY")))
+ `(sequence:with-sequence-iterator
+ (,nstate ,nlimit ,nfrom-end ,nstep ,nendp ,nelt ,nsetf ,nindex ,ncopy)
+ (,s , at args)
+ (flet ((,step () (setq ,nstate (funcall ,nstep ,s ,nstate ,nfrom-end)))
+ (,endp () (funcall ,nendp ,s ,nstate ,nlimit ,nfrom-end))
+ (,elt () (funcall ,nelt ,s ,nstate))
+ (,setf (new-value) (funcall ,nsetf new-value ,s ,nstate))
+ (,index () (funcall ,nindex ,s ,nstate))
+ (,copy () (funcall ,ncopy ,s ,nstate)))
+ (declare (truly-dynamic-extent #',step #',endp #',elt
+ #',setf #',index #',copy))
+ , at body))))
+
+(defun sequence:canonize-test (test test-not)
+ (cond
+ (test (if (functionp test) test (fdefinition test)))
+ (test-not (if (functionp test-not)
+ (complement test-not)
+ (complement (fdefinition test-not))))
+ (t #'eql)))
+
+(defun sequence:canonize-key (key)
+ (or (and key (if (functionp key) key (fdefinition key))) #'identity))
+
+;;;; generic implementations for sequence functions.
+
+;;; FIXME: COUNT, POSITION and FIND share an awful lot of structure.
+;;; They could usefully be defined in an OAOO way.
+(defgeneric sequence:count
+ (item sequence &key from-end start end test test-not key)
+ (:argument-precedence-order sequence item))
+(defmethod sequence:count
+ (item (sequence sequence) &key from-end (start 0) end test test-not key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((count 0))
+ ((funcall endp sequence state limit from-end) count)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall test item (funcall key o))
+ (incf count))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:count-if (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:count-if
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((count 0))
+ ((funcall endp sequence state limit from-end) count)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall pred (funcall key o))
+ (incf count))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:count-if-not (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:count-if-not
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((count 0))
+ ((funcall endp sequence state limit from-end) count)
+ (let ((o (funcall elt sequence state)))
+ (unless (funcall pred (funcall key o))
+ (incf count))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:find
+ (item sequence &key from-end start end test test-not key)
+ (:argument-precedence-order sequence item))
+(defmethod sequence:find
+ (item (sequence sequence) &key from-end (start 0) end test test-not key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ()
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall test item (funcall key o))
+ (return o))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:find-if (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:find-if
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ()
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall pred (funcall key o))
+ (return o))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:find-if-not (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:find-if-not
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ()
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (unless (funcall pred (funcall key o))
+ (return o))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:position
+ (item sequence &key from-end start end test test-not key)
+ (:argument-precedence-order sequence item))
+(defmethod sequence:position
+ (item (sequence sequence) &key from-end (start 0) end test test-not key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((s (if from-end -1 1))
+ (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall test item (funcall key o))
+ (return pos))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:position-if (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:position-if
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((s (if from-end -1 1))
+ (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall pred (funcall key o))
+ (return pos))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:position-if-not
+ (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:position-if-not
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((s (if from-end -1 1))
+ (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (unless (funcall pred (funcall key o))
+ (return pos))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:subseq (sequence start &optional end))
+(defmethod sequence:subseq ((sequence sequence) start &optional end)
+ (let* ((end (or end (length sequence)))
+ (length (- end start))
+ (result (sequence:make-sequence-like sequence length)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :start start :end end)
+ (declare (ignore limit endp))
+ (sequence:with-sequence-iterator (rstate rlimit rfrom-end rstep rendp relt rsetelt)
+ (result)
+ (declare (ignore rlimit rendp relt))
+ (do ((i 0 (+ i 1)))
+ ((>= i length) result)
+ (funcall rsetelt (funcall elt sequence state) result rstate)
+ (setq state (funcall step sequence state from-end))
+ (setq rstate (funcall rstep result rstate rfrom-end)))))))
+
+(defgeneric sequence:copy-seq (sequence))
+(defmethod sequence:copy-seq ((sequence sequence))
+ (sequence:subseq sequence 0))
+
+(fmakunbound 'sequence:fill)
+(defgeneric sequence:fill (sequence item &key start end))
+(defmethod sequence:fill ((sequence sequence) item &key (start 0) end)
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence :start start :end end)
+ (declare (ignore elt))
+ (do ()
+ ((funcall endp sequence state limit from-end) sequence)
+ (funcall setelt item sequence state)
+ (setq state (funcall step sequence state from-end)))))
+
+(defgeneric sequence:nsubstitute
+ (new old sequence &key start end from-end test test-not count key)
+ (:argument-precedence-order sequence new old))
+(defmethod sequence:nsubstitute (new old (sequence sequence) &key (start 0)
+ end from-end test test-not count key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence :start start :end end :from-end from-end)
+ (do ((c 0))
+ ((or (and count (>= c count))
+ (funcall endp sequence state limit from-end))
+ sequence)
+ (when (funcall test old (funcall key (funcall elt sequence state)))
+ (incf c)
+ (funcall setelt new sequence state))
+ (setq state (funcall step sequence state from-end))))))
+
+(defgeneric sequence:nsubstitute-if
+ (new predicate sequence &key start end from-end count key)
+ (:argument-precedence-order sequence new predicate))
+(defmethod sequence:nsubstitute-if
+ (new predicate (sequence sequence) &key (start 0) end from-end count key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence :start start :end end :from-end from-end)
+ (do ((c 0))
+ ((or (and count (>= c count))
+ (funcall endp sequence state limit from-end))
+ sequence)
+ (when (funcall predicate (funcall key (funcall elt sequence state)))
+ (incf c)
+ (funcall setelt new sequence state))
+ (setq state (funcall step sequence state from-end))))))
+
+(defgeneric sequence:nsubstitute-if-not
+ (new predicate sequence &key start end from-end count key)
+ (:argument-precedence-order sequence new predicate))
+(defmethod sequence:nsubstitute-if-not
+ (new predicate (sequence sequence) &key (start 0) end from-end count key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence :start start :end end :from-end from-end)
+ (do ((c 0))
+ ((or (and count (>= c count))
+ (funcall endp sequence state limit from-end))
+ sequence)
+ (unless (funcall predicate (funcall key (funcall elt sequence state)))
+ (incf c)
+ (funcall setelt new sequence state))
+ (setq state (funcall step sequence state from-end))))))
+
+(defgeneric sequence:substitute
+ (new old sequence &key start end from-end test test-not count key)
+ (:argument-precedence-order sequence new old))
+(defmethod sequence:substitute (new old (sequence sequence) &rest args &key
+ (start 0) end from-end test test-not count key)
+ (declare (truly-dynamic-extent args))
+ (declare (ignore start end from-end test test-not count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:nsubstitute new old result args)))
+
+(defgeneric sequence:substitute-if
+ (new predicate sequence &key start end from-end count key)
+ (:argument-precedence-order sequence new predicate))
+(defmethod sequence:substitute-if (new predicate (sequence sequence) &rest args
+ &key (start 0) end from-end count key)
+ (declare (truly-dynamic-extent args))
+ (declare (ignore start end from-end count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:nsubstitute-if new predicate result args)))
+
+(defgeneric sequence:substitute-if-not
+ (new predicate sequence &key start end from-end count key)
+ (:argument-precedence-order sequence new predicate))
+(defmethod sequence:substitute-if-not
+ (new predicate (sequence sequence) &rest args &key
+ (start 0) end from-end count key)
+ (declare (truly-dynamic-extent args))
+ (declare (ignore start end from-end count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:nsubstitute-if-not new predicate result args)))
+
+(defun %sequence-replace (sequence1 sequence2 start1 end1 start2 end2)
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence1 :start start1 :end end1)
+ (declare (ignore elt1))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence2 :start start2 :end end2)
+ (do ()
+ ((or (funcall endp1 sequence1 state1 limit1 from-end1)
+ (funcall endp2 sequence2 state2 limit2 from-end2))
+ sequence1)
+ (funcall setelt1 (funcall elt2 sequence2 state2) sequence1 state1)
+ (setq state1 (funcall step1 sequence1 state1 from-end1))
+ (setq state2 (funcall step2 sequence2 state2 from-end2))))))
+
+(defgeneric sequence:replace
+ (sequence1 sequence2 &key start1 end1 start2 end2)
+ (:argument-precedence-order sequence2 sequence1))
+(defmethod sequence:replace
+ ((sequence1 sequence) (sequence2 sequence) &key
+ (start1 0) end1 (start2 0) end2)
+ (print sequence1)
+ (print sequence2)
+ (cond
+ ((eq sequence1 sequence2)
+ (let ((replaces (subseq sequence2 start2 end2)))
+ (%sequence-replace sequence1 replaces start1 end1 0 nil)))
+ (t (%sequence-replace sequence1 sequence2 start1 end1 start2 end2))))
+
+(defgeneric sequence:nreverse (sequence))
+(defmethod sequence:nreverse ((sequence sequence))
+ ;; FIXME: this, in particular the :from-end iterator, will suck
+ ;; mightily if the user defines a list-like structure.
+ (let ((length (length sequence)))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence :end (floor length 2))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2 setelt2)
+ (sequence :start (ceiling length 2) :from-end t)
+ (declare (ignore limit2 endp2))
+ (do ()
+ ((funcall endp1 sequence state1 limit1 from-end1) sequence)
+ (let ((x (funcall elt1 sequence state1))
+ (y (funcall elt2 sequence state2)))
+ (funcall setelt1 y sequence state1)
+ (funcall setelt2 x sequence state2))
+ (setq state1 (funcall step1 sequence state1 from-end1))
+ (setq state2 (funcall step2 sequence state2 from-end2)))))))
+
+(defgeneric sequence:reverse (sequence))
+(defmethod sequence:reverse ((sequence sequence))
+ (let ((result (copy-seq sequence)))
+ (sequence:nreverse result)))
+
+(defgeneric sequence:reduce
+ (function sequence &key from-end start end initial-value)
+ (:argument-precedence-order sequence function))
+(defmethod sequence:reduce
+ (function (sequence sequence) &key from-end (start 0) end key
+ (initial-value nil ivp))
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :start start :end end :from-end from-end)
+ (if (funcall endp sequence state limit from-end)
+ (if ivp initial-value (funcall function))
+ (do* ((state state (funcall step sequence state from-end))
+ (value (cond
+ (ivp initial-value)
+ (t (prog1
+ (funcall key (funcall elt sequence state))
+ (setq state (funcall step sequence state from-end)))))))
+ ((funcall endp sequence state limit from-end) value)
+ (let ((e (funcall key (funcall elt sequence state))))
+ (if from-end
+ (setq value (funcall function e value))
+ (setq value (funcall function value e)))))))))
+
+(defgeneric sequence:mismatch (sequence1 sequence2 &key from-end start1 end1
+ start2 end2 test test-not key))
+(defmethod sequence:mismatch
+ ((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
+ (start2 0) end2 test test-not key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1)
+ (sequence1 :start start1 :end end1 :from-end from-end)
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence2 :start start2 :end end2 :from-end from-end)
+ (if from-end
+ (do ((result (or end1 (length sequence1)) (1- result))
+ (e1 (funcall endp1 sequence1 state1 limit1 from-end1)
+ (funcall endp1 sequence1 state1 limit1 from-end1))
+ (e2 (funcall endp2 sequence2 state2 limit2 from-end2)
+ (funcall endp2 sequence2 state2 limit2 from-end2)))
+ ((or e1 e2) (if (and e1 e2) nil result))
+ (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
+ (o2 (funcall key (funcall elt2 sequence2 state2))))
+ (unless (funcall test o1 o2)
+ (return result))
+ (setq state1 (funcall step1 sequence1 state1 from-end1))
+ (setq state2 (funcall step2 sequence2 state2 from-end2))))
+ (do ((result start1 (1+ result))
+ (e1 (funcall endp1 sequence1 state1 limit1 from-end1)
+ (funcall endp1 sequence1 state1 limit1 from-end1))
+ (e2 (funcall endp2 sequence2 state2 limit2 from-end2)
+ (funcall endp2 sequence2 state2 limit2 from-end2)))
+ ((or e1 e2) (if (and e1 e2) nil result))
+ (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
+ (o2 (funcall key (funcall elt2 sequence2 state2))))
+ (unless (funcall test o1 o2)
+ (return result)))
+ (setq state1 (funcall step1 sequence1 state1 from-end1))
+ (setq state2 (funcall step2 sequence2 state2 from-end2))))))))
+
+(defgeneric sequence:search (sequence1 sequence2 &key from-end start1 end1
+ start2 end2 test test-not key))
+(defmethod sequence:search
+ ((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
+ (start2 0) end2 test test-not key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key))
+ (mainend2 (- (or end2 (length sequence2))
+ (- (or end1 (length sequence1)) start1))))
+ (when (< mainend2 0)
+ (return-from sequence:search nil))
+ (sequence:with-sequence-iterator (statem limitm from-endm stepm endpm)
+ (sequence2 :start start2 :end mainend2 :from-end from-end)
+ (do ((s2 (if from-end mainend2 0) (if from-end (1- s2) (1+ s2))))
+ (nil)
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1)
+ (sequence1 :start start1 :end end1)
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence2 :start s2)
+ (declare (ignore limit2 endp2))
+ (when (do ()
+ ((funcall endp1 sequence1 state1 limit1 from-end1) t)
+ (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
+ (o2 (funcall key (funcall elt2 sequence2 state2))))
+ (unless (funcall test o1 o2)
+ (return nil)))
+ (setq state1 (funcall step1 sequence1 state1 from-end1))
+ (setq state2 (funcall step2 sequence2 state2 from-end2)))
+ (return-from sequence:search s2))))
+ (when (funcall endpm sequence2 statem limitm from-endm)
+ (return nil))
+ (setq statem (funcall stepm sequence2 statem from-endm))))))
+
+(defgeneric sequence:delete
+ (item sequence &key from-end test test-not start end count key)
+ (:argument-precedence-order sequence item))
+(defmethod sequence:delete (item (sequence sequence) &key
+ from-end test test-not (start 0) end count key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key))
+ (c 0))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence :start start :end end :from-end from-end)
+ (declare (ignore limit1 endp1 elt1))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence :start start :end end :from-end from-end)
+ (flet ((finish ()
+ (if from-end
+ (replace sequence sequence
+ :start1 start :end1 (- (length sequence) c)
+ :start2 (+ start c) :end2 (length sequence))
+ (unless (or (null end) (= end (length sequence)))
+ (replace sequence sequence :start2 end :start1 (- end c)
+ :end1 (- (length sequence) c))))
+ (sequence:adjust-sequence sequence (- (length sequence) c))))
+ (declare (truly-dynamic-extent #'finish))
+ (do ()
+ ((funcall endp2 sequence state2 limit2 from-end2) (finish))
+ (let ((e (funcall elt2 sequence state2)))
+ (loop
+ (when (and count (>= c count))
+ (return))
+ (if (funcall test item (funcall key e))
+ (progn
+ (incf c)
+ (setq state2 (funcall step2 sequence state2 from-end2))
+ (when (funcall endp2 sequence state2 limit2 from-end2)
+ (return-from sequence:delete (finish)))
+ (setq e (funcall elt2 sequence state2)))
+ (return)))
+ (funcall setelt1 e sequence state1))
+ (setq state1 (funcall step1 sequence state1 from-end1))
+ (setq state2 (funcall step2 sequence state2 from-end2))))))))
+
+(defgeneric sequence:delete-if
+ (predicate sequence &key from-end start end count key)
+ (:argument-precedence-order sequence predicate))
+(defmethod sequence:delete-if (predicate (sequence sequence) &key
+ from-end (start 0) end count key)
+ (let ((key (sequence:canonize-key key))
+ (c 0))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence :start start :end end :from-end from-end)
+ (declare (ignore limit1 endp1 elt1))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence :start start :end end :from-end from-end)
+ (flet ((finish ()
+ (if from-end
+ (replace sequence sequence
+ :start1 start :end1 (- (length sequence) c)
+ :start2 (+ start c) :end2 (length sequence))
+ (unless (or (null end) (= end (length sequence)))
+ (replace sequence sequence :start2 end :start1 (- end c)
+ :end1 (- (length sequence) c))))
+ (sequence:adjust-sequence sequence (- (length sequence) c))))
+ (declare (truly-dynamic-extent #'finish))
+ (do ()
+ ((funcall endp2 sequence state2 limit2 from-end2) (finish))
+ (let ((e (funcall elt2 sequence state2)))
+ (loop
+ (when (and count (>= c count))
+ (return))
+ (if (funcall predicate (funcall key e))
+ (progn
+ (incf c)
+ (setq state2 (funcall step2 sequence state2 from-end2))
+ (when (funcall endp2 sequence state2 limit2 from-end2)
+ (return-from sequence:delete-if (finish)))
+ (setq e (funcall elt2 sequence state2)))
+ (return)))
+ (funcall setelt1 e sequence state1))
+ (setq state1 (funcall step1 sequence state1 from-end1))
+ (setq state2 (funcall step2 sequence state2 from-end2))))))))
+
+(defgeneric sequence:delete-if-not
+ (predicate sequence &key from-end start end count key)
+ (:argument-precedence-order sequence predicate))
+(defmethod sequence:delete-if-not (predicate (sequence sequence) &key
+ from-end (start 0) end count key)
+ (let ((key (sequence:canonize-key key))
+ (c 0))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence :start start :end end :from-end from-end)
+ (declare (ignore limit1 endp1 elt1))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence :start start :end end :from-end from-end)
+ (flet ((finish ()
+ (if from-end
+ (replace sequence sequence
+ :start1 start :end1 (- (length sequence) c)
+ :start2 (+ start c) :end2 (length sequence))
+ (unless (or (null end) (= end (length sequence)))
+ (replace sequence sequence :start2 end :start1 (- end c)
+ :end1 (- (length sequence) c))))
+ (sequence:adjust-sequence sequence (- (length sequence) c))))
+ (declare (truly-dynamic-extent #'finish))
+ (do ()
+ ((funcall endp2 sequence state2 limit2 from-end2) (finish))
+ (let ((e (funcall elt2 sequence state2)))
+ (loop
+ (when (and count (>= c count))
+ (return))
+ (if (funcall predicate (funcall key e))
+ (return)
+ (progn
+ (incf c)
+ (setq state2 (funcall step2 sequence state2 from-end2))
+ (when (funcall endp2 sequence state2 limit2 from-end2)
+ (return-from sequence:delete-if-not (finish)))
+ (setq e (funcall elt2 sequence state2)))))
+ (funcall setelt1 e sequence state1))
+ (setq state1 (funcall step1 sequence state1 from-end1))
+ (setq state2 (funcall step2 sequence state2 from-end2))))))))
+
+(defgeneric sequence:remove
+ (item sequence &key from-end test test-not start end count key)
+ (:argument-precedence-order sequence item))
+(defmethod sequence:remove (item (sequence sequence) &rest args &key
+ from-end test test-not (start 0) end count key)
+ (declare (dynamic-extent args))
+ (declare (ignore from-end test test-not start end count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:delete item result args)))
+
+(defgeneric sequence:remove-if
+ (predicate sequence &key from-end start end count key)
+ (:argument-precedence-order sequence predicate))
+(defmethod sequence:remove-if (predicate (sequence sequence) &rest args &key
+ from-end (start 0) end count key)
+ (declare (truly-dynamic-extent args))
+ (declare (ignore from-end start end count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:delete-if predicate result args)))
+
+(defgeneric sequence:remove-if-not
+ (predicate sequence &key from-end start end count key)
+ (:argument-precedence-order sequence predicate))
+(defmethod sequence:remove-if-not (predicate (sequence sequence) &rest args
+ &key from-end (start 0) end count key)
+ (declare (truly-dynamic-extent args))
+ (declare (ignore from-end start end count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:delete-if-not predicate result args)))
+
+(defgeneric sequence:delete-duplicates
+ (sequence &key from-end test test-not start end key))
+(defmethod sequence:delete-duplicates
+ ((sequence sequence) &key from-end test test-not (start 0) end key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key))
+ (c 0))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence :start start :end end :from-end from-end)
+ (declare (ignore limit1 endp1 elt1))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence :start start :end end :from-end from-end)
+ (flet ((finish ()
+ (if from-end
+ (replace sequence sequence
+ :start1 start :end1 (- (length sequence) c)
+ :start2 (+ start c) :end2 (length sequence))
+ (unless (or (null end) (= end (length sequence)))
+ (replace sequence sequence :start2 end :start1 (- end c)
+ :end1 (- (length sequence) c))))
+ (sequence:adjust-sequence sequence (- (length sequence) c))))
+ (declare (truly-dynamic-extent #'finish))
+ (do ((end (or end (length sequence)))
+ (step 0 (1+ step)))
+ ((funcall endp2 sequence state2 limit2 from-end2) (finish))
+ (let ((e (funcall elt2 sequence state2)))
+ (loop
+ ;; FIXME: replace with POSITION once position is
+ ;; working
+ (if (> (count (funcall key e) sequence :test test :key key
+ :start (if from-end start (+ start step 1))
+ :end (if from-end (- end step 1) end))
+ 0)
+ (progn
+ (incf c)
+ (incf step)
+ (setq state2 (funcall step2 sequence state2 from-end2))
+ (when (funcall endp2 sequence state2 limit2 from-end2)
+ (return-from sequence:delete-duplicates (finish)))
+ (setq e (funcall elt2 sequence state2)))
+ (progn
+ (return))))
+ (funcall setelt1 e sequence state1))
+ (setq state1 (funcall step1 sequence state1 from-end1))
+ (setq state2 (funcall step2 sequence state2 from-end2))))))))
+
+(defgeneric sequence:remove-duplicates
+ (sequence &key from-end test test-not start end key))
+(defmethod sequence:remove-duplicates
+ ((sequence sequence) &rest args &key from-end test test-not (start 0) end key)
+ (declare (truly-dynamic-extent args))
+ (declare (ignore from-end test test-not start end key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:delete-duplicates result args)))
+
+(defgeneric sequence:sort (sequence predicate &key key))
+(defmethod sequence:sort ((sequence sequence) predicate &rest args &key key)
+ (declare (dynamic-extent args))
+ (declare (ignore key))
+ (let* ((length (length sequence))
+ (vector (make-array length)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence)
+ (declare (ignore limit endp))
+ (do ((i 0 (1+ i)))
+ ((>= i length))
+ (setf (aref vector i) (funcall elt sequence state))
+ (setq state (funcall step sequence state from-end))))
+ (apply #'cl:sort vector predicate args)
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence)
+ (declare (ignore limit endp elt))
+ (do ((i 0 (1+ i)))
+ ((>= i length) sequence)
+ (funcall setelt (aref vector i) sequence state)
+ (setq state (funcall step sequence state from-end))))))
+
+(defgeneric sequence:stable-sort (sequence predicate &key key))
+(defmethod sequence:stable-sort
+ ((sequence sequence) predicate &rest args &key key)
+ (declare (dynamic-extent args))
+ (declare (ignore key))
+ (let* ((length (length sequence))
+ (vector (make-array length)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence)
+ (declare (ignore limit endp))
+ (do ((i 0 (1+ i)))
+ ((>= i length))
+ (setf (aref vector i) (funcall elt sequence state))
+ (setq state (funcall step sequence state from-end))))
+ (apply #'cl:stable-sort vector predicate args)
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence)
+ (declare (ignore limit endp elt))
+ (do ((i 0 (1+ i)))
+ ((>= i length) sequence)
+ (funcall setelt (aref vector i) sequence state)
+ (setq state (funcall step sequence state from-end))))))
+
+;;LOOP extension
+(defun loop-elements-iteration-path (variable data-type prep-phrases)
+ (let (of-phrase)
+ (loop for (prep . rest) in prep-phrases do
+ (ecase prep
+ ((:of :in) (if of-phrase
+ (loop::loop-error "Too many prepositions")
+ (setq of-phrase rest)))))
+ (destructuring-bind (it lim f-e step endp elt seq)
+ (loop repeat 7 collect (gensym))
+ (push `(let ((,seq ,(car of-phrase)))) loop::*loop-wrappers*)
+ (push `(sequence:with-sequence-iterator (,it ,lim ,f-e ,step ,endp ,elt) (,seq))
+ loop::*loop-wrappers*)
+ `(((,variable nil ,data-type)) () () nil (funcall ,endp ,seq ,it ,lim ,f-e)
+ (,variable (funcall ,elt ,seq ,it) ,it (funcall ,step ,seq ,it ,f-e))))))
+
+(loop::add-loop-path
+ '(element elements) 'loop-elements-iteration-path loop::*loop-ansi-universe*
+ :preposition-groups '((:of :in)) :inclusive-permitted nil)
+
+(provide "EXTENSIBLE-SEQUENCES")
\ No newline at end of file
Modified: trunk/abcl/src/org/armedbear/lisp/fill.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/fill.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/fill.lisp Wed Mar 3 16:05:41 2010
@@ -31,6 +31,8 @@
(in-package "SYSTEM")
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
;;; Adapted from CMUCL.
(defun list-fill (sequence item start end)
@@ -48,11 +50,16 @@
(setf (aref sequence index) item)))
(defun fill (sequence item &key (start 0) end)
- (cond ((listp sequence)
- (list-fill sequence item start end))
- ((and (stringp sequence)
- (zerop start)
- (null end))
- (simple-string-fill sequence item))
- (t
- (vector-fill sequence item start end))))
+ "Replace the specified elements of SEQUENCE with ITEM."
+ (sequence::seq-dispatch sequence
+ (list-fill sequence item start end)
+ (cond ((and (stringp sequence)
+ (zerop start)
+ (null end))
+ (simple-string-fill sequence item))
+ (t
+ (vector-fill sequence item start end)))
+ (sequence:fill sequence item
+ :start start
+ :end (sequence::%check-generic-sequence-bounds
+ sequence start end))))
\ No newline at end of file
Modified: trunk/abcl/src/org/armedbear/lisp/find.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/find.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/find.lisp Wed Mar 3 16:05:41 2010
@@ -31,6 +31,8 @@
(in-package #:system)
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
;;; From CMUCL.
(defmacro vector-locater-macro (sequence body-form return-type)
@@ -142,12 +144,12 @@
`(list-locater ,item ,sequence :position))
-(defun position (item sequence &key from-end (test #'eql) test-not (start 0)
- end key)
- (if (listp sequence)
- (list-position* item sequence from-end test test-not start end key)
- (vector-position* item sequence from-end test test-not start end key)))
-
+(defun position (item sequence &rest args &key from-end (test #'eql) test-not
+ (start 0) end key)
+ (sequence::seq-dispatch sequence
+ (list-position* item sequence from-end test test-not start end key)
+ (vector-position* item sequence from-end test test-not start end key)
+ (apply #'sequence:position item sequence args)))
(defun list-position* (item sequence from-end test test-not start end key)
(declare (type fixnum start))
@@ -167,13 +169,14 @@
(defmacro list-position-if (test sequence)
`(list-locater-if ,test ,sequence :position))
-(defun position-if (test sequence &key from-end (start 0) key end)
+(defun position-if (test sequence &rest args &key from-end (start 0) key end)
(declare (type fixnum start))
(let ((end (or end (length sequence))))
(declare (type fixnum end))
- (if (listp sequence)
- (list-position-if test sequence)
- (vector-position-if test sequence))))
+ (sequence::seq-dispatch sequence
+ (list-position-if test sequence)
+ (vector-position-if test sequence)
+ (apply #'sequence:position-if test sequence args))))
(defmacro vector-position-if-not (test sequence)
`(vector-locater-if-not ,test ,sequence :position))
@@ -181,13 +184,14 @@
(defmacro list-position-if-not (test sequence)
`(list-locater-if-not ,test ,sequence :position))
-(defun position-if-not (test sequence &key from-end (start 0) key end)
+(defun position-if-not (test sequence &rest args &key from-end (start 0) key end)
(declare (type fixnum start))
(let ((end (or end (length sequence))))
(declare (type fixnum end))
- (if (listp sequence)
- (list-position-if-not test sequence)
- (vector-position-if-not test sequence))))
+ (sequence::seq-dispatch sequence
+ (list-position-if-not test sequence)
+ (vector-position-if-not test sequence)
+ (apply #'sequence:position-if-not test sequence args))))
(defmacro vector-find (item sequence)
`(vector-locater ,item ,sequence :element))
@@ -207,12 +211,13 @@
(setf test 'eql))
(vector-find item sequence))
-(defun find (item sequence &key from-end (test #'eql) test-not (start 0)
- end key)
+(defun find (item sequence &rest args &key from-end (test #'eql) test-not
+ (start 0) end key)
(let ((end (check-sequence-bounds sequence start end)))
- (if (listp sequence)
- (list-find* item sequence from-end test test-not start end key)
- (vector-find* item sequence from-end test test-not start end key))))
+ (sequence::seq-dispatch sequence
+ (list-find* item sequence from-end test test-not start end key)
+ (vector-find* item sequence from-end test test-not start end key)
+ (apply #'sequence:find item sequence args))))
(defmacro vector-find-if (test sequence)
`(vector-locater-if ,test ,sequence :element))
@@ -220,12 +225,13 @@
(defmacro list-find-if (test sequence)
`(list-locater-if ,test ,sequence :element))
-(defun find-if (test sequence &key from-end (start 0) end key)
+(defun find-if (test sequence &rest args &key from-end (start 0) end key)
(let ((end (or end (length sequence))))
(declare (type fixnum end))
- (if (listp sequence)
- (list-find-if test sequence)
- (vector-find-if test sequence))))
+ (sequence::seq-dispatch sequence
+ (list-find-if test sequence)
+ (vector-find-if test sequence)
+ (apply #'sequence:find-if test sequence args))))
(defmacro vector-find-if-not (test sequence)
`(vector-locater-if-not ,test ,sequence :element))
@@ -233,9 +239,10 @@
(defmacro list-find-if-not (test sequence)
`(list-locater-if-not ,test ,sequence :element))
-(defun find-if-not (test sequence &key from-end (start 0) end key)
+(defun find-if-not (test sequence &rest args &key from-end (start 0) end key)
(let ((end (or end (length sequence))))
(declare (type fixnum end))
- (if (listp sequence)
- (list-find-if-not test sequence)
- (vector-find-if-not test sequence))))
+ (sequence::seq-dispatch sequence
+ (list-find-if-not test sequence)
+ (vector-find-if-not test sequence)
+ (apply #'sequence:find-if-not test sequence args))))
Modified: trunk/abcl/src/org/armedbear/lisp/make-sequence.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/make-sequence.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/make-sequence.lisp Wed Mar 3 16:05:41 2010
@@ -39,11 +39,18 @@
:format-arguments (list size type)))
(defun make-sequence (type size &key (initial-element nil iesp))
- (let (element-type sequence)
+ (let (element-type sequence class)
(setf type (normalize-type type))
(cond ((atom type)
+ (setf class (if (classp type) type (find-class type nil)))
(when (classp type)
- (setf type (%class-name type)))
+ (let ((class-name (%class-name type)))
+ (when (member class-name '(LIST CONS STRING SIMPLE-STRING
+ BASE-STRING SIMPLE-BASE-STRING NULL
+ BIT-VECTOR SIMPLE-BIT-VECTOR VECTOR
+ SIMPLE-VECTOR))
+ (setf type class-name))))
+ ;;Else we suppose it's a user-defined sequence and move on
(cond ((memq type '(LIST CONS))
(when (zerop size)
(if (eq type 'CONS)
@@ -66,11 +73,11 @@
(setq element-type
(cond ((memq type '(BIT-VECTOR SIMPLE-BIT-VECTOR)) 'BIT)
((memq type '(VECTOR SIMPLE-VECTOR)) t)
- (t
+ ((null class)
(error 'simple-type-error
:format-control "~S is not a sequence type."
:format-arguments (list type))))))))
- (t
+ (t
(let ((name (%car type))
(args (%cdr type)))
(when (eq name 'LIST)
@@ -108,7 +115,15 @@
(when (/= size len)
(size-mismatch-error type size)))))))
(setq sequence
- (if iesp
- (make-array size :element-type element-type :initial-element initial-element)
- (make-array size :element-type element-type)))
+ (cond ((or (not (atom type)) (subtypep type 'array))
+ (if iesp
+ (make-array size :element-type element-type :initial-element initial-element)
+ (make-array size :element-type element-type)))
+ ((and class (subtypep type 'sequence))
+ (if iesp
+ (sequence:make-sequence-like (mop::class-prototype class) size :initial-element initial-element)
+ (sequence:make-sequence-like (mop::class-prototype class) size)))
+ (t (error 'simple-type-error
+ :format-control "~S is not a sequence type."
+ :format-arguments (list type)))))
sequence))
Modified: trunk/abcl/src/org/armedbear/lisp/mismatch.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/mismatch.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/mismatch.lisp Wed Mar 3 16:05:41 2010
@@ -32,6 +32,8 @@
(in-package "COMMON-LISP")
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
(export 'mismatch)
;;; From ECL.
@@ -70,27 +72,28 @@
(defun test-error()
(error "both test and test are supplied"))
-(defun mismatch (sequence1 sequence2 &key from-end test test-not
- (key #'identity) start1 start2 end1 end2)
+(defun mismatch (sequence1 sequence2 &rest args &key from-end test test-not
+ (key #'identity) start1 start2 end1 end2)
(and test test-not (test-error))
- (with-start-end
- start1 end1 sequence1
- (with-start-end
- start2 end2 sequence2
- (if (not from-end)
- (do ((i1 start1 (1+ i1))
- (i2 start2 (1+ i2)))
- ((or (>= i1 end1) (>= i2 end2))
- (if (and (>= i1 end1) (>= i2 end2)) nil i1))
- (unless (call-test test test-not
- (funcall key (elt sequence1 i1))
- (funcall key (elt sequence2 i2)))
- (return i1)))
- (do ((i1 (1- end1) (1- i1))
- (i2 (1- end2) (1- i2)))
- ((or (< i1 start1) (< i2 start2))
- (if (and (< i1 start1) (< i2 start2)) nil (1+ i1)))
- (unless (call-test test test-not
- (funcall key (elt sequence1 i1))
- (funcall key (elt sequence2 i2)))
- (return (1+ i1))))))))
+ (if (and (or (listp sequence1) (arrayp sequence1))
+ (or (listp sequence2) (arrayp sequence2)))
+ (with-start-end start1 end1 sequence1
+ (with-start-end start2 end2 sequence2
+ (if (not from-end)
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (>= i1 end1) (>= i2 end2))
+ (if (and (>= i1 end1) (>= i2 end2)) nil i1))
+ (unless (call-test test test-not
+ (funcall key (elt sequence1 i1))
+ (funcall key (elt sequence2 i2)))
+ (return i1)))
+ (do ((i1 (1- end1) (1- i1))
+ (i2 (1- end2) (1- i2)))
+ ((or (< i1 start1) (< i2 start2))
+ (if (and (< i1 start1) (< i2 start2)) nil (1+ i1)))
+ (unless (call-test test test-not
+ (funcall key (elt sequence1 i1))
+ (funcall key (elt sequence2 i2)))
+ (return (1+ i1)))))))
+ (apply #'sequence:mismatch sequence1 sequence2 args)))
Modified: trunk/abcl/src/org/armedbear/lisp/reduce.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/reduce.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/reduce.lisp Wed Mar 3 16:05:41 2010
@@ -33,6 +33,8 @@
(in-package #:system)
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
(defmacro list-reduce (function sequence start end initial-value ivp key)
(let ((what `(if ,key (funcall ,key (car sequence)) (car sequence))))
`(let ((sequence (nthcdr ,start ,sequence)))
@@ -56,12 +58,12 @@
((= count ,end) value)))))
-(defun reduce (function sequence &key from-end (start 0)
+(defun reduce (function sequence &rest args &key from-end (start 0)
end (initial-value nil ivp) key)
(unless end (setq end (length sequence)))
(if (= end start)
(if ivp initial-value (funcall function))
- (if (listp sequence)
+ (sequence::seq-dispatch sequence
(if from-end
(list-reduce-from-end function sequence start end initial-value ivp key)
(list-reduce function sequence start end initial-value ivp key))
@@ -80,4 +82,5 @@
element (if key (funcall key element) element)
value (funcall function
(if from-end element value)
- (if from-end value element))))))))
+ (if from-end value element)))))
+ (apply #'sequence:reduce function sequence args))))
Modified: trunk/abcl/src/org/armedbear/lisp/remove-duplicates.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/remove-duplicates.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/remove-duplicates.lisp Wed Mar 3 16:05:41 2010
@@ -31,6 +31,8 @@
(in-package #:system)
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
;;; Adapted from CMUCL.
(defun list-remove-duplicates (list test test-not start end key from-end)
@@ -97,16 +99,17 @@
(setq jndex (1+ jndex)))
(shrink-vector result jndex)))
-(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) from-end
- end key)
- (if (listp sequence)
- (when sequence
- (if (and (eq test #'eql)
- (null test-not)
- (eql start 0)
- (null from-end)
- (null end)
- (null key))
- (simple-list-remove-duplicates sequence)
- (list-remove-duplicates sequence test test-not start end key from-end)))
- (vector-remove-duplicates sequence test test-not start end key from-end)))
+(defun remove-duplicates (sequence &rest args &key (test #'eql) test-not
+ (start 0) from-end end key)
+ (sequence::seq-dispatch sequence
+ (when sequence
+ (if (and (eq test #'eql)
+ (null test-not)
+ (eql start 0)
+ (null from-end)
+ (null end)
+ (null key))
+ (simple-list-remove-duplicates sequence)
+ (list-remove-duplicates sequence test test-not start end key from-end)))
+ (vector-remove-duplicates sequence test test-not start end key from-end)
+ (apply #'sequence:remove-duplicates sequence args)))
Modified: trunk/abcl/src/org/armedbear/lisp/remove.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/remove.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/remove.lisp Wed Mar 3 16:05:41 2010
@@ -32,6 +32,7 @@
(in-package "SYSTEM")
(require "DELETE") ; MUMBLE-DELETE-FROM-END
+(require "EXTENSIBLE-SEQUENCES-BASE")
;;; From CMUCL.
@@ -155,39 +156,44 @@
`(list-remove-from-end
(not (funcall predicate (apply-key key this-element)))))
-(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
- end count key)
+(defun remove (item sequence &rest args &key from-end (test #'eql) test-not
+ (start 0) end count key)
(let* ((length (length sequence))
(end (or end length))
(count (real-count count)))
- (if (listp sequence)
- (if from-end
- (normal-list-remove-from-end)
- (normal-list-remove))
- (if from-end
- (normal-mumble-remove-from-end)
- (normal-mumble-remove)))))
+ (sequence::seq-dispatch sequence
+ (if from-end
+ (normal-list-remove-from-end)
+ (normal-list-remove))
+ (if from-end
+ (normal-mumble-remove-from-end)
+ (normal-mumble-remove))
+ (apply #'sequence:remove item sequence args))))
-(defun remove-if (predicate sequence &key from-end (start 0) end count key)
+(defun remove-if (predicate sequence &rest args &key from-end (start 0)
+ end count key)
(let* ((length (length sequence))
(end (or end length))
(count (real-count count)))
- (if (listp sequence)
- (if from-end
- (if-list-remove-from-end)
- (if-list-remove))
- (if from-end
- (if-mumble-remove-from-end)
- (if-mumble-remove)))))
+ (sequence::seq-dispatch sequence
+ (if from-end
+ (if-list-remove-from-end)
+ (if-list-remove))
+ (if from-end
+ (if-mumble-remove-from-end)
+ (if-mumble-remove))
+ (apply #'sequence:remove-if predicate sequence args))))
-(defun remove-if-not (predicate sequence &key from-end (start 0) end count key)
+(defun remove-if-not (predicate sequence &rest args &key from-end (start 0)
+ end count key)
(let* ((length (length sequence))
(end (or end length))
(count (real-count count)))
- (if (listp sequence)
- (if from-end
- (if-not-list-remove-from-end)
- (if-not-list-remove))
- (if from-end
- (if-not-mumble-remove-from-end)
- (if-not-mumble-remove)))))
+ (sequence::seq-dispatch sequence
+ (if from-end
+ (if-not-list-remove-from-end)
+ (if-not-list-remove))
+ (if from-end
+ (if-not-mumble-remove-from-end)
+ (if-not-mumble-remove))
+ (apply #'sequence:remove-if-not predicate sequence args))))
Modified: trunk/abcl/src/org/armedbear/lisp/replace.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/replace.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/replace.lisp Wed Mar 3 16:05:41 2010
@@ -33,11 +33,13 @@
(in-package #:system)
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
+#|(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro seq-dispatch (sequence list-form array-form)
`(if (listp ,sequence)
,list-form
- ,array-form)))
+ ,array-form)))|#
(eval-when (:compile-toplevel :execute)
@@ -144,20 +146,10 @@
(when (null source-end) (setq source-end (length source-sequence)))
(mumble-replace-from-mumble))
-(defun %replace (target-sequence source-sequence target-start target-end source-start source-end)
- (declare (type (integer 0 #.most-positive-fixnum) target-start target-end source-start source-end))
- (seq-dispatch target-sequence
- (seq-dispatch source-sequence
- (list-replace-from-list)
- (list-replace-from-mumble))
- (seq-dispatch source-sequence
- (mumble-replace-from-list)
- (mumble-replace-from-mumble))))
-
;;; REPLACE cannot default end arguments to the length of sequence since it
;;; is not an error to supply nil for their values. We must test for ends
;;; being nil in the body of the function.
-(defun replace (target-sequence source-sequence &key
+(defun replace (target-sequence source-sequence &rest args &key
((:start1 target-start) 0)
((:end1 target-end))
((:start2 source-start) 0)
@@ -166,4 +158,14 @@
elements into it from the source sequence."
(let ((target-end (or target-end (length target-sequence)))
(source-end (or source-end (length source-sequence))))
- (%replace target-sequence source-sequence target-start target-end source-start source-end)))
+ (declare (type (integer 0 #.most-positive-fixnum) target-start target-end source-start source-end))
+ (sequence::seq-dispatch target-sequence
+ (sequence::seq-dispatch source-sequence
+ (list-replace-from-list)
+ (list-replace-from-mumble)
+ (apply #'sequence:replace target-sequence source-sequence args))
+ (sequence::seq-dispatch source-sequence
+ (mumble-replace-from-list)
+ (mumble-replace-from-mumble)
+ (apply #'sequence:replace target-sequence source-sequence args))
+ (apply #'sequence:replace target-sequence source-sequence args))))
Modified: trunk/abcl/src/org/armedbear/lisp/search.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/search.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/search.lisp Wed Mar 3 16:05:41 2010
@@ -31,6 +31,8 @@
(in-package "SYSTEM")
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
;; From CMUCL.
(eval-when (:compile-toplevel :execute)
@@ -110,15 +112,16 @@
) ; eval-when
-(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not
- (start1 0) end1 (start2 0) end2 key)
+(defun search (sequence1 sequence2 &rest args &key from-end (test #'eql)
+ test-not (start1 0) end1 (start2 0) end2 key)
(let ((end1 (or end1 (length sequence1)))
(end2 (or end2 (length sequence2))))
(when key
(setq key (coerce-to-function key)))
- (if (listp sequence2)
- (list-search sequence2 sequence1)
- (vector-search sequence2 sequence1))))
+ (sequence::seq-dispatch sequence2
+ (list-search sequence2 sequence1)
+ (vector-search sequence2 sequence1)
+ (apply #'sequence:search sequence1 sequence2 args))))
(defun simple-search (sequence1 sequence2)
(cond ((and (stringp sequence1) (stringp sequence2))
Modified: trunk/abcl/src/org/armedbear/lisp/sequences.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/sequences.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/sequences.lisp Wed Mar 3 16:05:41 2010
@@ -29,6 +29,8 @@
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
+;(require "EXTENSIBLE-SEQUENCES-BASE")
+
(in-package #:system)
(defmacro type-specifier-atom (type)
@@ -56,4 +58,10 @@
(error "MAKE-SEQUENCE-OF-TYPE: unsupported case ~S" type))))
(defmacro make-sequence-like (sequence length)
- `(make-sequence-of-type (type-of ,sequence) ,length))
+ "Return a sequence of the same type as SEQUENCE and the given LENGTH."
+ ;;Can't use gensyms: stack overflow in boot.lisp
+ `(let ((msl-seq-tmp-var ,sequence) (msl-len-tmp-var ,length))
+ (sequence::seq-dispatch msl-seq-tmp-var
+ (make-sequence-of-type (type-of msl-seq-tmp-var) msl-len-tmp-var)
+ (make-sequence-of-type (type-of msl-seq-tmp-var) msl-len-tmp-var)
+ (sequence::make-sequence-like msl-seq-tmp-var msl-len-tmp-var))))
\ No newline at end of file
Modified: trunk/abcl/src/org/armedbear/lisp/setf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/setf.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/setf.lisp Wed Mar 3 16:05:41 2010
@@ -222,6 +222,7 @@
(defsetf tenth %set-tenth)
(defsetf rest set-cdr)
+;;Redefined in extensible-sequences-base.lisp
(defsetf elt %set-elt)
(defsetf nth %set-nth)
(defsetf svref svset)
Modified: trunk/abcl/src/org/armedbear/lisp/sort.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/sort.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/sort.lisp Wed Mar 3 16:05:41 2010
@@ -31,15 +31,19 @@
(in-package #:system)
-(defun sort (sequence predicate &key key)
- (if (listp sequence)
- (sort-list sequence predicate key)
- (quick-sort sequence 0 (length sequence) predicate key)))
-
-(defun stable-sort (sequence predicate &key key)
- (if (listp sequence)
- (sort-list sequence predicate key)
- (quick-sort sequence 0 (length sequence) predicate key)))
+(require "EXTENSIBLE-SEQUENCES-BASE")
+
+(defun sort (sequence predicate &rest args &key key)
+ (sequence::seq-dispatch sequence
+ (sort-list sequence predicate key)
+ (quick-sort sequence 0 (length sequence) predicate key)
+ (apply #'sequence:sort sequence predicate args)))
+
+(defun stable-sort (sequence predicate &rest args &key key)
+ (sequence::seq-dispatch sequence
+ (sort-list sequence predicate key)
+ (quick-sort sequence 0 (length sequence) predicate key)
+ (apply #'sequence:stable-sort sequence predicate args)))
;; Adapted from SBCL.
(declaim (ftype (function (list) cons) last-cons-of))
@@ -192,7 +196,8 @@
(quick-sort seq start j pred key)
(quick-sort seq (1+ j) end pred key))))
-;;; From ECL.
+;;; From ECL. Should already be user-extensible as it does no type dispatch
+;;; and uses only user-extensible functions.
(defun merge (result-type sequence1 sequence2 predicate
&key key
&aux (l1 (length sequence1)) (l2 (length sequence2)))
Modified: trunk/abcl/src/org/armedbear/lisp/substitute.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/substitute.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/substitute.lisp Wed Mar 3 16:05:41 2010
@@ -29,6 +29,7 @@
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
+(require "EXTENSIBLE-SEQUENCES-BASE")
(in-package "COMMON-LISP")
@@ -109,7 +110,7 @@
result))
(defmacro subst-dispatch (pred)
- `(if (listp sequence)
+ `(sequence::seq-dispatch sequence
(if from-end
(nreverse (list-substitute* ,pred new (reverse sequence)
(- length end)
@@ -122,10 +123,14 @@
-1 length (1- end)
(1- start) count key test test-not old)
(vector-substitute* ,pred new sequence 1 0 length length
- start end count key test test-not old))))
+ start end count key test test-not old))
+ ,(ecase (cadr pred) ;;pred is (quote <foo>)
+ (normal `(apply #'sequence:substitute new old sequence args))
+ (if `(apply #'sequence:substitute-if new test sequence args))
+ (if-not `(apply #'sequence:substitute-if-not new test sequence args)))))
-(defun substitute (new old sequence &key from-end (test #'eql) test-not
+(defun substitute (new old sequence &rest args &key from-end (test #'eql) test-not
(start 0) count end key)
(let* ((length (length sequence))
(end (or end length))
@@ -133,7 +138,7 @@
(subst-dispatch 'normal)))
-(defun substitute-if (new test sequence &key from-end (start 0) end count key)
+(defun substitute-if (new test sequence &rest args &key from-end (start 0) end count key)
(let* ((length (length sequence))
(end (or end length))
(count (real-count count))
@@ -142,7 +147,7 @@
(subst-dispatch 'if)))
-(defun substitute-if-not (new test sequence &key from-end (start 0)
+(defun substitute-if-not (new test sequence &rest args &key from-end (start 0)
end count key)
(let* ((length (length sequence))
(end (or end length))
More information about the armedbear-cvs
mailing list