Changeset 12516


Ignore:
Timestamp:
03/03/10 21:05:41 (11 years ago)
Author:
astalla
Message:

Support for user-extensible sequences, adapted from SBCL.

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  
    120120  public static final BuiltInClass REAL                 = addClass(Symbol.REAL);
    121121  public static final BuiltInClass RESTART              = addClass(Symbol.RESTART);
    122   public static final BuiltInClass SEQUENCE             = addClass(Symbol.SEQUENCE);
    123122  public static final BuiltInClass SIMPLE_ARRAY         = addClass(Symbol.SIMPLE_ARRAY);
    124123  public static final BuiltInClass SIMPLE_BASE_STRING   = addClass(Symbol.SIMPLE_BASE_STRING);
    … …  
    139138    (StructureClass)addClass(Symbol.STRUCTURE_OBJECT,
    140139             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)));
    141144
    142145    /* All the stream classes below are being defined as structure classes

  • trunk/abcl/src/org/armedbear/lisp/Cons.java

    r12431 r12516  
    8888          return T;
    8989      }
    90     else if (typeSpecifier instanceof BuiltInClass)
     90    else if (typeSpecifier instanceof LispClass)
    9191      {
    9292        if (typeSpecifier == BuiltInClass.LIST)

  • trunk/abcl/src/org/armedbear/lisp/Lisp.java

    r12513 r12516  
    8888  public static final Package PACKAGE_PRECOMPILER =
    8989    Packages.createPackage("PRECOMPILER");
     90  public static final Package PACKAGE_SEQUENCE =
     91    Packages.createPackage("SEQUENCE");
    9092
    9193
    … …  
    135137    PACKAGE_PRECOMPILER.usePackage(PACKAGE_EXT);
    136138    PACKAGE_PRECOMPILER.usePackage(PACKAGE_SYS);
     139    PACKAGE_SEQUENCE.usePackage(PACKAGE_CL);
    137140  }
    138141

  • trunk/abcl/src/org/armedbear/lisp/Primitives.java

    r12513 r12516  
    463463    private static final class pf_length extends Primitive {
    464464        pf_length() {
    465             super(Symbol.LENGTH, "sequence");
     465            super("%LENGTH", PACKAGE_SYS, false, "sequence");
    466466        }
    467467
    … …  
    476476    private static final class pf_elt extends Primitive {
    477477        pf_elt() {
    478             super(Symbol.ELT, "sequence index");
     478            super("%ELT", PACKAGE_SYS, false, "sequence index");
    479479        }
    480480
    … …  
    41604160    };
    41614161
    4162     // ### call-count
     4162    // ### hot-count
    41634163    private static final Primitive HOT_COUNT = new pf_hot_count();
    41644164    private static final class pf_hot_count extends Primitive {
    … …  
    41734173    };
    41744174
    4175     // ### set-call-count
     4175    // ### set-hot-count
    41764176    private static final Primitive SET_HOT_COUNT = new pf_set_hot_count();
    41774177    private static final class pf_set_hot_count extends Primitive {
    … …  
    42544254    private static final class pf_subseq extends Primitive {
    42554255        pf_subseq() {
    4256             super(Symbol.SUBSEQ, "sequence start &optional end");
     4256            super(PACKAGE_SYS.intern("%SUBSEQ"), "sequence start &optional end");
    42574257        }
    42584258
    … …  
    44214421    private static final class pf_nreverse extends Primitive {
    44224422        pf_nreverse() {
    4423             super(Symbol.NREVERSE, "sequence");
     4423            super("%NREVERSE", PACKAGE_SYS, false, "sequence");
    44244424        }
    44254425
    … …  
    44764476    private static final class pf_reverse extends Primitive {
    44774477        pf_reverse() {
    4478             super(Symbol.REVERSE, "sequence");
     4478            super("%reverse", PACKAGE_SYS, false, "sequence");
    44794479        }
    44804480

  • trunk/abcl/src/org/armedbear/lisp/autoloads.lisp

    r12395 r12516  
    8484            acons pairlis copy-alist)
    8585          "assoc")
     86(autoload-macro 'sequence::seq-dispatch "extensible-sequences-base")
    8687(autoload '(mapcan mapl maplist mapcon) "map1")
    8788(autoload 'make-sequence)
     89;(autoload 'sequence::fill "extensible-sequences")
    8890(autoload '(copy-seq fill replace))
    8991(autoload '(map map-into))

  • trunk/abcl/src/org/armedbear/lisp/boot.lisp

    r12514 r12516  
    131131  (ext:quit))
    132132
     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
    133149(load-system-file "autoloads")
    134150(load-system-file "early-defuns")
    … …  
    162178(load-system-file "signal")
    163179(load-system-file "list")
     180(load-system-file "require")
     181(load-system-file "extensible-sequences-base")
    164182(load-system-file "sequences")
    165183(load-system-file "error")
    166184(load-system-file "defpackage")
    167185(load-system-file "define-modify-macro")
    168 (load-system-file "require")
    169186(load-system-file "defstruct")
    170187

  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r12481 r12516  
    23942394(defgeneric function-keywords (method))
    23952395
     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))
    23962407
    23972408(provide 'clos)

  • trunk/abcl/src/org/armedbear/lisp/compile-system.lisp

    r12514 r12516  
    103103      (load (do-compile "opcodes.lisp"))
    104104      (load (do-compile "setf.lisp"))
     105      (load (do-compile "extensible-sequences-base.lisp"))
     106      (load (do-compile "require.lisp"))
    105107      (load (do-compile "substitute.lisp"))
    106108      (load (do-compile "clos.lisp"))
    … …  
    174176                           "ensure-directories-exist.lisp"
    175177                           "error.lisp"
     178         "extensible-sequences.lisp"
    176179                           "featurep.lisp"
    177180                           "fdefinition.lisp"
    … …  
    231234                           "remove.lisp"
    232235                           "replace.lisp"
    233                            "require.lisp"
    234236                           "restart.lisp"
    235237                           "revappend.lisp"

  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12415 r12516  
    25742574                    (DENOMINATOR     "DENOMINATOR")
    25752575                    (FIRST           "car")
    2576                     (LENGTH          "LENGTH")
     2576                    (SYS::%LENGTH    "LENGTH")
    25772577                    (NREVERSE        "nreverse")
    25782578                    (NUMERATOR       "NUMERATOR")
    … …  
    85898589      ;; Pass 1.
    85908590      (p1-compiland compiland)
    8591 
    85928591      ;; *all-variables* doesn't contain variables which
    85938592      ;; are in an enclosing lexical environment (variable-environment)
    … …  
    88978896  (install-p2-handler 'go                  'p2-go)
    88988897  (install-p2-handler 'if                  'p2-if)
    8899   (install-p2-handler 'length              'p2-length)
     8898  (install-p2-handler 'sys::%length        'p2-length)
    89008899  (install-p2-handler 'list                'p2-list)
    89018900  (install-p2-handler 'sys::backq-list     'p2-list)

  • trunk/abcl/src/org/armedbear/lisp/concatenate.lisp

    r11391 r12516  
    5252              (incf i)))))))
    5353
     54;;It uses make-sequence: it should already be user-extensible as-is
    5455(defun concatenate (result-type &rest sequences)
    5556  (case result-type

  • trunk/abcl/src/org/armedbear/lisp/copy-seq.lisp

    r11391 r12516  
    3030;;; exception statement from your version.
    3131
     32(require "EXTENSIBLE-SEQUENCES-BASE")
     33
    3234(in-package "SYSTEM")
    3335
    … …  
    5254
    5355(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  
    3232(in-package "COMMON-LISP")
    3333
     34(require "EXTENSIBLE-SEQUENCES-BASE")
     35
    3436;;; From CMUCL.
    3537
    … …  
    5759           (setq count (1+ count)))))))
    5860
    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)
    6062       (start 0) end key)
    6163  (when (and test-p test-not-p)
    … …  
    6870         (lambda (x)
    6971           (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)))))
    7780
    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)
    7982  (let* ((length (length sequence))
    8083   (end (or end length)))
    81     (if (listp sequence)
     84    (sequence::seq-dispatch sequence
    8285        (if from-end
    8386            (list-count-if nil t test sequence)
    … …  
    8588        (if from-end
    8689            (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))))
    8892
    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)
    9094  (let* ((length (length sequence))
    9195   (end (or end length)))
    92     (if (listp sequence)
     96    (sequence::seq-dispatch sequence
    9397        (if from-end
    9498            (list-count-if t t test sequence)
    … …  
    96100        (if from-end
    97101            (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  
    3131
    3232(in-package "SYSTEM")
     33
     34(require "EXTENSIBLE-SEQUENCES-BASE")
    3335
    3436;;; From CMUCL.
    … …  
    8082      (setq jndex (1+ jndex)))))
    8183
    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  
    3131
    3232(in-package "SYSTEM")
     33
     34(require "EXTENSIBLE-SEQUENCES-BASE")
    3335
    3436;;; From CMUCL.
    … …  
    134136        (funcall test item (funcall-key key (car current))))))
    135137
    136 (defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
    137                     end count key)
     138(defun delete (item sequence &rest args &key from-end (test #'eql) test-not
     139         (start 0) end count key)
    138140  (when key
    139141    (setq key (coerce-to-function key)))
    … …  
    141143   (end (or end length))
    142144   (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))))
    150153
    151154(defmacro if-mumble-delete ()
    … …  
    165168    (funcall predicate (funcall-key key (car current)))))
    166169
    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)
    168172  (when key
    169173    (setq key (coerce-to-function key)))
    … …  
    171175   (end (or end length))
    172176   (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))))
    180185
    181186(defmacro if-not-mumble-delete ()
    … …  
    195200    (not (funcall predicate (funcall-key key (car current))))))
    196201
    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)
    198204  (when key
    199205    (setq key (coerce-to-function key)))
    … …  
    201207   (end (or end length))
    202208   (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  
    3232(in-package "SYSTEM")
    3333
     34(require "EXTENSIBLE-SEQUENCES-BASE")
     35
    3436;;; Adapted from CMUCL.
    3537
    … …  
    4951
    5052(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  
    3131
    3232(in-package #:system)
     33
     34(require "EXTENSIBLE-SEQUENCES-BASE")
    3335
    3436;;; From CMUCL.
    … …  
    143145
    144146
    145 (defun position (item sequence &key from-end (test #'eql) test-not (start 0)
    146                       end key)
    147   (if (listp sequence)
    148       (list-position* item sequence from-end test test-not start end key)
    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)))
    151153
    152154(defun list-position* (item sequence from-end test test-not start end key)
    … …  
    168170  `(list-locater-if ,test ,sequence :position))
    169171
    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))))
    177180
    178181(defmacro vector-position-if-not (test sequence)
    … …  
    182185  `(list-locater-if-not ,test ,sequence :position))
    183186
    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))))
    191195
    192196(defmacro vector-find (item sequence)
    … …  
    208212  (vector-find item sequence))
    209213
    210 (defun find (item sequence &key from-end (test #'eql) test-not (start 0)
    211                   end key)
     214(defun find (item sequence &rest args &key from-end (test #'eql) test-not
     215       (start 0) end key)
    212216  (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))))
    216221
    217222(defmacro vector-find-if (test sequence)
    … …  
    221226  `(list-locater-if ,test ,sequence :element))
    222227
    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))))
    229235
    230236(defmacro vector-find-if-not (test sequence)
    … …  
    234240  `(list-locater-if-not ,test ,sequence :element))
    235241
    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  
    4040
    4141(defun make-sequence (type size &key (initial-element nil iesp))
    42   (let (element-type sequence)
     42  (let (element-type sequence class)
    4343    (setf type (normalize-type type))
    4444    (cond ((atom type)
     45     (setf class (if (classp type) type (find-class type nil)))
    4546           (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
    4754           (cond ((memq type '(LIST CONS))
    4855                  (when (zerop size)
    … …  
    6774                        (cond ((memq type '(BIT-VECTOR SIMPLE-BIT-VECTOR)) 'BIT)
    6875                              ((memq type '(VECTOR SIMPLE-VECTOR)) t)
    69                               (t
     76                              ((null class)
    7077                               (error 'simple-type-error
    7178                                      :format-control "~S is not a sequence type."
    7279                                      :format-arguments (list type))))))))
    73           (t
     80    (t
    7481           (let ((name (%car type))
    7582                 (args (%cdr type)))
    … …  
    109116                   (size-mismatch-error type size)))))))
    110117    (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)))))
    114129    sequence))

  • trunk/abcl/src/org/armedbear/lisp/mismatch.lisp

    r11391 r12516  
    3232
    3333(in-package "COMMON-LISP")
     34
     35(require "EXTENSIBLE-SEQUENCES-BASE")
    3436
    3537(export 'mismatch)
    … …  
    7173  (error "both test and test are supplied"))
    7274
    73 (defun mismatch (sequence1 sequence2 &key from-end test test-not
    74                           (key #'identity) start1 start2 end1 end2)
     75(defun mismatch (sequence1 sequence2 &rest args &key from-end test test-not
     76    (key #'identity) start1 start2 end1 end2)
    7577  (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  
    3434(in-package #:system)
    3535
     36(require "EXTENSIBLE-SEQUENCES-BASE")
     37
    3638(defmacro list-reduce (function sequence start end initial-value ivp key)
    3739  (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence))))
    … …  
    5759
    5860
    59 (defun reduce (function sequence &key from-end (start 0)
     61(defun reduce (function sequence &rest args &key from-end (start 0)
    6062                        end (initial-value nil ivp) key)
    6163  (unless end (setq end (length sequence)))
    6264  (if (= end start)
    6365      (if ivp initial-value (funcall function))
    64       (if (listp sequence)
     66      (sequence::seq-dispatch sequence
    6567          (if from-end
    6668              (list-reduce-from-end function sequence start end initial-value ivp key)
    … …  
    8183                    value (funcall function
    8284                                   (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  
    3131
    3232(in-package #:system)
     33
     34(require "EXTENSIBLE-SEQUENCES-BASE")
    3335
    3436;;; Adapted from CMUCL.
    … …  
    98100    (shrink-vector result jndex)))
    99101
    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  
    3333
    3434(require "DELETE") ; MUMBLE-DELETE-FROM-END
     35(require "EXTENSIBLE-SEQUENCES-BASE")
    3536
    3637;;; From CMUCL.
    … …  
    156157    (not (funcall predicate (apply-key key this-element)))))
    157158
    158 (defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
    159                     end count key)
     159(defun remove (item sequence &rest args &key from-end (test #'eql) test-not
     160         (start 0) end count key)
    160161  (let* ((length (length sequence))
    161162   (end (or end length))
    162163   (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))))
    170172
    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)
    172175  (let* ((length (length sequence))
    173176   (end (or end length))
    174177   (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))))
    182186
    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)
    184189  (let* ((length (length sequence))
    185190   (end (or end length))
    186191   (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  
    3434(in-package #:system)
    3535
    36 (eval-when (:compile-toplevel :load-toplevel :execute)
     36(require "EXTENSIBLE-SEQUENCES-BASE")
     37
     38#|(eval-when (:compile-toplevel :load-toplevel :execute)
    3739  (defmacro seq-dispatch (sequence list-form array-form)
    3840    `(if (listp ,sequence)
    3941         ,list-form
    40          ,array-form)))
     42         ,array-form)))|#
    4143
    4244(eval-when (:compile-toplevel :execute)
    … …  
    146148  (mumble-replace-from-mumble))
    147149
    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-sequence
    151                 (seq-dispatch source-sequence
    152                               (list-replace-from-list)
    153                               (list-replace-from-mumble))
    154                 (seq-dispatch source-sequence
    155                               (mumble-replace-from-list)
    156                               (mumble-replace-from-mumble))))
    157 
    158150;;; REPLACE cannot default end arguments to the length of sequence since it
    159151;;; is not an error to supply nil for their values.  We must test for ends
    160152;;; being nil in the body of the function.
    161 (defun replace (target-sequence source-sequence &key
     153(defun replace (target-sequence source-sequence &rest args &key
    162154                                ((:start1 target-start) 0)
    163155                                ((:end1 target-end))
    … …  
    168160  (let ((target-end (or target-end (length target-sequence)))
    169161  (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  
    3131
    3232(in-package "SYSTEM")
     33
     34(require "EXTENSIBLE-SEQUENCES-BASE")
    3335
    3436;; From CMUCL.
    … …  
    111113  ) ; eval-when
    112114
    113 (defun search (sequence1 sequence2 &key from-end (test #'eql) test-not
    114                         (start1 0) end1 (start2 0) end2 key)
     115(defun search (sequence1 sequence2 &rest args &key from-end (test #'eql)
     116         test-not (start1 0) end1 (start2 0) end2 key)
    115117  (let ((end1 (or end1 (length sequence1)))
    116118  (end2 (or end2 (length sequence2))))
    117119    (when key
    118120      (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))))
    122125
    123126(defun simple-search (sequence1 sequence2)

  • trunk/abcl/src/org/armedbear/lisp/sequences.lisp

    r11391 r12516  
    3030;;; exception statement from your version.
    3131
     32;(require "EXTENSIBLE-SEQUENCES-BASE")
     33
    3234(in-package #:system)
    3335
    … …  
    5759
    5860(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  
    223223
    224224(defsetf rest set-cdr)
     225;;Redefined in extensible-sequences-base.lisp
    225226(defsetf elt %set-elt)
    226227(defsetf nth %set-nth)

  • trunk/abcl/src/org/armedbear/lisp/sort.lisp

    r11391 r12516  
    3232(in-package #:system)
    3333
    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)))
    4347
    4448;; Adapted from SBCL.
    … …  
    193197        (quick-sort seq (1+ j) end pred key))))
    194198
    195 ;;; From ECL.
     199;;; From ECL. Should already be user-extensible as it does no type dispatch
     200;;; and uses only user-extensible functions.
    196201(defun merge (result-type sequence1 sequence2 predicate
    197202                          &key key

  • trunk/abcl/src/org/armedbear/lisp/substitute.lisp

    r11391 r12516  
    3030;;; exception statement from your version.
    3131
     32(require "EXTENSIBLE-SEQUENCES-BASE")
    3233
    3334(in-package "COMMON-LISP")
    … …  
    110111
    111112(defmacro subst-dispatch (pred)
    112   `(if (listp sequence)
     113  `(sequence::seq-dispatch sequence
    113114       (if from-end
    114115           (nreverse (list-substitute* ,pred new (reverse sequence)
    … …  
    123124                               (1- start) count key test test-not old)
    124125           (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)))))
    126131
    127132
    128 (defun substitute (new old sequence &key from-end (test #'eql) test-not
     133(defun substitute (new old sequence &rest args &key from-end (test #'eql) test-not
    129134                       (start 0) count end key)
    130135  (let* ((length (length sequence))
    … …  
    134139
    135140
    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)
    137142  (let* ((length (length sequence))
    138143   (end (or end length))
    … …  
    143148
    144149
    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)
    146151                              end count key)
    147152  (let* ((length (length sequence))
Note: See TracChangeset for help on using the changeset viewer.