/[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.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:06 2003 UTC
# Line 0  Line 1 
1    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
2    
3    ;; This file is part of GNU Common Lisp, herein referred to as GCL
4    ;;
5    ;; GCL is free software; you can redistribute it and/or modify it under
6    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
7    ;; the Free Software Foundation; either version 2, or (at your option)
8    ;; any later version.
9    ;;
10    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
11    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
13    ;; License for more details.
14    ;;
15    ;; You should have received a copy of the GNU Library General Public License
16    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
17    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
18    
19    
20    ;;;;   seq.lsp
21    ;;;;
22    ;;;;                           sequence routines
23    
24    
25    (in-package 'lisp)
26    
27    (export '(make-sequence concatenate map some every notany notevery))
28    
29    (in-package 'system)
30    
31    
32    (proclaim '(optimize (safety 2) (space 3)))
33    
34    
35    (defun make-sequence (type size &key (initial-element nil iesp)
36                                    &aux element-type sequence)
37      (setq element-type
38            (cond ((eq type 'list)
39                   (return-from make-sequence
40                    (if iesp
41                        (make-list size :initial-element initial-element)
42                        (make-list size))))
43                  ((or (eq type 'simple-string) (eq type 'string)) 'string-char)
44                  ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit)
45                  ((or (eq type 'simple-vector) (eq type 'vector)) t)
46                  (t
47                   (setq type (normalize-type type))
48                   (when (subtypep (car type) 'list)
49                     (if (or (and (eq 'null (car type)) (not (equal size 0)))
50                             (and (eq 'cons (car type)) (equal size 0)))
51                         (specific-error :wrong-type-argument "~S is not of type ~S."
52                                         type (format nil "list (size ~S)" size)))
53                         (return-from make-sequence
54                          (if iesp
55                              (make-list size :initial-element initial-element)
56                              (make-list size))))
57                   (unless (or (eq (car type) 'array)
58                               (eq (car type) 'simple-array))
59                     (specific-error :wrong-type-argument "~S is not of type ~S."
60                                     type 'sequence))
61                   (let ((ssize (caddr type)))
62                     (if (listp ssize) (setq ssize (car ssize)))
63                     (if (not (si::fixnump ssize)) (setq ssize size))
64                     (unless (equal ssize size)
65                     (specific-error :wrong-type-argument "~S is not of type ~S."
66                                     type (format nil "~S (size ~S)" type size))))
67                   (or (cadr type) t))))
68      (setq element-type (si::best-array-element-type element-type))
69      (setq sequence (si:make-vector element-type size nil nil nil nil nil))
70      (when iesp
71            (do ((i 0 (1+ i))
72                 (size size))
73                ((>= i size))
74              (declare (fixnum i size))
75              (setf (elt sequence i) initial-element)))
76      sequence)
77    
78    
79    (defun concatenate (result-type &rest sequences)
80      (do ((x (make-sequence result-type
81                             (apply #'+ (mapcar #'length sequences))))
82           (s sequences (cdr s))
83           (i 0))
84          ((null s) x)
85        (declare (fixnum i))
86        (do ((j 0 (1+ j))
87             (n (length (car s))))
88            ((>= j n))
89          (declare (fixnum j n))
90          (setf (elt x i) (elt (car s) j))
91          (incf i))))
92    
93    
94    (defun map (result-type function sequence &rest more-sequences)
95      (setq more-sequences (cons sequence more-sequences))
96      (let ((l (apply #'min (mapcar #'length more-sequences))))
97        (if (null result-type)
98            (do ((i 0 (1+ i))
99                 (l l))
100                ((>= i l) nil)
101              (declare (fixnum i l))
102              (apply function (mapcar #'(lambda (z) (elt z i))
103                                      more-sequences)))
104            (let ((x (make-sequence result-type l)))
105              (do ((i 0 (1+ i))
106                   (l l))
107                  ((>= i l) x)
108                (declare (fixnum i l))
109                (setf (elt x i)
110                      (apply function (mapcar #'(lambda (z) (elt z i))
111                                              more-sequences))))))))
112    
113    
114    (defun some (predicate sequence &rest more-sequences)
115      (setq more-sequences (cons sequence more-sequences))
116      (do ((i 0 (1+ i))
117           (l (apply #'min (mapcar #'length more-sequences))))
118          ((>= i l) nil)
119        (declare (fixnum i l))
120        (let ((that-value
121               (apply predicate
122                      (mapcar #'(lambda (z) (elt z i)) more-sequences))))
123          (when that-value (return that-value)))))
124    
125    
126    (defun every (predicate sequence &rest more-sequences)
127      (setq more-sequences (cons sequence more-sequences))
128      (do ((i 0 (1+ i))
129           (l (apply #'min (mapcar #'length more-sequences))))
130          ((>= i l) t)
131        (declare (fixnum i l))
132        (unless (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences))
133                (return nil))))
134    
135    
136    (defun notany (predicate sequence &rest more-sequences)
137      (not (apply #'some predicate sequence more-sequences)))
138    
139    
140    (defun notevery (predicate sequence &rest more-sequences)
141      (not (apply #'every predicate sequence more-sequences)))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

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