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))) |