diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp index e72e4593385a5c788a6f7bc2406af09d442034d3..99428b6c5d7a4097f6da7db55ebcf9a0f19b3307 100644 --- a/compiler/fndb.lisp +++ b/compiler/fndb.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.112 2003/04/26 19:34:52 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.113 2003/04/27 13:58:59 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -416,6 +416,11 @@ ; :derive-type 'type-spec-arg1 Nope... (map nil ...) returns null, not nil. ) +(defknown map-into (sequence callable &rest sequence) + sequence + (call) + :derive-type #'result-type-first-arg) + ;;; Returns predicate result... (defknown some (callable sequence &rest sequence) t (foldable flushable call)) diff --git a/compiler/seqtran.lisp b/compiler/seqtran.lisp index 79fba8c079b274f007a30ff5eab0ddd60e49265d..ead63aeb683b52cbdd7b31eb51ab4f7b520fefbc 100644 --- a/compiler/seqtran.lisp +++ b/compiler/seqtran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.26 2003/04/21 15:56:31 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.27 2003/04/27 13:58:59 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -70,6 +70,37 @@ (def-source-transform mapcon (function list &rest more-lists) (mapper-transform function (cons list more-lists) :nconc nil)) + +;;; MAP-INTO +(deftransform map-into ((result fun &rest seqs) + (vector * &rest *) + *) + "open code" + (let ((seqs-names (mapcar (lambda (x) + (declare (ignore x)) + (gensym)) + seqs))) + `(lambda (result fun ,@seqs-names) + (let ((length (array-dimension result 0)) + (i 0)) + (declare (type index i)) + (declare (ignorable i)) + ,(cond ((null seqs) + `(dotimes (j length (setq i length)) + (setf (aref result j) (funcall fun)))) + (t + `(block nil + (map nil + (lambda (,@seqs-names) + (when (= i length) (return)) + (setf (aref result i) + (funcall fun ,@seqs-names)) + (incf i)) + ,@seqs-names)))) + (when (array-has-fill-pointer-p result) + (setf (fill-pointer result) i)) + result)))) + (deftransform elt ((s i) ((simple-array * (*)) *) * :when :both) '(aref s i))