# HG changeset patch # User Aidan Kehoe # Date 1270149770 -3600 # Node ID 2e528066e2fcb2b66f82a3482206e860b72089ff # Parent a00bfbd64e0a41de364abbab8ea6c8451c88763d Move #'sort*, #'fill, #'merge to C from cl-seq.el. lisp/ChangeLog addition: 2010-04-01 Aidan Kehoe * cl-seq.el (fill, sort*, merge): Move these functions to fns.c. (stable-sort): Make this docstring reflect the argument names used in the #'sort* docstring. * cl-macs.el (stable-sort): Make #'stable-sort exactly equivalent to #'sort* in compiled code. * bytecomp.el (byte-compile-maybe-add-*): New macro, for functions like #'sort and #'mapcar that, to be strictly compatible, should only take two args, but in our implementation can take more, because they're aliases of #'sort* and #'mapcar*. (byte-compile-mapcar, byte-compile-sort, byte-compile-fillarray): Use this new macro. (map-into): Add a byte-compile method for #'map-into in passing. * apropos.el (apropos-print): Use #'sort* with a :key argument, now it's in C. * compat.el (extent-at): Ditto. * register.el (list-registers): Ditto. * package-ui.el (pui-list-packages): Ditto. * help.el (sorted-key-descriptions): Ditto. src/ChangeLog addition: 2010-03-31 Aidan Kehoe * fns.c (STRING_DATA_TO_OBJECT_ARRAY) (BIT_VECTOR_TO_OBJECT_ARRAY, c_merge_predicate_key) (c_merge_predicate_nokey, list_merge, array_merge) (list_array_merge_into_list, list_list_merge_into_array) (list_array_merge_into_array, CHECK_KEY_ARGUMENT, Fmerge) (list_sort, array_sort, FsortX): Move #'sort*, #'fill, #'merge from cl-seq.el to C, extending the implementations of Fsort, Ffillarray, and merge() to do so. * keymap.c (keymap_submaps, map_keymap_sort_predicate) (describe_map_sort_predicate): Change the calling semantics of the C sort predicates to return a non-nil Lisp object if the first argument is less than the second, rather than C integers. * fontcolor-msw.c (sort_font_list_function): * fileio.c (build_annotations): * dired.c (Fdirectory_files): * abbrev.c (Finsert_abbrev_table_description): Call list_sort instead of Fsort, list_merge instead of merge() in these functions. man/ChangeLog addition: 2010-04-01 Aidan Kehoe * lispref/lists.texi (Rearrangement): Update the documentation of #'sort here, now that it accepts any type of sequence and the KEY keyword argument. (Though this is probably now the wrong place for this function, given that.) diff -r a00bfbd64e0a -r 2e528066e2fc lisp/ChangeLog --- a/lisp/ChangeLog Mon Mar 29 23:23:33 2010 -0500 +++ b/lisp/ChangeLog Thu Apr 01 20:22:50 2010 +0100 @@ -1,3 +1,27 @@ +2010-04-01 Aidan Kehoe + + * cl-seq.el (fill, sort*, merge): Move these functions to fns.c. + (stable-sort): Make this docstring reflect the argument names used + in the #'sort* docstring. + * cl-macs.el (stable-sort): Make #'stable-sort exactly equivalent + to #'sort* in compiled code. + + * bytecomp.el (byte-compile-maybe-add-*): + New macro, for functions like #'sort and #'mapcar that, to be + strictly compatible, should only take two args, but in our + implementation can take more, because they're aliases of #'sort* + and #'mapcar*. + (byte-compile-mapcar, byte-compile-sort, byte-compile-fillarray): + Use this new macro. + (map-into): Add a byte-compile method for #'map-into in passing. + + * apropos.el (apropos-print): Use #'sort* with a :key argument, + now it's in C. + * compat.el (extent-at): Ditto. + * register.el (list-registers): Ditto. + * package-ui.el (pui-list-packages): Ditto. + * help.el (sorted-key-descriptions): Ditto. + 2010-02-22 Ben Wing * dumped-lisp.el (preloaded-file-list): diff -r a00bfbd64e0a -r 2e528066e2fc lisp/apropos.el --- a/lisp/apropos.el Mon Mar 29 23:23:33 2010 -0500 +++ b/lisp/apropos.el Thu Apr 01 20:22:50 2010 +0100 @@ -500,8 +500,7 @@ (if doc-fn (funcall doc-fn apropos-accumulator)) (setq apropos-accumulator - (sort apropos-accumulator (lambda (a b) - (string-lessp (car a) (car b))))) + (sort* apropos-accumulator #'string-lessp :key #'car)) (and apropos-label-face (or (symbolp apropos-label-face) (facep apropos-label-face)) ; XEmacs diff -r a00bfbd64e0a -r 2e528066e2fc lisp/bytecomp.el --- a/lisp/bytecomp.el Mon Mar 29 23:23:33 2010 -0500 +++ b/lisp/bytecomp.el Thu Apr 01 20:22:50 2010 +0100 @@ -3510,8 +3510,8 @@ (null (memq 'quoted-lambda byte-compile-warnings)) (byte-compile-warn - "Passing a quoted lambda to #'%s, forcing \ -function quoting" (car form)))) + "Passing a quoted lambda (arg %d) to #'%s, \ +forcing function quoting" ,en (car form)))) (setcar fn 'function)))) (byte-compile-normal-call form))) @@ -3549,6 +3549,25 @@ (setq form (cons 'mapl (cdr form)))) (byte-compile-funarg form)) +;; For when calls to #'sort or #'mapcar have more than two args, something +;; recent XEmacs can handle, but GNU and 21.4 can't. +(defmacro byte-compile-maybe-add-* (complex max) + `#'(lambda (form) + (when (> (length (cdr form)) ,max) + (when (memq 'callargs byte-compile-warnings) + (byte-compile-warn + "#'%s called with %d arguments, using #'%s instead" + (car form) (length (cdr form)) ',complex)) + (setq form (cons ',complex (cdr form)))) + (funcall (or (get ',complex 'byte-compile) + 'byte-compile-normal-call) form))) + +(defalias 'byte-compile-mapcar (byte-compile-maybe-add-* mapcar* 2)) + +(defalias 'byte-compile-sort (byte-compile-maybe-add-* sort* 2)) + +(defalias 'byte-compile-fillarray (byte-compile-maybe-add-* fill 2)) + ;; (function foo) must compile like 'foo, not like (symbol-function 'foo). ;; Otherwise it will be incompatible with the interpreter, ;; and (funcall (function foo)) will lose with autoloads. @@ -3725,7 +3744,8 @@ (byte-defop-compiler-1 while) (byte-defop-compiler-1 funcall) (byte-defop-compiler-1 apply byte-compile-funarg) -(byte-defop-compiler-1 mapcar byte-compile-maybe-mapc) +(byte-defop-compiler-1 mapcar byte-compile-mapcar) +(byte-defop-compiler-1 mapcar* byte-compile-maybe-mapc) (byte-defop-compiler-1 mapatoms byte-compile-funarg) (byte-defop-compiler-1 mapconcat byte-compile-funarg) (byte-defop-compiler-1 mapc byte-compile-funarg) @@ -3743,7 +3763,6 @@ (byte-defop-compiler-1 map-plist byte-compile-funarg) (byte-defop-compiler-1 map-range-table byte-compile-funarg) (byte-defop-compiler-1 map-syntax-table byte-compile-funarg) -(byte-defop-compiler-1 mapcar* byte-compile-maybe-mapc) (byte-defop-compiler-1 remove-if byte-compile-funarg) (byte-defop-compiler-1 remove-if-not byte-compile-funarg) @@ -3771,8 +3790,9 @@ (byte-defop-compiler-1 get-window-with-predicate byte-compile-funarg) (byte-defop-compiler-1 map byte-compile-funarg-2) +(byte-defop-compiler-1 map-into byte-compile-funarg-2) (byte-defop-compiler-1 apropos-internal byte-compile-funarg-2) -(byte-defop-compiler-1 sort byte-compile-funarg-2) +(byte-defop-compiler-1 sort byte-compile-sort) (byte-defop-compiler-1 sort* byte-compile-funarg-2) (byte-defop-compiler-1 stable-sort byte-compile-funarg-2) (byte-defop-compiler-1 substitute-if byte-compile-funarg-2) @@ -3793,6 +3813,7 @@ (byte-defop-compiler-1 let*) (byte-defop-compiler-1 integerp) +(byte-defop-compiler-1 fillarray) (defun byte-compile-progn (form) (byte-compile-body-do-effect (cdr form))) diff -r a00bfbd64e0a -r 2e528066e2fc lisp/cl-macs.el --- a/lisp/cl-macs.el Mon Mar 29 23:23:33 2010 -0500 +++ b/lisp/cl-macs.el Thu Apr 01 20:22:50 2010 +0100 @@ -3649,6 +3649,9 @@ t "Placeholders should each have been used once"))) ,(compiled-function-stack-depth compiled)))))) +(define-compiler-macro stable-sort (&whole form &rest cl-rest) + (cons 'sort* (cdr form))) + (mapc #'(lambda (y) (put (car y) 'side-effect-free t) diff -r a00bfbd64e0a -r 2e528066e2fc lisp/cl-seq.el --- a/lisp/cl-seq.el Mon Mar 29 23:23:33 2010 -0500 +++ b/lisp/cl-seq.el Thu Apr 01 20:22:50 2010 +0100 @@ -176,26 +176,6 @@ (cl-check-key (pop cl-seq)))))) cl-accum))) -(defun fill (seq item &rest cl-keys) - "Fill the elements of SEQ with ITEM. -Keywords supported: :start :end -:start and :end specify a subsequence of SEQ; see `remove*' for more -information." - (cl-parsing-keywords ((:start 0) :end) () - (if (listp seq) - (let ((p (nthcdr cl-start seq)) - (n (if cl-end (- cl-end cl-start) 8000000))) - (while (and p (>= (setq n (1- n)) 0)) - (setcar p item) - (setq p (cdr p)))) - (or cl-end (setq cl-end (length seq))) - (if (and (= cl-start 0) (= cl-end (length seq))) - (fillarray seq item) - (while (< cl-start cl-end) - (aset seq cl-start item) - (setq cl-start (1+ cl-start))))) - seq)) - (defun replace (cl-seq1 cl-seq2 &rest cl-keys) "Replace the elements of SEQ1 with the elements of SEQ2. SEQ1 is destructively modified, then returned. @@ -670,49 +650,16 @@ (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) (and (< cl-start2 cl-end2) cl-pos))))) -(defun sort* (cl-seq cl-pred &rest cl-keys) - "Sort the argument SEQUENCE according to PREDICATE. -This is a destructive function; it reuses the storage of SEQUENCE if possible. -Keywords supported: :key -:key specifies a one-argument function that transforms elements of SEQUENCE -into \"comparison keys\" before the test predicate is applied. See -`member*' for more information." - (if (nlistp cl-seq) - (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys)) - (cl-parsing-keywords (:key) () - (if (memq cl-key '(nil identity)) - (sort cl-seq cl-pred) - (sort cl-seq (function (lambda (cl-x cl-y) - (funcall cl-pred (funcall cl-key cl-x) - (funcall cl-key cl-y))))))))) - (defun stable-sort (cl-seq cl-pred &rest cl-keys) "Sort the argument SEQUENCE stably according to PREDICATE. This is a destructive function; it reuses the storage of SEQUENCE if possible. Keywords supported: :key :key specifies a one-argument function that transforms elements of SEQUENCE into \"comparison keys\" before the test predicate is applied. See -`member*' for more information." - (apply 'sort* cl-seq cl-pred cl-keys)) +`member*' for more information. -(defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) - "Destructively merge the two sequences to produce a new sequence. -TYPE is the sequence type to return, SEQ1 and SEQ2 are the two -argument sequences, and PRED is a `less-than' predicate on the elements. -Keywords supported: :key -:key specifies a one-argument function that transforms elements of SEQ1 and -SEQ2 into \"comparison keys\" before the test predicate is applied. See -`member*' for more information." - (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) - (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) - (cl-parsing-keywords (:key) () - (let ((cl-res nil)) - (while (and cl-seq1 cl-seq2) - (if (funcall cl-pred (cl-check-key (car cl-seq2)) - (cl-check-key (car cl-seq1))) - (push (pop cl-seq2) cl-res) - (push (pop cl-seq1) cl-res))) - (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) +arguments: (SEQUENCE PREDICATE &key (KEY #'IDENTITY))" + (apply 'sort* cl-seq cl-pred cl-keys)) ;;; See compiler macro in cl-macs.el (defun member* (cl-item cl-list &rest cl-keys) diff -r a00bfbd64e0a -r 2e528066e2fc lisp/compat.el --- a/lisp/compat.el Mon Mar 29 23:23:33 2010 -0500 +++ b/lisp/compat.el Thu Apr 01 20:22:50 2010 +0100 @@ -695,12 +695,7 @@ (setq tmp (cdr tmp))) (setq ovls tmp tmp nil)) - (car-safe - (sort ovls - (function - (lambda (a b) - (< (- (extent-end-position a) (extent-start-position a)) - (- (extent-end-position b) (extent-start-position b))))))))) + (car (sort* ovls #'< :key #'extent-length)))) (defun-compat map-extents (function &optional object from to maparg flags property value) diff -r a00bfbd64e0a -r 2e528066e2fc lisp/help.el --- a/lisp/help.el Mon Mar 29 23:23:33 2010 -0500 +++ b/lisp/help.el Thu Apr 01 20:22:50 2010 +0100 @@ -1731,9 +1731,8 @@ The sorting is done by length (shortest bindings first), and the bindings are separated with SEPARATOR (\", \" by default)." (mapconcat 'key-description - (sort keys #'(lambda (x y) - (< (length x) (length y)))) - (or separator ", "))) + (sort* keys #'< :key #'length) + (or separator ", "))) (defun where-is (definition &optional insert) "Print message listing key sequences that invoke specified command. diff -r a00bfbd64e0a -r 2e528066e2fc lisp/package-ui.el --- a/lisp/package-ui.el Mon Mar 29 23:23:33 2010 -0500 +++ b/lisp/package-ui.el Thu Apr 01 20:22:50 2010 +0100 @@ -664,10 +664,7 @@ (set-extent-property extent 'pui-info info) (set-extent-property extent 'help-echo 'pui-help-echo) (set-extent-property extent 'keymap pui-package-keymap))) - (sort (copy-sequence package-get-base) - #'(lambda (a b) - (string< (symbol-name (car a)) - (symbol-name (car b)))))) + (sort* (copy-sequence package-get-base) #'string< :key #'car)) (insert sep-string) (insert (documentation 'list-packages-mode)) (set-buffer-modified-p nil) diff -r a00bfbd64e0a -r 2e528066e2fc lisp/register.el --- a/lisp/register.el Mon Mar 29 23:23:33 2010 -0500 +++ b/lisp/register.el Thu Apr 01 20:22:50 2010 +0100 @@ -175,7 +175,7 @@ "Display a list of nonempty registers saying briefly what they contain." (interactive) (let ((list (copy-sequence register-alist))) - (setq list (sort list (lambda (a b) (< (car a) (car b))))) + (setq list (sort* list #'< :key #'car)) (with-output-to-temp-buffer "*Output*" (dolist (elt list) (when (get-register (car elt)) diff -r a00bfbd64e0a -r 2e528066e2fc lisp/subr.el --- a/lisp/subr.el Mon Mar 29 23:23:33 2010 -0500 +++ b/lisp/subr.el Thu Apr 01 20:22:50 2010 +0100 @@ -1784,8 +1784,7 @@ ;; they're used reasonably often, since they've been around for a long time ;; and they're portable to GNU. -;; Used in fileio.c if format-annotate-function has a function binding -;; (which it won't have before this file is loaded): +;; No longer used in C, now list_merge() accepts a KEY argument. (defun car-less-than-car (a b) "Return t if the car of A is numerically less than the car of B." (< (car a) (car b))) diff -r a00bfbd64e0a -r 2e528066e2fc man/ChangeLog --- a/man/ChangeLog Mon Mar 29 23:23:33 2010 -0500 +++ b/man/ChangeLog Thu Apr 01 20:22:50 2010 +0100 @@ -1,3 +1,10 @@ +2010-04-01 Aidan Kehoe + + * lispref/lists.texi (Rearrangement): + Update the documentation of #'sort here, now that it accepts any + type of sequence and the KEY keyword argument. (Though this is + probably now the wrong place for this function, given that.) + 2010-02-22 Ben Wing * internals/internals.texi (A Summary of the Various XEmacs Modules): diff -r a00bfbd64e0a -r 2e528066e2fc man/lispref/lists.texi --- a/man/lispref/lists.texi Mon Mar 29 23:23:33 2010 -0500 +++ b/man/lispref/lists.texi Thu Apr 01 20:22:50 2010 +0100 @@ -1050,31 +1050,54 @@ @end smallexample @end defun -@defun sort list predicate +@defun sort* sequence predicate &key (key #'identity) @cindex stable sort @cindex sorting lists -This function sorts @var{list} stably, though destructively, and -returns the sorted list. It compares elements using @var{predicate}. A +@cindex sorting arrays +@cindex sort +This function sorts @var{sequence} stably, though destructively, and +returns the sorted sequence. It compares elements using @var{predicate}. A stable sort is one in which elements with equal sort keys maintain their relative order before and after the sort. Stability is important when successive sorts are used to order elements according to different criteria. +@var{sequence} can be any sequence, that is, a list, a vector, a +bit-vector, or a string. + The argument @var{predicate} must be a function that accepts two -arguments. It is called with two elements of @var{list}. To get an +arguments. It is called with two elements of @var{sequence}. To get an increasing order sort, the @var{predicate} should return @code{t} if the first element is ``less than'' the second, or @code{nil} if not. -The destructive aspect of @code{sort} is that it rearranges the cons -cells forming @var{list} by changing @sc{cdr}s. A nondestructive sort +The keyword argument @var{key}, if supplied, is a function used to +extract an object to be used for comparison from each element of +@var{sequence}, and defaults to @code{identity}. For example, to sort a +vector of lists by the numeric value of the first element, you could use +the following code: + +@example +@group +(setq example-vector [(1 "foo") (3.14159 bar) (2 . quux)]) + @result{} [(1 "foo") (3.14159 bar) (2 . quux)] +@end group +@group +(sort* example-vector #'< :key #'car) + @result{} [(1 "foo") (2 . quux) (3.14159 bar)] +@end group +@end example + +If @var{sequence} is a list, @code{sort*} rearranges the cons cells +forming @var{sequence} by changing @sc{cdr}s. A nondestructive sort function would create new cons cells to store the elements in their -sorted order. If you wish to make a sorted copy without destroying the +sorted order. @code{sort*} treats other sequence types in an analogous +fashion---if you wish to make a sorted copy without destroying the original, copy it first with @code{copy-sequence} and then sort. -Sorting does not change the @sc{car}s of the cons cells in @var{list}; -the cons cell that originally contained the element @code{a} in -@var{list} still has @code{a} in its @sc{car} after sorting, but it now -appears in a different position in the list due to the change of +Sorting will not change the @sc{car}s of the cons cells of a list +@var{sequence}; the cons cell that originally contained the element @code{a} in +@var{sequence} still has @code{a} in its @sc{car} after sorting, but it now +appears in a different position in the sequence due to the change of @sc{cdr}s. For example: @example @@ -1083,7 +1106,7 @@ @result{} (1 3 2 6 5 4 0) @end group @group -(sort nums '<) +(sort* nums '<) @result{} (0 1 2 3 4 5 6) @end group @group @@ -1096,17 +1119,23 @@ Note that the list in @code{nums} no longer contains 0; this is the same cons cell that it was before, but it is no longer the first one in the list. Don't assume a variable that formerly held the argument now holds -the entire sorted list! Instead, save the result of @code{sort} and use +the entire sorted list! Instead, save the result of @code{sort*} and use that. Most often we store the result back into the variable that held -the original list: +the original sequence: @example -(setq nums (sort nums '<)) +(setq nums (sort* nums '<)) @end example +In this implementation, @code{sort} is a function alias for +@code{sort*}, and accepts the same arguments. In older XEmacs, and in +current GNU Emacs, @code{sort} only accepted lists, and did not accept +the @var{key} argument, so the byte-compiler will warn you if you call +@code{sort} with more than two arguments. + @xref{Sorting}, for more functions that perform sorting. See @code{documentation} in @ref{Accessing Documentation}, for a -useful example of @code{sort}. +useful example of @code{sort*}. @end defun @node Sets And Lists diff -r a00bfbd64e0a -r 2e528066e2fc src/ChangeLog --- a/src/ChangeLog Mon Mar 29 23:23:33 2010 -0500 +++ b/src/ChangeLog Thu Apr 01 20:22:50 2010 +0100 @@ -1,3 +1,27 @@ +2010-03-31 Aidan Kehoe + + * fns.c (STRING_DATA_TO_OBJECT_ARRAY) + (BIT_VECTOR_TO_OBJECT_ARRAY, c_merge_predicate_key) + (c_merge_predicate_nokey, list_merge, array_merge) + (list_array_merge_into_list, list_list_merge_into_array) + (list_array_merge_into_array, CHECK_KEY_ARGUMENT, Fmerge) + (list_sort, array_sort, FsortX): + Move #'sort*, #'fill, #'merge from cl-seq.el to C, extending the + implementations of Fsort, Ffillarray, and merge() to do so. + + * keymap.c (keymap_submaps, map_keymap_sort_predicate) + (describe_map_sort_predicate): + Change the calling semantics of the C sort predicates to return a + non-nil Lisp object if the first argument is less than the second, + rather than C integers. + + * fontcolor-msw.c (sort_font_list_function): + * fileio.c (build_annotations): + * dired.c (Fdirectory_files): + * abbrev.c (Finsert_abbrev_table_description): + Call list_sort instead of Fsort, list_merge instead of merge() in + these functions. + 2010-03-29 Ben Wing * lisp.h (PRIVATE_UNVERIFIED_LIST_LOOP_7): diff -r a00bfbd64e0a -r 2e528066e2fc src/abbrev.c --- a/src/abbrev.c Mon Mar 29 23:23:33 2010 -0500 +++ b/src/abbrev.c Thu Apr 01 20:22:50 2010 +0100 @@ -524,7 +524,7 @@ map_obarray (table, record_symbol, &symbols); /* map_obarray (table, record_symbol, &closure); */ symbols = XCDR (symbols); - symbols = Fsort (symbols, Qstring_lessp); + symbols = list_sort (symbols, NULL, Qstring_lessp, Qidentity); if (!NILP (readable)) { diff -r a00bfbd64e0a -r 2e528066e2fc src/dired.c --- a/src/dired.c Mon Mar 29 23:23:33 2010 -0500 +++ b/src/dired.c Thu Apr 01 20:22:50 2010 +0100 @@ -180,7 +180,7 @@ unbind_to (speccount); /* This will close the dir */ if (NILP (nosort)) - list = Fsort (Fnreverse (list), Qstring_lessp); + list = list_sort (Fnreverse (list), NULL, Qstring_lessp, Qidentity); RETURN_UNGCPRO (list); } diff -r a00bfbd64e0a -r 2e528066e2fc src/fileio.c --- a/src/fileio.c Mon Mar 29 23:23:33 2010 -0500 +++ b/src/fileio.c Thu Apr 01 20:22:50 2010 +0100 @@ -3666,7 +3666,7 @@ annotations = Qnil; } Flength (res); /* Check basic validity of return value */ - annotations = merge (annotations, res, Qcar_less_than_car); + annotations = list_merge (annotations, res, NULL, Qlss, Qcar); p = Fcdr (p); } @@ -3697,7 +3697,7 @@ annotations = Qnil; } Flength (res); - annotations = merge (annotations, res, Qcar_less_than_car); + annotations = list_merge (annotations, res, NULL, Qlss, Qcar); p = Fcdr (p); } diff -r a00bfbd64e0a -r 2e528066e2fc src/fns.c --- a/src/fns.c Mon Mar 29 23:23:33 2010 -0500 +++ b/src/fns.c Thu Apr 01 20:22:50 2010 +0100 @@ -54,9 +54,9 @@ /* NOTE: This symbol is also used in lread.c */ #define FEATUREP_SYNTAX -Lisp_Object Qstring_lessp; +Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill; Lisp_Object Qidentity; -Lisp_Object Qvector, Qarray, Qbit_vector; +Lisp_Object Qvector, Qarray, Qbit_vector, QsortX; Lisp_Object Qbase64_conversion_error; @@ -1936,100 +1936,82 @@ return reversed_list; } -static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, - Lisp_Object lisp_arg, - int (*pred_fn) (Lisp_Object, Lisp_Object, - Lisp_Object lisp_arg)); - -/* The sort function should return > 0 if OBJ1 < OBJ2, < 0 otherwise. - NOTE: This is backwards from the way qsort() works. */ - -Lisp_Object -list_sort (Lisp_Object list, - Lisp_Object lisp_arg, - int (*pred_fn) (Lisp_Object obj1, Lisp_Object obj2, - Lisp_Object lisp_arg)) +static Lisp_Object +c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2, + Lisp_Object pred, Lisp_Object key_func) { - struct gcpro gcpro1, gcpro2, gcpro3; - Lisp_Object back, tem; - Lisp_Object front = list; - Lisp_Object len = Flength (list); - - if (XINT (len) < 2) - return list; - - len = make_int (XINT (len) / 2 - 1); - tem = Fnthcdr (len, list); - back = Fcdr (tem); - Fsetcdr (tem, Qnil); - - GCPRO3 (front, back, lisp_arg); - front = list_sort (front, lisp_arg, pred_fn); - back = list_sort (back, lisp_arg, pred_fn); - UNGCPRO; - return list_merge (front, back, lisp_arg, pred_fn); + struct gcpro gcpro1; + Lisp_Object args[3]; + + /* We could use call2() and call3() here, but we're called O(nlogn) times + for a sequence of length n, it make some sense to inline them. */ + args[0] = key_func; + args[1] = obj1; + args[2] = Qnil; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + + obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + + args[1] = obj2; + obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + + args[0] = pred; + args[1] = obj1; + args[2] = obj2; + + RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args))); } - -static int -merge_pred_function (Lisp_Object obj1, Lisp_Object obj2, - Lisp_Object pred) +static Lisp_Object +c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2, + Lisp_Object pred, Lisp_Object UNUSED (key_func)) { - Lisp_Object tmp; - - /* prevents the GC from happening in call2 */ - /* Emacs' GC doesn't actually relocate pointers, so this probably - isn't strictly necessary */ - int speccount = begin_gc_forbidden (); - tmp = call2 (pred, obj1, obj2); - unbind_to (speccount); - - if (NILP (tmp)) - return -1; - else - return 1; -} - -DEFUN ("sort", Fsort, 2, 2, 0, /* -Sort LIST, stably, comparing elements using PREDICATE. -Returns the sorted list. LIST is modified by side effects. -PREDICATE is called with two elements of LIST, and should return T -if the first element is "less" than the second. -*/ - (list, predicate)) -{ - return list_sort (list, predicate, merge_pred_function); + struct gcpro gcpro1; + Lisp_Object args[3]; + + /* This is (almost) the implementation of call2, it makes some sense to + inline it here. */ + args[0] = pred; + args[1] = obj1; + args[2] = obj2; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + + RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args))); } Lisp_Object -merge (Lisp_Object org_l1, Lisp_Object org_l2, - Lisp_Object pred) -{ - return list_merge (org_l1, org_l2, pred, merge_pred_function); -} - - -static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, - Lisp_Object lisp_arg, - int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg)) + Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func) { Lisp_Object value; Lisp_Object tail; Lisp_Object tem; Lisp_Object l1, l2; struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + int looped = 0; l1 = org_l1; l2 = org_l2; tail = Qnil; value = Qnil; + if (NULL == c_predicate) + { + c_predicate = EQ (key_func, Qidentity) ? + c_merge_predicate_nokey : c_merge_predicate_key; + } + /* It is sufficient to protect org_l1 and org_l2. When l1 and l2 are updated, we copy the new values back into the org_ vars. */ - GCPRO4 (org_l1, org_l2, lisp_arg, value); + GCPRO4 (org_l1, org_l2, predicate, value); while (1) { @@ -2050,7 +2032,7 @@ return value; } - if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0) + if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func))) { tem = l1; l1 = Fcdr (l1); @@ -2067,9 +2049,682 @@ else Fsetcdr (tail, tem); tail = tem; + + if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + /* Just check the lists aren't circular:*/ + { + EXTERNAL_LIST_LOOP_1 (l1) + { + } + } + { + EXTERNAL_LIST_LOOP_1 (l2) + { + } + } + } +} + +static void +array_merge (Lisp_Object *dest, Elemcount dest_len, + Lisp_Object *front, Elemcount front_len, + Lisp_Object *back, Elemcount back_len, + Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func) +{ + Elemcount ii, fronting, backing; + Lisp_Object *front_staging = front; + Lisp_Object *back_staging = back; + struct gcpro gcpro1, gcpro2; + + assert (dest_len == (back_len + front_len)); + + if (0 == dest_len) + { + return; + } + + if (front >= dest && front < (dest + dest_len)) + { + front_staging = alloca_array (Lisp_Object, front_len); + + for (ii = 0; ii < front_len; ++ii) + { + front_staging[ii] = front[ii]; + } + } + + if (back >= dest && back < (dest + dest_len)) + { + back_staging = alloca_array (Lisp_Object, back_len); + + for (ii = 0; ii < back_len; ++ii) + { + back_staging[ii] = back[ii]; + } + } + + GCPRO2 (front_staging[0], back_staging[0]); + gcpro1.nvars = front_len; + gcpro2.nvars = back_len; + + for (ii = fronting = backing = 0; ii < dest_len; ++ii) + { + if (fronting >= front_len) + { + while (ii < dest_len) + { + dest[ii] = back_staging[backing]; + ++ii, ++backing; + } + UNGCPRO; + return; + } + + if (backing >= back_len) + { + while (ii < dest_len) + { + dest[ii] = front_staging[fronting]; + ++ii, ++fronting; + } + UNGCPRO; + return; + } + + if (NILP (c_predicate (back_staging[backing], front_staging[fronting], + predicate, key_func))) + { + dest[ii] = front_staging[fronting]; + ++fronting; + } + else + { + dest[ii] = back_staging[backing]; + ++backing; + } + } + + UNGCPRO; +} + +static Lisp_Object +list_array_merge_into_list (Lisp_Object list, + Lisp_Object *array, Elemcount array_len, + Lisp_Object (*c_predicate) (Lisp_Object, + Lisp_Object, + Lisp_Object, + Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func, + Boolint reverse_order) +{ + Lisp_Object tail = Qnil, value = Qnil; + struct gcpro gcpro1, gcpro2, gcpro3; + Elemcount array_index = 0; + int looped = 0; + + GCPRO3 (list, tail, value); + + while (1) + { + if (NILP (list)) + { + UNGCPRO; + + if (NILP (tail)) + { + return Flist (array_len, array); + } + + Fsetcdr (tail, Flist (array_len - array_index, array + array_index)); + return value; + } + + if (array_index >= array_len) + { + UNGCPRO; + if (NILP (tail)) + { + return list; + } + + Fsetcdr (tail, list); + return value; + } + + + if (reverse_order ? + !NILP (c_predicate (Fcar (list), array [array_index], predicate, + key_func)) : + NILP (c_predicate (array [array_index], Fcar (list), predicate, + key_func))) + { + if (NILP (tail)) + { + value = tail = list; + } + else + { + Fsetcdr (tail, list); + tail = XCDR (tail); + } + + list = Fcdr (list); + } + else + { + if (NILP (tail)) + { + value = tail = Fcons (array [array_index], Qnil); + } + else + { + Fsetcdr (tail, Fcons (array [array_index], tail)); + tail = XCDR (tail); + } + ++array_index; + } + + if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + { + EXTERNAL_LIST_LOOP_1 (list) + { + } + } + } +} + +static void +list_list_merge_into_array (Lisp_Object *output, Elemcount output_len, + Lisp_Object list_one, Lisp_Object list_two, + Lisp_Object (*c_predicate) (Lisp_Object, + Lisp_Object, + Lisp_Object, + Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func) +{ + Elemcount output_index = 0; + + while (output_index < output_len) + { + if (NILP (list_one)) + { + while (output_index < output_len) + { + output [output_index] = Fcar (list_two); + list_two = Fcdr (list_two), ++output_index; + } + return; + } + + if (NILP (list_two)) + { + while (output_index < output_len) + { + output [output_index] = Fcar (list_one); + list_one = Fcdr (list_one), ++output_index; + } + return; + } + + if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate, + key_func))) + { + output [output_index] = XCAR (list_one); + list_one = XCDR (list_one); + } + else + { + output [output_index] = XCAR (list_two); + list_two = XCDR (list_two); + } + + ++output_index; + + /* No need to check for circularity. */ + } +} + +static void +list_array_merge_into_array (Lisp_Object *output, Elemcount output_len, + Lisp_Object list, + Lisp_Object *array, Elemcount array_len, + Lisp_Object (*c_predicate) (Lisp_Object, + Lisp_Object, + Lisp_Object, + Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func, + Boolint reverse_order) +{ + Elemcount output_index = 0, array_index = 0; + + while (output_index < output_len) + { + if (NILP (list)) + { + if (array_len - array_index != output_len - output_index) + { + invalid_state ("List length modified during merge", Qunbound); + } + + while (array_index < array_len) + { + output [output_index++] = array [array_index++]; + } + + return; + } + + if (array_index >= array_len) + { + while (output_index < output_len) + { + output [output_index++] = Fcar (list); + list = Fcdr (list); + } + + return; + } + + if (reverse_order ? + !NILP (c_predicate (Fcar (list), array [array_index], predicate, + key_func)) : + NILP (c_predicate (array [array_index], Fcar (list), predicate, + key_func))) + { + output [output_index] = XCAR (list); + list = XCDR (list); + } + else + { + output [output_index] = array [array_index]; + ++array_index; + } + + ++output_index; } } +#define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \ + do { \ + c_array = alloca_array (Lisp_Object, len); \ + for (counter = 0; counter < len; ++counter) \ + { \ + c_array[counter] = make_char (itext_ichar (strdata)); \ + INC_IBYTEPTR (strdata); \ + } \ + } while (0) + +#define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \ + c_array = alloca_array (Lisp_Object, len); \ + for (counter = 0; counter < len; ++counter) \ + { \ + c_array[counter] = make_int (bit_vector_bit (v, counter)); \ + } \ + } while (0) + +/* This macro might eventually find a better home than here. */ + +#define CHECK_KEY_ARGUMENT(key, c_predicate) \ + do { \ + if (NILP (key)) \ + { \ + key = Qidentity; \ + } \ + \ + if (EQ (key, Qidentity)) \ + { \ + c_predicate = c_merge_predicate_nokey; \ + } \ + else \ + { \ + key = indirect_function (key, 1); \ + c_predicate = c_merge_predicate_key; \ + } \ + } while (0) + +DEFUN ("merge", Fmerge, 4, MANY, 0, /* +Destructively merge SEQUENCE-ONE and SEQUENCE-TWO, producing a new sequence. + +TYPE is the type of sequence to return. PREDICATE is a `less-than' +predicate on the elements. + +Optional keyword argument KEY is a function used to extract an object to be +used for comparison from each element of SEQUENCE-ONE and SEQUENCE-TWO. + +arguments: (TYPE SEQUENCE-ONE SEQUENCE-TWO PREDICATE &key (KEY #'IDENTITY)) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object type = args[0], sequence_one = args[1], sequence_two = args[2], + predicate = args[3], result = Qnil; + Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object); + + PARSE_KEYWORDS (Qmerge, nargs, args, 4, 1, (key), NULL, 0); + + CHECK_SEQUENCE (sequence_one); + CHECK_SEQUENCE (sequence_two); + + CHECK_KEY_ARGUMENT (key, c_predicate); + + if (EQ (type, Qlist) && (LISTP (sequence_one) || LISTP (sequence_two))) + { + if (NILP (sequence_two)) + { + result = Fappend (2, args + 1); + } + else if (NILP (sequence_one)) + { + args[3] = Qnil; /* Overwriting PREDICATE, and losing its GC + protection, but that doesn't matter. */ + result = Fappend (2, args + 2); + } + else if (CONSP (sequence_one) && CONSP (sequence_two)) + { + result = list_merge (sequence_one, sequence_two, c_predicate, + predicate, key); + } + else + { + Lisp_Object *array_storage, swap; + Elemcount array_length, i; + Boolint reverse_order = 0; + + if (!CONSP (sequence_one)) + { + /* Make sequence_one the cons, sequence_two the array: */ + swap = sequence_one; + sequence_one = sequence_two; + sequence_two = swap; + reverse_order = 1; + } + + if (VECTORP (sequence_two)) + { + array_storage = XVECTOR_DATA (sequence_two); + array_length = XVECTOR_LENGTH (sequence_two); + } + else if (STRINGP (sequence_two)) + { + Ibyte *strdata = XSTRING_DATA (sequence_two); + array_length = string_char_length (sequence_two); + /* No need to GCPRO, characters are immediate. */ + STRING_DATA_TO_OBJECT_ARRAY (strdata, array_storage, i, + array_length); + + } + else + { + Lisp_Bit_Vector *v = XBIT_VECTOR (sequence_two); + array_length = bit_vector_length (v); + /* No need to GCPRO, fixnums are immediate. */ + BIT_VECTOR_TO_OBJECT_ARRAY (v, array_storage, i, array_length); + } + + result = list_array_merge_into_list (sequence_one, + array_storage, array_length, + c_predicate, + predicate, key, + reverse_order); + } + } + else + { + Elemcount sequence_one_len = XINT (Flength (sequence_one)), + sequence_two_len = XINT (Flength (sequence_two)), i; + Elemcount output_len = 1 + sequence_one_len + sequence_two_len; + Lisp_Object *output = alloca_array (Lisp_Object, output_len), + *sequence_one_storage = NULL, *sequence_two_storage = NULL; + Boolint do_coerce = !(EQ (type, Qvector) || EQ (type, Qstring) + || EQ (type, Qbit_vector) || EQ (type, Qlist)); + Ibyte *strdata = NULL; + Lisp_Bit_Vector *v = NULL; + struct gcpro gcpro1; + + output[0] = do_coerce ? Qlist : type; + for (i = 1; i < output_len; ++i) + { + output[i] = Qnil; + } + + GCPRO1 (output[0]); + gcpro1.nvars = output_len; + + if (VECTORP (sequence_one)) + { + sequence_one_storage = XVECTOR_DATA (sequence_one); + } + else if (STRINGP (sequence_one)) + { + strdata = XSTRING_DATA (sequence_one); + STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_one_storage, + i, sequence_one_len); + } + else if (BIT_VECTORP (sequence_one)) + { + v = XBIT_VECTOR (sequence_one); + BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_one_storage, + i, sequence_one_len); + } + + if (VECTORP (sequence_two)) + { + sequence_two_storage = XVECTOR_DATA (sequence_two); + } + else if (STRINGP (sequence_two)) + { + strdata = XSTRING_DATA (sequence_two); + STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_two_storage, + i, sequence_two_len); + } + else if (BIT_VECTORP (sequence_two)) + { + v = XBIT_VECTOR (sequence_two); + BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_two_storage, + i, sequence_two_len); + } + + if (LISTP (sequence_one) && LISTP (sequence_two)) + { + list_list_merge_into_array (output + 1, output_len - 1, + sequence_one, sequence_two, + c_predicate, predicate, + key); + } + else if (LISTP (sequence_one)) + { + list_array_merge_into_array (output + 1, output_len - 1, + sequence_one, + sequence_two_storage, + sequence_two_len, + c_predicate, predicate, + key, 0); + } + else if (LISTP (sequence_two)) + { + list_array_merge_into_array (output + 1, output_len - 1, + sequence_two, + sequence_one_storage, + sequence_one_len, + c_predicate, predicate, + key, 1); + } + else + { + array_merge (output + 1, output_len - 1, + sequence_one_storage, sequence_one_len, + sequence_two_storage, sequence_two_len, + c_predicate, predicate, + key); + } + + result = Ffuncall (output_len, output); + + if (do_coerce) + { + result = call2 (Qcoerce, result, type); + } + + UNGCPRO; + } + + return result; +} + +/* The sort function should return non-nil if OBJ1 < OBJ2, nil otherwise. + NOTE: This is backwards from the way qsort() works. */ +Lisp_Object +list_sort (Lisp_Object list, + Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func) +{ + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + Lisp_Object back, tem; + Lisp_Object front = list; + Lisp_Object len = Flength (list); + + if (XINT (len) < 2) + return list; + + if (NULL == c_predicate) + { + c_predicate = EQ (key_func, Qidentity) ? c_merge_predicate_nokey : + c_merge_predicate_key; + } + + len = make_int (XINT (len) / 2 - 1); + tem = Fnthcdr (len, list); + back = Fcdr (tem); + Fsetcdr (tem, Qnil); + + GCPRO4 (front, back, predicate, key_func); + front = list_sort (front, c_predicate, predicate, key_func); + back = list_sort (back, c_predicate, predicate, key_func); + + RETURN_UNGCPRO (list_merge (front, back, c_predicate, predicate, key_func)); +} + +static void +array_sort (Lisp_Object *array, Elemcount array_len, + Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func) +{ + Elemcount split; + + if (array_len < 2) + return; + + split = array_len / 2; + + array_sort (array, split, c_predicate, predicate, key_func); + array_sort (array + split, array_len - split, c_predicate, predicate, + key_func); + array_merge (array, array_len, array, split, array + split, + array_len - split, c_predicate, predicate, key_func); +} + +DEFUN ("sort*", FsortX, 2, MANY, 0, /* +Sort SEQUENCE, comparing elements using PREDICATE. +Returns the sorted sequence. SEQUENCE is modified by side effect. + +PREDICATE is called with two elements of SEQUENCE, and should return t if +the first element is `less' than the second. + +Optional keyword argument KEY is a function used to extract an object to be +used for comparison from each element of SEQUENCE. + +In this implementation, sorting is always stable; but call `stable-sort' if +this stability is important to you, other implementations may not make the +same guarantees. + +arguments: (SEQUENCE PREDICATE &key (KEY #'IDENTITY)) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence = args[0], predicate = args[1]; + Lisp_Object *sequence_carray; + Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object); + Elemcount sequence_len, i; + + PARSE_KEYWORDS (QsortX, nargs, args, 2, 1, (key), NULL, 0); + + CHECK_SEQUENCE (sequence); + + CHECK_KEY_ARGUMENT (key, c_predicate); + + if (LISTP (sequence)) + { + sequence = list_sort (sequence, c_predicate, predicate, key); + } + else if (VECTORP (sequence)) + { + array_sort (XVECTOR_DATA (sequence), XVECTOR_LENGTH (sequence), + c_predicate, predicate, key); + } + else if (STRINGP (sequence)) + { + Ibyte *strdata = XSTRING_DATA (sequence); + Elemcount string_ascii_begin = 0; + Ichar ch; + + sequence_len = string_char_length (sequence); + + STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_carray, i, sequence_len); + + /* No GCPRO necessary, characters are immediate. */ + array_sort (sequence_carray, sequence_len, c_predicate, predicate, key); + + strdata = XSTRING_DATA (sequence); + + CHECK_LISP_WRITEABLE (sequence); + for (i = 0; i < sequence_len; ++i) + { + ch = XCHAR (sequence_carray[i]); + strdata += set_itext_ichar (strdata, ch); + + if (string_ascii_begin <= i) + { + if (byte_ascii_p (ch)) + { + string_ascii_begin = i; + } + else + { + string_ascii_begin = MAX_STRING_ASCII_BEGIN; + } + } + } + + XSET_STRING_ASCII_BEGIN (sequence, min (string_ascii_begin, + MAX_STRING_ASCII_BEGIN)); + bump_string_modiff (sequence); + sledgehammer_check_ascii_begin (sequence); + } + else if (BIT_VECTORP (sequence)) + { + Lisp_Bit_Vector *v = XBIT_VECTOR (sequence); + sequence_len = bit_vector_length (v); + + BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_carray, i, sequence_len); + + /* No GCPRO necessary, bits are immediate. */ + array_sort (sequence_carray, sequence_len, c_predicate, predicate, key); + + for (i = 0; i < sequence_len; ++i) + { + set_bit_vector_bit (v, i, XINT (sequence_carray [i])); + } + } + + return sequence; +} /************************************************************************/ /* property-list functions */ @@ -3124,69 +3779,121 @@ } -DEFUN ("fillarray", Ffillarray, 2, 2, 0, /* -Destructively modify ARRAY by replacing each element with ITEM. -ARRAY is a vector, bit vector, or string. +DEFUN ("fill", Ffill, 2, MANY, 0, /* +Destructively modify SEQUENCE by replacing each element with ITEM. +SEQUENCE is a list, vector, bit vector, or string. + +Optional keyword START is the index of the first element of SEQUENCE +to be modified, and defaults to zero. Optional keyword END is the +exclusive upper bound on the elements of SEQUENCE to be modified, and +defaults to the length of SEQUENCE. + +arguments: (SEQUENCE ITEM &key (START 0) END) */ - (array, item)) + (int nargs, Lisp_Object *args)) { - retry: - if (STRINGP (array)) + Lisp_Object sequence = args[0]; + Lisp_Object item = args[1]; + Elemcount starting = 0, ending = EMACS_INT_MAX, ii; + + PARSE_KEYWORDS (Qfill, nargs, args, 2, 2, (start, end), + (start = Qzero, end = Qunbound), 0); + + CHECK_NATNUM (start); + starting = XINT (start); + + if (!UNBOUNDP (end)) { - Bytecount old_bytecount = XSTRING_LENGTH (array); - Bytecount new_bytecount; - Bytecount item_bytecount; + CHECK_NATNUM (end); + ending = XINT (end); + } + + retry: + if (STRINGP (sequence)) + { + Bytecount old_bytecount, new_bytecount, item_bytecount; Ibyte item_buf[MAX_ICHAR_LEN]; Ibyte *p; - Ibyte *end; + Ibyte *pend; CHECK_CHAR_COERCE_INT (item); - CHECK_LISP_WRITEABLE (array); - sledgehammer_check_ascii_begin (array); + CHECK_LISP_WRITEABLE (sequence); + sledgehammer_check_ascii_begin (sequence); item_bytecount = set_itext_ichar (item_buf, XCHAR (item)); - new_bytecount = item_bytecount * (Bytecount) string_char_length (array); - - resize_string (array, -1, new_bytecount - old_bytecount); - - for (p = XSTRING_DATA (array), end = p + new_bytecount; - p < end; - p += item_bytecount) + + p = XSTRING_DATA (sequence); + p = (Ibyte *) itext_n_addr (p, starting); + old_bytecount = p - XSTRING_DATA (sequence); + + ending = min (ending, string_char_length (sequence)); + pend = (Ibyte *) itext_n_addr (p, ending - starting); + + new_bytecount = old_bytecount + (item_bytecount * (ending - starting)); + resize_string (sequence, -1, new_bytecount - old_bytecount); + + for (; p < pend; p += item_bytecount) memcpy (p, item_buf, item_bytecount); *p = '\0'; - XSET_STRING_ASCII_BEGIN (array, + XSET_STRING_ASCII_BEGIN (sequence, item_bytecount == 1 ? min (new_bytecount, MAX_STRING_ASCII_BEGIN) : 0); - bump_string_modiff (array); - sledgehammer_check_ascii_begin (array); + bump_string_modiff (sequence); + sledgehammer_check_ascii_begin (sequence); } - else if (VECTORP (array)) + else if (VECTORP (sequence)) { - Lisp_Object *p = XVECTOR_DATA (array); - Elemcount len = XVECTOR_LENGTH (array); - CHECK_LISP_WRITEABLE (array); - while (len--) - *p++ = item; + Lisp_Object *p = XVECTOR_DATA (sequence); + CHECK_LISP_WRITEABLE (sequence); + + ending = min (ending, XVECTOR_LENGTH (sequence)); + for (ii = starting; ii < ending; ++ii) + { + p[ii] = item; + } } - else if (BIT_VECTORP (array)) + else if (BIT_VECTORP (sequence)) { - Lisp_Bit_Vector *v = XBIT_VECTOR (array); - Elemcount len = bit_vector_length (v); + Lisp_Bit_Vector *v = XBIT_VECTOR (sequence); int bit; CHECK_BIT (item); bit = XINT (item); - CHECK_LISP_WRITEABLE (array); - while (len--) - set_bit_vector_bit (v, len, bit); + CHECK_LISP_WRITEABLE (sequence); + + ending = min (ending, bit_vector_length (v)); + for (ii = starting; ii < ending; ++ii) + { + set_bit_vector_bit (v, ii, bit); + } + } + else if (LISTP (sequence)) + { + Elemcount counting = 0; + + EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + if (counting >= starting) + { + if (counting < ending) + { + XSETCAR (tail, item); + } + else if (counting == ending) + { + break; + } + } + ++counting; + } } else { - array = wrong_type_argument (Qarrayp, array); + sequence = wrong_type_argument (Qsequencep, sequence); goto retry; } - return array; + return sequence; } Lisp_Object @@ -4758,12 +5465,16 @@ INIT_LISP_OBJECT (bit_vector); DEFSYMBOL (Qstring_lessp); + DEFSYMBOL (Qsort); + DEFSYMBOL (Qmerge); + DEFSYMBOL (Qfill); DEFSYMBOL (Qidentity); DEFSYMBOL (Qvector); DEFSYMBOL (Qarray); DEFSYMBOL (Qstring); DEFSYMBOL (Qlist); DEFSYMBOL (Qbit_vector); + defsymbol (&QsortX, "sort*"); DEFSYMBOL (Qyes_or_no_p); @@ -4814,7 +5525,9 @@ DEFSUBR (Fremrassq); DEFSUBR (Fnreverse); DEFSUBR (Freverse); - DEFSUBR (Fsort); + DEFSUBR (FsortX); + Ffset (intern ("sort"), QsortX); + DEFSUBR (Fmerge); DEFSUBR (Fplists_eq); DEFSUBR (Fplists_equal); DEFSUBR (Flax_plists_eq); @@ -4839,7 +5552,9 @@ DEFSUBR (Fequal); DEFSUBR (Fequalp); DEFSUBR (Fold_equal); - DEFSUBR (Ffillarray); + DEFSUBR (Ffill); + Ffset (intern ("fillarray"), Qfill); + DEFSUBR (Fnconc); DEFSUBR (FmapcarX); DEFSUBR (Fmapvector); diff -r a00bfbd64e0a -r 2e528066e2fc src/fontcolor-msw.c --- a/src/fontcolor-msw.c Mon Mar 29 23:23:33 2010 -0500 +++ b/src/fontcolor-msw.c Thu Apr 01 20:22:50 2010 +0100 @@ -1172,9 +1172,10 @@ "family::::charset" for TrueType fonts, "family::size::charset" otherwise. */ -static int +static Lisp_Object sort_font_list_function (Lisp_Object obj1, Lisp_Object obj2, - Lisp_Object UNUSED (pred)) + Lisp_Object UNUSED (pred), + Lisp_Object UNUSED (key_function)) { Ibyte *font1, *font2; Ibyte *c1, *c2; @@ -1188,16 +1189,16 @@ 5. Courier New over other families. */ - /* The sort function should return > 0 if OBJ1 < OBJ2, < 0 otherwise. + /* The sort function should return non-nil if OBJ1 < OBJ2, nil otherwise. NOTE: This is backwards from the way qsort() works. */ t1 = !NILP (XCDR (obj1)); t2 = !NILP (XCDR (obj2)); if (t1 && !t2) - return 1; + return Qt; if (t2 && !t1) - return -1; + return Qnil; font1 = XSTRING_DATA (XCAR (obj1)); font2 = XSTRING_DATA (XCAR (obj2)); @@ -1209,9 +1210,9 @@ t2 = !qxestrcasecmp_ascii (c2 + 1, "western"); if (t1 && !t2) - return 1; + return Qt; if (t2 && !t1) - return -1; + return Qnil; c1 -= 2; c2 -= 2; @@ -1219,9 +1220,9 @@ t2 = *c2 == ':'; if (t1 && !t2) - return 1; + return Qt; if (t2 && !t1) - return -1; + return Qnil; if (!t1 && !t2) { @@ -1234,25 +1235,25 @@ t2 = qxeatoi (c2 + 1) - 10; if (abs (t1) < abs (t2)) - return 1; + return Qt; else if (abs (t2) < abs (t1)) - return -1; + return Qnil; else if (t1 < t2) /* Prefer a smaller font over a larger one just as far away because the smaller one won't upset the total line height if it's just a few chars. */ - return 1; + return Qt; } t1 = !qxestrncasecmp_ascii (font1, "courier new:", 12); t2 = !qxestrncasecmp_ascii (font2, "courier new:", 12); if (t1 && !t2) - return 1; + return Qt; if (t2 && !t1) - return -1; + return Qnil; - return -1; + return Qnil; } /* @@ -1278,7 +1279,7 @@ qxeEnumFontFamiliesEx (hdc, &logfont, (FONTENUMPROCW) font_enum_callback_1, (LPARAM) (&font_enum), 0); - return list_sort (font_enum.list, Qnil, sort_font_list_function); + return list_sort (font_enum.list, sort_font_list_function, Qnil, Qidentity); } static HFONT diff -r a00bfbd64e0a -r 2e528066e2fc src/general-slots.h --- a/src/general-slots.h Mon Mar 29 23:23:33 2010 -0500 +++ b/src/general-slots.h Thu Apr 01 20:22:50 2010 +0100 @@ -72,6 +72,7 @@ SYMBOL_KEYWORD (Q_callback); SYMBOL_KEYWORD (Q_callback_ex); SYMBOL (Qcancel); +SYMBOL (Qcar); SYMBOL (Qcategory); SYMBOL (Qccl_program); SYMBOL (Qcenter); @@ -116,6 +117,7 @@ SYMBOL (Qduplex); SYMBOL (Qemergency); SYMBOL (Qempty); +SYMBOL_KEYWORD (Q_end); SYMBOL (Qencode_as_utf_8); SYMBOL (Qeq); SYMBOL (Qeql); @@ -171,6 +173,7 @@ SYMBOL_KEYWORD (Q_justify); SYMBOL_KEYWORD (Q_vertically_justify); SYMBOL_KEYWORD (Q_horizontally_justify); +SYMBOL_KEYWORD (Q_key); SYMBOL (Qkey); SYMBOL (Qkey_assoc); SYMBOL (Qkey_mapping); @@ -189,6 +192,7 @@ SYMBOL (Qlittle_endian); SYMBOL (Qlocale); SYMBOL (Qlow); +SYMBOL_GENERAL (Qlss, "<"); SYMBOL (Qmagic); SYMBOL_KEYWORD (Q_margin_width); SYMBOL (Qmarkers); @@ -263,6 +267,7 @@ SYMBOL (Qspace); SYMBOL (Qspecifier); SYMBOL (Qstandard); +SYMBOL_KEYWORD (Q_start); SYMBOL (Qstream); SYMBOL (Qstring); SYMBOL_KEYWORD (Q_style); diff -r a00bfbd64e0a -r 2e528066e2fc src/keymap.c --- a/src/keymap.c Mon Mar 29 23:23:33 2010 -0500 +++ b/src/keymap.c Thu Apr 01 20:22:50 2010 +0100 @@ -737,8 +737,10 @@ return 0; } -static int map_keymap_sort_predicate (Lisp_Object obj1, Lisp_Object obj2, - Lisp_Object pred); +static Lisp_Object map_keymap_sort_predicate (Lisp_Object obj1, + Lisp_Object obj2, + Lisp_Object pred, + Lisp_Object key_func); static Lisp_Object keymap_submaps (Lisp_Object keymap) @@ -761,9 +763,8 @@ elisp_maphash (keymap_submaps_mapper, k->table, &keymap_submaps_closure); /* keep it sorted so that the result of accessible-keymaps is ordered */ - k->sub_maps_cache = list_sort (result, - Qnil, - map_keymap_sort_predicate); + k->sub_maps_cache = list_sort (result, map_keymap_sort_predicate, + Qnil, Qidentity); UNGCPRO; } return k->sub_maps_cache; @@ -2889,9 +2890,10 @@ /* used by map_keymap_sorted(), describe_map_sort_predicate(), and keymap_submaps(). */ -static int +static Lisp_Object map_keymap_sort_predicate (Lisp_Object obj1, Lisp_Object obj2, - Lisp_Object UNUSED (pred)) + Lisp_Object UNUSED (pred), + Lisp_Object UNUSED (key_func)) { /* obj1 and obj2 are conses with keysyms in their cars. Cdrs are ignored. */ @@ -2904,7 +2906,7 @@ obj2 = XCAR (obj2); if (EQ (obj1, obj2)) - return -1; + return Qnil; bit1 = MODIFIER_HASH_KEY_BITS (obj1); bit2 = MODIFIER_HASH_KEY_BITS (obj2); @@ -2934,7 +2936,7 @@ /* all symbols (non-ASCIIs) come after characters (ASCIIs) */ if (XTYPE (obj1) != XTYPE (obj2)) - return SYMBOLP (obj2) ? 1 : -1; + return SYMBOLP (obj2) ? Qt : Qnil; if (! bit1 && CHARP (obj1)) /* they're both ASCII */ { @@ -2942,24 +2944,24 @@ int o2 = XCHAR (obj2); if (o1 == o2 && /* If one started out as a symbol and the */ sym1_p != sym2_p) /* other didn't, the symbol comes last. */ - return sym2_p ? 1 : -1; - - return o1 < o2 ? 1 : -1; /* else just compare them */ + return sym2_p ? Qt : Qnil; + + return o1 < o2 ? Qt : Qnil; /* else just compare them */ } /* else they're both symbols. If they're both buckys, then order them. */ if (bit1 && bit2) - return bit1 < bit2 ? 1 : -1; + return bit1 < bit2 ? Qt : Qnil; /* if only one is a bucky, then it comes later */ if (bit1 || bit2) - return bit2 ? 1 : -1; + return bit2 ? Qt : Qnil; /* otherwise, string-sort them. */ { Ibyte *s1 = XSTRING_DATA (XSYMBOL (obj1)->name); Ibyte *s2 = XSTRING_DATA (XSYMBOL (obj2)->name); - return 0 > qxestrcmp (s1, s2) ? 1 : -1; + return 0 > qxestrcmp (s1, s2) ? Qt : Qnil; } } @@ -2987,7 +2989,7 @@ c1.result_locative = &contents; elisp_maphash (map_keymap_sorted_mapper, keymap_table, &c1); } - contents = list_sort (contents, Qnil, map_keymap_sort_predicate); + contents = list_sort (contents, map_keymap_sort_predicate, Qnil, Qidentity); for (; !NILP (contents); contents = XCDR (contents)) { Lisp_Object keysym = XCAR (XCAR (contents)); @@ -4080,9 +4082,9 @@ } -static int +static Lisp_Object describe_map_sort_predicate (Lisp_Object obj1, Lisp_Object obj2, - Lisp_Object pred) + Lisp_Object pred, Lisp_Object key_func) { /* obj1 and obj2 are conses of the form ( ( . ) . ) @@ -4094,9 +4096,9 @@ bit1 = XINT (XCDR (obj1)); bit2 = XINT (XCDR (obj2)); if (bit1 != bit2) - return bit1 < bit2 ? 1 : -1; + return bit1 < bit2 ? Qt : Qnil; else - return map_keymap_sort_predicate (obj1, obj2, pred); + return map_keymap_sort_predicate (obj1, obj2, pred, key_func); } /* Elide 2 or more consecutive numeric keysyms bound to the same thing, @@ -4204,7 +4206,7 @@ if (!NILP (list)) { - list = list_sort (list, Qnil, describe_map_sort_predicate); + list = list_sort (list, describe_map_sort_predicate, Qnil, Qidentity); buffer_insert_ascstring (buf, "\n"); while (!NILP (list)) { diff -r a00bfbd64e0a -r 2e528066e2fc src/lisp.h --- a/src/lisp.h Mon Mar 29 23:23:33 2010 -0500 +++ b/src/lisp.h Thu Apr 01 20:22:50 2010 +0100 @@ -5170,15 +5170,21 @@ EXFUN (Freplace_list, 2); MODULE_API EXFUN (Freverse, 1); EXFUN (Fsafe_length, 1); -EXFUN (Fsort, 2); EXFUN (Fstring_equal, 2); EXFUN (Fstring_lessp, 2); EXFUN (Fsubseq, 3); EXFUN (Fvalid_plist_p, 1); -Lisp_Object list_sort (Lisp_Object, Lisp_Object, - int (*) (Lisp_Object, Lisp_Object, Lisp_Object)); -Lisp_Object merge (Lisp_Object, Lisp_Object, Lisp_Object); +Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, + Lisp_Object (*c_predicate) (Lisp_Object o1, + Lisp_Object o2, + Lisp_Object pred, + Lisp_Object keyf), + Lisp_Object predicate, Lisp_Object key_func); +Lisp_Object list_sort (Lisp_Object list, + Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object predicate, Lisp_Object key_func); void bump_string_modiff (Lisp_Object); Lisp_Object memq_no_quit (Lisp_Object, Lisp_Object); diff -r a00bfbd64e0a -r 2e528066e2fc src/symbols.c --- a/src/symbols.c Mon Mar 29 23:23:33 2010 -0500 +++ b/src/symbols.c Thu Apr 01 20:22:50 2010 +0100 @@ -500,7 +500,8 @@ closure.accumulation = Qnil; GCPRO1 (closure.accumulation); map_obarray (Vobarray, apropos_mapper, &closure); - closure.accumulation = Fsort (closure.accumulation, Qstring_lessp); + closure.accumulation = list_sort (closure.accumulation, NULL, Qstring_lessp, + Qidentity); UNGCPRO; return closure.accumulation; }