commit: Correct some minor problems in my last change.
13 years, 9 months
Aidan Kehoe
Aidan Kehoe
changeset: 5377:eac2e6bd5b2c
tag: tip
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
[COMMIT] Eliminate unused blocks named nil, too, cl-macs.el, bytecomp.el
13 years, 9 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1300396036 0
# Node ID 4b529b940e2e8bcc623fed865ac1796132b99eaa
# Parent 2fba45e5b48d45e4df97aba9f07f4c00e368bb6a
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.
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Eliminate unused blocks named nil, too, cl-macs.el, bytecomp.el
13 years, 9 months
Aidan Kehoe
Aidan Kehoe
changeset: 5376:4b529b940e2e
tag: tip
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
[PATCH] Conditionalise `old-eq', `old-equal' etc. at compile time.
13 years, 9 months
Aidan Kehoe
Aidan Kehoe
As I said a few months ago, nothing in our code base provokes the ebola
warnings any more (though I think I should have pointed Andreas Roehler to
them at some point, he seemed to be affected by char-int confoundance in
code he had originally written for GNU Emacs). I’d like to remove thes
functions and their byte codes at some point in the future, and this is one
step towards that.
diff -r 6c3a695f54f5 lisp/ChangeLog
--- a/lisp/ChangeLog Mon Mar 14 21:04:45 2011 +0000
+++ b/lisp/ChangeLog Tue Mar 15 21:30:04 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 lisp/bytecomp.el
--- a/lisp/bytecomp.el Mon Mar 14 21:04:45 2011 +0000
+++ b/lisp/bytecomp.el Tue Mar 15 21:30:04 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 man/ChangeLog
--- a/man/ChangeLog Mon Mar 14 21:04:45 2011 +0000
+++ b/man/ChangeLog Tue Mar 15 21:30:04 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 man/lispref/objects.texi
--- a/man/lispref/objects.texi Mon Mar 14 21:04:45 2011 +0000
+++ b/man/lispref/objects.texi Tue Mar 15 21:30:04 2011 +0000
＠＠ -349,19 +349,6 ＠＠
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
＠w{integer 65}, following the standard ＠sc{ascii} representation of
＠＠ -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 src/ChangeLog
--- a/src/ChangeLog Mon Mar 14 21:04:45 2011 +0000
+++ b/src/ChangeLog Tue Mar 15 21:30:04 2011 +0000
＠＠ -1,3 +1,26 ＠＠
+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:
+ * data.c (syms_of_data):
+ Wrap Fold_eq with #ifdef SUPPORT_CONFOUNDING_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 src/bytecode.c
--- a/src/bytecode.c Mon Mar 14 21:04:45 2011 +0000
+++ b/src/bytecode.c Tue Mar 15 21:30:04 2011 +0000
＠＠ -1692,6 +1692,8 ＠＠
break;
}
+#ifdef SUPPORT_CONFOUNDING_FUNCTIONS
+
case Bold_eq:
{
Lisp_Object arg = POP;
＠＠ -1727,6 +1729,8 ＠＠
break;
}
+#endif
+
case Bbind_multiple_value_limits:
{
Lisp_Object upper = POP, first = TOP, speccount;
diff -r 6c3a695f54f5 src/config.h.in
--- a/src/config.h.in Mon Mar 14 21:04:45 2011 +0000
+++ b/src/config.h.in Tue Mar 15 21:30:04 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 src/data.c
--- a/src/data.c Mon Mar 14 21:04:45 2011 +0000
+++ b/src/data.c Tue Mar 15 21:30:04 2011 +0000
＠＠ -183,6 +183,8 ＠＠
return EQ_WITH_EBOLA_NOTICE (object1, object2) ? Qt : Qnil;
}
+#ifdef SUPPORT_CONFOUNDING_FUNCTIONS
+
DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
Return t if the two args are (in most cases) the same Lisp object.
＠＠ -201,6 +203,8 ＠＠
return HACKEQ_UNSAFE (object1, object2) ? Qt : Qnil;
}
+#endif
+
DEFUN ("null", Fnull, 1, 1, 0, /*
Return t if OBJECT is nil.
*/
＠＠ -3568,7 +3572,9 ＠＠
DEFSUBR (Fdiv);
#endif
DEFSUBR (Feq);
+#ifdef SUPPORT_CONFOUNDING_FUNCTIONS
DEFSUBR (Fold_eq);
+
DEFSUBR (Fnull);
Ffset (intern ("not"), intern ("null"));
DEFSUBR (Flistp);
diff -r 6c3a695f54f5 src/fns.c
--- a/src/fns.c Mon Mar 14 21:04:45 2011 +0000
+++ b/src/fns.c Tue Mar 15 21:30:04 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.
＠＠ -2611,22 +2594,6 ＠＠
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;
-}
-
Lisp_Object
memq_no_quit (Lisp_Object elt, Lisp_Object list)
{
＠＠ -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. */
＠＠ -2960,20 +2895,6 ＠＠
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 ("rassq", Frassq, 2, 2, 0, /*
Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
The value is actually the element of ALIST whose cdr is VALUE.
＠＠ -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,157 ＠＠
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
+
+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;
+}
+
/* 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,49 +6601,6 ＠＠
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-equal", Fold_equal, 2, 2, 0, /*
Return t if two Lisp objects have similar structure and contents.
They must have the same data type.
＠＠ -6614,6 +6615,8 ＠＠
return internal_old_equal (object1, object2, 0) ? Qt : Qnil;
}
+#endif
+
static Lisp_Object replace_string_range_1 (Lisp_Object dest,
Lisp_Object start,
＠＠ -11798,25 +11801,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 +11848,19 ＠＠
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);
+#endif
DEFSUBR (FassocX);
DEFSUBR (FrassocX);
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 1 comments
commit: Merge.
13 years, 9 months
Aidan Kehoe
Aidan Kehoe
changeset: 5375:2fba45e5b48d
tag: tip
parent: 5373:b6e59ea11533
parent: 5374: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
commit: Conditionalise the old-* functions and byte codes at compile time.
13 years, 9 months
Aidan Kehoe
Aidan Kehoe
changeset: 5374:d967d96ca043
parent: 5372:6c3a695f54f5
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
[COMMIT] Update MH to use unquoted symbols for `block', `return-from'.
13 years, 9 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
xemacs-packages/mh-e/ChangeLog addition:
2011-03-17 Aidan Kehoe <kehoea(a)parhasard.net>
* mh-mime.el (mh-mhn-directive-present-p):
Use unquoted symbols for `block', `return-from', as always
document but only recently enforced in XEmacs 21.5.
XEmacs Packages source patch:
Diff command: cvs -q diff -Nu
Files affected: xemacs-packages/mh-e/mh-mime.el
Index: xemacs-packages/mh-e/mh-mime.el
===================================================================
RCS file: /cvsroot/xemacs/XEmacs/packages/xemacs-packages/mh-e/mh-mime.el,v
retrieving revision 1.6
diff -u -u -r1.6 mh-mime.el
--- xemacs-packages/mh-e/mh-mime.el 2 Sep 2003 23:39:26 -0000 1.6
+++ xemacs-packages/mh-e/mh-mime.el 17 Mar 2011 19:21:12 -0000
＠＠ -425,16 +425,16 ＠＠
(defun mh-mhn-directive-present-p ()
"Check if the current buffer has text which might be a MHN directive."
(save-excursion
- (block 'search-for-mhn-directive
+ (block search-for-mhn-directive
(goto-char (point-min))
(while (re-search-forward "^#" nil t)
(let ((s (buffer-substring-no-properties (point) (line-end-position))))
(cond ((equal s ""))
((string-match "^forw[ \t\n]+" s)
- (return-from 'search-for-mhn-directive t))
+ (return-from search-for-mhn-directive t))
(t (let ((first-token (car (split-string s "[ \t;＠]"))))
(when (string-match mh-media-type-regexp first-token)
- (return-from 'search-for-mhn-directive t)))))))
+ (return-from search-for-mhn-directive t)))))))
nil)))
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Update sudoku to work with more recent versions of the byte compiler
13 years, 9 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
xemacs-packages/games/ChangeLog addition:
2011-03-17 Aidan Kehoe <kehoea(a)parhasard.net>
* sudoku.el:
* sudoku.el (sudoku-mode-setup-modeline):
* sudoku.el (sudoku-autoinsert):
* sudoku.el (sudoku-pencil-mode):
* sudoku.el (sudoku-download-puzzle):
* sudoku.el (sudoku-print):
* sudoku.el (sudoku-sdk-file-p):
* sudoku.el (sudoku-string-to-board):
* sudoku.el (sudoku-builtin-puzzles): Moved.
Update this file to work better with more recent versions of XEmacs.
This involves:
-- modeline-multibyte-status -> modeline-coding-system
-- Using unquoted symbols in `block' and `return-from', as always
documented but only recently forced.
-- Use #'signum, not #'positivep (the latter is not in any
standard and was never built-in to XEmacs.
-- Mark various special symbols used by the code as such.
XEmacs Packages source patch:
Diff command: cvs -q diff -Nu
Files affected: xemacs-packages/games/sudoku.el
Index: xemacs-packages/games/sudoku.el
===================================================================
RCS file: /cvsroot/xemacs/XEmacs/packages/xemacs-packages/games/sudoku.el,v
retrieving revision 1.1
diff -u -u -r1.1 sudoku.el
--- xemacs-packages/games/sudoku.el 12 Apr 2010 08:20:24 -0000 1.1
+++ xemacs-packages/games/sudoku.el 17 Mar 2011 19:13:47 -0000
＠＠ -138,11 +138,6 ＠＠
(require 'cl)
(require 'easymenu)
-;; XEmacs compatibility
-(unless (fboundp 'positivep)
- (defun positivep (num)
- (and (numberp num) (> num 0))))
-
;;{{{ Custom variables
(defgroup sudoku nil
＠＠ -540,7 +535,7 ＠＠
(setq modeline-format
(list
""
- modeline-multibyte-status
+ modeline-coding-system
"--"
(cons modeline-buffer-id-extent 'modeline-buffer-identification)
" "
＠＠ -1012,16 +1007,16 ＠＠
was incorrect.
Auto-insert does not work for pencils."
(interactive)
- (unless (or (positivep sudoku-current-pencil)
+ (unless (or (eql 1 (signum sudoku-current-pencil))
(and cell (sudoku-cell-empty-p cell)))
(let ((gc (or cell (sudoku-current-cell)))
(sb (copy-tree sudoku-current-board)))
(unwind-protect
- (block 'autoins
+ (block autoins
(while (some #'(lambda (fun)
(let ((rv (funcall fun cell deduce)))
(when (and deduce rv)
- (return-from 'autoins t))
+ (return-from autoins t))
rv))
sudoku-deduce-methods)))
;; Save previous board to stack, for undo
＠＠ -1399,7 +1394,7 ＠＠
If `sudoku-current-pencil' is 2, then reset to pen."
(interactive "P")
(cond (arg
- (when (positivep sudoku-current-pencil)
+ (when (eql 1 (signum sudoku-current-pencil))
(let* ((cp sudoku-current-pencil)
(sudoku-current-pencil (1- cp)))
(sudoku-pencil-reset cp))
＠＠ -1568,6 +1563,7 ＠＠
(sud (with-temp-buffer
(if (fboundp 'url-retrieve)
(let ((url-working-buffer (current-buffer)))
+ (declare (special url-working-buffer))
(url-retrieve source))
(call-process "curl" nil t nil "-s" source))
(goto-char (point-min))
＠＠ -1635,6 +1631,7 ＠＠
"Print current puzzle."
(interactive)
(let ((auto-insert nil))
+ (declare (special auto-insert))
(find-file (format "/tmp/sudoku-%s.tex"
(sudoku-puzzle-id sudoku-puzzle))))
(erase-buffer)
＠＠ -1717,7 +1714,7 ＠＠
"Return non-nil if FILE can be readed by `sudoku-load-puzzle'.
Can be used with `find-file-magic-files-alist'."
(ignore-errors
- (block 'sdk-file
+ (block sdk-file
(with-temp-buffer
(insert-file-contents-literally file)
(goto-char (point-min))
＠＠ -1727,17 +1724,17 ＠＠
(forward-line))
(dotimes (i 9)
(unless (looking-at "^[123456789.]\\{9,9\\}\r?$")
- (return-from 'sdk-file nil))
+ (return-from sdk-file nil))
(forward-line))
;; State
(unless (eobp)
(unless (looking-at "\\[State\\]\r?$")
- (return-from 'sdk-file nil))
+ (return-from sdk-file nil))
(forward-line)
(dotimes (i 9)
(unless (looking-at "^[123456789.]\\{9,9\\}\r?$")
- (return-from 'sdk-file nil))
+ (return-from sdk-file nil))
(forward-line)))
t))))
＠＠ -1786,12 +1783,6 ＠＠
;;{{{ Built-in puzzles
-(defun sudoku-builtin-puzzles (level)
- "Filter builtin puzzles by LEVEL."
- (remove-if-not #'(lambda (bip)
- (eq (plist-get (cdr bip) :level) level))
- sudoku-builtin-puzzles))
-
(defun sudoku-string-to-board (nl)
"Convert flat numbers list NL to sudoku board."
(setq nl (mapcar #'(lambda (c) (- (char-to-int c) 48))
＠＠ -1993,6 +1984,11 ＠＠
("170050000800200000045000600000500430010070000006090002000006000200000040000300180" :level evil :url "http://lgarc.narod.ru/xemacs/sudoku.el")
))
+(defun sudoku-builtin-puzzles (level)
+ "Filter builtin puzzles by LEVEL."
+ (remove-if-not #'(lambda (bip) (eq (plist-get (cdr bip) :level) level))
+ sudoku-builtin-puzzles))
+
;;}}}
(provide 'sudoku) nil
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Add min-colors specifier to defface, and document it.
13 years, 9 months
Jeff Sparkes
Jeff Sparkes
changeset: 5373:b6e59ea11533
tag: tip
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
[PATCH] Add min-colors specifier to defface
13 years, 9 months
Jeff Sparkes
Jeff Sparkes
Emacs has an extra specifier to defface, min-colors, which allows you to
use
different settings based on the number of colors that can be displayed on a
device.
http://www.gnu.org/software/emacs/elisp/html_node/Defining-Faces.html
<http://www.gnu.org/software/emacs/elisp/html_node/Defining-Faces.html>It
has been showing up in customize-based themes, so I thought I'd make
them load in XEmacs as well. An example theme is at
http://git.savannah.gnu.org/cgit/emacs.git/tree/etc/themes/tango-theme.el
--
Jeff Sparkes
jsparkes(a)gmail.com
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 2 participants
- 1 comments