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