1 |
|
;; -*-Lisp-*- |
2 |
;;; CMPMAP Map functions. |
;;; CMPMAP Map functions. |
3 |
;;; |
;;; |
4 |
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
261 |
(push temp locs1)) |
(push temp locs1)) |
262 |
(push loc locs1)))) |
(push loc locs1)))) |
263 |
|
|
264 |
|
(defun c1map-into (args) |
265 |
|
(when (or (endp args) (endp (cdr args))) |
266 |
|
(too-few-args 'map-function 2 (length args))) |
267 |
|
(let ((info (make-info))) |
268 |
|
(let ((nargs (c1args args info))) |
269 |
|
(if (not (member-if-not (lambda (x) (subtypep (info-type (cadr x)) 'vector)) (cddr nargs))) |
270 |
|
(let ((l (gensym)) (i (gensym))) |
271 |
|
(c1expr |
272 |
|
`(let ((,l (min ,@(mapcar (lambda (x) `(length ,x)) (cddr args))))) |
273 |
|
(do ((,i 0 (+ ,i 1))) ((= ,i ,l)) |
274 |
|
(declare (seqind ,i)) |
275 |
|
(setf (aref ,(car args) ,i) (funcall ,(cadr args) ,@(mapcar (lambda (x) `(aref ,x ,i)) (cddr args)))))))) |
276 |
|
(list 'call-global info 'map-into nargs))))) |
277 |
|
(si::putprop 'map-into 'c1map-into 'c1) |
278 |
|
|
279 |
|
(defun c1map (args) |
280 |
|
(when (or (endp args) (endp (cdr args))) |
281 |
|
(too-few-args 'map-function 2 (length args))) |
282 |
|
(let ((info (make-info))) |
283 |
|
(let ((nargs (c1args (cddr args) info))) |
284 |
|
(if (and (not (car args)) (not (member-if-not (lambda (x) (subtypep (info-type (cadr x)) 'vector)) nargs))) |
285 |
|
(let ((l (gensym)) (i (gensym))) |
286 |
|
(c1expr |
287 |
|
`(let ((,l (min ,@(mapcar (lambda (x) `(length ,x)) (cddr args))))) |
288 |
|
(do ((,i 0 (+ ,i 1))) ((= ,i ,l)) |
289 |
|
(declare (seqind ,i)) |
290 |
|
(funcall ,(cadr args) ,@(mapcar (lambda (x) `(aref ,x ,i)) (cddr args))))))) |
291 |
|
(let ((info (make-info))) |
292 |
|
(list 'call-global info 'map (c1args args info))))))) |
293 |
|
(si::putprop 'map 'c1map 'c1) |
294 |
|
|
295 |
|
|