source: trunk/abcl/src/org/armedbear/lisp/make-sequence.lisp @ 14207

Last change on this file since 14207 was 12516, checked in by astalla, 11 years ago

Support for user-extensible sequences, adapted from SBCL.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.2 KB
Line 
1;;; make-sequence.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: make-sequence.lisp 12516 2010-03-03 21:05:41Z astalla $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:system)
33
34;;; Adapted from ECL.
35
36(defun size-mismatch-error (type size)
37  (error 'simple-type-error
38         :format-control "The requested length (~D) does not match the specified type ~A."
39         :format-arguments (list size type)))
40
41(defun make-sequence (type size &key (initial-element nil iesp))
42  (let (element-type sequence class)
43    (setf type (normalize-type type))
44    (cond ((atom type)
45     (setf class (if (classp type) type (find-class type nil)))
46           (when (classp 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
54           (cond ((memq type '(LIST CONS))
55                  (when (zerop size)
56                    (if (eq type 'CONS)
57                        (size-mismatch-error type size)
58                        (return-from make-sequence nil)))
59                  (return-from make-sequence
60                               (if iesp
61                                   (make-list size :initial-element initial-element)
62                                   (make-list size))))
63                 ((memq type '(STRING SIMPLE-STRING BASE-STRING SIMPLE-BASE-STRING))
64                  (return-from make-sequence
65                               (if iesp
66                                   (make-string size :initial-element initial-element)
67                                   (make-string size))))
68                 ((eq type 'NULL)
69                  (if (zerop size)
70                      (return-from make-sequence nil)
71                      (size-mismatch-error type size)))
72                 (t
73                  (setq element-type
74                        (cond ((memq type '(BIT-VECTOR SIMPLE-BIT-VECTOR)) 'BIT)
75                              ((memq type '(VECTOR SIMPLE-VECTOR)) t)
76                              ((null class)
77                               (error 'simple-type-error
78                                      :format-control "~S is not a sequence type."
79                                      :format-arguments (list type))))))))
80    (t
81           (let ((name (%car type))
82                 (args (%cdr type)))
83             (when (eq name 'LIST)
84               (return-from make-sequence
85                            (if iesp
86                                (make-list size :initial-element initial-element)
87                                (make-list size))))
88             (when (eq name 'CONS)
89               (unless (plusp size)
90                 (size-mismatch-error name size))
91               (return-from make-sequence
92                            (if iesp
93                                (make-list size :initial-element initial-element)
94                                (make-list size))))
95             (unless (memq name '(ARRAY SIMPLE-ARRAY VECTOR SIMPLE-VECTOR
96                                  BIT-VECTOR SIMPLE-BIT-VECTOR STRING SIMPLE-STRING
97                                  BASE-STRING SIMPLE-BASE-STRING))
98               (error 'simple-type-error
99                      :format-control "~S is not a sequence type."
100                      :format-arguments (list type)))
101             (let ((len nil))
102               (cond ((memq name '(STRING SIMPLE-STRING BASE-STRING SIMPLE-BASE-STRING))
103                      (setf element-type 'character
104                            len (car args)))
105                     ((memq name '(ARRAY SIMPLE-ARRAY))
106                      (setf element-type (or (car args) t)
107                            len (if (consp (cadr args)) (caadr args) '*)))
108                     ((memq name '(BIT-VECTOR SIMPLE-BIT-VECTOR))
109                      (setf element-type 'bit
110                            len (car args)))
111                     (t
112                      (setf element-type (or (car args) t)
113                            len (cadr args))))
114               (unless (or (null len) (eq len '*) (equal len '(*)))
115                 (when (/= size len)
116                   (size-mismatch-error type size)))))))
117    (setq sequence
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)))))
129    sequence))
Note: See TracBrowser for help on using the repository browser.