Mercurial > hg > xemacs-beta
changeset 5190:1c1d8843de5e
merge
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Mon, 05 Apr 2010 00:18:49 -0500 |
| parents | b65692aa90d8 (current diff) 000287f8053b (diff) |
| children | 71ee43b8a74d |
| files | src/ChangeLog src/lisp.h |
| diffstat | 30 files changed, 1255 insertions(+), 337 deletions(-) [+] |
line wrap: on
line diff
--- a/CHANGES-beta Sun Apr 04 23:46:50 2010 -0500 +++ b/CHANGES-beta Mon Apr 05 00:18:49 2010 -0500 @@ -105,7 +105,73 @@ -- Fix long-standing bug: searching for Control-1 chars didn't work -- Turn on `load-ignore-out-of-date-elc-files' by default +by Aidan Kehoe: +Documentation: + +-- add argument information to remaining MANY or UNEVALLED C subrs. +-- add arglist info for autoloaded functions and macros. +-- correct the docstring for #'range-table-type. +-- change "special form" to "special operator" in our sources and manuals +-- use DOC for dumped file names; Xref to source-lisp if readable, symbol-file +-- update documentation for #'sort in the lispref + +Tests: + +-- add tests for the regexp-ranges-treat-control-1-chars badly bug. +-- fix some test failures, mule-tests.el. + +Lisp API: + +-- add `file-system-ignore-case-p', use it. +-- if STRING is constant, call regexp-quote at compile time. +-- make #'letf not error if handed a #'values form. +-- rationalise duplicated functionality, #'custom-quote, #'quote-maybe. +-- serialise non-default hash table rehash thresholds correctly; use this. +-- fix issue 546, use next-single-char-property-change in list-mode.el +-- make COLUMN optional in #'indent-region, as in GNU. +-- use keywords, not ordinary symbols, in the structure syntax for hash tables. +-- fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums +-- move the various map* functions to C; add #'map-into. +-- make canoncase visible to Lisp; use it with chars in internal_equalp. +-- move #'some, #'every to C, implementing them with mapcarX. +-- remove a couple of XEmacs-specific duplicate functions, find-paths.el +-- add a new optional ESCAPE-CHAR argument to #'split-string-by-char. +-- add #'constantly, as specified by ANSI Common Lisp. +-- handle the :from-end argument correctly, #'delete-duplicates compiler macro. +-- make #'substring an alias of #'subseq; give the latter the byte code. +-- remove #'byte-compile-compiled-obj-to-list, bytecomp.el +-- handle (function ...) specially, cl-prettyprint. +-- move #'merge, #'sort*, #'fill to C. alias #'sort, #'fillarray to latter two. + +Lisp implementation: + +-- don't cons with #'mapcar calls where the result is discarded +-- fix modeline-mousable, other faces that inherit from modeline, on startup. +-- be much more comprehensive in our use of byte-compile-funarg. +-- resolve the unregistered-CCL-programs-get-garbage-collected problem + correctly +-- remove attempted support for 1996-era emacs without self-quoting keywords. +-- use uninterned symbols instead of variable names with _ +-- eliminate funcalls, #'handle-pre-motion-command-current-command-is-motion +-- make iso-left-tab equivalent to shift-tab, XFree86 +-- behave better with no database support or no associated font, descr-text.el +-- use #'function-arglist, etc. from help.el, not reimplementing them, + hyper-apropos + +internal implementation: + +-- remove Fsave_window_excursion from window.c, it's overridden by Lisp. +-- make readlink_or_correct_case function correctly on Darwin. +-- no need to fatal () on startup if $PWD doesn't exist; chdir to "/" instead. +-- don't attempt to free dumped data, alloc.c:resize_string() +-- call character_to_event on characters received from XIM, event-Xt.c +-- dump the arabic-iso8859-6 character set, again, for the sake of XKB input +-- always use our rint(), for rounding consistency with the bignum code. +-- be more careful about canonical integer forms when dealing with ratios. +-- don't use Boyer-Moore if repeated octets & case-insensitive search. +-- do not assume #'format-decode exists in fileio.c. +-- add a PARSE_KEYWORDS macro, use it in #'make-hash-table. by Didier Verna:
--- a/ChangeLog Sun Apr 04 23:46:50 2010 -0500 +++ b/ChangeLog Mon Apr 05 00:18:49 2010 -0500 @@ -1,3 +1,8 @@ +2010-04-02 Aidan Kehoe <kehoea@parhasard.net> + + * CHANGES-beta: + Update with my changes to the trunk since 2009-09-20. + 2010-03-18 Ben Wing <ben@xemacs.org> * CHANGES-beta:
--- a/lisp/ChangeLog Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/ChangeLog Mon Apr 05 00:18:49 2010 -0500 @@ -1,3 +1,34 @@ +2010-04-02 Aidan Kehoe <kehoea@parhasard.net> + + * descr-text.el (describe-char-unicode-data): + Don't give up if describe-char-use-cache is t and the database + isn't readable, warn and insert the entire UnicodeData.txt file + instead. + +2010-04-01 Aidan Kehoe <kehoea@parhasard.net> + + * 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 <ben@xemacs.org> * dumped-lisp.el (preloaded-file-list):
--- a/lisp/apropos.el Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/apropos.el Mon Apr 05 00:18:49 2010 -0500 @@ -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
--- a/lisp/bytecomp.el Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/bytecomp.el Mon Apr 05 00:18:49 2010 -0500 @@ -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)))
--- a/lisp/cl-macs.el Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/cl-macs.el Mon Apr 05 00:18:49 2010 -0500 @@ -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)
--- a/lisp/cl-seq.el Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/cl-seq.el Mon Apr 05 00:18:49 2010 -0500 @@ -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)
--- a/lisp/compat.el Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/compat.el Mon Apr 05 00:18:49 2010 -0500 @@ -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)
--- a/lisp/descr-text.el Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/descr-text.el Mon Apr 05 00:18:49 2010 -0500 @@ -686,52 +686,54 @@ (when (characterp char) (setq char (encode-char char 'ucs))) (with-temp-buffer - (if describe-char-use-cache - ;; Use the database info. - (let ((database-handle (open-database - (unidata-generate-database-file-name - describe-char-unicodedata-file - (eighth (file-attributes - describe-char-unicodedata-file)) - unidata-database-format) - unidata-database-format - nil "r" - #o644 'no-conversion-unix)) - (coding-system-for-read 'no-conversion-unix) - key lookup) - (unless database-handle - (error 'io-error - (format "Could not open %s as a %s database" - (unidata-generate-database-file-name - describe-char-unicodedata-file - (eighth (file-attributes - describe-char-unicodedata-file)) - unidata-database-format) - unidata-database-format))) - (setq key (format "%04X" char) - lookup (get-database key database-handle)) - (if lookup - ;; Okay, we have information on that character in particular. - (progn (setq lookup (read lookup)) - (insert-file-contents describe-char-unicodedata-file nil - (first lookup) (second lookup))) - ;; No information on that character in particular. Do we have - ;; range information? If so, load and check for our desired - ;; character. - (setq lookup (get-database "range-information" database-handle) - lookup (if lookup (read lookup)) - lookup (if lookup (get-range-table char lookup))) - (when lookup - (insert-file-contents describe-char-unicodedata-file nil - (first lookup) (second lookup)))) - (close-database database-handle)) - - ;; Otherwise, insert the whole file (the FSF approach). - (set-buffer (get-buffer-create " *Unicode Data*")) - (when (zerop (buffer-size)) - ;; Don't use -literally in case of DOS line endings. - (insert-file-contents describe-char-unicodedata-file))) - + (let ((coding-system-for-read coding-system-for-read) + database-handle key lookup) + (if (and describe-char-use-cache + (prog1 + (setq database-handle + (open-database + (unidata-generate-database-file-name + describe-char-unicodedata-file + (eighth (file-attributes + describe-char-unicodedata-file)) + unidata-database-format) + unidata-database-format + nil "r" + #o644 'no-conversion-unix)) + (unless database-handle + (warn "Could not open %s as a %s database" + (unidata-generate-database-file-name + describe-char-unicodedata-file + (eighth (file-attributes + describe-char-unicodedata-file)) + unidata-database-format) + unidata-database-format)))) + (progn + ;; Use the database info. + (setq coding-system-for-read 'no-conversion-unix + key (format "%04X" char) + lookup (get-database key database-handle)) + (if lookup + ;; Okay, we have information on that character in particular. + (progn (setq lookup (read lookup)) + (insert-file-contents describe-char-unicodedata-file + nil (first lookup) + (second lookup))) + ;; No information on that character in particular. Do we + ;; have range information? If so, load and check for our + ;; desired character. + (setq lookup (get-database "range-information" database-handle) + lookup (if lookup (read lookup)) + lookup (if lookup (get-range-table char lookup))) + (when lookup + (insert-file-contents describe-char-unicodedata-file nil + (first lookup) (second lookup)))) + (close-database database-handle)) + ;; Otherwise, insert the whole file (the FSF approach). + (set-buffer (get-buffer-create " *Unicode Data*")) + (when (zerop (buffer-size)) + ;; Don't use -literally in case of DOS line endings. + (insert-file-contents describe-char-unicodedata-file)))) (goto-char (point-min)) (let ((hex (format "%04X" char)) found first last unihan-match unihan-info unihan-database-handle
--- a/lisp/help.el Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/help.el Mon Apr 05 00:18:49 2010 -0500 @@ -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.
--- a/lisp/package-ui.el Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/package-ui.el Mon Apr 05 00:18:49 2010 -0500 @@ -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)
--- a/lisp/register.el Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/register.el Mon Apr 05 00:18:49 2010 -0500 @@ -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))
--- a/lisp/subr.el Sun Apr 04 23:46:50 2010 -0500 +++ b/lisp/subr.el Mon Apr 05 00:18:49 2010 -0500 @@ -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)))
--- a/man/ChangeLog Sun Apr 04 23:46:50 2010 -0500 +++ b/man/ChangeLog Mon Apr 05 00:18:49 2010 -0500 @@ -1,3 +1,10 @@ +2010-04-01 Aidan Kehoe <kehoea@parhasard.net> + + * 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 <ben@xemacs.org> * internals/internals.texi (A Summary of the Various XEmacs Modules):
--- a/man/lispref/lists.texi Sun Apr 04 23:46:50 2010 -0500 +++ b/man/lispref/lists.texi Mon Apr 05 00:18:49 2010 -0500 @@ -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
--- a/src/ChangeLog Sun Apr 04 23:46:50 2010 -0500 +++ b/src/ChangeLog Mon Apr 05 00:18:49 2010 -0500 @@ -72,6 +72,56 @@ New function for doing printf-like formatting involving Lisp objects and outputting to the debug output. +2010-04-03 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (Ffill): + Be much more careful about resizing a string argument, update + pointers to within the string data that may have been relocated + with the string resize. Fixes a test hang reported by Vin Shelton; + thanks, Vin. + +2010-04-02 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (FsortX, Ffill): + Don't try to be clever with the ascii_begin string header slot in + these function, just call init_string_ascii_begin(). + +2010-04-02 Aidan Kehoe <kehoea@parhasard.net> + + Avoid build failure, Apple's g++-4.0.1, Mac OS 10.4. + * sysdll.c (search_linked_libs, dll_variable): Correct some casts + for the C++ build. + * regex.h (END_C_DECLS, BEGIN_C_DECLS): Wrap function declarations + in extern "C" { ... } on the C++ build. + * mule-ccl.c (ccl_driver): Initialise i, silencing a warning on + a C++ build. + * keymap.c (key_desc_list_to_event): + Work around a bug in Apple's g++-4.0.1. + +2010-03-31 Aidan Kehoe <kehoea@parhasard.net> + + * 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 <ben@xemacs.org> * lisp.h (PRIVATE_UNVERIFIED_LIST_LOOP_7):
--- a/src/abbrev.c Sun Apr 04 23:46:50 2010 -0500 +++ b/src/abbrev.c Mon Apr 05 00:18:49 2010 -0500 @@ -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)) {
--- a/src/dired.c Sun Apr 04 23:46:50 2010 -0500 +++ b/src/dired.c Mon Apr 05 00:18:49 2010 -0500 @@ -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); }
--- a/src/fileio.c Sun Apr 04 23:46:50 2010 -0500 +++ b/src/fileio.c Mon Apr 05 00:18:49 2010 -0500 @@ -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); }
--- a/src/fns.c Sun Apr 04 23:46:50 2010 -0500 +++ b/src/fns.c Mon Apr 05 00:18:49 2010 -0500 @@ -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,666 @@ 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); + + 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) + { + strdata += set_itext_ichar (strdata, XCHAR (sequence_carray[i])); + } + + init_string_ascii_begin (sequence); + 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 +3763,126 @@ } -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)) { + 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)) + { + CHECK_NATNUM (end); + ending = XINT (end); + } + retry: - if (STRINGP (array)) + if (STRINGP (sequence)) { - Bytecount old_bytecount = XSTRING_LENGTH (array); - Bytecount new_bytecount; - Bytecount item_bytecount; + Bytecount prefix_bytecount, item_bytecount, delta; Ibyte item_buf[MAX_ICHAR_LEN]; - Ibyte *p; - Ibyte *end; + Ibyte *p, *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); + prefix_bytecount = p - XSTRING_DATA (sequence); + + ending = min (ending, string_char_length (sequence)); + pend = (Ibyte *) itext_n_addr (p, ending - starting); + delta = ((ending - starting) * item_bytecount) - (pend - p); + + /* Resize the string if the bytecount for the area being modified is + different. */ + if (delta) + { + resize_string (sequence, prefix_bytecount, delta); + /* No need to zero-terminate the string, resize_string has done + that for us. */ + p = XSTRING_DATA (sequence) + prefix_bytecount; + pend = p + ((ending - starting) * item_bytecount); + } + + for (; p < pend; p += item_bytecount) memcpy (p, item_buf, item_bytecount); - *p = '\0'; - - XSET_STRING_ASCII_BEGIN (array, - item_bytecount == 1 ? - min (new_bytecount, MAX_STRING_ASCII_BEGIN) : - 0); - bump_string_modiff (array); - sledgehammer_check_ascii_begin (array); + + + init_string_ascii_begin (sequence); + 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 +5454,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 +5514,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 +5541,9 @@ DEFSUBR (Fequal); DEFSUBR (Fequalp); DEFSUBR (Fold_equal); - DEFSUBR (Ffillarray); + DEFSUBR (Ffill); + Ffset (intern ("fillarray"), Qfill); + DEFSUBR (Fnconc); DEFSUBR (FmapcarX); DEFSUBR (Fmapvector);
--- a/src/fontcolor-msw.c Sun Apr 04 23:46:50 2010 -0500 +++ b/src/fontcolor-msw.c Mon Apr 05 00:18:49 2010 -0500 @@ -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
--- a/src/general-slots.h Sun Apr 04 23:46:50 2010 -0500 +++ b/src/general-slots.h Mon Apr 05 00:18:49 2010 -0500 @@ -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);
--- a/src/keymap.c Sun Apr 04 23:46:50 2010 -0500 +++ b/src/keymap.c Mon Apr 05 00:18:49 2010 -0500 @@ -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; @@ -1527,7 +1528,13 @@ define_key_parser (list, &raw_key); - if ( + /* The first zero is needed for Apple's i686-apple-darwin8-g++-4.0.1, + otherwise the build fails with: + + In function ‘void key_desc_list_to_event(Lisp_Object, Lisp_Object, int)’: + cc1plus: error: expected primary-expression + cc1plus: error: expected `)' */ + if (0 || #define INCLUDE_BUTTON_ZERO #define FROB(num) \ EQ (raw_key.keysym, Qbutton##num) || \ @@ -2889,9 +2896,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 +2912,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 +2942,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 +2950,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 +2995,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 +4088,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 ( ( <keysym> . <modifiers> ) . <binding> ) @@ -4094,9 +4102,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 +4212,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)) {
--- a/src/lisp.h Sun Apr 04 23:46:50 2010 -0500 +++ b/src/lisp.h Mon Apr 05 00:18:49 2010 -0500 @@ -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);
--- a/src/mule-ccl.c Sun Apr 04 23:46:50 2010 -0500 +++ b/src/mule-ccl.c Mon Apr 05 00:18:49 2010 -0500 @@ -953,7 +953,7 @@ register Lisp_Object *ccl_prog = ccl->prog; const unsigned char *src = source, *src_end = src + src_bytes; int jump_address; - int i, j, op; + int i = 0, j, op; int stack_idx = ccl->stack_idx; /* Instruction counter of the current CCL code. */ int this_ic = 0;
--- a/src/regex.h Sun Apr 04 23:46:50 2010 -0500 +++ b/src/regex.h Mon Apr 05 00:18:49 2010 -0500 @@ -42,6 +42,18 @@ #define Bytecount ssize_t #endif /* emacs */ +#ifndef emacs +# ifdef __cplusplus +# define BEGIN_C_DECLS extern "C" { +# define END_C_DECLS } +# else +# define BEGIN_C_DECLS +# define END_C_DECLS +# endif +#endif /* emacs */ + +BEGIN_C_DECLS + /* POSIX says that <sys/types.h> must be included (by the caller) before <regex.h>. */ @@ -535,4 +547,6 @@ extern int debug_regexps; +END_C_DECLS + #endif /* INCLUDED_regex_h_ */
--- a/src/symbols.c Sun Apr 04 23:46:50 2010 -0500 +++ b/src/symbols.c Mon Apr 05 00:18:49 2010 -0500 @@ -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; }
--- a/src/sysdll.c Sun Apr 04 23:46:50 2010 -0500 +++ b/src/sysdll.c Mon Apr 05 00:18:49 2010 -0500 @@ -368,9 +368,9 @@ struct mach_header *wh; if ((wh = (struct mach_header *) - my_find_image((Rawbyte *) + my_find_image((const Chbyte *) (((struct dylib_command *) lc)-> - dylib.name.offset + (Rawbyte *) lc)))) + dylib.name.offset + (const Chbyte *) lc)))) { Extbyte *symext = ITEXT_TO_EXTERNAL (symbol, Qdll_symbol_encoding); @@ -442,7 +442,7 @@ MAYBE_PREPEND_UNDERSCORE (n); next = ITEXT_TO_EXTERNAL (n, Qdll_variable_name_encoding); - sym = NSLookupSymbolInModule ((NSModule) h, n); + sym = NSLookupSymbolInModule ((NSModule) h, (const Chbyte *)n); if (sym == 0) return 0; return (dll_var) NSAddressOfSymbol (sym); }
--- a/tests/ChangeLog Sun Apr 04 23:46:50 2010 -0500 +++ b/tests/ChangeLog Mon Apr 05 00:18:49 2010 -0500 @@ -1,3 +1,15 @@ +2010-04-03 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + Correct the parentheses in the equalp tests, so they get run more + often. + Within them, only attempt to read a bignum if the bignum + feature is present; actually evaluate (/ 3/2 0.2), (/ 3/2 0.7) if + the ratio feature is present. + Construct the (Assert ...) calls at + macroexpansion time, so the output in the *Test-Log* buffer is + more informative. + 2010-03-18 Ben Wing <ben@xemacs.org> * automated/c-tests.el:
--- a/tests/automated/lisp-tests.el Sun Apr 04 23:46:50 2010 -0500 +++ b/tests/automated/lisp-tests.el Mon Apr 05 00:18:49 2010 -0500 @@ -2138,35 +2138,52 @@ for char being each element in-ref res do (setf char (int-to-char int-char)) finally return res))) - (let ((equal-lists - '((111111111111111111111111111111111111111111111111111 - 111111111111111111111111111111111111111111111111111.0) - (0 0.0 0.000 -0 -0.0 -0.000 #b0 0/5 -0/5) - (21845 #b101010101010101 #x5555) - (1.5 1.500000000000000000000000000000000000000000000000000000000 - 3/2) - (-55 -110/2) - ;; Can't use this, these values aren't `='. - ;;(-12345678901234567890123457890123457890123457890123457890123457890 - ;; -12345678901234567890123457890123457890123457890123457890123457890.0) - ))) - (loop for li in equal-lists do - (loop for (x . tail) on li do - (loop for y in tail do - (Assert (equalp x y)) - (Assert (equalp y x)))))) - (let ((diff-list - `(0 1 2 3 1000 5000000000 5555555555555555555555555555555555555 - -1 -2 -3 -1000 -5000000000 -5555555555555555555555555555555555555 - 1/2 1/3 2/3 8/2 355/113 (/ 3/2 0.2) (/ 3/2 0.7) - 55555555555555555555555555555555555555555/2718281828459045 - 0.111111111111111111111111111111111111111111111111111111111111111 - 1e+300 1e+301 -1e+300 -1e+301))) - (loop for (x . tail) on diff-list do - (loop for y in tail do - (Assert (not (equalp x y))) - (Assert (not (equalp y x)))))) + (macrolet + ((equalp-equal-list-tests (equal-list) + (let (res) + (setq equal-lists (eval equal-list)) + (loop for li in equal-lists do + (loop for (x . tail) on li do + (loop for y in tail do + (push `(Assert (equalp ,(quote-maybe x) + ,(quote-maybe y))) res) + (push `(Assert (equalp ,(quote-maybe y) + ,(quote-maybe x))) res)))) + (cons 'progn (nreverse res)))) + (equalp-diff-list-tests (diff-list) + (let (res) + (setq diff-list (eval diff-list)) + (loop for (x . tail) on diff-list do + (loop for y in tail do + (push `(Assert (not (equalp ,(quote-maybe x) + ,(quote-maybe y)))) res) + (push `(Assert (not (equalp ,(quote-maybe y) + ,(quote-maybe x)))) res))) + (cons 'progn (nreverse res))))) + (equalp-equal-list-tests + `(,@(when (featurep 'bignum) + (read "((111111111111111111111111111111111111111111111111111 + 111111111111111111111111111111111111111111111111111.0))")) + (0 0.0 0.000 -0 -0.0 -0.000 #b0 ,@(when (featurep 'ratio) '(0/5 -0/5))) + (21845 #b101010101010101 #x5555) + (1.5 1.500000000000000000000000000000000000000000000000000000000 + ,@(when (featurep 'ratio) '(3/2))) + ;; Can't use this, these values aren't `='. + ;;(-12345678901234567890123457890123457890123457890123457890123457890 + ;; -12345678901234567890123457890123457890123457890123457890123457890.0) + (-55 -55.000 ,@(when (featurep 'ratio) '(-110/2))))) + (equalp-diff-list-tests + `(0 1 2 3 1000 5000000000 + ,@(when (featurep 'bignum) + (read "(5555555555555555555555555555555555555 + -5555555555555555555555555555555555555)")) + -1 -2 -3 -1000 -5000000000 + 1/2 1/3 2/3 8/2 355/113 + ,@(when (featurep 'ratio) (mapcar* #'/ '(3/2 3/2) '(0.2 0.7))) + 55555555555555555555555555555555555555555/2718281828459045 + 0.111111111111111111111111111111111111111111111111111111111111111 + 1e+300 1e+301 -1e+300 -1e+301))) (Assert (equalp "hi there" "Hi There") "checking equalp isn't case-sensitive") @@ -2231,7 +2248,7 @@ (let ((aragh (make-char-table 'generic))) (put-char-table ?\u0080 "hi there" aragh) aragh))) - "checking #'equalp fails correctly, char-tables") + "checking #'equalp fails correctly, char-tables")) ;; There are more tests available for equalp here: ;;