Mercurial > hg > xemacs-beta
diff src/fns.c @ 5374:d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
src/ChangeLog addition:
2011-03-15 Aidan Kehoe <kehoea@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@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@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@parhasard.net>
* automated/lisp-tests.el:
Only test the various old-* function if old-eq is bound and a
subr.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Thu, 17 Mar 2011 20:13:00 +0000 |
parents | 46b53e84ea7a |
children | e99b473303e3 ac37a5f7e5be |
line wrap: on
line diff
--- 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. @@ -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,26 +6430,6 @@ return internal_equal (obj1, obj2, depth); } -/* 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, - but that seems unlikely. */ - -static int -internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) -{ - if (depth + lisp_eval_depth > max_lisp_eval_depth) - stack_overflow ("Stack overflow in equal", Qunbound); - QUIT; - if (HACKEQ_UNSAFE (obj1, obj2)) - return 1; - /* Note that (equal 20 20.0) should be nil */ - if (XTYPE (obj1) != XTYPE (obj2)) - return 0; - - 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. @@ -6600,6 +6473,134 @@ 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, + but that seems unlikely. */ + +static int +internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + if (depth + lisp_eval_depth > max_lisp_eval_depth) + stack_overflow ("Stack overflow in equal", Qunbound); + QUIT; + if (HACKEQ_UNSAFE (obj1, obj2)) + return 1; + /* Note that (equal 20 20.0) should be nil */ + if (XTYPE (obj1) != XTYPE (obj2)) + return 0; + + return internal_equal (obj1, obj2, depth); +} + +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, /* Return t if two Lisp objects have similar structure and contents. They must have the same data type. @@ -6614,6 +6615,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, Lisp_Object start, @@ -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);