carbon2-commit: Correct some minor problems in my last change.
12 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 5436:eac2e6bd5b2c
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Mar 17 21:50:34 2011 +0000
files: lisp/ChangeLog lisp/bytecomp.el
description:
Correct some minor problems in my last change.
2011-03-17 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-catch):
* bytecomp.el (byte-compile-throw):
Correct some minor problems in my last change. Happy St. Patrick's
day, everyone!
diff -r 4b529b940e2e -r eac2e6bd5b2c lisp/ChangeLog
--- a/lisp/ChangeLog Thu Mar 17 21:07:16 2011 +0000
+++ b/lisp/ChangeLog Thu Mar 17 21:50:34 2011 +0000
＠＠ -1,3 +1,10 ＠＠
+2011-03-17 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecomp.el (byte-compile-catch):
+ * bytecomp.el (byte-compile-throw):
+ Correct some minor problems in my last change. Happy St. Patrick's
+ day, everyone!
+
2011-03-17 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-catch):
diff -r 4b529b940e2e -r eac2e6bd5b2c lisp/bytecomp.el
--- a/lisp/bytecomp.el Thu Mar 17 21:07:16 2011 +0000
+++ b/lisp/bytecomp.el Thu Mar 17 21:50:34 2011 +0000
＠＠ -4209,7 +4209,7 ＠＠
byte-compile-active-blocks))
(body
(byte-compile-top-level (cons 'progn (cddr form))
- (and elt for-effect))))
+ (and (not elt) for-effect))))
(if (and elt (not (cdr elt)))
;; A lexical block without any contained return-from clauses:
(byte-compile-form body)
＠＠ -4371,16 +4371,17 ＠＠
;; corresponding block as having been referenced.
(let* ((symbol (car-safe (cdr-safe (nth 1 form))))
(not-present '#:not-present)
- (block (and symbol (symbolp symbol)
- (get symbol 'cl-block-name not-present)))
+ (block (if (and symbol (symbolp symbol))
+ (get symbol 'cl-block-name not-present)
+ not-present))
(assq (and (not (eq block not-present))
(assq block byte-compile-active-blocks))))
- (when assq
- (setcdr assq t))
- (when (not (eq block not-present))
- ;; No corresponding enclosing block.
- (byte-compile-warn "return-from: no enclosing block named `%s'"
- block)))
+ (if assq
+ (setcdr assq t)
+ (if (not (eq block not-present))
+ ;; No corresponding enclosing block.
+ (byte-compile-warn "return-from: no enclosing block named `%s'"
+ block))))
(mapc 'byte-compile-form (cdr form)) ;; Push the arguments
(byte-compile-out (get (car form) 'byte-opcode) 0)
(pushnew '(null (function-max-args 'throw)) byte-compile-checks-on-load
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Eliminate unused blocks named nil, too, cl-macs.el, bytecomp.el
12 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 5435:4b529b940e2e
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Mar 17 21:07:16 2011 +0000
files: lisp/ChangeLog lisp/bytecomp.el lisp/cl-macs.el
description:
Eliminate unused blocks named nil, too, cl-macs.el, bytecomp.el
2011-03-17 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-catch):
* bytecomp.el (byte-compile-throw):
* cl-macs.el (return-from):
With `block' and `return-from', a nil NAME is perfectly
legitimate, and the corresponding `catch' statements need be
removed by the byte-compiler. 5dd1ba5e0113 , my change of
2011-02-12, didn't do this; correct that now.
diff -r 2fba45e5b48d -r 4b529b940e2e lisp/ChangeLog
--- a/lisp/ChangeLog Thu Mar 17 20:17:19 2011 +0000
+++ b/lisp/ChangeLog Thu Mar 17 21:07:16 2011 +0000
＠＠ -1,3 +1,13 ＠＠
+2011-03-17 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecomp.el (byte-compile-catch):
+ * bytecomp.el (byte-compile-throw):
+ * cl-macs.el (return-from):
+ With `block' and `return-from', a nil NAME is perfectly
+ legitimate, and the corresponding `catch' statements need be
+ removed by the byte-compiler. 5dd1ba5e0113 , my change of
+ 2011-02-12, didn't do this; correct that now.
+
2011-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el:
diff -r 2fba45e5b48d -r 4b529b940e2e lisp/bytecomp.el
--- a/lisp/bytecomp.el Thu Mar 17 20:17:19 2011 +0000
+++ b/lisp/bytecomp.el Thu Mar 17 21:07:16 2011 +0000
＠＠ -4195,20 +4195,22 ＠＠
"Byte-compile and return a `catch' from.
If FORM is the result of macroexpanding a `block' form (the TAG argument is
-a quoted symbol with a non-nil `cl-block-name' property) and there is no
+a quoted symbol with a `cl-block-name' property) and there is no
corresponding `return-from' within the block--or equivalently, it was
optimized away--just byte compile and return the BODY."
(let* ((symbol (car-safe (cdr-safe (nth 1 form))))
- (block (and symbol (symbolp symbol) (get symbol 'cl-block-name)))
- (elt (and block (cons block nil)))
+ (not-present '#:not-present)
+ (block (and symbol (symbolp symbol)
+ (get symbol 'cl-block-name not-present)))
+ (elt (and (not (eq block not-present)) (list block)))
(byte-compile-active-blocks
- (if block
+ (if elt
(cons elt byte-compile-active-blocks)
byte-compile-active-blocks))
(body
(byte-compile-top-level (cons 'progn (cddr form))
- (if block nil for-effect))))
- (if (and block (not (cdr elt)))
+ (and elt for-effect))))
+ (if (and elt (not (cdr elt)))
;; A lexical block without any contained return-from clauses:
(byte-compile-form body)
;; A normal catch call, or a lexical block with a contained
＠＠ -4368,14 +4370,20 ＠＠
;; If this form was macroexpanded from `return-from', mark the
;; corresponding block as having been referenced.
(let* ((symbol (car-safe (cdr-safe (nth 1 form))))
- (block (and symbol (symbolp symbol) (get symbol 'cl-block-name)))
- (assq (and block (assq block byte-compile-active-blocks))))
- (and assq (setcdr assq t)))
- (byte-compile-form (nth 1 form)) ;; Push the arguments
- (byte-compile-form (nth 2 form))
+ (not-present '#:not-present)
+ (block (and symbol (symbolp symbol)
+ (get symbol 'cl-block-name not-present)))
+ (assq (and (not (eq block not-present))
+ (assq block byte-compile-active-blocks))))
+ (when assq
+ (setcdr assq t))
+ (when (not (eq block not-present))
+ ;; No corresponding enclosing block.
+ (byte-compile-warn "return-from: no enclosing block named `%s'"
+ block)))
+ (mapc 'byte-compile-form (cdr form)) ;; Push the arguments
(byte-compile-out (get (car form) 'byte-opcode) 0)
- (pushnew '(null (function-max-args 'throw))
- byte-compile-checks-on-load
+ (pushnew '(null (function-max-args 'throw)) byte-compile-checks-on-load
:test #'equal)))
;;; top-level forms elsewhere
diff -r 2fba45e5b48d -r 4b529b940e2e lisp/cl-macs.el
--- a/lisp/cl-macs.el Thu Mar 17 20:17:19 2011 +0000
+++ b/lisp/cl-macs.el Thu Mar 17 21:07:16 2011 +0000
＠＠ -767,12 +767,12 ＠＠
This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
`(throw ',(or (cdr (assq name cl-active-block-names))
- (prog1 (copy-symbol name)
- (and-fboundp 'byte-compile-warn (cl-compiling-file)
- (byte-compile-warn
- "return-from: no enclosing block named `%s'"
- name))))
- ,result))
+ ;; Tell the byte-compiler the original name of the block,
+ ;; leave any warning to it.
+ (let ((copy-symbol (copy-symbol name)))
+ (put copy-symbol 'cl-block-name name)
+ copy-symbol))
+ ,result))
;;; The "loop" macro.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Merge.
12 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 5434:2fba45e5b48d
parent: 5433:b6e59ea11533
parent: 5432:d967d96ca043
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Mar 17 20:17:19 2011 +0000
files: lisp/ChangeLog man/ChangeLog
description:
Merge.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Add min-colors specifier to defface, and document it.
12 years, 11 months
Jeff Sparkes
Jeff Sparkes
changeset: 5433:b6e59ea11533
parent: 5431:6c3a695f54f5
user: Jeff Sparkes <jsparkes(a)gmail.com>
date: Thu Mar 17 14:35:02 2011 -0400
files: lisp/ChangeLog lisp/custom.el lisp/faces.el man/ChangeLog man/lispref/faces.texi
description:
Add min-colors specifier to defface, and document it.
diff -r 6c3a695f54f5 -r b6e59ea11533 lisp/ChangeLog
--- a/lisp/ChangeLog Mon Mar 14 21:04:45 2011 +0000
+++ b/lisp/ChangeLog Thu Mar 17 14:35:02 2011 -0400
＠＠ -1,3 +1,10 ＠＠
+2011-03-14 Jeff Sparkes <jsparkes(a)gmail.com>
+
+ * custom.el (defface): Document `min-colors' specifier.
+
+ * faces.el (face-spec-set-match-display): Add `min-colors'
+ specifer for defface.
+
2011-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* isearch-mode.el (isearch-mode-map):
diff -r 6c3a695f54f5 -r b6e59ea11533 lisp/custom.el
--- a/lisp/custom.el Mon Mar 14 21:04:45 2011 +0000
+++ b/lisp/custom.el Thu Mar 17 14:35:02 2011 -0400
＠＠ -324,6 +324,9 ＠＠
`class' (the frame's color support)
Should be one of `color', `grayscale', or `mono'.
+
+`min-colors' (the minimum number of colors the frame supports)
+ Should be in integer which is compared to `display-color-cells'
`background' (what color is used for the background text)
Should be one of `light' or `dark'.
diff -r 6c3a695f54f5 -r b6e59ea11533 lisp/faces.el
--- a/lisp/faces.el Mon Mar 14 21:04:45 2011 +0000
+++ b/lisp/faces.el Thu Mar 17 14:35:02 2011 -0400
＠＠ -1702,6 +1702,7 ＠＠
(type (plist-get props 'type))
(class (plist-get props 'class))
(background (plist-get props 'background))
+ (min-colors (plist-get props 'min-colors))
(match t)
(entries display)
entry req options)
＠＠ -1714,6 +1715,8 ＠＠
(type (memq type options))
(class (memq class options))
(background (memq background options))
+ (min-colors (>= (display-color-cells frame)
+ (car options)))
(t (warn "Unknown req `%S' with options `%S'"
req options)
nil))))
diff -r 6c3a695f54f5 -r b6e59ea11533 man/ChangeLog
--- a/man/ChangeLog Mon Mar 14 21:04:45 2011 +0000
+++ b/man/ChangeLog Thu Mar 17 14:35:02 2011 -0400
＠＠ -1,3 +1,8 ＠＠
+2011-03-14 Jeff Sparkes <jsparkes(a)gmail.com>
+
+ * lispref/faces.texi (Faces): Mention `min-colors' as a
+ face specifier.
+
2011-03-01 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/commands.texi (Using Interactive):
diff -r 6c3a695f54f5 -r b6e59ea11533 man/lispref/faces.texi
--- a/man/lispref/faces.texi Mon Mar 14 21:04:45 2011 +0000
+++ b/man/lispref/faces.texi Thu Mar 17 14:35:02 2011 -0400
＠＠ -27,7 +27,8 ＠＠
Each built-in property of a face is controlled using a specifier,
which allows it to have separate values in particular buffers, frames,
windows, and devices and to further vary according to device type
-(X or TTY) and device class (color, mono, or grayscale).
+(X or TTY), device class (color, mono, or grayscale) and number of
+displayable colors (min-colors).
＠xref{Specifiers}, for more information.
The face named ＠code{default} is used for ordinary text. The face named
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Conditionalise the old-* functions and byte codes at compile time.
12 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 5432:d967d96ca043
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Mar 17 20:13:00 2011 +0000
files: lisp/ChangeLog lisp/bytecomp.el man/ChangeLog man/lispref/objects.texi src/ChangeLog src/bytecode.c src/config.h.in src/data.c src/fns.c tests/ChangeLog tests/automated/lisp-tests.el
description:
Conditionalise the old-* functions and byte codes at compile time.
src/ChangeLog addition:
2011-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
* config.h.in (SUPPORT_CONFOUNDING_FUNCTIONS): New #define,
equivalent NEED_TO_HANDLE_21_4_CODE by default, describing whether
this XEmacs should support the old-eq, old-equal and related
functions and byte codes.
* bytecode.c (UNUSED):
Only interpret old-eq, old-equal, old-memq if
SUPPORT_CONFOUNDING_FUNCTIONS is defined.
* data.c:
Move Fold_eq to fns.c with the rest of the Fold_* functions.
* fns.c:
* fns.c (Fmemq):
* fns.c (memq_no_quit):
* fns.c (assoc_no_quit):
* fns.c (Frassq):
* fns.c (Fequal):
* fns.c (Fold_equal):
* fns.c (syms_of_fns):
Group old-eq, old-equal, old-memq etc together, surround them with
#ifdef SUPPORT_CONFOUNDING_FUNCTIONS.
lisp/ChangeLog addition:
2011-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el:
Don't generate the old-eq, old-memq, old-equal bytecodes any more,
but keep the information about them around for the sake of the
disassembler.
man/ChangeLog addition:
2011-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/objects.texi (Character Type):
* lispref/objects.texi (Equality Predicates):
No longer document `old-eq', `old-equal', they haven't been used
in years.
tests/ChangeLog addition:
2011-03-17 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
Only test the various old-* function if old-eq is bound and a
subr.
diff -r 6c3a695f54f5 -r d967d96ca043 lisp/ChangeLog
--- a/lisp/ChangeLog Mon Mar 14 21:04:45 2011 +0000
+++ b/lisp/ChangeLog Thu Mar 17 20:13:00 2011 +0000
＠＠ -1,3 +1,10 ＠＠
+2011-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecomp.el:
+ Don't generate the old-eq, old-memq, old-equal bytecodes any more,
+ but keep the information about them around for the sake of the
+ disassembler.
+
2011-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* isearch-mode.el (isearch-mode-map):
diff -r 6c3a695f54f5 -r d967d96ca043 lisp/bytecomp.el
--- a/lisp/bytecomp.el Mon Mar 14 21:04:45 2011 +0000
+++ b/lisp/bytecomp.el Thu Mar 17 20:13:00 2011 +0000
＠＠ -3161,8 +3161,8 ＠＠
(byte-defop-compiler skip-chars-forward 1-2+1)
(byte-defop-compiler skip-chars-backward 1-2+1)
(byte-defop-compiler eq 2)
-(byte-defop-compiler20 old-eq 2)
-(byte-defop-compiler20 old-memq 2)
+; (byte-defop-compiler20 old-eq 2)
+; (byte-defop-compiler20 old-memq 2)
(byte-defop-compiler cons 2)
(byte-defop-compiler aref 2)
(byte-defop-compiler get 2+1)
＠＠ -3179,7 +3179,7 ＠＠
(byte-defop-compiler string< 2)
(byte-defop-compiler (string-equal byte-string=) 2)
(byte-defop-compiler (string-lessp byte-string<) 2)
-(byte-defop-compiler20 old-equal 2)
+; (byte-defop-compiler20 old-equal 2)
(byte-defop-compiler nthcdr 2)
(byte-defop-compiler elt 2)
(byte-defop-compiler20 old-member 2)
diff -r 6c3a695f54f5 -r d967d96ca043 man/ChangeLog
--- a/man/ChangeLog Mon Mar 14 21:04:45 2011 +0000
+++ b/man/ChangeLog Thu Mar 17 20:13:00 2011 +0000
＠＠ -1,3 +1,10 ＠＠
+2011-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lispref/objects.texi (Character Type):
+ * lispref/objects.texi (Equality Predicates):
+ No longer document `old-eq', `old-equal', they haven't been used
+ in years.
+
2011-03-01 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/commands.texi (Using Interactive):
diff -r 6c3a695f54f5 -r d967d96ca043 man/lispref/objects.texi
--- a/man/lispref/objects.texi Mon Mar 14 21:04:45 2011 +0000
+++ b/man/lispref/objects.texi Thu Mar 17 20:13:00 2011 +0000
＠＠ -348,19 +348,6 ＠＠
the modern convention is followed, and characters are their own
primitive types. (This change was necessary in order for ＠sc{mule},
i.e. Asian-language, support to be correctly implemented.)
-
- Even in XEmacs version 20, remnants of the equivalence between
-characters and integers still exist; this is termed the ＠dfn{char-int
-confoundance disease}. In particular, many functions such as ＠code{eq},
-＠code{equal}, and ＠code{memq} have equivalent functions (＠code{old-eq},
-＠code{old-equal}, ＠code{old-memq}, etc.) that pretend like characters
-are integers are the same. Byte code compiled under any version 19
-Emacs will have all such functions mapped to their ＠code{old-} equivalents
-when the byte code is read into XEmacs 20. This is to preserve
-compatibility---Emacs 19 converts all constant characters to the equivalent
-integer during byte-compilation, and thus there is no other way to preserve
-byte-code compatibility even if the code has specifically been written
-with the distinction between characters and integers in mind.
Every character has an equivalent integer, called the ＠dfn{character
code}. For example, the character ＠kbd{A} is represented as the
＠＠ -2317,32 +2304,6 ＠＠
＠end defun
-＠defun old-eq object1 object2
-This function exists under XEmacs 20 and is exactly like ＠code{eq}
-except that it suffers from the char-int confoundance disease.
-In other words, it returns ＠code{t} if given a character and the
-equivalent integer, even though the objects are of different types!
-You should ＠emph{not} ever call this function explicitly in your
-code. However, be aware that all calls to ＠code{eq} in byte code
-compiled under version 19 map to ＠code{old-eq} in XEmacs 20.
-(Likewise for ＠code{old-equal}, ＠code{old-memq}, ＠code{old-member},
-＠code{old-assq} and ＠code{old-assoc}.)
-
-＠example
-＠group
-;; ＠r{Remember, this does not apply under XEmacs 19.}
-?A
- ＠result{} ?A
-(char-int ?A)
- ＠result{} 65
-(old-eq ?A 65)
- ＠result{} t ; ＠r{Eek, we've been infected.}
-(eq ?A 65)
- ＠result{} nil ; ＠r{We are still healthy.}
-＠end group
-＠end example
-＠end defun
-
＠defun eql object1 object2
This function returns ＠code{t} if the two arguments are the same object,
diff -r 6c3a695f54f5 -r d967d96ca043 src/ChangeLog
--- a/src/ChangeLog Mon Mar 14 21:04:45 2011 +0000
+++ b/src/ChangeLog Thu Mar 17 20:13:00 2011 +0000
＠＠ -1,3 +1,25 ＠＠
+2011-03-15 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * config.h.in (SUPPORT_CONFOUNDING_FUNCTIONS): New #define,
+ equivalent NEED_TO_HANDLE_21_4_CODE by default, describing whether
+ this XEmacs should support the old-eq, old-equal and related
+ functions and byte codes.
+ * bytecode.c (UNUSED):
+ Only interpret old-eq, old-equal, old-memq if
+ SUPPORT_CONFOUNDING_FUNCTIONS is defined.
+ * data.c:
+ Move Fold_eq to fns.c with the rest of the Fold_* functions.
+ * fns.c:
+ * fns.c (Fmemq):
+ * fns.c (memq_no_quit):
+ * fns.c (assoc_no_quit):
+ * fns.c (Frassq):
+ * fns.c (Fequal):
+ * fns.c (Fold_equal):
+ * fns.c (syms_of_fns):
+ Group old-eq, old-equal, old-memq etc together, surround them with
+ #ifdef SUPPORT_CONFOUNDING_FUNCTIONS.
+
2011-03-14 Aidan Kehoe <kehoea(a)parhasard.net>
* glyphs-eimage.c (png_instantiate):
diff -r 6c3a695f54f5 -r d967d96ca043 src/bytecode.c
--- a/src/bytecode.c Mon Mar 14 21:04:45 2011 +0000
+++ b/src/bytecode.c Thu Mar 17 20:13:00 2011 +0000
＠＠ -1692,6 +1692,8 ＠＠
break;
}
+#ifdef SUPPORT_CONFOUNDING_FUNCTIONS
+
case Bold_eq:
{
Lisp_Object arg = POP;
＠＠ -1726,6 +1728,8 ＠＠
TOP_LVALUE = Fold_assq (TOP, arg);
break;
}
+
+#endif
case Bbind_multiple_value_limits:
{
diff -r 6c3a695f54f5 -r d967d96ca043 src/config.h.in
--- a/src/config.h.in Mon Mar 14 21:04:45 2011 +0000
+++ b/src/config.h.in Thu Mar 17 20:13:00 2011 +0000
＠＠ -1183,4 +1183,6 ＠＠
/* Do we need to be able to run code compiled by and written for 21.4? */
#define NEED_TO_HANDLE_21_4_CODE 1
+#define SUPPORT_CONFOUNDING_FUNCTIONS NEED_TO_HANDLE_21_4_CODE
+
#endif /* _SRC_CONFIG_H_ */
diff -r 6c3a695f54f5 -r d967d96ca043 src/data.c
--- a/src/data.c Mon Mar 14 21:04:45 2011 +0000
+++ b/src/data.c Thu Mar 17 20:13:00 2011 +0000
＠＠ -181,24 +181,6 ＠＠
(object1, object2))
{
return EQ_WITH_EBOLA_NOTICE (object1, object2) ? Qt : Qnil;
-}
-
-DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
-Return t if the two args are (in most cases) the same Lisp object.
-
-Special kludge: A character is considered `old-eq' to its equivalent integer
-even though they are not the same object and are in fact of different
-types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
-preserve byte-code compatibility with v19. This kludge is known as the
-\"char-int confoundance disease\" and appears in a number of other
-functions with `old-foo' equivalents.
-
-Do not use this function!
-*/
- (object1, object2))
-{
- /* #### blasphemy */
- return HACKEQ_UNSAFE (object1, object2) ? Qt : Qnil;
}
DEFUN ("null", Fnull, 1, 1, 0, /*
＠＠ -3568,7 +3550,6 ＠＠
DEFSUBR (Fdiv);
#endif
DEFSUBR (Feq);
- DEFSUBR (Fold_eq);
DEFSUBR (Fnull);
Ffset (intern ("not"), intern ("null"));
DEFSUBR (Flistp);
diff -r 6c3a695f54f5 -r d967d96ca043 src/fns.c
--- a/src/fns.c Mon Mar 14 21:04:45 2011 +0000
+++ b/src/fns.c Thu Mar 17 20:13:00 2011 +0000
＠＠ -72,7 +72,6 ＠＠
extern Fixnum max_lisp_eval_depth;
extern int lisp_eval_depth;
-static int internal_old_equal (Lisp_Object, Lisp_Object, int);
Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth);
static DOESNT_RETURN
＠＠ -2581,22 +2580,6 ＠＠
return Qnil;
}
-DEFUN ("old-member", Fold_member, 2, 2, 0, /*
-Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
-The value is actually the tail of LIST whose car is ELT.
-This function is provided only for byte-code compatibility with v19.
-Do not use it.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
- {
- if (internal_old_equal (elt, list_elt, 0))
- return tail;
- }
- return Qnil;
-}
-
DEFUN ("memq", Fmemq, 2, 2, 0, /*
Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
The value is actually the tail of LIST whose car is ELT.
＠＠ -2606,22 +2589,6 ＠＠
EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
- return tail;
- }
- return Qnil;
-}
-
-DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
-Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
-The value is actually the tail of LIST whose car is ELT.
-This function is provided only for byte-code compatibility with v19.
-Do not use it.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
- {
- if (HACKEQ_UNSAFE (elt, list_elt))
return tail;
}
return Qnil;
＠＠ -2822,21 +2789,6 ＠＠
return Qnil;
}
-DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
-Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
-The value is actually the element of ALIST whose car equals KEY.
-*/
- (key, alist))
-{
- /* This function can GC. */
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (internal_old_equal (key, elt_car, 0))
- return elt;
- }
- return Qnil;
-}
-
Lisp_Object
assoc_no_quit (Lisp_Object key, Lisp_Object alist)
{
＠＠ -2860,23 +2812,6 ＠＠
return Qnil;
}
-DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
-Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
-The value is actually the element of ALIST whose car is KEY.
-Elements of ALIST that are not conses are ignored.
-This function is provided only for byte-code compatibility with v19.
-Do not use it.
-*/
- (key, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (HACKEQ_UNSAFE (key, elt_car))
- return elt;
- }
- return Qnil;
-}
-
/* Like Fassq but never report an error and do not allow quits.
Use only on lists known never to be circular. */
＠＠ -2955,20 +2890,6 ＠＠
EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
{
if (internal_equal (value, elt_cdr, 0))
- return elt;
- }
- return Qnil;
-}
-
-DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
-Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
-The value is actually the element of ALIST whose cdr equals VALUE.
-*/
- (value, alist))
-{
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
- {
- if (internal_old_equal (value, elt_cdr, 0))
return elt;
}
return Qnil;
＠＠ -3278,34 +3199,6 ＠＠
return object;
}
-DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
-Delete by side effect any occurrences of ELT as a member of LIST.
-The modified LIST is returned. Comparison is done with `old-equal'.
-If the first member of LIST is ELT, there is no way to remove it by side
-effect; therefore, write `(setq foo (old-delete element foo))' to be sure
-of changing the value of `foo'.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (internal_old_equal (elt, list_elt, 0)));
- return list;
-}
-
-DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
-Delete by side effect any occurrences of ELT as a member of LIST.
-The modified LIST is returned. Comparison is done with `old-eq'.
-If the first member of LIST is ELT, there is no way to remove it by side
-effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
-changing the value of `foo'.
-*/
- (elt, list))
-{
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (HACKEQ_UNSAFE (elt, list_elt)));
- return list;
-}
-
/* Like Fdelq, but caller must ensure that LIST is properly
nil-terminated and ebola-free. */
＠＠ -6537,6 +6430,51 ＠＠
return internal_equal (obj1, obj2, depth);
}
+DEFUN ("equal", Fequal, 2, 2, 0, /*
+Return t if two Lisp objects have similar structure and contents.
+They must have the same data type.
+Conses are compared by comparing the cars and the cdrs.
+Vectors and strings are compared element by element.
+Numbers are compared by value. Symbols must match exactly.
+*/
+ (object1, object2))
+{
+ return internal_equal (object1, object2, 0) ? Qt : Qnil;
+}
+
+DEFUN ("equalp", Fequalp, 2, 2, 0, /*
+Return t if two Lisp objects have similar structure and contents.
+
+This is like `equal', except that it accepts numerically equal
+numbers of different types (float, integer, bignum, bigfloat), and also
+compares strings and characters case-insensitively.
+
+Type objects that are arrays (that is, strings, bit-vectors, and vectors)
+of the same length and with contents that are `equalp' are themselves
+`equalp', regardless of whether the two objects have the same type.
+
+Other objects whose primary purpose is as containers of other objects are
+`equalp' if they would otherwise be equal (same length, type, etc.) and
+their contents are `equalp'. This goes for conses, weak lists,
+weak boxes, ephemerons, specifiers, hash tables, char tables and range
+tables. However, objects that happen to contain other objects but are not
+primarily designed for this purpose (e.g. compiled functions, events or
+display-related objects such as glyphs, faces or extents) are currently
+compared using `equalp' the same way as using `equal'.
+
+More specifically, two hash tables are `equalp' if they have the same test
+(see `hash-table-test'), the same number of entries, and the same value for
+`hash-table-weakness', and if, for each entry in one hash table, its key is
+equivalent to a key in the other hash table using the hash table test, and
+its value is `equalp' to the other hash table's value for that key.
+*/
+ (object1, object2))
+{
+ return internal_equalp (object1, object2, 0) ? Qt : Qnil;
+}
+
+#ifdef SUPPORT_CONFOUNDING_FUNCTIONS
+
/* Note that we may be calling sub-objects that will use
internal_equal() (instead of internal_old_equal()). Oh well.
We will get an Ebola note if there's any possibility of confusion,
＠＠ -6557,47 +6495,110 ＠＠
return internal_equal (obj1, obj2, depth);
}
-DEFUN ("equal", Fequal, 2, 2, 0, /*
-Return t if two Lisp objects have similar structure and contents.
-They must have the same data type.
-Conses are compared by comparing the cars and the cdrs.
-Vectors and strings are compared element by element.
-Numbers are compared by value. Symbols must match exactly.
-*/
- (object1, object2))
-{
- return internal_equal (object1, object2, 0) ? Qt : Qnil;
-}
-
-DEFUN ("equalp", Fequalp, 2, 2, 0, /*
-Return t if two Lisp objects have similar structure and contents.
-
-This is like `equal', except that it accepts numerically equal
-numbers of different types (float, integer, bignum, bigfloat), and also
-compares strings and characters case-insensitively.
-
-Type objects that are arrays (that is, strings, bit-vectors, and vectors)
-of the same length and with contents that are `equalp' are themselves
-`equalp', regardless of whether the two objects have the same type.
-
-Other objects whose primary purpose is as containers of other objects are
-`equalp' if they would otherwise be equal (same length, type, etc.) and
-their contents are `equalp'. This goes for conses, weak lists,
-weak boxes, ephemerons, specifiers, hash tables, char tables and range
-tables. However, objects that happen to contain other objects but are not
-primarily designed for this purpose (e.g. compiled functions, events or
-display-related objects such as glyphs, faces or extents) are currently
-compared using `equalp' the same way as using `equal'.
-
-More specifically, two hash tables are `equalp' if they have the same test
-(see `hash-table-test'), the same number of entries, and the same value for
-`hash-table-weakness', and if, for each entry in one hash table, its key is
-equivalent to a key in the other hash table using the hash table test, and
-its value is `equalp' to the other hash table's value for that key.
-*/
- (object1, object2))
-{
- return internal_equalp (object1, object2, 0) ? Qt : Qnil;
+DEFUN ("old-member", Fold_member, 2, 2, 0, /*
+Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
+The value is actually the tail of LIST whose car is ELT.
+This function is provided only for byte-code compatibility with v19.
+Do not use it.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
+ {
+ if (internal_old_equal (elt, list_elt, 0))
+ return tail;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
+Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
+The value is actually the tail of LIST whose car is ELT.
+This function is provided only for byte-code compatibility with v19.
+Do not use it.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
+ {
+ if (HACKEQ_UNSAFE (elt, list_elt))
+ return tail;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
+Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car equals KEY.
+*/
+ (key, alist))
+{
+ /* This function can GC. */
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (internal_old_equal (key, elt_car, 0))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
+Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car is KEY.
+Elements of ALIST that are not conses are ignored.
+This function is provided only for byte-code compatibility with v19.
+Do not use it.
+*/
+ (key, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (HACKEQ_UNSAFE (key, elt_car))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
+Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr equals VALUE.
+*/
+ (value, alist))
+{
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
+ {
+ if (internal_old_equal (value, elt_cdr, 0))
+ return elt;
+ }
+ return Qnil;
+}
+
+DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
+Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `old-equal'.
+If the first member of LIST is ELT, there is no way to remove it by side
+effect; therefore, write `(setq foo (old-delete element foo))' to be sure
+of changing the value of `foo'.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (internal_old_equal (elt, list_elt, 0)));
+ return list;
+}
+
+DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
+Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `old-eq'.
+If the first member of LIST is ELT, there is no way to remove it by side
+effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
+changing the value of `foo'.
+*/
+ (elt, list))
+{
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (HACKEQ_UNSAFE (elt, list_elt)));
+ return list;
}
DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
＠＠ -6613,6 +6614,26 ＠＠
{
return internal_old_equal (object1, object2, 0) ? Qt : Qnil;
}
+
+DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
+Return t if the two args are (in most cases) the same Lisp object.
+
+Special kludge: A character is considered `old-eq' to its equivalent integer
+even though they are not the same object and are in fact of different
+types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
+preserve byte-code compatibility with v19. This kludge is known as the
+\"char-int confoundance disease\" and appears in a number of other
+functions with `old-foo' equivalents.
+
+Do not use this function!
+*/
+ (object1, object2))
+{
+ /* #### blasphemy */
+ return HACKEQ_UNSAFE (object1, object2) ? Qt : Qnil;
+}
+
+#endif
static Lisp_Object replace_string_range_1 (Lisp_Object dest,
＠＠ -11798,25 +11819,17 ＠＠
DEFSUBR (Fbutlast);
DEFSUBR (Fnbutlast);
DEFSUBR (Fmember);
- DEFSUBR (Fold_member);
DEFSUBR (Fmemq);
- DEFSUBR (Fold_memq);
DEFSUBR (FmemberX);
DEFSUBR (Fadjoin);
DEFSUBR (Fassoc);
- DEFSUBR (Fold_assoc);
DEFSUBR (Fassq);
- DEFSUBR (Fold_assq);
DEFSUBR (Frassoc);
- DEFSUBR (Fold_rassoc);
DEFSUBR (Frassq);
- DEFSUBR (Fold_rassq);
DEFSUBR (Fposition);
DEFSUBR (Ffind);
- DEFSUBR (Fold_delete);
- DEFSUBR (Fold_delq);
DEFSUBR (FdeleteX);
DEFSUBR (FremoveX);
DEFSUBR (Fremassoc);
＠＠ -11853,8 +11866,20 ＠＠
DEFSUBR (Fobject_setplist);
DEFSUBR (Fequal);
DEFSUBR (Fequalp);
+ DEFSUBR (Ffill);
+
+#ifdef SUPPORT_CONFOUNDING_FUNCTIONS
+ DEFSUBR (Fold_member);
+ DEFSUBR (Fold_memq);
+ DEFSUBR (Fold_assoc);
+ DEFSUBR (Fold_assq);
+ DEFSUBR (Fold_rassoc);
+ DEFSUBR (Fold_rassq);
+ DEFSUBR (Fold_delete);
+ DEFSUBR (Fold_delq);
DEFSUBR (Fold_equal);
- DEFSUBR (Ffill);
+ DEFSUBR (Fold_eq);
+#endif
DEFSUBR (FassocX);
DEFSUBR (FrassocX);
diff -r 6c3a695f54f5 -r d967d96ca043 tests/ChangeLog
--- a/tests/ChangeLog Mon Mar 14 21:04:45 2011 +0000
+++ b/tests/ChangeLog Thu Mar 17 20:13:00 2011 +0000
＠＠ -1,3 +1,9 ＠＠
+2011-03-17 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el:
+ Only test the various old-* function if old-eq is bound and a
+ subr.
+
2011-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/byte-compiler-tests.el:
diff -r 6c3a695f54f5 -r d967d96ca043 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Mon Mar 14 21:04:45 2011 +0000
+++ b/tests/automated/lisp-tests.el Thu Mar 17 20:13:00 2011 +0000
＠＠ -796,18 +796,18 ＠＠
(Check-Error (malformed-list wrong-type-argument) (,fun nil 1))
,＠(loop for n in '(1 2 2000)
collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
- (test-funs (&rest funs) `(progn ,＠(loop for fun in funs collect `(test-fun ,fun)))))
-
+ (test-funs (&rest funs) `(progn ,＠(loop for fun in funs collect `(test-fun ,fun))))
+ (test-old-funs (&rest funs)
+ `(when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq)))
+ ,＠(loop for fun in funs collect `(test-fun ,fun)))))
(test-funs member* member memq
assoc* assoc assq
rassoc* rassoc rassq
delete* delete delq
remove* remove remq
- old-member old-memq
- old-assoc old-assq
- old-rassoc old-rassq
- old-delete old-delq
- remassoc remassq remrassoc remrassq))
+ remassoc remassq remrassoc remrassq)
+ (test-old-funs old-member old-memq old-assoc old-assq old-rassoc old-rassq
+ old-delete old-delq))
(let ((x '((1 . 2) 3 (4 . 5))))
(Assert (eq (assoc 1 x) (car x)))
＠＠ -891,19 +891,15 ＠＠
(Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a)))))
(Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a)))))
(Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a)))))
-
(Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
(Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
- (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
- (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
-
(Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
(Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
- (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
- (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
- )
-
-
+ (when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq)))
+ (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
+ (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
+ (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
+ (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))))
(flet ((a () (list '("1" . "2") "3" '("4" . "5"))))
(Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Update png_instantiate () to work with more recent versions of libpng.
12 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 5431:6c3a695f54f5
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Mon Mar 14 21:04:45 2011 +0000
files: src/ChangeLog src/glyphs-eimage.c
description:
Update png_instantiate () to work with more recent versions of libpng.
2011-03-14 Aidan Kehoe <kehoea(a)parhasard.net>
* glyphs-eimage.c (png_instantiate):
Update the PNG handling code to work with versions of the library
where the png_info structure is no longer visible. Thank you for
the report, Robert Delius Royar.
diff -r 6f10ac29bf40 -r 6c3a695f54f5 src/ChangeLog
--- a/src/ChangeLog Sat Mar 12 13:11:31 2011 +0000
+++ b/src/ChangeLog Mon Mar 14 21:04:45 2011 +0000
＠＠ -1,3 +1,10 ＠＠
+2011-03-14 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * glyphs-eimage.c (png_instantiate):
+ Update the PNG handling code to work with versions of the library
+ where the png_info structure is no longer visible. Thank you for
+ the report, Robert Delius Royar.
+
2011-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* event-stream.c (Fdispatch_event):
diff -r 6f10ac29bf40 -r 6c3a695f54f5 src/glyphs-eimage.c
--- a/src/glyphs-eimage.c Sat Mar 12 13:11:31 2011 +0000
+++ b/src/glyphs-eimage.c Mon Mar 14 21:04:45 2011 +0000
＠＠ -982,8 +982,8 ＠＠
int y, padding;
Binbyte **row_pointers;
UINT_64_BIT pixels_sq;
- height = info_ptr->height;
- width = info_ptr->width;
+ height = png_get_image_height (png_ptr, info_ptr);
+ width = png_get_image_width (png_ptr, info_ptr);
pixels_sq = (UINT_64_BIT) width * (UINT_64_BIT) height;
if (pixels_sq > ((size_t) -1) / 3)
signal_image_error ("PNG image too large to instantiate", instantiator);
＠＠ -1044,30 +1044,37 ＠＠
/* Now that we're using EImage, ask for 8bit RGB triples for any type
of image*/
- /* convert palette images to RGB */
- if (info_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
- png_set_palette_to_rgb (png_ptr);
- /* convert grayscale images to RGB */
- else if (info_ptr->color_type == PNG_COLOR_TYPE_GRAY ||
- info_ptr->color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
- png_set_gray_to_rgb (png_ptr);
- /* pad images with depth < 8 bits */
- else if (info_ptr->bit_depth < 8)
+ switch (png_get_color_type (png_ptr, info_ptr))
{
- if (info_ptr->color_type == PNG_COLOR_TYPE_GRAY)
- png_set_expand (png_ptr);
- else
- png_set_packing (png_ptr);
+ case PNG_COLOR_TYPE_PALETTE:
+ /* convert palette images to RGB */
+ png_set_palette_to_rgb (png_ptr);
+ break;
+
+ case PNG_COLOR_TYPE_GRAY:
+ case PNG_COLOR_TYPE_GRAY_ALPHA:
+ /* convert grayscale images to RGB */
+ png_set_gray_to_rgb (png_ptr);
+ break;
+
+ default:
+ /* pad images with depth < 8 bits */
+ if (png_get_bit_depth (png_ptr, info_ptr) < 8)
+ {
+ png_set_packing (png_ptr);
+ }
+ break;
}
+
/* strip 16-bit depth files down to 8 bits */
- if (info_ptr->bit_depth == 16)
+ if (png_get_bit_depth (png_ptr, info_ptr) == 16)
png_set_strip_16 (png_ptr);
/* strip alpha channel
#### shouldn't we handle this?
first call png_read_update_info in case above transformations
have generated an alpha channel */
png_read_update_info(png_ptr, info_ptr);
- if (info_ptr->color_type & PNG_COLOR_MASK_ALPHA)
+ if (png_get_color_type (png_ptr, info_ptr) & PNG_COLOR_MASK_ALPHA)
png_set_strip_alpha (png_ptr);
png_read_image (png_ptr, row_pointers);
＠＠ -1077,23 +1084,25 ＠＠
* into the glyph code, where you can get to it from lisp
* anyway. - WMP */
{
- int i;
+ int ii, num_text = 0;
+ png_textp text_ptr = NULL;
DECLARE_EISTRING (key);
DECLARE_EISTRING (text);
- for (i = 0 ; i < info_ptr->num_text ; i++)
- {
- /* How paranoid do I have to be about no trailing NULLs, and
- using (int)info_ptr->text[i].text_length, and strncpy and a temp
- string somewhere? */
- eireset(key);
- eireset(text);
- eicpy_ext(key, info_ptr->text[i].key, Qbinary);
- eicpy_ext(text, info_ptr->text[i].text, Qbinary);
+ if (png_get_text (png_ptr, info_ptr, &text_ptr, &num_text) > 0)
+ {
+ for (ii = 0 ; ii < num_text; ii++)
+ {
+ eireset (key);
+ eireset (text);
- warn_when_safe (Qpng, Qinfo, "%s - %s",
- eidata(key), eidata(text));
- }
+ eicpy_ext (key, text_ptr[ii].key, Qbinary);
+ eicpy_ext (text, text_ptr[ii].text, Qbinary);
+
+ warn_when_safe (Qpng, Qinfo, "%s - %s", eidata (key),
+ eidata (text));
+ }
+ }
}
xfree (row_pointers);
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Be better about searching for chars typed via XIM and x-compose.el, isearch
12 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 5430:6f10ac29bf40
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sat Mar 12 13:11:31 2011 +0000
files: lisp/ChangeLog lisp/isearch-mode.el src/ChangeLog src/event-stream.c
description:
Be better about searching for chars typed via XIM and x-compose.el, isearch
lisp/ChangeLog addition:
2011-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* isearch-mode.el (isearch-mode-map):
Document why we bind the ASCII characters to isearch-printing-char
in more detail.
* isearch-mode.el (isearch-maybe-frob-keyboard-macros):
If `this-command' is nil and the keys typed would normally be
bound to `self-insert-command' in the global map, force
`isearch-printing-char' to be called with an appropriate value for
last-command-event. Addresses an issue where searching for
characters generated from x-compose.el and XIM threw errors for me
in dired.
src/ChangeLog addition:
2011-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* event-stream.c (Fdispatch_event):
As documented, allow pre-command-hook to usefully modify
this-command even when this-command is nil (that is, we would
normally throw an undefined-keystroke-sequence error). Don't throw
that error if this-command was modified, instead try to execute
the new value.
Allow pre-command-hook to modify last-command-event in this
specific context. Don't document this, for the moment.
diff -r 4c4b96b13f70 -r 6f10ac29bf40 lisp/ChangeLog
--- a/lisp/ChangeLog Fri Mar 11 20:40:01 2011 +0000
+++ b/lisp/ChangeLog Sat Mar 12 13:11:31 2011 +0000
＠＠ -1,3 +1,16 ＠＠
+2011-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * isearch-mode.el (isearch-mode-map):
+ Document why we bind the ASCII characters to isearch-printing-char
+ in more detail.
+ * isearch-mode.el (isearch-maybe-frob-keyboard-macros):
+ If `this-command' is nil and the keys typed would normally be
+ bound to `self-insert-command' in the global map, force
+ `isearch-printing-char' to be called with an appropriate value for
+ last-command-event. Addresses an issue where searching for
+ characters generated from x-compose.el and XIM threw errors for me
+ in dired.
+
2011-03-10 Aidan Kehoe <kehoea(a)parhasard.net>
* etags.el (buffer-tag-table-list):
diff -r 4c4b96b13f70 -r 6f10ac29bf40 lisp/isearch-mode.el
--- a/lisp/isearch-mode.el Fri Mar 11 20:40:01 2011 +0000
+++ b/lisp/isearch-mode.el Sat Mar 12 13:11:31 2011 +0000
＠＠ -239,10 +239,18 ＠＠
(let ((map (make-keymap)))
(set-keymap-name map 'isearch-mode-map)
- ;; Bind all printing characters to `isearch-printing-char'.
- ;; This isn't normally necessary, but if a printing character were
- ;; bound to something other than self-insert-command in global-map,
- ;; then it would terminate the search and be executed without this.
+ ;; Bind ASCII printing characters to `isearch-printing-char'. This
+ ;; isn't normally necessary, but if a printing character were bound to
+ ;; something other than self-insert-command in global-map, then it would
+ ;; terminate the search and be executed without this.
+
+ ;; This is also relevant when other modes (notably dired and gnus) call
+ ;; `suppress-keymap' on their major mode maps; this means that
+ ;; `isearch-maybe-frob-keyboard-macros' won't pick up that the command
+ ;; that would normally be executed is `self-insert-command' and do its
+ ;; thing of transforming that to `isearch-printing-char'. This is less
+ ;; of an issue for the non-ASCII characters, because they rarely have
+ ;; specific bindings in major modes.
(let ((i 32)
(str (make-string 1 0)))
(while (< i 127)
＠＠ -1609,8 +1617,27 ＠＠
last-command-char (and (stringp this-command)
(aref this-command 0))
this-command 'isearch-printing-char))
- ))
-
+ ((and (null this-command)
+ (eq 'key-press (event-type last-command-event))
+ (current-local-map)
+ (let* ((this-command-keys (this-command-keys))
+ (this-command-keys (or (lookup-key function-key-map
+ this-command-keys)
+ this-command-keys))
+ (lookup-key (lookup-key global-map this-command-keys)))
+ (and (eq 'self-insert-command lookup-key)
+ ;; The feature here that a modification of
+ ;; last-command-event is respected is undocumented, and
+ ;; only applies when this-command is nil. The design
+ ;; isn't reat, and I welcome suggestions for a better
+ ;; one.
+ (setq last-command-event
+ (find-if 'key-press-event-p this-command-keys
+:from-end t)
+ last-command-char
+ (event-to-character last-command-event)
+ this-command 'isearch-printing-char)))))))
+
;;;========================================================
;;; Highlighting
diff -r 4c4b96b13f70 -r 6f10ac29bf40 src/ChangeLog
--- a/src/ChangeLog Fri Mar 11 20:40:01 2011 +0000
+++ b/src/ChangeLog Sat Mar 12 13:11:31 2011 +0000
＠＠ -1,3 +1,14 ＠＠
+2011-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * event-stream.c (Fdispatch_event):
+ As documented, allow pre-command-hook to usefully modify
+ this-command even when this-command is nil (that is, we would
+ normally throw an undefined-keystroke-sequence error). Don't throw
+ that error if this-command was modified, instead try to execute
+ the new value.
+ Allow pre-command-hook to modify last-command-event in this
+ specific context. Don't document this, for the moment.
+
2011-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecode.c (optimize_byte_code):
diff -r 4c4b96b13f70 -r 6f10ac29bf40 src/event-stream.c
--- a/src/event-stream.c Fri Mar 11 20:40:01 2011 +0000
+++ b/src/event-stream.c Sat Mar 12 13:11:31 2011 +0000
＠＠ -4445,6 +4445,7 ＠＠
{
Lisp_Object leaf = lookup_command_event (command_builder, event, 1);
+ lookedup:
if (KEYMAPP (leaf))
/* Incomplete key sequence */
break;
＠＠ -4524,6 +4525,22 ＠＠
GCPRO1 (keys);
pre_command_hook ();
UNGCPRO;
+
+ if (!NILP (Vthis_command))
+ {
+ /* Allow pre-command-hook to change the command to
+ something more useful, and avoid barfing. */
+ leaf = Vthis_command;
+ if (!EQ (command_builder->most_current_event,
+ Vlast_command_event))
+ {
+ reset_current_events (command_builder);
+ command_builder_append_event (command_builder,
+ Vlast_command_event);
+ }
+ goto lookedup;
+ }
+
/* The post-command-hook doesn't run. */
Fsignal (Qundefined_keystroke_sequence, list1 (keys));
}
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Address the easy test failures in tests/automated.
12 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 5429:4c4b96b13f70
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Fri Mar 11 20:40:01 2011 +0000
files: src/ChangeLog src/bytecode.c tests/ChangeLog tests/automated/byte-compiler-tests.el tests/automated/lisp-tests.el
description:
Address the easy test failures in tests/automated.
src/ChangeLog addition:
2011-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecode.c (optimize_byte_code):
Only transform assignments to keywords to Bdiscard if
NEED_TO_HANDLE_21_4_CODE is turned on. Cf. similar code in
reject_constant_symbols().
tests/ChangeLog addition:
2011-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/byte-compiler-tests.el:
(defconst :foo 1) now gives a warning when byte-compiled, check
for that.
(setq :foo 1) now errors with interpreted code, but succeeds with
byte-compiled code; check for the former, wrap a
Known-Bug-Expect-Failure around a check for the error in the
latter case, we can't yet remove this behaviour while we're using
packages compiled by 21.4.
* automated/lisp-tests.el (wrong-type-argument):
Integer zero is a valid argument to #'substring-no-properties, use
Assert not Check-Error for it. Check some other aspects of the
functionality of #'substring-no-properties in passing.
diff -r 4141aeddc55b -r 4c4b96b13f70 src/ChangeLog
--- a/src/ChangeLog Thu Mar 10 19:14:25 2011 +0000
+++ b/src/ChangeLog Fri Mar 11 20:40:01 2011 +0000
＠＠ -1,3 +1,10 ＠＠
+2011-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecode.c (optimize_byte_code):
+ Only transform assignments to keywords to Bdiscard if
+ NEED_TO_HANDLE_21_4_CODE is turned on. Cf. similar code in
+ reject_constant_symbols().
+
2011-02-24 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Fsubstring_no_properties):
diff -r 4141aeddc55b -r 4c4b96b13f70 src/bytecode.c
--- a/src/bytecode.c Thu Mar 10 19:14:25 2011 +0000
+++ b/src/bytecode.c Fri Mar 11 20:40:01 2011 +0000
＠＠ -1961,11 +1961,14 ＠＠
wtaerror ("attempt to set non-symbol", val);
if (EQ (val, Qnil) || EQ (val, Qt))
signal_error (Qsetting_constant, 0, val);
+#ifdef NEED_TO_HANDLE_21_4_CODE
/* Ignore assignments to keywords by converting to Bdiscard.
- For backward compatibility only - we'd like to make this an error. */
+ For backward compatibility only - we'd like to make this an
+ error. */
if (SYMBOL_IS_KEYWORD (val))
REWRITE_OPCODE (Bdiscard);
else
+#endif
WRITE_NARGS (Bvarset);
break;
diff -r 4141aeddc55b -r 4c4b96b13f70 tests/ChangeLog
--- a/tests/ChangeLog Thu Mar 10 19:14:25 2011 +0000
+++ b/tests/ChangeLog Fri Mar 11 20:40:01 2011 +0000
＠＠ -1,3 +1,18 ＠＠
+2011-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/byte-compiler-tests.el:
+ (defconst :foo 1) now gives a warning when byte-compiled, check
+ for that.
+ (setq :foo 1) now errors with interpreted code, but succeeds with
+ byte-compiled code; check for the former, wrap a
+ Known-Bug-Expect-Failure around a check for the error in the
+ latter case, we can't yet remove this behaviour while we're using
+ packages compiled by 21.4.
+ * automated/lisp-tests.el (wrong-type-argument):
+ Integer zero is a valid argument to #'substring-no-properties, use
+ Assert not Check-Error for it. Check some other aspects of the
+ functionality of #'substring-no-properties in passing.
+
2011-02-24 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (substring-no-properties):
diff -r 4141aeddc55b -r 4c4b96b13f70 tests/automated/byte-compiler-tests.el
--- a/tests/automated/byte-compiler-tests.el Thu Mar 10 19:14:25 2011 +0000
+++ b/tests/automated/byte-compiler-tests.el Fri Mar 11 20:40:01 2011 +0000
＠＠ -45,7 +45,7 ＠＠
(check-byte-compiler-message "Attempt to set non-symbol" (setq 1 1))
(check-byte-compiler-message "Attempt to set constant symbol" (setq t 1))
(check-byte-compiler-message "Attempt to set constant symbol" (setq nil 1))
-(check-byte-compiler-message "^$" (defconst :foo 1))
+(check-byte-compiler-message "Attempt to set constant symbol" (defconst :foo 1))
(check-byte-compiler-message "Attempt to let-bind non-symbol" (let ((1 'x)) 1))
(check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((t 'x)) (foo)))
＠＠ -60,12 +60,16 ＠＠
(check-byte-compiler-message "reference to free variable" (car free-variable))
(check-byte-compiler-message "called with 2 args, but requires 1" (car 'x 'y))
-(check-byte-compiler-message "^$" (setq :foo 1))
(let ((fun '(lambda () (setq :foo 1))))
(fset 'test-byte-compiler-fun fun))
(Check-Error setting-constant (test-byte-compiler-fun))
-(byte-compile 'test-byte-compiler-fun)
-(Check-Error setting-constant (test-byte-compiler-fun))
+(Check-Message "Attempt to set constant symbol"
+ (byte-compile 'test-byte-compiler-fun))
+
+;; Once NEED_TO_HANDLE_21_4_CODE is no longer defined in C, this will error
+;; correctly. It's disabled because the packages are compiled by 21.4.
+(Known-Bug-Expect-Failure
+ (Check-Error setting-constant (test-byte-compiler-fun)))
(eval-when-compile (defvar setq-test-foo nil) (defvar setq-test-bar nil))
(progn
diff -r 4141aeddc55b -r 4c4b96b13f70 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Thu Mar 10 19:14:25 2011 +0000
+++ b/tests/automated/lisp-tests.el Fri Mar 11 20:40:01 2011 +0000
＠＠ -1339,9 +1339,17 ＠＠
(Check-Error args-out-of-range (subseq [1 2 3] -42))
(Check-Error args-out-of-range (subseq [1 2 3] 0 42))
-(Check-Error wrong-type-argument (substring-no-properties nil 4))
-(Check-Error wrong-type-argument (substring-no-properties "hi there" pi))
-(Check-Error wrong-type-argument (substring-no-properties "hi there" 0))
+(let ((string "hi there"))
+ (Assert (equal (substring-no-properties "123" 0) "123"))
+ (Assert (equal (substring-no-properties "1234" -3 -1) "23"))
+ (Assert (equal (substring-no-properties "hi there" 0) "hi there"))
+ (put-text-property 0 (length string) 'foo 'bar string)
+ (Assert (eq 'bar (get-text-property 0 'foo string)))
+ (Assert (not
+ (get-text-property 0 'foo (substring-no-properties "hi there" 0))))
+ (Check-Error wrong-type-argument (substring-no-properties nil 4))
+ (Check-Error wrong-type-argument (substring-no-properties "hi there" pi))
+ (Check-Error wrong-type-argument (substring-no-properties "hi there" 0.0)))
;;-----------------------------------------------------
;; Time-related tests
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Eliminate byte-compile warnings, core Lisp.
12 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 5428:4141aeddc55b
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Mar 10 19:14:25 2011 +0000
files: lisp/ChangeLog lisp/etags.el lisp/files.el lisp/info.el lisp/menubar-items.el lisp/mouse.el lisp/test-harness.el
description:
Eliminate byte-compile warnings, core Lisp.
2011-03-10 Aidan Kehoe <kehoea(a)parhasard.net>
* etags.el (buffer-tag-table-list):
* files.el (find-file-read-only):
* files.el (find-file-read-only-other-window):
* info.el (Info-dir-outdated-p):
* info.el (Info-dump-dir-entries):
* info.el (Info-rebuild-dir):
* menubar-items.el (default-menubar):
* mouse.el (drag-window-divider):
* mouse.el (vertical-divider-map):
* test-harness.el (emacs-lisp-file-regexp):
Eliminate byte-compile warnings, again aside from those linked to
Stephen's various non-defined fontconfig functions.
diff -r ed74d2ca7082 -r 4141aeddc55b lisp/ChangeLog
--- a/lisp/ChangeLog Thu Mar 10 18:51:15 2011 +0000
+++ b/lisp/ChangeLog Thu Mar 10 19:14:25 2011 +0000
＠＠ -1,3 +1,18 ＠＠
+2011-03-10 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * etags.el (buffer-tag-table-list):
+ * files.el (find-file-read-only):
+ * files.el (find-file-read-only-other-window):
+ * info.el (Info-dir-outdated-p):
+ * info.el (Info-dump-dir-entries):
+ * info.el (Info-rebuild-dir):
+ * menubar-items.el (default-menubar):
+ * mouse.el (drag-window-divider):
+ * mouse.el (vertical-divider-map):
+ * test-harness.el (emacs-lisp-file-regexp):
+ Eliminate byte-compile warnings, again aside from those linked to
+ Stephen's various non-defined fontconfig functions.
+
2011-03-10 Aidan Kehoe <kehoea(a)parhasard.net>
* cmdloop.el (yes-or-no-p):
diff -r ed74d2ca7082 -r 4141aeddc55b lisp/etags.el
--- a/lisp/etags.el Thu Mar 10 18:51:15 2011 +0000
+++ b/lisp/etags.el Thu Mar 10 19:14:25 2011 +0000
＠＠ -250,8 +250,8 ＠＠
(and (file-readable-p name)
;; get-tag-table-buffer has side-effects
(list (symbol-value-in-buffer 'buffer-file-name
- (get-tag-table-buffer name))))))
- result)
+ (get-tag-table-buffer name)))))
+ result))
;; If no TAGS file has been found, ask the user explicitly.
;; #### tags-file-name is *evil*.
(or result tags-file-name
diff -r ed74d2ca7082 -r 4141aeddc55b lisp/files.el
--- a/lisp/files.el Thu Mar 10 18:51:15 2011 +0000
+++ b/lisp/files.el Thu Mar 10 19:14:25 2011 +0000
＠＠ -998,9 +998,9 ＠＠
(read-coding-system "Coding system: "))
t))
(let ((value (find-file filename codesys wildcards)))
- (mapcar #'(lambda (buffer)
- (set-symbol-value-in-buffer 'buffer-read-only t buffer))
- (if (listp value) value (list value)))
+ (mapc #'(lambda (buffer)
+ (set-symbol-value-in-buffer 'buffer-read-only t buffer))
+ (if (listp value) value (list value)))
value))
(defun find-file-read-only-other-window (filename &optional codesys wildcards)
diff -r ed74d2ca7082 -r 4141aeddc55b lisp/info.el
--- a/lisp/info.el Thu Mar 10 18:51:15 2011 +0000
+++ b/lisp/info.el Thu Mar 10 19:14:25 2011 +0000
＠＠ -1127,7 +1127,7 ＠＠
(let ((dir-mod-time (nth 5 (file-attributes file)))
f-mod-time newer)
(setq Info-dir-newer-info-files nil)
- (mapcar
+ (mapc
#'(lambda (f)
(prog2
(setq f-mod-time (nth 5 (file-attributes f)))
＠＠ -1191,23 +1191,23 ＠＠
(let ((tab-width 8)
(description-col 0)
len)
- (mapcar #'(lambda (e)
- (setq e (cdr e)) ; Drop filename
- (setq len (length (concat (car e)
- (car (cdr e)))))
- (if (> len description-col)
- (setq description-col len)))
- entries)
+ (mapc #'(lambda (e)
+ (setq e (cdr e)) ; Drop filename
+ (setq len (length (concat (car e)
+ (car (cdr e)))))
+ (if (> len description-col)
+ (setq description-col len)))
+ entries)
(setq description-col (+ 5 description-col))
- (mapcar #'(lambda (e)
- (setq e (cdr e)) ; Drop filename
- (insert "* " (car e) ":" (car (cdr e)))
- (setq e (car (cdr (cdr e))))
- (while e
- (indent-to-column description-col)
- (insert (car e) "\n")
- (setq e (cdr e))))
- entries)
+ (mapc #'(lambda (e)
+ (setq e (cdr e)) ; Drop filename
+ (insert "* " (car e) ":" (car (cdr e)))
+ (setq e (car (cdr (cdr e))))
+ (while e
+ (indent-to-column description-col)
+ (insert (car e) "\n")
+ (setq e (cdr e))))
+ entries)
(insert "\n")))
＠＠ -1299,7 +1299,7 ＠＠
(narrow-to-region mark next-section)
(setq dir-section-contents (nreverse (Info-parse-dir-entries
(point-min) (point-max))))
- (mapcar
+ (mapc
#'(lambda (file)
(setq dir-entry (assoc (downcase
(file-name-sans-extension
diff -r ed74d2ca7082 -r 4141aeddc55b lisp/menubar-items.el
--- a/lisp/menubar-items.el Thu Mar 10 18:51:15 2011 +0000
+++ b/lisp/menubar-items.el Thu Mar 10 19:14:25 2011 +0000
＠＠ -262,7 +262,7 ＠＠
(submenu-generate-accelerator-spec
(mapcar #'(lambda (bmk)
`[,bmk (bookmark-delete ',bmk)])
- (bookmark-all-names)))))
+ (declare-fboundp (bookmark-all-names))))))
["%_Edit Bookmark List" bookmark-bmenu-list
:active (and-boundp 'bookmark-alist bookmark-alist)]
"---"
diff -r ed74d2ca7082 -r 4141aeddc55b lisp/mouse.el
--- a/lisp/mouse.el Thu Mar 10 18:51:15 2011 +0000
+++ b/lisp/mouse.el Thu Mar 10 19:14:25 2011 +0000
＠＠ -1781,22 +1781,24 ＠＠
(let ((all-that-bad nil)
(new-left-ok nil)
(new-right-ok nil))
- (mapcar* (lambda (window old-edges)
- (let ((new (car (window-pixel-edges window))))
- (if (/= new (car old-edges))
- (if (and new-left-ok
- (/= new-left-ok new))
- (setq all-that-bad t)
- (setq new-left-ok new)))))
- (window-list) old-edges-all-windows)
- (mapcar* (lambda (window old-edges)
- (let ((new (caddr (window-pixel-edges window))))
- (if (/= new (caddr old-edges))
- (if (and new-right-ok
- (/= new-right-ok new))
- (setq all-that-bad t)
- (setq new-right-ok new)))))
- (window-list) old-edges-all-windows)
+ (mapc (lambda (window old-edges)
+ (let ((new
+ (car (window-pixel-edges window))))
+ (if (/= new (car old-edges))
+ (if (and new-left-ok
+ (/= new-left-ok new))
+ (setq all-that-bad t)
+ (setq new-left-ok new)))))
+ (window-list) old-edges-all-windows)
+ (mapc (lambda (window old-edges)
+ (let ((new
+ (caddr (window-pixel-edges window))))
+ (if (/= new (caddr old-edges))
+ (if (and new-right-ok
+ (/= new-right-ok new))
+ (setq all-that-bad t)
+ (setq new-right-ok new)))))
+ (window-list) old-edges-all-windows)
all-that-bad))
(set-window-configuration backup-conf)))))))))
diff -r ed74d2ca7082 -r 4141aeddc55b lisp/test-harness.el
--- a/lisp/test-harness.el Thu Mar 10 18:51:15 2011 +0000
+++ b/lisp/test-harness.el Thu Mar 10 19:14:25 2011 +0000
＠＠ -128,7 +128,7 ＠＠
(defvar test-harness-current-file nil)
-(defvar emacs-lisp-file-regexp (purecopy "\\.el\\'")
+(defvar emacs-lisp-file-regexp "\\.el\\'"
"*Regexp which matches Emacs Lisp source files.")
(defconst test-harness-file-summary-template
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Use Common Lisp-derived builtins in a few more places in core Lisp.
12 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 5426:8b70d37ab80e
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Tue Mar 08 23:57:21 2011 +0000
files: lisp/ChangeLog lisp/cl-macs.el lisp/etags.el lisp/frame.el
description:
Use Common Lisp-derived builtins in a few more places in core Lisp.
2011-03-08 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el:
* cl-macs.el (loop):
* cl-macs.el (cl-expand-do-loop):
* cl-macs.el (shiftf):
* cl-macs.el (rotatef):
* cl-macs.el (assert):
* cl-macs.el (cl-defsubst-expand):
* etags.el (buffer-tag-table-list):
* frame.el:
* frame.el (frame-notice-user-settings):
* frame.el (minibuffer-frame-list):
* frame.el (get-frame-for-buffer-noselect):
Use Common Lisp-derived builtins in a few more places, none of
them performance-critical, but the style is better.
diff -r f00192e1cd49 -r 8b70d37ab80e lisp/ChangeLog
--- a/lisp/ChangeLog Tue Mar 08 23:41:52 2011 +0000
+++ b/lisp/ChangeLog Tue Mar 08 23:57:21 2011 +0000
＠＠ -1,3 +1,20 ＠＠
+2011-03-08 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el:
+ * cl-macs.el (loop):
+ * cl-macs.el (cl-expand-do-loop):
+ * cl-macs.el (shiftf):
+ * cl-macs.el (rotatef):
+ * cl-macs.el (assert):
+ * cl-macs.el (cl-defsubst-expand):
+ * etags.el (buffer-tag-table-list):
+ * frame.el:
+ * frame.el (frame-notice-user-settings):
+ * frame.el (minibuffer-frame-list):
+ * frame.el (get-frame-for-buffer-noselect):
+ Use Common Lisp-derived builtins in a few more places, none of
+ them performance-critical, but the style is better.
+
2011-03-08 Aidan Kehoe <kehoea(a)parhasard.net>
* buff-menu.el (list-buffers-noselect):
diff -r f00192e1cd49 -r 8b70d37ab80e lisp/cl-macs.el
--- a/lisp/cl-macs.el Tue Mar 08 23:41:52 2011 +0000
+++ b/lisp/cl-macs.el Tue Mar 08 23:57:21 2011 +0000
＠＠ -1066,7 +1066,7 ＠＠
Specify the name for block surrounding the loop, in place of nil.
(See `block'.)
"
- (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list clauses))))))
+ (if (notany #'symbolp (set-difference clauses '(nil t)))
(list 'block nil (list* 'while t clauses))
(let ((loop-name nil) (loop-bindings nil)
(loop-body nil) (loop-steps nil)
＠＠ -1648,12 +1648,12 ＠＠
steps)
(list* 'while (list 'not (car endtest))
(append body
- (let ((sets (mapcar
+ (let ((sets (mapcan
#'(lambda (c)
(and (consp c) (cdr (cdr c))
- (list (car c) (nth 2 c))))
+ (list
+ (list (car c) (nth 2 c)))))
steps)))
- (setq sets (delq nil sets))
(and sets
(list (cons (if (or star (not (cdr sets)))
'setq 'psetq)
＠＠ -2579,7 +2579,7 ＠＠
Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
;; XEmacs change: use iteration instead of recursion
- (if (not (memq nil (mapcar 'symbolp (butlast (cons place args)))))
+ (if (every #'symbolp (butlast (cons place args)))
(list* 'prog1 place
(let ((sets nil))
(while args
＠＠ -2600,7 +2600,7 ＠＠
"Rotate left among PLACES.
Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
- (if (not (memq nil (mapcar 'symbolp places)))
+ (if (every #'symbolp places)
(and (cdr places)
(let ((sets nil)
(first (car places)))
＠＠ -3127,11 +3127,7 ＠＠
omitted, a default message listing FORM itself is used."
(and (or (not (cl-compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
- (let ((sargs (and show-args (delq nil (mapcar
- #'(lambda (x)
- (and (not (cl-const-expr-p x))
- x))
- (cdr form))))))
+ (let ((sargs (and show-args (remove-if #'cl-const-expr-p (cdr form)))))
(list 'progn
(list 'or form
(if string
＠＠ -3226,13 +3222,12 ＠＠
(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
(if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
(if (cl-simple-exprs-p argvs) (setq simple t))
- (let ((lets (delq nil
- (mapcar* #'(lambda (argn argv)
- (if (or simple (cl-const-expr-p argv))
- (progn (setq body (subst argv argn body))
- (and unsafe (list argn argv)))
- (list argn argv)))
- argns argvs))))
+ (let ((lets (mapcan #'(lambda (argn argv)
+ (if (or simple (cl-const-expr-p argv))
+ (progn (setq body (subst argv argn body))
+ (and unsafe (list (list argn argv))))
+ (list (list argn argv))))
+ argns argvs)))
(if lets (list 'let lets body) body))))
diff -r f00192e1cd49 -r 8b70d37ab80e lisp/etags.el
--- a/lisp/etags.el Tue Mar 08 23:41:52 2011 +0000
+++ b/lisp/etags.el Tue Mar 08 23:57:21 2011 +0000
＠＠ -243,16 +243,15 ＠＠
(push expression result)
(error "Expression in tag-table-alist evaluated to non-string")))))
(setq result
- (mapcar
+ (mapcan
(lambda (name)
(when (file-directory-p name)
(setq name (concat (file-name-as-directory name) "TAGS")))
(and (file-readable-p name)
;; get-tag-table-buffer has side-effects
- (symbol-value-in-buffer 'buffer-file-name
- (get-tag-table-buffer name))))
- result))
- (setq result (delq nil result))
+ (list (symbol-value-in-buffer 'buffer-file-name
+ (get-tag-table-buffer name))))))
+ result)
;; If no TAGS file has been found, ask the user explicitly.
;; #### tags-file-name is *evil*.
(or result tags-file-name
diff -r f00192e1cd49 -r 8b70d37ab80e lisp/frame.el
--- a/lisp/frame.el Tue Mar 08 23:41:52 2011 +0000
+++ b/lisp/frame.el Tue Mar 08 23:57:21 2011 +0000
＠＠ -475,12 +475,13 ＠＠
;; onto a new frame. The default-minibuffer-frame
;; variable must be handled similarly.
(let ((users-of-initial
- (filtered-frame-list
+ (remove-if-not
#'(lambda (frame)
(and (not (eq frame frame-initial-frame))
(eq (window-frame
(minibuffer-window frame))
- frame-initial-frame))))))
+ frame-initial-frame)))
+ (frame-list))))
(if (or users-of-initial
(eq default-minibuffer-frame frame-initial-frame))
＠＠ -488,10 +489,11 ＠＠
;; are only minibuffers.
(let* ((new-surrogate
(car
- (or (filtered-frame-list
+ (or (remove-if-not
#'(lambda (frame)
(eq 'only
- (frame-property frame 'minibuffer))))
+ (frame-property frame 'minibuffer)))
+ (frame-list))
(minibuffer-frame-list))))
(new-minibuffer (minibuffer-window new-surrogate)))
＠＠ -674,29 +676,22 ＠＠
;; XEmacs change: Emacs has make-frame here. We have it in C, so no need for
;; frame-creation-function.
-;; XEmacs addition: support optional DEVICE argument.
+;; XEmacs addition: support optional DEVICE argument, use delete-if-not.
(defun filtered-frame-list (predicate &optional device)
"Return a list of all live frames which satisfy PREDICATE.
If optional second arg DEVICE is non-nil, restrict the frames
returned to that device."
- (let ((frames (if device (device-frame-list device)
- (frame-list)))
- good-frames)
- (while (consp frames)
- (if (funcall predicate (car frames))
- (setq good-frames (cons (car frames) good-frames)))
- (setq frames (cdr frames)))
- good-frames))
+ (delete-if-not predicate
+ (if device (device-frame-list device) (frame-list))))
;; XEmacs addition: support optional DEVICE argument.
(defun minibuffer-frame-list (&optional device)
"Return a list of all frames with their own minibuffers.
If optional second arg DEVICE is non-nil, restrict the frames
returned to that device."
- (filtered-frame-list
- #'(lambda (frame)
- (eq frame (window-frame (minibuffer-window frame))))
- device))
+ (delete-if-not
+ #'(lambda (frame) (eq frame (window-frame (minibuffer-window frame))))
+ (if device (device-frame-list device) (frame-list))))
;; XEmacs omission: Emacs has frames-on-display-list here, but that is
;; essentially equivalent to supplying the optional DEVICE argument to
＠＠ -1745,9 +1740,10 ＠＠
(or (plist-get default-frame-plist 'name)
default-frame-name))
(frames
- (sort (filtered-frame-list #'(lambda (x)
- (or (frame-visible-p x)
- (frame-iconified-p x))))
+ (sort (remove-if-not #'(lambda (x)
+ (or (frame-visible-p x)
+ (frame-iconified-p x)))
+ (frame-list))
#'(lambda (s1 s2)
(cond ((and (frame-visible-p s1)
(not (frame-visible-p s2))))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments