Mercurial > hg > xemacs-beta

diff lisp/cl-extra.el @ 4995:8431b52e43b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Move the various map* functions to C; add #'map-into. src/ChangeLog addition: 2010-01-31 Aidan Kehoe <kehoea@parhasard.net> Move #'mapcar*, #'mapcan, #'mapc, #'map, #'mapl, #'mapcon to C; extend #'mapvector, #'mapconcat, #'mapcar to support more SEQUENCES; have them all error with circular lists. * fns.c (Fsubseq): Call CHECK_SEQUENCE here; Flength can return from the debugger if it errors with a non-sequence, leading to a crash in Fsubseq if sequence really is *not* a sequence. (mapcarX): Rename mapcar1 to mapcarX; rework it comprehensively to take an optional lisp output argument, and a varying number of sequences. Special-case a single list argument, as we used to, saving its elements in the stack space for the results before calling FUNCTION, so FUNCTION can corrupt the list all it wants. dead_wrong_type_argument() in the other cases if we encounter a non-cons where we expected a cons. (Fmapconcat): Accept further SEQUENCES after separator here. Special-case the idiom (mapconcat 'identity SEQUENCE), don't even funcall. (FmapcarX): Rename this from Fmapcar. Accept optional SEQUENCES. (Fmapvector): Accept optional SEQUENCES. (Fmapcan, Fmapc, Fmap): Move these here from cl-extra.el. (Fmap_into): New function, as specified by Common Lisp. (maplist): New function, the guts of the implementation of Fmaplist and Fmapl. (Fmaplist, Fmapl, Fmapcon): Move these from cl-extra.el. (syms_of_fns): Add a few needed symbols here, for the type tests used by #'map. Add the new subrs, with aliases for #'mapc-internal and #'mapcar. * general-slots.h: Declare Qcoerce here, now it's used in both indent.c and fns.c * indent.c (syms_of_indent): Qcoerce is gone from here. * lisp.h: Add ARRAYP(), SEQUENCEP(), and the corresponding CHECK_* macros. Declare Fbit_vector, Fstring, FmapcarX, now other files need to use them. * data.c (Farrayp, Fsequencep): Use ARRAYP and SEQUENCEP, just added to lisp.h * buffer.c (Fbuffer_list): Now Fmapcar has been renamed FmapcarX and takes MANY arguments, update this function to reflect that. lisp/ChangeLog addition: 2010-01-31 Aidan Kehoe <kehoea@parhasard.net> * cl.el (mapcar*): Delete; this is now in fns.c. Use #'mapc, not #'mapc-internal in a couple of places. * cl-macs.el (mapc, mapcar*, map): Delete these compiler macros now the corresponding functions are in fns.c; there's no run-time advantage to the macros. * cl-extra.el (coerce): Extend the possible conversions here a little; it's not remotely comprehensive yet, though it does allow running slightly more Common Lisp code than previously. (cl-mapcar-many): Delete. (map, maplist, mapc, mapl, mapcan, mapcon): Move these to fns.c. * bytecomp.el (byte-compile-maybe-mapc): Use #'mapc itself, not #'mapc-internal, now the former is in C. (mapcar*): Use #'byte-compile-maybe-mapc as this function's byte-compile method, now a #'mapc that can take more than one sequence is in C. * obsolete.el (cl-mapc): Move this compatibility alias to this file. * update-elc.el (do-autoload-commands): Use #'mapc, not #'mapc-internal here.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 31 Jan 2010 18:29:48 +0000
parents b828e06dbe38
children c17c857e20bf
line wrap: on
line diff
--- a/lisp/cl-extra.el	Sun Jan 31 18:09:57 2010 +0000
+++ b/lisp/cl-extra.el	Sun Jan 31 18:29:48 2010 +0000
@@ -75,14 +75,27 @@
 	   (memq type '(integer ratio bigfloat))
 	   (coerce-number x type)))
 	;; XEmacs addition: bit-vector coercion
-	((eq type 'bit-vector) (if (bit-vector-p x) x
-				 (apply 'bit-vector (append x nil))))
+	((or (eq type 'bit-vector)
+	     (eq type 'simple-bit-vector))
+	 (if (bit-vector-p x) x (apply 'bit-vector (append x nil))))
 	;; XEmacs addition: weak-list coercion
 	((eq type 'weak-list)
 	 (if (weak-list-p x) x
 	   (let ((wl (make-weak-list)))
 	     (set-weak-list-list wl (if (listp x) x (append x nil)))
 	     wl)))
+	((and
+	  (consp type)
+	  (or (eq (car type) 'vector)
+	      (eq (car type) 'simple-array)
+	      (eq (car type) 'simple-vector))
+	  (cond
+	   ((equal (cdr-safe type) '(*))
+	    (coerce x 'vector))
+	   ((equal (cdr-safe type) '(bit))
+	    (coerce x 'bit-vector))
+	   ((equal (cdr-safe type) '(character))
+	    (coerce x 'string)))))
 	((typep x type) x)
 	(t (error "Can't coerce %s to type %s" x type))))
 
@@ -212,94 +225,8 @@
 		      (and (equal "" y) (equal #* x)))))
 		 (t (equal x y)))))))
 
-;;; Control structures.
-
-(defun cl-mapcar-many (cl-func cl-seqs)
-  (if (cdr (cdr cl-seqs))
-      (let* ((cl-res nil)
-	     (cl-n (apply 'min (mapcar 'length cl-seqs)))
-	     (cl-i 0)
-	     (cl-args (copy-sequence cl-seqs))
-	     cl-p1 cl-p2)
-	(setq cl-seqs (copy-sequence cl-seqs))
-	(while (< cl-i cl-n)
-	  (setq cl-p1 cl-seqs cl-p2 cl-args)
-	  (while cl-p1
-	    (setcar cl-p2
-		    (if (consp (car cl-p1))
-			(prog1 (car (car cl-p1))
-			  (setcar cl-p1 (cdr (car cl-p1))))
-		      (aref (car cl-p1) cl-i)))
-	    (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
-	  (push (apply cl-func cl-args) cl-res)
-	  (setq cl-i (1+ cl-i)))
-	(nreverse cl-res))
-    (let ((cl-res nil)
-	  (cl-x (car cl-seqs))
-	  (cl-y (nth 1 cl-seqs)))
-      (let ((cl-n (min (length cl-x) (length cl-y)))
-	    (cl-i -1))
-	(while (< (setq cl-i (1+ cl-i)) cl-n)
-	  (push (funcall cl-func
-			    (if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
-			    (if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))
-		   cl-res)))
-      (nreverse cl-res))))
-
-(defun map (cl-type cl-func cl-seq &rest cl-rest)
-  "Map a function across one or more sequences, returning a sequence.
-TYPE is the sequence type to return, FUNC is the function, and SEQS
-are the argument sequences."
-  (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest)))
-    (and cl-type (coerce cl-res cl-type))))
-
-(defun maplist (cl-func cl-list &rest cl-rest)
-  "Map FUNC to each sublist of LIST or LISTS.
-Like `mapcar', except applies to lists and their cdr's rather than to
-the elements themselves."
-  (if cl-rest
-      (let ((cl-res nil)
-	    (cl-args (cons cl-list (copy-sequence cl-rest)))
-	    cl-p)
-	(while (not (memq nil cl-args))
-	  (push (apply cl-func cl-args) cl-res)
-	  (setq cl-p cl-args)
-	  (while cl-p (setcar cl-p (cdr (pop cl-p)) )))
-	(nreverse cl-res))
-    (let ((cl-res nil))
-      (while cl-list
-	(push (funcall cl-func cl-list) cl-res)
-	(setq cl-list (cdr cl-list)))
-      (nreverse cl-res))))
-
-;; XEmacs change: in Emacs, this function is named cl-mapc.
-(defun mapc (cl-func cl-seq &rest cl-rest)
-  "Like `mapcar', but does not accumulate values returned by the function."
-  (if cl-rest
-      (apply 'map nil cl-func cl-seq cl-rest)
-    ;; XEmacs change: in the simplest case we call mapc-internal,
-    ;; which really doesn't accumulate any results.
-    (mapc-internal cl-func cl-seq))
-  cl-seq)
-
-;; XEmacs addition: FSF compatibility
-(defalias 'cl-mapc 'mapc)
-
-(defun mapl (cl-func cl-list &rest cl-rest)
-  "Like `maplist', but does not accumulate values returned by the function."
-  (if cl-rest
-      (apply 'maplist cl-func cl-list cl-rest)
-    (let ((cl-p cl-list))
-      (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
-  cl-list)
-
-(defun mapcan (cl-func cl-seq &rest cl-rest)
-  "Like `mapcar', but nconc's together the values returned by the function."
-  (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest)))
-
-(defun mapcon (cl-func cl-list &rest cl-rest)
-  "Like `maplist', but nconc's together the values returned by the function."
-  (apply 'nconc (apply 'maplist cl-func cl-list cl-rest)))
+;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon are now in C, together
+;; with #'map-into, which was never in this file.
 
 (defun some (cl-pred cl-seq &rest cl-rest)
   "Return true if PREDICATE is true of any element of SEQ or SEQs.