Changeset 12516
- Timestamp:
- 03/03/10 21:05:41 (11 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 2 added
- 27 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java
r12481 r12516 120 120 public static final BuiltInClass REAL = addClass(Symbol.REAL); 121 121 public static final BuiltInClass RESTART = addClass(Symbol.RESTART); 122 public static final BuiltInClass SEQUENCE = addClass(Symbol.SEQUENCE);123 122 public static final BuiltInClass SIMPLE_ARRAY = addClass(Symbol.SIMPLE_ARRAY); 124 123 public static final BuiltInClass SIMPLE_BASE_STRING = addClass(Symbol.SIMPLE_BASE_STRING); … … 139 138 (StructureClass)addClass(Symbol.STRUCTURE_OBJECT, 140 139 new StructureClass(Symbol.STRUCTURE_OBJECT, list(CLASS_T))); 140 141 public static final SlotClass SEQUENCE = 142 (SlotClass) addClass(Symbol.SEQUENCE, 143 new SlotClass(Symbol.SEQUENCE, list(CLASS_T))); 141 144 142 145 /* All the stream classes below are being defined as structure classes -
trunk/abcl/src/org/armedbear/lisp/Cons.java
r12431 r12516 88 88 return T; 89 89 } 90 else if (typeSpecifier instanceof BuiltInClass)90 else if (typeSpecifier instanceof LispClass) 91 91 { 92 92 if (typeSpecifier == BuiltInClass.LIST) -
trunk/abcl/src/org/armedbear/lisp/Lisp.java
r12513 r12516 88 88 public static final Package PACKAGE_PRECOMPILER = 89 89 Packages.createPackage("PRECOMPILER"); 90 public static final Package PACKAGE_SEQUENCE = 91 Packages.createPackage("SEQUENCE"); 90 92 91 93 … … 135 137 PACKAGE_PRECOMPILER.usePackage(PACKAGE_EXT); 136 138 PACKAGE_PRECOMPILER.usePackage(PACKAGE_SYS); 139 PACKAGE_SEQUENCE.usePackage(PACKAGE_CL); 137 140 } 138 141 -
trunk/abcl/src/org/armedbear/lisp/Primitives.java
r12513 r12516 463 463 private static final class pf_length extends Primitive { 464 464 pf_length() { 465 super( Symbol.LENGTH, "sequence");465 super("%LENGTH", PACKAGE_SYS, false, "sequence"); 466 466 } 467 467 … … 476 476 private static final class pf_elt extends Primitive { 477 477 pf_elt() { 478 super( Symbol.ELT, "sequence index");478 super("%ELT", PACKAGE_SYS, false, "sequence index"); 479 479 } 480 480 … … 4160 4160 }; 4161 4161 4162 // ### call-count4162 // ### hot-count 4163 4163 private static final Primitive HOT_COUNT = new pf_hot_count(); 4164 4164 private static final class pf_hot_count extends Primitive { … … 4173 4173 }; 4174 4174 4175 // ### set- call-count4175 // ### set-hot-count 4176 4176 private static final Primitive SET_HOT_COUNT = new pf_set_hot_count(); 4177 4177 private static final class pf_set_hot_count extends Primitive { … … 4254 4254 private static final class pf_subseq extends Primitive { 4255 4255 pf_subseq() { 4256 super( Symbol.SUBSEQ, "sequence start &optional end");4256 super(PACKAGE_SYS.intern("%SUBSEQ"), "sequence start &optional end"); 4257 4257 } 4258 4258 … … 4421 4421 private static final class pf_nreverse extends Primitive { 4422 4422 pf_nreverse() { 4423 super( Symbol.NREVERSE, "sequence");4423 super("%NREVERSE", PACKAGE_SYS, false, "sequence"); 4424 4424 } 4425 4425 … … 4476 4476 private static final class pf_reverse extends Primitive { 4477 4477 pf_reverse() { 4478 super( Symbol.REVERSE, "sequence");4478 super("%reverse", PACKAGE_SYS, false, "sequence"); 4479 4479 } 4480 4480 -
trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
r12395 r12516 84 84 acons pairlis copy-alist) 85 85 "assoc") 86 (autoload-macro 'sequence::seq-dispatch "extensible-sequences-base") 86 87 (autoload '(mapcan mapl maplist mapcon) "map1") 87 88 (autoload 'make-sequence) 89 ;(autoload 'sequence::fill "extensible-sequences") 88 90 (autoload '(copy-seq fill replace)) 89 91 (autoload '(map map-into)) -
trunk/abcl/src/org/armedbear/lisp/boot.lisp
r12514 r12516 131 131 (ext:quit)) 132 132 133 ;;Redefined in extensible-sequences.lisp 134 (defun length (sequence) 135 (%length sequence)) 136 137 (defun elt (sequence index) 138 (%elt sequence index)) 139 140 (defun subseq (sequence start &optional end) 141 (sys::%subseq sequence start end)) 142 143 (defun reverse (sequence) 144 (sys::%reverse sequence)) 145 146 (defun nreverse (sequence) 147 (sys::%nreverse sequence)) 148 133 149 (load-system-file "autoloads") 134 150 (load-system-file "early-defuns") … … 162 178 (load-system-file "signal") 163 179 (load-system-file "list") 180 (load-system-file "require") 181 (load-system-file "extensible-sequences-base") 164 182 (load-system-file "sequences") 165 183 (load-system-file "error") 166 184 (load-system-file "defpackage") 167 185 (load-system-file "define-modify-macro") 168 (load-system-file "require")169 186 (load-system-file "defstruct") 170 187 -
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r12481 r12516 2394 2394 (defgeneric function-keywords (method)) 2395 2395 2396 (defgeneric class-prototype (class)) 2397 2398 (defmethod class-prototype :before (class) 2399 (unless (class-finalized-p class) 2400 (error "~@<~S is not finalized.~:@>" class))) 2401 2402 (defmethod class-prototype ((class standard-class)) 2403 (allocate-instance class)) 2404 2405 (defmethod class-prototype ((class structure-class)) 2406 (allocate-instance class)) 2396 2407 2397 2408 (provide 'clos) -
trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
r12514 r12516 103 103 (load (do-compile "opcodes.lisp")) 104 104 (load (do-compile "setf.lisp")) 105 (load (do-compile "extensible-sequences-base.lisp")) 106 (load (do-compile "require.lisp")) 105 107 (load (do-compile "substitute.lisp")) 106 108 (load (do-compile "clos.lisp")) … … 174 176 "ensure-directories-exist.lisp" 175 177 "error.lisp" 178 "extensible-sequences.lisp" 176 179 "featurep.lisp" 177 180 "fdefinition.lisp" … … 231 234 "remove.lisp" 232 235 "replace.lisp" 233 "require.lisp"234 236 "restart.lisp" 235 237 "revappend.lisp" -
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12415 r12516 2574 2574 (DENOMINATOR "DENOMINATOR") 2575 2575 (FIRST "car") 2576 ( LENGTH"LENGTH")2576 (SYS::%LENGTH "LENGTH") 2577 2577 (NREVERSE "nreverse") 2578 2578 (NUMERATOR "NUMERATOR") … … 8589 8589 ;; Pass 1. 8590 8590 (p1-compiland compiland) 8591 8592 8591 ;; *all-variables* doesn't contain variables which 8593 8592 ;; are in an enclosing lexical environment (variable-environment) … … 8897 8896 (install-p2-handler 'go 'p2-go) 8898 8897 (install-p2-handler 'if 'p2-if) 8899 (install-p2-handler ' length'p2-length)8898 (install-p2-handler 'sys::%length 'p2-length) 8900 8899 (install-p2-handler 'list 'p2-list) 8901 8900 (install-p2-handler 'sys::backq-list 'p2-list) -
trunk/abcl/src/org/armedbear/lisp/concatenate.lisp
r11391 r12516 52 52 (incf i))))))) 53 53 54 ;;It uses make-sequence: it should already be user-extensible as-is 54 55 (defun concatenate (result-type &rest sequences) 55 56 (case result-type -
trunk/abcl/src/org/armedbear/lisp/copy-seq.lisp
r11391 r12516 30 30 ;;; exception statement from your version. 31 31 32 (require "EXTENSIBLE-SEQUENCES-BASE") 33 32 34 (in-package "SYSTEM") 33 35 … … 52 54 53 55 (defun copy-seq (sequence) 54 (if (listp sequence) 55 (list-copy-seq sequence) 56 (vector-copy-seq sequence (type-of sequence)))) 56 "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ." 57 (sequence::seq-dispatch sequence 58 (list-copy-seq sequence) 59 (vector-copy-seq sequence (type-of sequence)) 60 (sequence:copy-seq sequence))) -
trunk/abcl/src/org/armedbear/lisp/count.lisp
r11391 r12516 32 32 (in-package "COMMON-LISP") 33 33 34 (require "EXTENSIBLE-SEQUENCES-BASE") 35 34 36 ;;; From CMUCL. 35 37 … … 57 59 (setq count (1+ count))))))) 58 60 59 (defun count (item sequence & key from-end (test #'eql test-p) (test-not nil test-not-p)61 (defun count (item sequence &rest args &key from-end (test #'eql test-p) (test-not nil test-not-p) 60 62 (start 0) end key) 61 63 (when (and test-p test-not-p) … … 68 70 (lambda (x) 69 71 (funcall test item x))))) 70 (if (listp sequence) 71 (if from-end 72 (list-count-if nil t %test sequence) 73 (list-count-if nil nil %test sequence)) 74 (if from-end 75 (vector-count-if nil t %test sequence) 76 (vector-count-if nil nil %test sequence)))))) 72 (sequence::seq-dispatch sequence 73 (if from-end 74 (list-count-if nil t %test sequence) 75 (list-count-if nil nil %test sequence)) 76 (if from-end 77 (vector-count-if nil t %test sequence) 78 (vector-count-if nil nil %test sequence)) 79 (apply #'sequence:count item sequence args))))) 77 80 78 (defun count-if (test sequence & key from-end (start 0) end key)81 (defun count-if (test sequence &rest args &key from-end (start 0) end key) 79 82 (let* ((length (length sequence)) 80 83 (end (or end length))) 81 ( if (listp sequence)84 (sequence::seq-dispatch sequence 82 85 (if from-end 83 86 (list-count-if nil t test sequence) … … 85 88 (if from-end 86 89 (vector-count-if nil t test sequence) 87 (vector-count-if nil nil test sequence))))) 90 (vector-count-if nil nil test sequence)) 91 (apply #'sequence:count-if test sequence args)))) 88 92 89 (defun count-if-not (test sequence & key from-end (start 0) end key)93 (defun count-if-not (test sequence &rest args &key from-end (start 0) end key) 90 94 (let* ((length (length sequence)) 91 95 (end (or end length))) 92 ( if (listp sequence)96 (sequence::seq-dispatch sequence 93 97 (if from-end 94 98 (list-count-if t t test sequence) … … 96 100 (if from-end 97 101 (vector-count-if t t test sequence) 98 (vector-count-if t nil test sequence))))) 102 (vector-count-if t nil test sequence)) 103 (apply #'sequence:count-if-not test sequence args)))) -
trunk/abcl/src/org/armedbear/lisp/delete-duplicates.lisp
r11391 r12516 31 31 32 32 (in-package "SYSTEM") 33 34 (require "EXTENSIBLE-SEQUENCES-BASE") 33 35 34 36 ;;; From CMUCL. … … 80 82 (setq jndex (1+ jndex))))) 81 83 82 83 (defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end 84 end key)85 (if (listp sequence)86 (if sequence 87 (list-delete-duplicates* sequence test test-not key from-end start end))88 (vector-delete-duplicates* sequence test test-not key from-end start end)))84 (defun delete-duplicates (sequence &rest args &key (test #'eql) test-not 85 (start 0) from-end end key) 86 (sequence::seq-dispatch sequence 87 (if sequence 88 (list-delete-duplicates* sequence test test-not key from-end start end)) 89 (vector-delete-duplicates* sequence test test-not key from-end start end) 90 (apply #'sequence:delete-duplicates sequence args))) -
trunk/abcl/src/org/armedbear/lisp/delete.lisp
r11391 r12516 31 31 32 32 (in-package "SYSTEM") 33 34 (require "EXTENSIBLE-SEQUENCES-BASE") 33 35 34 36 ;;; From CMUCL. … … 134 136 (funcall test item (funcall-key key (car current)))))) 135 137 136 (defun delete (item sequence & key from-end (test #'eql) test-not (start 0)137 138 (defun delete (item sequence &rest args &key from-end (test #'eql) test-not 139 (start 0) end count key) 138 140 (when key 139 141 (setq key (coerce-to-function key))) … … 141 143 (end (or end length)) 142 144 (count (real-count count))) 143 (if (listp sequence) 144 (if from-end 145 (normal-list-delete-from-end) 146 (normal-list-delete)) 147 (if from-end 148 (normal-mumble-delete-from-end) 149 (normal-mumble-delete))))) 145 (sequence::seq-dispatch sequence 146 (if from-end 147 (normal-list-delete-from-end) 148 (normal-list-delete)) 149 (if from-end 150 (normal-mumble-delete-from-end) 151 (normal-mumble-delete)) 152 (apply #'sequence:delete item sequence args)))) 150 153 151 154 (defmacro if-mumble-delete () … … 165 168 (funcall predicate (funcall-key key (car current))))) 166 169 167 (defun delete-if (predicate sequence &key from-end (start 0) key end count) 170 (defun delete-if (predicate sequence &rest args &key from-end (start 0) 171 key end count) 168 172 (when key 169 173 (setq key (coerce-to-function key))) … … 171 175 (end (or end length)) 172 176 (count (real-count count))) 173 (if (listp sequence) 174 (if from-end 175 (if-list-delete-from-end) 176 (if-list-delete)) 177 (if from-end 178 (if-mumble-delete-from-end) 179 (if-mumble-delete))))) 177 (sequence::seq-dispatch sequence 178 (if from-end 179 (if-list-delete-from-end) 180 (if-list-delete)) 181 (if from-end 182 (if-mumble-delete-from-end) 183 (if-mumble-delete)) 184 (apply #'sequence:delete-if predicate sequence args)))) 180 185 181 186 (defmacro if-not-mumble-delete () … … 195 200 (not (funcall predicate (funcall-key key (car current)))))) 196 201 197 (defun delete-if-not (predicate sequence &key from-end (start 0) end key count) 202 (defun delete-if-not (predicate sequence &rest args &key from-end (start 0) 203 end key count) 198 204 (when key 199 205 (setq key (coerce-to-function key))) … … 201 207 (end (or end length)) 202 208 (count (real-count count))) 203 (if (listp sequence) 204 (if from-end 205 (if-not-list-delete-from-end) 206 (if-not-list-delete)) 207 (if from-end 208 (if-not-mumble-delete-from-end) 209 (if-not-mumble-delete))))) 209 (sequence::seq-dispatch sequence 210 (if from-end 211 (if-not-list-delete-from-end) 212 (if-not-list-delete)) 213 (if from-end 214 (if-not-mumble-delete-from-end) 215 (if-not-mumble-delete)) 216 (apply #'sequence:delete-if-not predicate sequence args)))) -
trunk/abcl/src/org/armedbear/lisp/fill.lisp
r11391 r12516 32 32 (in-package "SYSTEM") 33 33 34 (require "EXTENSIBLE-SEQUENCES-BASE") 35 34 36 ;;; Adapted from CMUCL. 35 37 … … 49 51 50 52 (defun fill (sequence item &key (start 0) end) 51 (cond ((listp sequence) 52 (list-fill sequence item start end)) 53 ((and (stringp sequence) 54 (zerop start) 55 (null end)) 56 (simple-string-fill sequence item)) 57 (t 58 (vector-fill sequence item start end)))) 53 "Replace the specified elements of SEQUENCE with ITEM." 54 (sequence::seq-dispatch sequence 55 (list-fill sequence item start end) 56 (cond ((and (stringp sequence) 57 (zerop start) 58 (null end)) 59 (simple-string-fill sequence item)) 60 (t 61 (vector-fill sequence item start end))) 62 (sequence:fill sequence item 63 :start start 64 :end (sequence::%check-generic-sequence-bounds 65 sequence start end)))) -
trunk/abcl/src/org/armedbear/lisp/find.lisp
r11391 r12516 31 31 32 32 (in-package #:system) 33 34 (require "EXTENSIBLE-SEQUENCES-BASE") 33 35 34 36 ;;; From CMUCL. … … 143 145 144 146 145 (defun position (item sequence & key from-end (test #'eql) test-not (start 0)146 147 ( if (listp sequence)148 149 (vector-position* item sequence from-end test test-not start end key)))150 147 (defun position (item sequence &rest args &key from-end (test #'eql) test-not 148 (start 0) end key) 149 (sequence::seq-dispatch sequence 150 (list-position* item sequence from-end test test-not start end key) 151 (vector-position* item sequence from-end test test-not start end key) 152 (apply #'sequence:position item sequence args))) 151 153 152 154 (defun list-position* (item sequence from-end test test-not start end key) … … 168 170 `(list-locater-if ,test ,sequence :position)) 169 171 170 (defun position-if (test sequence &key from-end (start 0) key end) 171 (declare (type fixnum start)) 172 (let ((end (or end (length sequence)))) 173 (declare (type fixnum end)) 174 (if (listp sequence) 175 (list-position-if test sequence) 176 (vector-position-if test sequence)))) 172 (defun position-if (test sequence &rest args &key from-end (start 0) key end) 173 (declare (type fixnum start)) 174 (let ((end (or end (length sequence)))) 175 (declare (type fixnum end)) 176 (sequence::seq-dispatch sequence 177 (list-position-if test sequence) 178 (vector-position-if test sequence) 179 (apply #'sequence:position-if test sequence args)))) 177 180 178 181 (defmacro vector-position-if-not (test sequence) … … 182 185 `(list-locater-if-not ,test ,sequence :position)) 183 186 184 (defun position-if-not (test sequence &key from-end (start 0) key end) 185 (declare (type fixnum start)) 186 (let ((end (or end (length sequence)))) 187 (declare (type fixnum end)) 188 (if (listp sequence) 189 (list-position-if-not test sequence) 190 (vector-position-if-not test sequence)))) 187 (defun position-if-not (test sequence &rest args &key from-end (start 0) key end) 188 (declare (type fixnum start)) 189 (let ((end (or end (length sequence)))) 190 (declare (type fixnum end)) 191 (sequence::seq-dispatch sequence 192 (list-position-if-not test sequence) 193 (vector-position-if-not test sequence) 194 (apply #'sequence:position-if-not test sequence args)))) 191 195 192 196 (defmacro vector-find (item sequence) … … 208 212 (vector-find item sequence)) 209 213 210 (defun find (item sequence & key from-end (test #'eql) test-not (start 0)211 214 (defun find (item sequence &rest args &key from-end (test #'eql) test-not 215 (start 0) end key) 212 216 (let ((end (check-sequence-bounds sequence start end))) 213 (if (listp sequence) 214 (list-find* item sequence from-end test test-not start end key) 215 (vector-find* item sequence from-end test test-not start end key)))) 217 (sequence::seq-dispatch sequence 218 (list-find* item sequence from-end test test-not start end key) 219 (vector-find* item sequence from-end test test-not start end key) 220 (apply #'sequence:find item sequence args)))) 216 221 217 222 (defmacro vector-find-if (test sequence) … … 221 226 `(list-locater-if ,test ,sequence :element)) 222 227 223 (defun find-if (test sequence &key from-end (start 0) end key) 224 (let ((end (or end (length sequence)))) 225 (declare (type fixnum end)) 226 (if (listp sequence) 227 (list-find-if test sequence) 228 (vector-find-if test sequence)))) 228 (defun find-if (test sequence &rest args &key from-end (start 0) end key) 229 (let ((end (or end (length sequence)))) 230 (declare (type fixnum end)) 231 (sequence::seq-dispatch sequence 232 (list-find-if test sequence) 233 (vector-find-if test sequence) 234 (apply #'sequence:find-if test sequence args)))) 229 235 230 236 (defmacro vector-find-if-not (test sequence) … … 234 240 `(list-locater-if-not ,test ,sequence :element)) 235 241 236 (defun find-if-not (test sequence &key from-end (start 0) end key) 237 (let ((end (or end (length sequence)))) 238 (declare (type fixnum end)) 239 (if (listp sequence) 240 (list-find-if-not test sequence) 241 (vector-find-if-not test sequence)))) 242 (defun find-if-not (test sequence &rest args &key from-end (start 0) end key) 243 (let ((end (or end (length sequence)))) 244 (declare (type fixnum end)) 245 (sequence::seq-dispatch sequence 246 (list-find-if-not test sequence) 247 (vector-find-if-not test sequence) 248 (apply #'sequence:find-if-not test sequence args)))) -
trunk/abcl/src/org/armedbear/lisp/make-sequence.lisp
r11391 r12516 40 40 41 41 (defun make-sequence (type size &key (initial-element nil iesp)) 42 (let (element-type sequence )42 (let (element-type sequence class) 43 43 (setf type (normalize-type type)) 44 44 (cond ((atom type) 45 (setf class (if (classp type) type (find-class type nil))) 45 46 (when (classp type) 46 (setf type (%class-name type))) 47 (let ((class-name (%class-name type))) 48 (when (member class-name '(LIST CONS STRING SIMPLE-STRING 49 BASE-STRING SIMPLE-BASE-STRING NULL 50 BIT-VECTOR SIMPLE-BIT-VECTOR VECTOR 51 SIMPLE-VECTOR)) 52 (setf type class-name)))) 53 ;;Else we suppose it's a user-defined sequence and move on 47 54 (cond ((memq type '(LIST CONS)) 48 55 (when (zerop size) … … 67 74 (cond ((memq type '(BIT-VECTOR SIMPLE-BIT-VECTOR)) 'BIT) 68 75 ((memq type '(VECTOR SIMPLE-VECTOR)) t) 69 ( t76 ((null class) 70 77 (error 'simple-type-error 71 78 :format-control "~S is not a sequence type." 72 79 :format-arguments (list type)))))))) 73 80 (t 74 81 (let ((name (%car type)) 75 82 (args (%cdr type))) … … 109 116 (size-mismatch-error type size))))))) 110 117 (setq sequence 111 (if iesp 112 (make-array size :element-type element-type :initial-element initial-element) 113 (make-array size :element-type element-type))) 118 (cond ((or (not (atom type)) (subtypep type 'array)) 119 (if iesp 120 (make-array size :element-type element-type :initial-element initial-element) 121 (make-array size :element-type element-type))) 122 ((and class (subtypep type 'sequence)) 123 (if iesp 124 (sequence:make-sequence-like (mop::class-prototype class) size :initial-element initial-element) 125 (sequence:make-sequence-like (mop::class-prototype class) size))) 126 (t (error 'simple-type-error 127 :format-control "~S is not a sequence type." 128 :format-arguments (list type))))) 114 129 sequence)) -
trunk/abcl/src/org/armedbear/lisp/mismatch.lisp
r11391 r12516 32 32 33 33 (in-package "COMMON-LISP") 34 35 (require "EXTENSIBLE-SEQUENCES-BASE") 34 36 35 37 (export 'mismatch) … … 71 73 (error "both test and test are supplied")) 72 74 73 (defun mismatch (sequence1 sequence2 & key from-end test test-not74 75 (defun mismatch (sequence1 sequence2 &rest args &key from-end test test-not 76 (key #'identity) start1 start2 end1 end2) 75 77 (and test test-not (test-error)) 76 (with-start-end 77 start1 end1 sequence1 78 (with-start-end 79 start2 end2 sequence2 80 (if (not from-end) 81 (do ((i1 start1 (1+ i1)) 82 (i2 start2 (1+ i2))) 83 ((or (>= i1 end1) (>= i2 end2)) 84 (if (and (>= i1 end1) (>= i2 end2)) nil i1)) 85 (unless (call-test test test-not 86 (funcall key (elt sequence1 i1)) 87 (funcall key (elt sequence2 i2))) 88 (return i1))) 89 (do ((i1 (1- end1) (1- i1)) 90 (i2 (1- end2) (1- i2))) 91 ((or (< i1 start1) (< i2 start2)) 92 (if (and (< i1 start1) (< i2 start2)) nil (1+ i1))) 93 (unless (call-test test test-not 94 (funcall key (elt sequence1 i1)) 95 (funcall key (elt sequence2 i2))) 96 (return (1+ i1)))))))) 78 (if (and (or (listp sequence1) (arrayp sequence1)) 79 (or (listp sequence2) (arrayp sequence2))) 80 (with-start-end start1 end1 sequence1 81 (with-start-end start2 end2 sequence2 82 (if (not from-end) 83 (do ((i1 start1 (1+ i1)) 84 (i2 start2 (1+ i2))) 85 ((or (>= i1 end1) (>= i2 end2)) 86 (if (and (>= i1 end1) (>= i2 end2)) nil i1)) 87 (unless (call-test test test-not 88 (funcall key (elt sequence1 i1)) 89 (funcall key (elt sequence2 i2))) 90 (return i1))) 91 (do ((i1 (1- end1) (1- i1)) 92 (i2 (1- end2) (1- i2))) 93 ((or (< i1 start1) (< i2 start2)) 94 (if (and (< i1 start1) (< i2 start2)) nil (1+ i1))) 95 (unless (call-test test test-not 96 (funcall key (elt sequence1 i1)) 97 (funcall key (elt sequence2 i2))) 98 (return (1+ i1))))))) 99 (apply #'sequence:mismatch sequence1 sequence2 args))) -
trunk/abcl/src/org/armedbear/lisp/reduce.lisp
r11391 r12516 34 34 (in-package #:system) 35 35 36 (require "EXTENSIBLE-SEQUENCES-BASE") 37 36 38 (defmacro list-reduce (function sequence start end initial-value ivp key) 37 39 (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence)))) … … 57 59 58 60 59 (defun reduce (function sequence & key from-end (start 0)61 (defun reduce (function sequence &rest args &key from-end (start 0) 60 62 end (initial-value nil ivp) key) 61 63 (unless end (setq end (length sequence))) 62 64 (if (= end start) 63 65 (if ivp initial-value (funcall function)) 64 ( if (listp sequence)66 (sequence::seq-dispatch sequence 65 67 (if from-end 66 68 (list-reduce-from-end function sequence start end initial-value ivp key) … … 81 83 value (funcall function 82 84 (if from-end element value) 83 (if from-end value element)))))))) 85 (if from-end value element))))) 86 (apply #'sequence:reduce function sequence args)))) -
trunk/abcl/src/org/armedbear/lisp/remove-duplicates.lisp
r11391 r12516 31 31 32 32 (in-package #:system) 33 34 (require "EXTENSIBLE-SEQUENCES-BASE") 33 35 34 36 ;;; Adapted from CMUCL. … … 98 100 (shrink-vector result jndex))) 99 101 100 (defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) from-end 101 end key) 102 (if (listp sequence) 103 (when sequence 104 (if (and (eq test #'eql) 105 (null test-not) 106 (eql start 0) 107 (null from-end) 108 (null end) 109 (null key)) 110 (simple-list-remove-duplicates sequence) 111 (list-remove-duplicates sequence test test-not start end key from-end))) 112 (vector-remove-duplicates sequence test test-not start end key from-end))) 102 (defun remove-duplicates (sequence &rest args &key (test #'eql) test-not 103 (start 0) from-end end key) 104 (sequence::seq-dispatch sequence 105 (when sequence 106 (if (and (eq test #'eql) 107 (null test-not) 108 (eql start 0) 109 (null from-end) 110 (null end) 111 (null key)) 112 (simple-list-remove-duplicates sequence) 113 (list-remove-duplicates sequence test test-not start end key from-end))) 114 (vector-remove-duplicates sequence test test-not start end key from-end) 115 (apply #'sequence:remove-duplicates sequence args))) -
trunk/abcl/src/org/armedbear/lisp/remove.lisp
r12217 r12516 33 33 34 34 (require "DELETE") ; MUMBLE-DELETE-FROM-END 35 (require "EXTENSIBLE-SEQUENCES-BASE") 35 36 36 37 ;;; From CMUCL. … … 156 157 (not (funcall predicate (apply-key key this-element))))) 157 158 158 (defun remove (item sequence & key from-end (test #'eql) test-not (start 0)159 159 (defun remove (item sequence &rest args &key from-end (test #'eql) test-not 160 (start 0) end count key) 160 161 (let* ((length (length sequence)) 161 162 (end (or end length)) 162 163 (count (real-count count))) 163 (if (listp sequence) 164 (if from-end 165 (normal-list-remove-from-end) 166 (normal-list-remove)) 167 (if from-end 168 (normal-mumble-remove-from-end) 169 (normal-mumble-remove))))) 164 (sequence::seq-dispatch sequence 165 (if from-end 166 (normal-list-remove-from-end) 167 (normal-list-remove)) 168 (if from-end 169 (normal-mumble-remove-from-end) 170 (normal-mumble-remove)) 171 (apply #'sequence:remove item sequence args)))) 170 172 171 (defun remove-if (predicate sequence &key from-end (start 0) end count key) 173 (defun remove-if (predicate sequence &rest args &key from-end (start 0) 174 end count key) 172 175 (let* ((length (length sequence)) 173 176 (end (or end length)) 174 177 (count (real-count count))) 175 (if (listp sequence) 176 (if from-end 177 (if-list-remove-from-end) 178 (if-list-remove)) 179 (if from-end 180 (if-mumble-remove-from-end) 181 (if-mumble-remove))))) 178 (sequence::seq-dispatch sequence 179 (if from-end 180 (if-list-remove-from-end) 181 (if-list-remove)) 182 (if from-end 183 (if-mumble-remove-from-end) 184 (if-mumble-remove)) 185 (apply #'sequence:remove-if predicate sequence args)))) 182 186 183 (defun remove-if-not (predicate sequence &key from-end (start 0) end count key) 187 (defun remove-if-not (predicate sequence &rest args &key from-end (start 0) 188 end count key) 184 189 (let* ((length (length sequence)) 185 190 (end (or end length)) 186 191 (count (real-count count))) 187 (if (listp sequence) 188 (if from-end 189 (if-not-list-remove-from-end) 190 (if-not-list-remove)) 191 (if from-end 192 (if-not-mumble-remove-from-end) 193 (if-not-mumble-remove))))) 192 (sequence::seq-dispatch sequence 193 (if from-end 194 (if-not-list-remove-from-end) 195 (if-not-list-remove)) 196 (if from-end 197 (if-not-mumble-remove-from-end) 198 (if-not-mumble-remove)) 199 (apply #'sequence:remove-if-not predicate sequence args)))) -
trunk/abcl/src/org/armedbear/lisp/replace.lisp
r11391 r12516 34 34 (in-package #:system) 35 35 36 (eval-when (:compile-toplevel :load-toplevel :execute) 36 (require "EXTENSIBLE-SEQUENCES-BASE") 37 38 #|(eval-when (:compile-toplevel :load-toplevel :execute) 37 39 (defmacro seq-dispatch (sequence list-form array-form) 38 40 `(if (listp ,sequence) 39 41 ,list-form 40 ,array-form))) 42 ,array-form)))|# 41 43 42 44 (eval-when (:compile-toplevel :execute) … … 146 148 (mumble-replace-from-mumble)) 147 149 148 (defun %replace (target-sequence source-sequence target-start target-end source-start source-end)149 (declare (type (integer 0 #.most-positive-fixnum) target-start target-end source-start source-end))150 (seq-dispatch target-sequence151 (seq-dispatch source-sequence152 (list-replace-from-list)153 (list-replace-from-mumble))154 (seq-dispatch source-sequence155 (mumble-replace-from-list)156 (mumble-replace-from-mumble))))157 158 150 ;;; REPLACE cannot default end arguments to the length of sequence since it 159 151 ;;; is not an error to supply nil for their values. We must test for ends 160 152 ;;; being nil in the body of the function. 161 (defun replace (target-sequence source-sequence & key153 (defun replace (target-sequence source-sequence &rest args &key 162 154 ((:start1 target-start) 0) 163 155 ((:end1 target-end)) … … 168 160 (let ((target-end (or target-end (length target-sequence))) 169 161 (source-end (or source-end (length source-sequence)))) 170 (%replace target-sequence source-sequence target-start target-end source-start source-end))) 162 (declare (type (integer 0 #.most-positive-fixnum) target-start target-end source-start source-end)) 163 (sequence::seq-dispatch target-sequence 164 (sequence::seq-dispatch source-sequence 165 (list-replace-from-list) 166 (list-replace-from-mumble) 167 (apply #'sequence:replace target-sequence source-sequence args)) 168 (sequence::seq-dispatch source-sequence 169 (mumble-replace-from-list) 170 (mumble-replace-from-mumble) 171 (apply #'sequence:replace target-sequence source-sequence args)) 172 (apply #'sequence:replace target-sequence source-sequence args)))) -
trunk/abcl/src/org/armedbear/lisp/search.lisp
r11391 r12516 31 31 32 32 (in-package "SYSTEM") 33 34 (require "EXTENSIBLE-SEQUENCES-BASE") 33 35 34 36 ;; From CMUCL. … … 111 113 ) ; eval-when 112 114 113 (defun search (sequence1 sequence2 & key from-end (test #'eql) test-not114 115 (defun search (sequence1 sequence2 &rest args &key from-end (test #'eql) 116 test-not (start1 0) end1 (start2 0) end2 key) 115 117 (let ((end1 (or end1 (length sequence1))) 116 118 (end2 (or end2 (length sequence2)))) 117 119 (when key 118 120 (setq key (coerce-to-function key))) 119 (if (listp sequence2) 120 (list-search sequence2 sequence1) 121 (vector-search sequence2 sequence1)))) 121 (sequence::seq-dispatch sequence2 122 (list-search sequence2 sequence1) 123 (vector-search sequence2 sequence1) 124 (apply #'sequence:search sequence1 sequence2 args)))) 122 125 123 126 (defun simple-search (sequence1 sequence2) -
trunk/abcl/src/org/armedbear/lisp/sequences.lisp
r11391 r12516 30 30 ;;; exception statement from your version. 31 31 32 ;(require "EXTENSIBLE-SEQUENCES-BASE") 33 32 34 (in-package #:system) 33 35 … … 57 59 58 60 (defmacro make-sequence-like (sequence length) 59 `(make-sequence-of-type (type-of ,sequence) ,length)) 61 "Return a sequence of the same type as SEQUENCE and the given LENGTH." 62 ;;Can't use gensyms: stack overflow in boot.lisp 63 `(let ((msl-seq-tmp-var ,sequence) (msl-len-tmp-var ,length)) 64 (sequence::seq-dispatch msl-seq-tmp-var 65 (make-sequence-of-type (type-of msl-seq-tmp-var) msl-len-tmp-var) 66 (make-sequence-of-type (type-of msl-seq-tmp-var) msl-len-tmp-var) 67 (sequence::make-sequence-like msl-seq-tmp-var msl-len-tmp-var)))) -
trunk/abcl/src/org/armedbear/lisp/setf.lisp
r12325 r12516 223 223 224 224 (defsetf rest set-cdr) 225 ;;Redefined in extensible-sequences-base.lisp 225 226 (defsetf elt %set-elt) 226 227 (defsetf nth %set-nth) -
trunk/abcl/src/org/armedbear/lisp/sort.lisp
r11391 r12516 32 32 (in-package #:system) 33 33 34 (defun sort (sequence predicate &key key) 35 (if (listp sequence) 36 (sort-list sequence predicate key) 37 (quick-sort sequence 0 (length sequence) predicate key))) 38 39 (defun stable-sort (sequence predicate &key key) 40 (if (listp sequence) 41 (sort-list sequence predicate key) 42 (quick-sort sequence 0 (length sequence) predicate key))) 34 (require "EXTENSIBLE-SEQUENCES-BASE") 35 36 (defun sort (sequence predicate &rest args &key key) 37 (sequence::seq-dispatch sequence 38 (sort-list sequence predicate key) 39 (quick-sort sequence 0 (length sequence) predicate key) 40 (apply #'sequence:sort sequence predicate args))) 41 42 (defun stable-sort (sequence predicate &rest args &key key) 43 (sequence::seq-dispatch sequence 44 (sort-list sequence predicate key) 45 (quick-sort sequence 0 (length sequence) predicate key) 46 (apply #'sequence:stable-sort sequence predicate args))) 43 47 44 48 ;; Adapted from SBCL. … … 193 197 (quick-sort seq (1+ j) end pred key)))) 194 198 195 ;;; From ECL. 199 ;;; From ECL. Should already be user-extensible as it does no type dispatch 200 ;;; and uses only user-extensible functions. 196 201 (defun merge (result-type sequence1 sequence2 predicate 197 202 &key key -
trunk/abcl/src/org/armedbear/lisp/substitute.lisp
r11391 r12516 30 30 ;;; exception statement from your version. 31 31 32 (require "EXTENSIBLE-SEQUENCES-BASE") 32 33 33 34 (in-package "COMMON-LISP") … … 110 111 111 112 (defmacro subst-dispatch (pred) 112 `( if (listp sequence)113 `(sequence::seq-dispatch sequence 113 114 (if from-end 114 115 (nreverse (list-substitute* ,pred new (reverse sequence) … … 123 124 (1- start) count key test test-not old) 124 125 (vector-substitute* ,pred new sequence 1 0 length length 125 start end count key test test-not old)))) 126 start end count key test test-not old)) 127 ,(ecase (cadr pred) ;;pred is (quote <foo>) 128 (normal `(apply #'sequence:substitute new old sequence args)) 129 (if `(apply #'sequence:substitute-if new test sequence args)) 130 (if-not `(apply #'sequence:substitute-if-not new test sequence args))))) 126 131 127 132 128 (defun substitute (new old sequence & key from-end (test #'eql) test-not133 (defun substitute (new old sequence &rest args &key from-end (test #'eql) test-not 129 134 (start 0) count end key) 130 135 (let* ((length (length sequence)) … … 134 139 135 140 136 (defun substitute-if (new test sequence & key from-end (start 0) end count key)141 (defun substitute-if (new test sequence &rest args &key from-end (start 0) end count key) 137 142 (let* ((length (length sequence)) 138 143 (end (or end length)) … … 143 148 144 149 145 (defun substitute-if-not (new test sequence & key from-end (start 0)150 (defun substitute-if-not (new test sequence &rest args &key from-end (start 0) 146 151 end count key) 147 152 (let* ((length (length sequence))
Note: See TracChangeset
for help on using the changeset viewer.