Mercurial > hg > xemacs-beta
diff src/data.c @ 70:131b0175ea99 r20-0b30
Import from CVS: tag r20-0b30
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:02:59 +0200 |
parents | 859a2309aef8 |
children | cf808b4c4290 |
line wrap: on
line diff
--- a/src/data.c Mon Aug 13 09:00:04 2007 +0200 +++ b/src/data.c Mon Aug 13 09:02:59 2007 +0200 @@ -70,6 +70,34 @@ Lisp_Object Qnumberp, Qnumber_or_marker_p, Qnumber_char_or_marker_p; Lisp_Object Qweak_listp; + +#ifdef DEBUG_XEMACS + +int debug_issue_ebola_notices; + +int debug_ebola_backtrace_length; + +int +eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2) +{ + if (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))) + && (debug_issue_ebola_notices >= 2 + || XREALINT (obj1) == XREALINT (obj2))) + { + stderr_out ("Ebola warning!! ("); + Fprinc (obj1, Qexternal_debugging_output); + stderr_out (" and "); + Fprinc (obj2, Qexternal_debugging_output); + stderr_out (")\n"); + debug_short_backtrace (debug_ebola_backtrace_length); + } + + return EQ (obj1, obj2); +} + +#endif /* DEBUG_XEMACS */ + + Lisp_Object wrong_type_argument (Lisp_Object predicate, Lisp_Object value) @@ -177,7 +205,8 @@ make_char (Emchar num) { Lisp_Object val; - val = make_int (num); + /* Don't use XSETCHAR here -- it's defined in terms of make_char (). */ + XSETOBJ (val, Lisp_Char, num); return val; } @@ -188,7 +217,26 @@ */ (obj1, obj2)) { - return EQ (obj1, obj2) ? Qt : Qnil; + return EQ_WITH_EBOLA_NOTICE (obj1, obj2) ? Qt : Qnil; +} + +DEFUN ("old-eq", Fold_eq, 2, 2, 0, /* +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! +*/ + (obj1, obj2)) +{ + /* The miscreant responsible for this blasphemy is known as + Richard M. Stallman, and he will burn in hell for it. */ + return HACKEQ_UNSAFE (obj1, obj2) ? Qt : Qnil; } DEFUN ("null", Fnull, 1, 1, 0, /* @@ -346,17 +394,87 @@ DEFUN ("characterp", Fcharacterp, 1, 1, 0, /* t if OBJECT is a character. -A character is an integer that can be inserted into a buffer with -`insert-char'. All integers are considered valid characters and are -modded with 256 to get the actual character to use. +Unlike in FSF Emacs, a character is its own primitive type. +Any character can be converted into an equivalent integer using +`char-int'. To convert the other way, use `int-char'; however, +only some integers can be converted into characters. Such an integer +is called a `char-int'; see `char-int-p'. + +Some functions that work on integers (e.g. the comparison functions +<, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.) +accept characters and implicitly convert them into integers. In +general, functions that work on characters also accept char-ints and +implicitly convert them into characters. WARNING: Neither of these +behaviors is very desirable, and they are maintained for backward +compatibility with old E-Lisp programs that confounded characters and +integers willy-nilly. These behaviors may change in the future; therefore, +do not rely on them. Instead, use the character-specific functions such +as `char='. */ (object)) { return CHARP (object) ? Qt : Qnil; } +DEFUN ("char-int", Fchar_int, 1, 1, 0, /* +Convert a character into an equivalent integer. +The resulting integer will always be non-negative. The integers in +the range 0 - 255 map to characters as follows: + +0 - 31 Control set 0 +32 - 127 ASCII +128 - 159 Control set 1 +160 - 255 Right half of ISO-8859-1 + +If support for Mule does not exist, these are the only valid character +values. When Mule support exists, the values assigned to other characters +may vary depending on the particular version of XEmacs, the order in which +character sets were loaded, etc., and you should not depend on them. +*/ + (ch)) +{ + CHECK_CHAR (ch); + return make_int (XCHAR (ch)); +} + +DEFUN ("int-char", Fint_char, 1, 1, 0, /* +Convert an integer into the equivalent character. +Not all integers correspond to valid characters; use `char-int-p' to +determine whether this is the case. If the integer cannot be converted, +nil is returned. +*/ + (integer)) +{ + CHECK_INT (integer); + if (CHAR_INTP (integer)) + return make_char (XINT (integer)); + else + return Qnil; +} + +DEFUN ("char-int-p", Fchar_int_p, 1, 1, 0, /* +t if OBJECT is an integer that can be converted into a character. +See `char-int'. +*/ + (object)) +{ + return CHAR_INTP (object) ? Qt : Qnil; +} + +DEFUN ("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /* +t if OBJECT is a character or an integer that can be converted into one. +*/ + (object)) +{ + return CHAR_OR_CHAR_INTP (object) ? Qt : Qnil; +} + DEFUN ("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /* -t if OBJECT is a character or a string. +t if OBJECT is a character (or a char-int) or a string. +It is semi-hateful that we allow a char-int here, as it goes against +the name of this function, but it makes the most sense considering the +other steps we take to maintain compatibility with the old character/integer +confoundedness in older versions of E-Lisp. */ (object)) { @@ -379,6 +497,22 @@ return INTP (object) || MARKERP (object) ? Qt : Qnil; } +DEFUN ("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /* +t if OBJECT is an integer or a character. +*/ + (object)) +{ + return INTP (object) || CHARP (object) ? Qt : Qnil; +} + +DEFUN ("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /* +t if OBJECT is an integer, character or a marker (editor pointer). +*/ + (object)) +{ + return INTP (object) || CHARP (object) || MARKERP (object) ? Qt : Qnil; +} + DEFUN ("natnump", Fnatnump, 1, 1, 0, /* t if OBJECT is a nonnegative integer. */ @@ -411,6 +545,17 @@ return INT_OR_FLOATP (object) || MARKERP (object) ? Qt : Qnil; } +DEFUN ("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /* +t if OBJECT is a number, character or a marker. +*/ + (object)) +{ + return (INT_OR_FLOATP (object) || + CHARP (object) || + MARKERP (object)) + ? Qt : Qnil; +} + #ifdef LISP_FLOAT_TYPE DEFUN ("floatp", Ffloatp, 1, 1, 0, /* t if OBJECT is a floating point number. @@ -430,6 +575,7 @@ if (SYMBOLP (object)) return Qsymbol; if (KEYWORDP (object)) return Qkeyword; if (INTP (object)) return Qinteger; + if (CHARP (object)) return Qcharacter; if (STRINGP (object)) return Qstring; if (VECTORP (object)) return Qvector; @@ -875,7 +1021,7 @@ } } #endif /* LISP_FLOAT_TYPE */ - + switch (comparison) { case equal: return XINT (num1) == XINT (num2) ? Qt : Qnil; @@ -891,7 +1037,7 @@ } DEFUN ("=", Feqlsign, 2, 2, 0, /* -T if two args, both numbers or markers, are equal. +T if two args, both numbers, characters or markers, are equal. */ (num1, num2)) { @@ -900,7 +1046,7 @@ DEFUN ("<", Flss, 2, 2, 0, /* T if first arg is less than second arg. -Both must be numbers or markers. +Both must be numbers, characters or markers. */ (num1, num2)) { @@ -909,7 +1055,7 @@ DEFUN (">", Fgtr, 2, 2, 0, /* T if first arg is greater than second arg. -Both must be numbers or markers. +Both must be numbers, characters or markers. */ (num1, num2)) { @@ -918,7 +1064,7 @@ DEFUN ("<=", Fleq, 2, 2, 0, /* T if first arg is less than or equal to second arg. -Both must be numbers or markers. +Both must be numbers, characters or markers. */ (num1, num2)) { @@ -927,7 +1073,7 @@ DEFUN (">=", Fgeq, 2, 2, 0, /* T if first arg is greater than or equal to second arg. -Both must be numbers or markers. +Both must be numbers, characters or markers. */ (num1, num2)) { @@ -936,13 +1082,83 @@ DEFUN ("/=", Fneq, 2, 2, 0, /* T if first arg is not equal to second arg. -Both must be numbers or markers. +Both must be numbers, characters or markers. */ (num1, num2)) { return arithcompare (num1, num2, notequal); } +#if 0 +/* I tried implementing Common Lisp multi-arg comparison functions, + but failed because the byte-compiler needs to be hacked as well. */ + +static Lisp_Object +arithcompare_many (enum comparison comparison, int nargs, Lisp_Object *args) +{ + REGISTER int argnum; + for (argnum = 1; argnum < nargs; argnum++) + if (EQ (arithcompare ( args[argnum-1], args[argnum], comparison), Qnil)) + return Qnil; + + return Qt; +} + +xxxDEFUN ("=", Feqlsign, 1, MANY, 0, /* +T if all the arguments are equal. +The arguments may be numbers, characters or markers. +*/ + (int nargs, Lisp_Object *args)) +{ + return arithcompare (equal, nargs, args); +} + +xxxDEFUN ("<", Flss, 1, MANY, 0, /* +T if the sequence of arguments is monotonically increasing. +The arguments may be numbers, characters or markers. +*/ + (int nargs, Lisp_Object *args)) +{ + return arithcompare (less, nargs, args); +} + +xxxDEFUN (">", Fgtr, 1, MANY, 0, /* +T if the sequence of arguments is monotonically decreasing. +The arguments may be numbers, characters or markers. +*/ + (int nargs, Lisp_Object *args)) +{ + return arithcompare (grtr, nargs, args); +} + +xxxDEFUN ("<=", Fleq, 1, MANY, 0, /* +T if the sequence of arguments is monotonically nondecreasing. +The arguments may be numbers, characters or markers. +*/ + (int nargs, Lisp_Object *args)) +{ + return arithcompare (less_or_equal, nargs, args); +} + +xxxDEFUN (">=", Fgeq, 1, MANY, 0, /* +T if the sequence of arguments is monotonically nonincreasing. +The arguments may be numbers, characters or markers. +*/ + (int nargs, Lisp_Object *args)) +{ + return arithcompare_many (grtr_or_equal, nargs, args); +} + +xxxDEFUN ("/=", Fneq, 1, MANY, 0, /* +T if the sequence of arguments is monotonically increasing. +The arguments may be numbers, characters or markers. +*/ + (int nargs, Lisp_Object *args)) +{ + return arithcompare_many (notequal, nargs, args); +} +#endif /* 0 - disabled for now */ + DEFUN ("zerop", Fzerop, 1, 1, 0, /* T if NUMBER is zero. */ @@ -1051,6 +1267,7 @@ enum arithop { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin }; + #ifdef LISP_FLOAT_TYPE static Lisp_Object float_arith_driver (double accum, int argnum, enum arithop code, int nargs, @@ -1100,7 +1317,7 @@ case Alogand: case Alogior: case Alogxor: - return wrong_type_argument (Qinteger_or_marker_p, val); + return wrong_type_argument (Qinteger_char_or_marker_p, val); case Amax: if (!argnum || isnan (next) || next > accum) accum = next; @@ -1188,7 +1405,7 @@ DEFUN ("+", Fplus, 0, MANY, 0, /* Return sum of any number of arguments. -The arguments should all be numbers or markers. +The arguments should all be numbers, characters or markers. */ (int nargs, Lisp_Object *args)) { @@ -1196,7 +1413,7 @@ } DEFUN ("-", Fminus, 0, MANY, 0, /* -Negate number or subtract numbers or markers. +Negate number or subtract numbers, characters or markers. With one arg, negates it. With more than one arg, subtracts all but the first from the first. */ @@ -1207,7 +1424,7 @@ DEFUN ("*", Ftimes, 0, MANY, 0, /* Return product of any number of arguments. -The arguments should all be numbers or markers. +The arguments should all be numbers, characters or markers. */ (int nargs, Lisp_Object *args)) { @@ -1216,7 +1433,7 @@ DEFUN ("/", Fquo, 2, MANY, 0, /* Return first argument divided by all the remaining arguments. -The arguments must be numbers or markers. +The arguments must be numbers, characters or markers. */ (int nargs, Lisp_Object *args)) { @@ -1225,7 +1442,7 @@ DEFUN ("%", Frem, 2, 2, 0, /* Return remainder of first arg divided by second. -Both must be integers or markers. +Both must be integers, characters or markers. */ (num1, num2)) { @@ -1256,7 +1473,7 @@ DEFUN ("mod", Fmod, 2, 2, 0, /* Return X modulo Y. The result falls between zero (inclusive) and Y (exclusive). -Both X and Y must be numbers or markers. +Both X and Y must be numbers, characters or markers. If either argument is a float, a float will be returned. */ (x, y)) @@ -1306,8 +1523,9 @@ DEFUN ("max", Fmax, 1, MANY, 0, /* Return largest of all the arguments. -All arguments must be numbers or markers. -The value is always a number; markers are converted to numbers. +All arguments must be numbers, characters or markers. +The value is always a number; markers and characters are converted +to numbers. */ (int nargs, Lisp_Object *args)) { @@ -1316,8 +1534,9 @@ DEFUN ("min", Fmin, 1, MANY, 0, /* Return smallest of all the arguments. -All arguments must be numbers or markers. -The value is always a number; markers are converted to numbers. +All arguments must be numbers, characters or markers. +The value is always a number; markers and characters are converted +to numbers. */ (int nargs, Lisp_Object *args)) { @@ -1326,7 +1545,7 @@ DEFUN ("logand", Flogand, 0, MANY, 0, /* Return bitwise-and of all the arguments. -Arguments may be integers, or markers converted to integers. +Arguments may be integers, or markers or characters converted to integers. */ (int nargs, Lisp_Object *args)) { @@ -1335,7 +1554,7 @@ DEFUN ("logior", Flogior, 0, MANY, 0, /* Return bitwise-or of all the arguments. -Arguments may be integers, or markers converted to integers. +Arguments may be integers, or markers or characters converted to integers. */ (int nargs, Lisp_Object *args)) { @@ -1344,7 +1563,7 @@ DEFUN ("logxor", Flogxor, 0, MANY, 0, /* Return bitwise-exclusive-or of all the arguments. -Arguments may be integers, or markers converted to integers. +Arguments may be integers, or markers or characters converted to integers. */ (int nargs, Lisp_Object *args)) { @@ -1362,14 +1581,14 @@ CHECK_INT (count); return make_int (XINT (count) > 0 ? - XINT (value) << XINT (count) : - XINT (value) >> -XINT (count)); + XINT (value) << XINT (count) : + XINT (value) >> -XINT (count)); } DEFUN ("lsh", Flsh, 2, 2, 0, /* Return VALUE with its bits shifted left by COUNT. If COUNT is negative, shifting is actually to the right. -In this case, zeros are shifted in on the left. +In this case, zeros are shifted in on the left. */ (value, count)) { @@ -1378,16 +1597,17 @@ CHECK_INT_COERCE_CHAR (value); CHECK_INT (count); - if (XINT (count) > 0) - XSETINT (val, (EMACS_UINT) XUINT (value) << XINT (count)); - else - XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count)); + { + int C_count = XINT (count); + EMACS_UINT C_value = (EMACS_UINT) XUINT (value); + XSETINT (val, C_count > 0 ? C_value << C_count : C_value >> -C_count); + } return val; } DEFUN ("1+", Fadd1, 1, 1, 0, /* Return NUMBER plus one. NUMBER may be a number or a marker. -Markers are converted to integers. +Markers and characters are converted to integers. */ (number)) { @@ -1403,7 +1623,7 @@ DEFUN ("1-", Fsub1, 1, 1, 0, /* Return NUMBER minus one. NUMBER may be a number or a marker. -Markers are converted to integers. +Markers and characters are converted to integers. */ (number)) { @@ -1477,8 +1697,8 @@ struct weak_list *w1 = XWEAK_LIST (o1); struct weak_list *w2 = XWEAK_LIST (o2); - return (w1->type != w2->type && - internal_equal (w1->list, w2->list, depth + 1)); + return (w1->type == w2->type) && + internal_equal (w1->list, w2->list, depth + 1); } static unsigned long @@ -1757,6 +1977,7 @@ CHECK_SYMBOL (symbol); if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE; if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC; + if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */ if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC; if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC; @@ -1977,16 +2198,15 @@ defsymbol (&Qchar_or_string_p, "char-or-string-p"); defsymbol (&Qmarkerp, "markerp"); defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p"); - /* HACK for 19.x only. */ - defsymbol (&Qinteger_char_or_marker_p, "integer-or-marker-p"); + defsymbol (&Qinteger_or_char_p, "integer-or-char-p"); + defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p"); #ifdef LISP_FLOAT_TYPE defsymbol (&Qfloatp, "floatp"); #endif /* LISP_FLOAT_TYPE */ defsymbol (&Qnumberp, "numberp"); defsymbol (&Qnumber_or_marker_p, "number-or-marker-p"); - /* HACK for 19.x only. */ - defsymbol (&Qnumber_char_or_marker_p, "number-or-marker-p"); + defsymbol (&Qnumber_char_or_marker_p, "number-char-or-marker-p"); defsymbol (&Qcdr, "cdr"); @@ -1995,6 +2215,7 @@ DEFSUBR (Fwrong_type_argument); DEFSUBR (Feq); + DEFSUBR (Fold_eq); DEFSUBR (Fnull); DEFSUBR (Flistp); DEFSUBR (Fnlistp); @@ -2002,10 +2223,17 @@ DEFSUBR (Fatom); DEFSUBR (Fchar_or_string_p); DEFSUBR (Fcharacterp); + DEFSUBR (Fchar_int_p); + DEFSUBR (Fchar_int); + DEFSUBR (Fint_char); + DEFSUBR (Fchar_or_char_int_p); DEFSUBR (Fintegerp); DEFSUBR (Finteger_or_marker_p); + DEFSUBR (Finteger_or_char_p); + DEFSUBR (Finteger_char_or_marker_p); DEFSUBR (Fnumberp); DEFSUBR (Fnumber_or_marker_p); + DEFSUBR (Fnumber_char_or_marker_p); #ifdef LISP_FLOAT_TYPE DEFSUBR (Ffloatp); #endif /* LISP_FLOAT_TYPE */ @@ -2083,4 +2311,30 @@ { /* This must not be staticpro'd */ Vall_weak_lists = Qnil; + +#ifdef DEBUG_XEMACS + DEFVAR_INT ("debug-issue-ebola-notices", &debug_issue_ebola_notices /* +If non-nil, note when your code may be suffering from char-int confoundance. +That is to say, if XEmacs encounters a usage of `eq', `memq', `equal', +etc. where a int and a char with the same value are being compared, +it will issue a notice on stderr to this effect, along with a backtrace. +In such situations, the result would be different in XEmacs 19 versus +XEmacs 20, and you probably don't want this. + +Note that in order to see these notices, you have to byte compile your +code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will +have its chars and ints all confounded in the byte code, making it +impossible to accurately determine Ebola infection. +*/ ); + + debug_issue_ebola_notices = 2; /* #### temporary hack */ + + DEFVAR_INT ("debug-ebola-backtrace-length", + &debug_ebola_backtrace_length /* +Length (in stack frames) of short backtrace printed out in Ebola notices. +See `debug-issue-ebola-notices'. +*/ ); + debug_ebola_backtrace_length = 8; + +#endif /* DEBUG_XEMACS */ }