/[gcl]/gcl/lsp/gcl_seq.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_seq.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by pfdietz, Sat Aug 27 14:29:19 2005 UTC revision 1.6 by pfdietz, Sat Aug 27 17:49:03 2005 UTC
# Line 33  Line 33 
33  (proclaim '(optimize (safety 2) (space 3)))  (proclaim '(optimize (safety 2) (space 3)))
34    
35    
36  (defun make-sequence (type size &key (initial-element nil iesp)  (defun make-sequence (type size        &key (initial-element nil iesp)
37                                  &aux element-type sequence)                                  &aux element-type sequence)
38    (setq element-type    (setq element-type
39          (cond ((eq type 'list)          (cond ((eq type 'list)
# Line 45  Line 45 
45                ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit)                ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit)
46                ((or (eq type 'simple-vector) (eq type 'vector)) t)                ((or (eq type 'simple-vector) (eq type 'vector)) t)
47                (t                (t
48                 (setq type (normalize-type type))                 (let ((normalized-type (normalize-type type)))
49                 (when (member (car type) '(cons null));(subtypep (car type) 'list)                   (when (member (car normalized-type) '(cons null))  ;(subtypep (car normalized-type) 'list)
50                   (if (or (and (eq 'null (car type)) (not (equal size 0)))                     (if (or (and (eq 'null (car normalized-type)) (not (equal size 0)))
51                           (and (eq 'cons (car type)) (equal size 0)))                             (and (eq 'cons (car normalized-type)) (equal size 0)))
52                       (specific-error :wrong-type-argument "~S is not of type ~S."                         (specific-error :wrong-type-argument "~S is not of type ~S."
53                                       type (format nil "list (size ~S)" size)))                                         type (format nil "list (size ~S)" size)))
54                       (return-from make-sequence                     (return-from make-sequence
55                        (if iesp                       (if iesp
56                            (make-list size :initial-element initial-element)                           (make-list size :initial-element initial-element)
57                            (make-list size))))                           (make-list size))))
58                 (unless (or (eq (car type) 'array)                   (when (and (equal normalized-type '(member nil)) (equal size 0))
59                             (eq (car type) 'simple-array))                     (return-from make-sequence nil))
60                   (specific-error :wrong-type-argument "~S is not of type ~S."                   (unless (or (eq (car normalized-type) 'array)
61                                   type 'sequence))                               (eq (car normalized-type) 'simple-array))
62                 (let ((ssize (caddr type)))                     (specific-error :wrong-type-argument "~S is not of type ~S."
63                   (if (listp ssize) (setq ssize (car ssize)))                                     type 'sequence))
64                   (if (not (si::fixnump ssize)) (setq ssize size))                   (let ((ssize (caddr normalized-type)))
65                   (unless (equal ssize size)                     (if (listp ssize) (setq ssize (car ssize)))
66                   (specific-error :wrong-type-argument "~S is not of type ~S."                     (if (not (si::fixnump ssize)) (setq ssize size))
67                                   type (format nil "~S (size ~S)" type size))))                     (unless (equal ssize size)
68                 (or (cadr type) t))))                       (specific-error :wrong-type-argument "~S is not of type ~S."
69                                         type (format nil "~S (size ~S)" type size))))
70                     (or (cadr normalized-type) t)))))
71    (setq element-type (si::best-array-element-type element-type))    (setq element-type (si::best-array-element-type element-type))
72    (setq sequence (si:make-vector element-type size nil nil nil nil nil))    (setq sequence (si:make-vector element-type size nil nil nil nil nil))
73    (when iesp    (when iesp
# Line 78  Line 80 
80    
81    
82  (defun concatenate (result-type &rest sequences)  (defun concatenate (result-type &rest sequences)
83    (do ((x (make-sequence result-type    (if (eq result-type 'list)
84                           (apply #'+ (mapcar #'length sequences))))        (let* ((head (cons nil nil))
85         (s sequences (cdr s))               (tail head))
86         (i 0))          (dolist (s sequences (cdr head))
87        ((null s) x)            (if (listp s)
88      (declare (fixnum i))                (dolist (e s)
89      (do ((j 0 (1+ j))                  (setf tail (setf (cdr tail) (cons e nil))))
90           (n (length (car s))))                (let ((len (length s)))
91          ((>= j n))                  (declare (type fixnum len))
92        (declare (fixnum j n))                  (do ((i 0 (1+ i)))
93        (setf (elt x i) (elt (car s) j))                      ((>= i len))
94        (incf i))))                    (setf tail (setf (cdr tail) (cons (elt s i) nil))))))))
95          (do ((x (make-sequence result-type
96                                 (apply #'+ (mapcar #'length sequences))))
97               (s sequences (cdr s))
98               (i 0))
99              ((null s) x)
100            (declare (fixnum i))
101            (if (listp (car s))
102                (dolist (e (car s))
103                  (setf (elt x i) e)
104                  (incf i))
105                (do ((j 0 (1+ j))
106                     (n (length (car s))))
107                    ((>= j n))
108                  (declare (fixnum j n))
109                  (setf (elt x i) (elt (car s) j))
110                  (incf i))))))
111    
112    
113  (defun map (result-type function sequence &rest more-sequences)  (defun map (result-type function sequence &rest more-sequences)
# Line 118  Line 136 
136       ;; special case -- only one sequence, and it's a list       ;; special case -- only one sequence, and it's a list
137       (dolist (e sequence nil)       (dolist (e sequence nil)
138         (let ((that-value (funcall predicate e)))         (let ((that-value (funcall predicate e)))
139           (when that-value (return that-value)))))           (when that-value (return that-value)))))
140      (t      (t
141       (setq more-sequences (cons sequence more-sequences))       (let* ((more-sequences (cons sequence more-sequences)))
142       (do ((i 0 (1+ i))         (do ((i 0 (1+ i))
143            (l (apply #'min (mapcar #'length more-sequences))))              (l (apply #'min (mapcar #'length more-sequences))))
144           ((>= i l) nil)             ((>= i l) nil)
145         (declare (fixnum i l))           (declare (fixnum i l))
146         (let ((that-value           (let ((that-value
147                (apply predicate                  (apply predicate
148                       (mapcar #'(lambda (z) (elt z i)) more-sequences))))                         ;; (mapcar #'(lambda (z) (elt z i)) more-sequences)
149           (when that-value (return that-value)))))))                         (let* ((head (cons nil nil))
150                                  (tail head))
151                             (do ((s more-sequences (cdr s)))
152                                 ((null s) (cdr head))
153                               (let ((e (car s)))
154                                 (setf tail (setf (cdr tail)
155                                                  (cons (if (consp e) (pop (car s)) (elt e i))
156                                                        nil))))))
157                           )))
158               (when that-value (return that-value))))))))
159    
160  (defun every (predicate sequence &rest more-sequences)  (defun every (predicate sequence &rest more-sequences)
161    (cond    (cond
# Line 137  Line 164 
164       (dolist (e sequence t)       (dolist (e sequence t)
165         (unless (funcall predicate e) (return nil))))         (unless (funcall predicate e) (return nil))))
166      (t      (t
167       (setq more-sequences (cons sequence more-sequences))       (let* ((more-sequences (cons sequence more-sequences)))
168       (do ((i 0 (1+ i))         (do ((i 0 (1+ i))
169            (l (apply #'min (mapcar #'length more-sequences))))              (l (apply #'min (mapcar #'length more-sequences))))
170           ((>= i l) t)             ((>= i l) t)
171         (declare (fixnum i l))           (declare (fixnum i l))
172         (unless (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences))           (unless (apply predicate
173           (return nil))))))                          ;; (mapcar #'(lambda (z) (elt z i)) more-sequences)
174                            (let* ((head (cons nil nil))
175                                   (tail head))
176                              (do ((s more-sequences (cdr s)))
177                                  ((null s) (cdr head))
178                                (let ((e (car s)))
179                                  (setf tail (setf (cdr tail)
180                                                   (cons (if (consp e) (pop (car s)) (elt e i))
181                                                         nil)))))))
182               (return nil)))))))
183    
184  (defun notany (predicate sequence &rest more-sequences)  (defun notany (predicate sequence &rest more-sequences)
185    (not (apply #'some predicate sequence more-sequences)))    (not (apply #'some predicate sequence more-sequences)))

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26