/[gcl]/gcl/cmpnew/gcl_cmpmap.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpmap.lsp

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

revision 1.3 by camm, Wed Jun 29 04:29:32 2005 UTC revision 1.4 by camm, Sat Jul 23 08:48:32 2005 UTC
# Line 1  Line 1 
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
# Line 260  Line 261 
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    

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

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