commit: Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
14 years, 8 months
Aidan Kehoe
Aidan Kehoe
changeset: 4678:b5e1d4f6b66f
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Tue Aug 11 17:59:23 2009 +0100
files: lisp/ChangeLog lisp/cl-compat.el lisp/cl-extra.el man/ChangeLog man/lispref/numbers.texi src/ChangeLog src/bytecode.c src/doprnt.c src/floatfns.c src/lisp.h src/number.c src/number.h tests/ChangeLog tests/automated/lisp-tests.el
description:
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
lisp/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-extra.el (ceiling*, floor*, round*, truncate*):
Implement these in terms of the C functions; mark them as
obsolete.
(mod*, rem*): Use #'nth-value with the C functions, not #'nth with
the CL emulation functions.
man/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/numbers.texi (Bigfloat Basics):
Correct this documentation (ignoring for the moment that it breaks
off in mid-sentence).
tests/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
Test the new Common Lisp-compatible rounding functions available in
C.
(generate-rounding-output): Provide a function useful for
generating the data for the rounding functions tests.
src/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
* floatfns.c (ROUNDING_CONVERT, CONVERT_WITH_NUMBER_TYPES)
(CONVERT_WITHOUT_NUMBER_TYPES, MAYBE_TWO_ARGS_BIGNUM)
(MAYBE_ONE_ARG_BIGNUM, MAYBE_TWO_ARGS_RATIO)
(MAYBE_ONE_ARG_RATIO, MAYBE_TWO_ARGS_BIGFLOAT)
(MAYBE_ONE_ARG_BIGFLOAT, MAYBE_EFF, MAYBE_CHAR_OR_MARKER):
New macros, used in the implementation of the rounding functions.
(ceiling_two_fixnum, ceiling_two_bignum, ceiling_two_ratio)
(ceiling_two_bigfloat, ceiling_one_ratio, ceiling_one_bigfloat)
(ceiling_two_float, ceiling_one_float, ceiling_one_mundane_arg)
(floor_two_fixnum, floor_two_bignum, floor_two_ratio)
(floor_two_bigfloat, floor_one_ratio, floor_one_bigfloat)
(floor_two_float, floor_one_mundane_arg, round_two_fixnum)
(round_two_bignum_1, round_two_bignum, round_two_ratio)
(round_one_bigfloat_1, round_two_bigfloat, round_one_ratio)
(round_one_bigfloat, round_two_float, round_one_float)
(round_one_mundane_arg, truncate_two_fixnum)
(truncate_two_bignum, truncate_two_ratio, truncate_two_bigfloat)
(truncate_one_ratio, truncate_one_bigfloat, truncate_two_float)
(truncate_one_float, truncate_one_mundane_arg):
New functions, used in the implementation of the rounding
functions.
(Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor)
(Ffround, Fftruncate):
Revise to fully support Common Lisp conventions. This means:
-- All functions have optional DIVISOR arguments
-- All functions return multiple values; see #'values
-- All functions do their arithmetic with the correct number types
according to the contamination rules.
-- #'round and #'fround always round towards the even number
in ambiguous cases.
* doprnt.c (emacs_doprnt_1):
* number.c (internal_coerce_number):
Call Ftruncate with two arguments, not one.
* floatfns.c (Ffloat):
Correct this, if NUMBER is a bignum.
* lisp.h:
Declare Ftruncate as taking two arguments.
* number.c:
Provide scratch_ratio2, init it appropriately.
* number.h:
Make scratch_ratio2 available.
* number.h (BIGFLOAT_ARITH_RETURN):
* number.h (BIGFLOAT_ARITH_RETURN1):
Correct these functions.
diff -r 8f1ee2d15784 -r b5e1d4f6b66f lisp/ChangeLog
--- a/lisp/ChangeLog Sun Aug 16 20:55:49 2009 +0100
+++ b/lisp/ChangeLog Tue Aug 11 17:59:23 2009 +0100
＠＠ -9,6 +9,14 ＠＠
* minibuf.el (read-from-minibuffer):
Use buffer (format " *Minibuf-%d*" (minibuffer-depth)), regardless
of depth.
+
+2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-extra.el (ceiling*, floor*, round*, truncate*):
+ Implement these in terms of the C functions; mark them as
+ obsolete.
+ (mod*, rem*): Use #'nth-value with the C functions, not #'nth with
+ the CL emulation functions.
2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
diff -r 8f1ee2d15784 -r b5e1d4f6b66f lisp/cl-compat.el
--- a/lisp/cl-compat.el Sun Aug 16 20:55:49 2009 +0100
+++ b/lisp/cl-compat.el Tue Aug 11 17:59:23 2009 +0100
＠＠ -82,12 +82,11 ＠＠
(if test-not (not (funcall test-not item elt))
(funcall (or test 'eql) item elt))))
-;;; Rounding functions with old-style multiple value returns.
-
-(defun cl-floor (a &optional b) (values-list (floor* a b)))
-(defun cl-ceiling (a &optional b) (values-list (ceiling* a b)))
-(defun cl-round (a &optional b) (values-list (round* a b)))
-(defun cl-truncate (a &optional b) (values-list (truncate* a b)))
+;; The rounding functions in C now have all the functionality this package
+;; used to:
+(loop
+ for symbol in '(floor ceiling round truncate)
+ do (defalias (intern (format "cl-%s" symbol)) symbol))
(defun safe-idiv (a b)
(let* ((q (/ (abs a) (abs b)))
diff -r 8f1ee2d15784 -r b5e1d4f6b66f lisp/cl-extra.el
--- a/lisp/cl-extra.el Sun Aug 16 20:55:49 2009 +0100
+++ b/lisp/cl-extra.el Tue Aug 11 17:59:23 2009 +0100
＠＠ -394,55 +394,40 ＠＠
(or (and (fboundp 'expt) (subrp (symbol-function 'expt)))
(defalias 'expt 'cl-expt))
-(defun floor* (x &optional y)
- "Return a list of the floor of X and the fractional part of X.
-With two arguments, return floor and remainder of their quotient."
- (let ((q (floor x y)))
- (list q (- x (if y (* y q) q)))))
+;; We can't use macrolet in this file; whence the literal macro
+;; definition-and-call:
+((macro . (lambda (&rest symbols)
+ "Make some old CL package truncate and round functions available.
-(defun ceiling* (x &optional y)
- "Return a list of the ceiling of X and the fractional part of X.
-With two arguments, return ceiling and remainder of their quotient."
- (let ((res (floor* x y)))
- (if (= (car (cdr res)) 0) res
- (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
-
-(defun truncate* (x &optional y)
- "Return a list of the integer part of X and the fractional part of X.
-With two arguments, return truncation and remainder of their quotient."
- (if (eq (>= x 0) (or (null y) (>= y 0)))
- (floor* x y) (ceiling* x y)))
-
-(defun round* (x &optional y)
- "Return a list of X rounded to the nearest integer and the remainder.
-With two arguments, return rounding and remainder of their quotient."
- (if y
- (if (and (integerp x) (integerp y))
- (let* ((hy (/ y 2))
- (res (floor* (+ x hy) y)))
- (if (and (= (car (cdr res)) 0)
- (= (+ hy hy) y)
- (/= (% (car res) 2) 0))
- (list (1- (car res)) hy)
- (list (car res) (- (car (cdr res)) hy))))
- (let ((q (round (/ x y))))
- (list q (- x (* q y)))))
- (if (integerp x) (list x 0)
- (let ((q (round x)))
- (list q (- x q))))))
+These functions are now implemented in C; their Lisp implementations in this
+XEmacs are trivial, so we provide them and mark them obsolete."
+ (let (symbol result)
+ (while symbols
+ (setq symbol (car symbols)
+ symbols (cdr symbols))
+ (push `(make-obsolete ',(intern (format "%s*" symbol))
+ ',symbol "21.5.29")
+ result)
+ (push
+ `(defun ,(intern (format "%s*" symbol)) (number &optional divisor)
+ ,(format "See `%s'. This returns a list, not multiple values."
+ symbol)
+ (multiple-value-list (,symbol number divisor)))
+ result))
+ (cons 'progn result))))
+ ceiling floor round truncate)
(defun mod* (x y)
"The remainder of X divided by Y, with the same sign as Y."
- (nth 1 (floor* x y)))
+ (nth-value 1 (floor x y)))
(defun rem* (x y)
"The remainder of X divided by Y, with the same sign as X."
- (nth 1 (truncate* x y)))
+ (nth-value 1 (truncate x y)))
(defun signum (a)
"Return 1 if A is positive, -1 if negative, 0 if zero."
(cond ((> a 0) 1) ((< a 0) -1) (t 0)))
-
;; Random numbers.
diff -r 8f1ee2d15784 -r b5e1d4f6b66f man/ChangeLog
--- a/man/ChangeLog Sun Aug 16 20:55:49 2009 +0100
+++ b/man/ChangeLog Tue Aug 11 17:59:23 2009 +0100
＠＠ -1,3 +1,9 ＠＠
+2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lispref/numbers.texi (Bigfloat Basics):
+ Correct this documentation (ignoring for the moment that it breaks
+ off in mid-sentence).
+
2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
* cl.texi (Organization):
diff -r 8f1ee2d15784 -r b5e1d4f6b66f man/lispref/numbers.texi
--- a/man/lispref/numbers.texi Sun Aug 16 20:55:49 2009 +0100
+++ b/man/lispref/numbers.texi Tue Aug 11 17:59:23 2009 +0100
＠＠ -410,7 +410,8 ＠＠
It is possible to make bigfloat the default floating point format by
setting ＠code{default-float-precision} to a non-zero value. Precision
-is given in bits, with a maximum precision of ＠code{bigfloat-max-prec}.
+is given in bits, with a maximum precision of
+＠code{bigfloat-maximum-precision}.
＠c #### is this true?
Bigfloats are created automatically when a number with yes
diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/ChangeLog
--- a/src/ChangeLog Sun Aug 16 20:55:49 2009 +0100
+++ b/src/ChangeLog Tue Aug 11 17:59:23 2009 +0100
＠＠ -1,3 +1,50 ＠＠
+2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * floatfns.c (ROUNDING_CONVERT, CONVERT_WITH_NUMBER_TYPES)
+ (CONVERT_WITHOUT_NUMBER_TYPES, MAYBE_TWO_ARGS_BIGNUM)
+ (MAYBE_ONE_ARG_BIGNUM, MAYBE_TWO_ARGS_RATIO)
+ (MAYBE_ONE_ARG_RATIO, MAYBE_TWO_ARGS_BIGFLOAT)
+ (MAYBE_ONE_ARG_BIGFLOAT, MAYBE_EFF, MAYBE_CHAR_OR_MARKER):
+ New macros, used in the implementation of the rounding functions.
+ (ceiling_two_fixnum, ceiling_two_bignum, ceiling_two_ratio)
+ (ceiling_two_bigfloat, ceiling_one_ratio, ceiling_one_bigfloat)
+ (ceiling_two_float, ceiling_one_float, ceiling_one_mundane_arg)
+ (floor_two_fixnum, floor_two_bignum, floor_two_ratio)
+ (floor_two_bigfloat, floor_one_ratio, floor_one_bigfloat)
+ (floor_two_float, floor_one_mundane_arg, round_two_fixnum)
+ (round_two_bignum_1, round_two_bignum, round_two_ratio)
+ (round_one_bigfloat_1, round_two_bigfloat, round_one_ratio)
+ (round_one_bigfloat, round_two_float, round_one_float)
+ (round_one_mundane_arg, truncate_two_fixnum)
+ (truncate_two_bignum, truncate_two_ratio, truncate_two_bigfloat)
+ (truncate_one_ratio, truncate_one_bigfloat, truncate_two_float)
+ (truncate_one_float, truncate_one_mundane_arg):
+ New functions, used in the implementation of the rounding
+ functions.
+ (Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor)
+ (Ffround, Fftruncate):
+ Revise to fully support Common Lisp conventions. This means:
+ -- All functions have optional DIVISOR arguments
+ -- All functions return multiple values; see #'values
+ -- All functions do their arithmetic with the correct number types
+ according to the contamination rules.
+ -- #'round and #'fround always round towards the even number
+ in ambiguous cases.
+ * doprnt.c (emacs_doprnt_1):
+ * number.c (internal_coerce_number):
+ Call Ftruncate with two arguments, not one.
+ * floatfns.c (Ffloat):
+ Correct this, if NUMBER is a bignum.
+ * lisp.h:
+ Declare Ftruncate as taking two arguments.
+ * number.c:
+ Provide scratch_ratio2, init it appropriately.
+ * number.h:
+ Make scratch_ratio2 available.
+ * number.h (BIGFLOAT_ARITH_RETURN):
+ * number.h (BIGFLOAT_ARITH_RETURN1):
+ Correct these functions.
+
2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecode.c (enum Opcode /* Byte codes */):
diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/bytecode.c
--- a/src/bytecode.c Sun Aug 16 20:55:49 2009 +0100
+++ b/src/bytecode.c Tue Aug 11 17:59:23 2009 +0100
＠＠ -301,8 +301,8 ＠＠
#ifdef HAVE_RATIO
if (RATIOP (obj)) RATIO_ARITH_RETURN (obj, neg);
#endif
-#ifdef HAVE_BIG_FLOAT
- if (BIGFLOAT_P (obj)) BIGFLOAT_ARITH_RETURN (obj, neg);
+#ifdef HAVE_BIGFLOAT
+ if (BIGFLOATP (obj)) BIGFLOAT_ARITH_RETURN (obj, neg);
#endif
obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/doprnt.c
--- a/src/doprnt.c Sun Aug 16 20:55:49 2009 +0100
+++ b/src/doprnt.c Tue Aug 11 17:59:23 2009 +0100
＠＠ -638,7 +638,7 ＠＠
else
{
if (FLOATP (obj))
- obj = Ftruncate (obj);
+ obj = Ftruncate (obj, Qnil);
#ifdef HAVE_BIGFLOAT
else if (BIGFLOATP (obj))
{
diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/floatfns.c
--- a/src/floatfns.c Sun Aug 16 20:55:49 2009 +0100
+++ b/src/floatfns.c Tue Aug 11 17:59:23 2009 +0100
＠＠ -769,7 +769,7 ＠＠
return make_float ((double) XINT (number));
#ifdef HAVE_BIGNUM
- if (BIGFLOATP (number))
+ if (BIGNUMP (number))
{
#ifdef HAVE_BIGFLOAT
if (ZEROP (Vdefault_float_precision))
＠＠ -848,347 +848,1602 ＠＠
#endif /* ! HAVE_LOGB */
}
-DEFUN ("ceiling", Fceiling, 1, 1, 0, /*
-Return the smallest integer no less than NUMBER. (Round toward +inf.)
-*/
- (number))
+#ifdef WITH_NUMBER_TYPES
+#define ROUNDING_CONVERT(conversion, return_float) \
+ CONVERT_WITH_NUMBER_TYPES(conversion, return_float)
+#else
+#define ROUNDING_CONVERT(conversion, return_float) \
+ CONVERT_WITHOUT_NUMBER_TYPES(conversion, return_float)
+#endif
+
+#define CONVERT_WITH_NUMBER_TYPES(conversion, return_float) \
+ if (!NILP (divisor)) \
+ { \
+ switch (promote_args (&number, &divisor)) \
+ { \
+ case FIXNUM_T: \
+ return conversion##_two_fixnum (number, divisor, \
+ return_float); \
+ MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \
+ BIGNUM, \
+ return_float); \
+ MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \
+ RATIO, \
+ return_float); \
+ MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \
+ BIGFLOAT, \
+ return_float); \
+ default: /* FLOAT_T */ \
+ return conversion##_two_float (number,divisor, \
+ return_float); \
+ } \
+ } \
+ \
+ /* Try this first, the arg is probably a float: */ \
+ if (FLOATP (number)) \
+ return conversion##_one_float (number, return_float); \
+ \
+ MAYBE_ONE_ARG_WITH_NUMBER_TYPES (conversion, \
+ RATIO, return_float); \
+ MAYBE_ONE_ARG_WITH_NUMBER_TYPES (conversion, \
+ BIGFLOAT, return_float); \
+ return conversion##_one_mundane_arg (number, divisor, \
+ return_float)
+
+
+#define CONVERT_WITHOUT_NUMBER_TYPES(conversion, return_float) \
+ if (!NILP (divisor)) \
+ { \
+ /* The promote_args call if number types are available \
+ does these conversions, we do them too for symmetry: */\
+ if (CHARP (number)) \
+ { \
+ number = make_int (XCHAR (number)); \
+ } \
+ else if (MARKERP (number)) \
+ { \
+ number = make_int (marker_position (number)); \
+ } \
+ \
+ if (CHARP (divisor)) \
+ { \
+ divisor = make_int (XCHAR (divisor)); \
+ } \
+ else if (MARKERP (divisor)) \
+ { \
+ divisor = make_int (marker_position (divisor)); \
+ } \
+ \
+ CHECK_INT_OR_FLOAT (divisor); \
+ if (INTP (number) && INTP (divisor)) \
+ { \
+ return conversion##_two_fixnum (number, divisor, \
+ return_float); \
+ } \
+ else \
+ { \
+ return conversion##_two_float (number, divisor, \
+ return_float); \
+ } \
+ } \
+ \
+ /* Try this first, the arg is probably a float: */ \
+ if (FLOATP (number)) \
+ return conversion##_one_float (number, return_float); \
+ \
+ return conversion##_one_mundane_arg (number, divisor, \
+ return_float) \
+
+#ifdef WITH_NUMBER_TYPES
+
+#ifdef HAVE_BIGNUM
+#define MAYBE_TWO_ARGS_BIGNUM(conversion, return_float) \
+ case BIGNUM_T: \
+ return conversion##_two_bignum (number, divisor, return_float)
+
+#define MAYBE_ONE_ARG_BIGNUM(converse, return_float) \
+ if (BIGNUM_P (number)) \
+ return conversion##_one_bignum (number, divisor, return_float)
+#else
+#define MAYBE_TWO_ARGS_BIGNUM(conversion, return_float)
+#define MAYBE_ONE_ARG_BIGNUM(converse, return_float)
+#endif
+
+#ifdef HAVE_RATIO
+#define MAYBE_TWO_ARGS_RATIO(conversion, return_float) \
+ case RATIO_T: \
+ return conversion##_two_ratio (number, divisor, return_float)
+
+#define MAYBE_ONE_ARG_RATIO(conversion, return_float) \
+ if (RATIOP (number)) \
+ return conversion##_one_ratio (number, divisor, return_float)
+#else
+#define MAYBE_TWO_ARGS_RATIO(conversion, return_float)
+#define MAYBE_ONE_ARG_RATIO(converse, return_float)
+#endif
+
+#ifdef HAVE_BIGFLOAT
+#define MAYBE_TWO_ARGS_BIGFLOAT(conversion, return_float) \
+ case BIGFLOAT_T: \
+ return conversion##_two_bigfloat (number, divisor, return_float)
+
+#define MAYBE_ONE_ARG_BIGFLOAT(conversion, return_float) \
+ if (BIGFLOATP (number)) \
+ return conversion##_one_bigfloat (number, divisor, return_float)
+#else
+#define MAYBE_TWO_ARGS_BIGFLOAT(conversion, return_float)
+#define MAYBE_ONE_ARG_BIGFLOAT(converse, return_float)
+#endif
+
+#define MAYBE_TWO_ARGS_WITH_NUMBER_TYPES(convers, upcase, return_float) \
+ MAYBE_TWO_ARGS_##upcase(convers, return_float)
+
+#define MAYBE_ONE_ARG_WITH_NUMBER_TYPES(convers, upcase, return_float) \
+ MAYBE_ONE_ARG_##upcase(convers, return_float)
+
+#endif /* WITH_NUMBER_TYPES */
+
+#define MAYBE_EFF(str) (return_float ? "f" str : str)
+
+/* The WITH_NUMBER_TYPES code calls promote_args, which accepts chars and
+ markers as equivalent to ints. This block does the same for
+ single-argument calls. */
+#define MAYBE_CHAR_OR_MARKER(conversion) do { \
+ if (CHARP (number)) \
+ { \
+ return conversion##_one_mundane_arg (make_int (XCHAR (number)), \
+ divisor, return_float); \
+ } \
+ \
+ if (MARKERP (number)) \
+ { \
+ return conversion##_one_mundane_arg (make_int \
+ (marker_position(number)), \
+ divisor, return_float); \
+ } \
+ } while (0)
+
+
+/* The guts of the implementations of the various rounding functions: */
+
+static Lisp_Object
+ceiling_two_fixnum (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
{
- if (FLOATP (number))
+ EMACS_INT i1 = XREALINT (number);
+ EMACS_INT i2 = XREALINT (divisor);
+ EMACS_INT i3 = 0, i4 = 0;
+
+ if (i2 == 0)
+ Fsignal (Qarith_error, Qnil);
+
+ /* With C89's integer /, the result is implementation-defined if either
+ operand is negative, so use only nonnegative operands. Here we do
+ basically the opposite of what floor_two_fixnum does, we add one in the
+ non-negative case: */
+
+ /* Make sure we use the same signs for the modulus calculation as for the
+ quotient calculation: */
+ if (i2 < 0)
{
- double d;
- IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), "ceiling", number);
- return (float_to_int (d, "ceiling", number, Qunbound));
+ if (i1 <= 0)
+ {
+ i3 = -i1 / -i2;
+ /* Quotient is positive; add one to give the figure for
+ ceiling. */
+ if (0 != (-i1 % -i2))
+ {
+ ++i3;
+ }
+ }
+ else
+ {
+ /* Quotient is negative; no need to add one. */
+ i3 = -(i1 / -i2);
+ }
+ }
+ else
+ {
+ if (i1 < 0)
+ {
+ /* Quotient is negative; no need to add one. */
+ i3 = -(-i1 / i2);
+ }
+ else
+ {
+ i3 = i1 / i2;
+ /* Quotient is positive; add one to give the figure for
+ ceiling. */
+ if (0 != (i1 % i2))
+ {
+ ++i3;
+ }
+ }
}
+ i4 = i1 - (i3 * i2);
+
+ if (!return_float)
+ {
+ return values2 (make_int (i3), make_int (i4));
+ }
+
+ return values2 (make_float ((double)i3),
+ make_int (i4));
+}
+
+#ifdef HAVE_BIGNUM
+static Lisp_Object
+ceiling_two_bignum (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0, res1;
+
+ if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ bignum_ceil (scratch_bignum, XBIGNUM_DATA (number), XBIGNUM_DATA (divisor));
+
+ res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) :
+ Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+
+ if (bignum_divisible_p (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor)))
+ {
+ res1 = Qzero;
+ }
+ else
+ {
+ bignum_mul (scratch_bignum, scratch_bignum, XBIGNUM_DATA (divisor));
+ bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum);
+ res1 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ }
+
+ return values2 (res0, res1);
+}
+#endif /* HAVE_BIGNUM */
+
+#ifdef HAVE_RATIO
+static Lisp_Object
+ceiling_two_ratio (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0, res1;
+
+ if (ratio_sign (XRATIO_DATA (divisor)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor));
+
+ bignum_ceil (scratch_bignum, ratio_numerator (scratch_ratio),
+ ratio_denominator (scratch_ratio));
+
+ res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) :
+ Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+
+ if (bignum_divisible_p (ratio_numerator (scratch_ratio),
+ ratio_denominator (scratch_ratio)))
+ {
+ res1 = Qzero;
+ }
+ else
+ {
+ ratio_set_bignum (scratch_ratio, scratch_bignum);
+ ratio_mul (scratch_ratio2, scratch_ratio, XRATIO_DATA (divisor));
+ ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2);
+ res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
+ }
+
+ return values2 (res0, res1);
+}
+#endif /* HAVE_RATIO */
+
+#ifdef HAVE_BIGFLOAT
+static Lisp_Object
+ceiling_two_bigfloat (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0;
+
+ if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (number),
+ XBIGFLOAT_GET_PREC (divisor)));
+ bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number),
+ XBIGFLOAT_DATA (divisor));
+ bigfloat_ceil (scratch_bigfloat, scratch_bigfloat);
+
+ if (return_float)
+ {
+ res0 = make_bigfloat_bf (scratch_bigfloat);
+ }
+ else
+ {
+#ifdef HAVE_BIGNUM
+ bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+#else
+ res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
+#endif /* HAVE_BIGNUM */
+ }
+
+ bigfloat_mul (scratch_bigfloat, scratch_bigfloat, XBIGFLOAT_DATA (divisor));
+ bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat);
+ return values2 (res0,
+ Fcanonicalize_number (make_bigfloat_bf (scratch_bigfloat)));
+}
+#endif /* HAVE_BIGFLOAT */
+
+#ifdef HAVE_RATIO
+static Lisp_Object
+ceiling_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor),
+ int return_float)
+{
+ Lisp_Object res0, res1;
+
+ bignum_ceil (scratch_bignum, XRATIO_NUMERATOR (number),
+ XRATIO_DENOMINATOR (number));
+
+ res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) :
+ Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+
+ if (bignum_divisible_p (XRATIO_NUMERATOR (number),
+ XRATIO_DENOMINATOR (number)))
+ {
+ res1 = Qzero;
+ }
+ else
+ {
+ ratio_set_bignum (scratch_ratio2, scratch_bignum);
+ ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2);
+ res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
+ }
+
+ return values2 (res0, res1);
+}
+#endif /* HAVE_RATIO */
+
+#ifdef HAVE_BIGFLOAT
+static Lisp_Object
+ceiling_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor),
+ int return_float)
+{
+ Lisp_Object res0, res1;
+
+ bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
+ bigfloat_ceil (scratch_bigfloat, XBIGFLOAT_DATA (number));
+
+ if (return_float)
+ {
+ res0 = make_bigfloat_bf (scratch_bigfloat);
+ }
+ else
+ {
+#ifdef HAVE_BIGNUM
+ bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+#else
+ res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
+#endif /* HAVE_BIGNUM */
+ }
+
+ bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat);
+
+ res1 = make_bigfloat_bf (scratch_bigfloat2);
+ return values2 (res0, res1);
+}
+#endif /* HAVE_BIGFLOAT */
+
+static Lisp_Object
+ceiling_two_float (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ double f1 = extract_float (number);
+ double f2 = extract_float (divisor);
+ double f0, remain;
+ Lisp_Object res0;
+
+ if (f2 == 0.0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ IN_FLOAT2 (f0 = ceil (f1 / f2), MAYBE_EFF("ceiling"), number, divisor);
+ IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF("ceiling"), number, divisor);
+
+ if (return_float)
+ {
+ res0 = make_float(f0);
+ }
+ else
+ {
+ res0 = float_to_int (f0, MAYBE_EFF("ceiling"), number, divisor);
+ }
+
+ return values2 (res0, make_float (remain));
+}
+
+static Lisp_Object
+ceiling_one_float (Lisp_Object number, int return_float)
+{
+ double d, remain;
+ Lisp_Object res0;
+
+ IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), MAYBE_EFF("ceiling"), number);
+ IN_FLOAT ((remain = XFLOAT_DATA (number) - d), MAYBE_EFF("ceiling"), number);
+
+ if (return_float)
+ {
+ res0 = make_float (d);
+ }
+ else
+ {
+ res0 = float_to_int (d, MAYBE_EFF("ceiling"), number, Qunbound);
+ }
+ return values2 (res0, make_float (remain));
+}
+
+EXFUN (Fceiling, 2);
+EXFUN (Ffceiling, 2);
+
+static Lisp_Object
+ceiling_one_mundane_arg (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+
+ if (return_float)
+ {
+ if (INTP (number))
+ {
+ return values2 (make_float ((double) XINT (number)), Qzero);
+ }
+#ifdef HAVE_BIGNUM
+ else if (BIGNUMP (number))
+ {
+ return values2 (make_float
+ (bignum_to_double (XBIGNUM_DATA (number))),
+ Qzero);
+ }
+#endif
+ }
+ else
+ {
+#ifdef HAVE_BIGNUM
+ if (INTEGERP (number))
+#else
+ if (INTP (number))
+#endif
+ {
+ return values2 (number, Qzero);
+ }
+ }
+
+ MAYBE_CHAR_OR_MARKER (ceiling);
+
+ return Ffceiling (wrong_type_argument (Qnumberp, number), divisor);
+}
+
+static Lisp_Object
+floor_two_fixnum (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ EMACS_INT i1 = XREALINT (number);
+ EMACS_INT i2 = XREALINT (divisor);
+ EMACS_INT i3 = 0, i4 = 0;
+ Lisp_Object res0;
+
+ if (i2 == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ /* With C89's integer /, the result is implementation-defined if either
+ operand is negative, so use only nonnegative operands. Notice also that
+ we're forcing the quotient of any negative numbers towards minus
+ infinity. */
+ i3 = (i2 < 0
+ ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2))
+ : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2));
+
+ i4 = i1 - (i3 * i2);
+
+ if (return_float)
+ {
+ res0 = make_float ((double)i3);
+ }
+ else
+ {
+ res0 = make_int (i3);
+ }
+
+ return values2 (res0, make_int (i4));
+}
+
+#ifdef HAVE_BIGNUM
+static Lisp_Object
+floor_two_bignum (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0, res1;
+
+ if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ bignum_floor (scratch_bignum, XBIGNUM_DATA (number),
+ XBIGNUM_DATA (divisor));
+
+ if (return_float)
+ {
+ res0 = make_float (bignum_to_double (scratch_bignum));
+ }
+ else
+ {
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ }
+
+ if (bignum_divisible_p (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor)))
+ {
+ res1 = Qzero;
+ }
+ else
+ {
+ bignum_mul (scratch_bignum, scratch_bignum, XBIGNUM_DATA (divisor));
+ bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum);
+ res1 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ }
+
+ return values2 (res0, res1);
+}
+#endif /* HAVE_BIGNUM */
+
+#ifdef HAVE_RATIO
+static Lisp_Object
+floor_two_ratio (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0, res1;
+
+ if (ratio_sign (XRATIO_DATA (divisor)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor));
+
+ bignum_floor (scratch_bignum, ratio_numerator (scratch_ratio),
+ ratio_denominator (scratch_ratio));
+
+ res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) :
+ Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+
+ if (bignum_divisible_p (ratio_numerator (scratch_ratio),
+ ratio_denominator (scratch_ratio)))
+ {
+ res1 = Qzero;
+ }
+ else
+ {
+ ratio_set_bignum (scratch_ratio, scratch_bignum);
+ ratio_mul (scratch_ratio, scratch_ratio, XRATIO_DATA (divisor));
+ ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio);
+ res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
+ }
+
+ return values2 (res0, res1);
+}
+#endif /* HAVE_RATIO */
+
+#ifdef HAVE_BIGFLOAT
+static Lisp_Object
+floor_two_bigfloat (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0;
+
+ if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (number),
+ XBIGFLOAT_GET_PREC (divisor)));
+ bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number),
+ XBIGFLOAT_DATA (divisor));
+ bigfloat_floor (scratch_bigfloat, scratch_bigfloat);
+
+ if (return_float)
+ {
+ res0 = make_bigfloat_bf (scratch_bigfloat);
+ }
+ else
+ {
+#ifdef HAVE_BIGNUM
+ bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+#else
+ res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
+#endif /* HAVE_BIGNUM */
+ }
+
+ bigfloat_mul (scratch_bigfloat2, scratch_bigfloat,
+ XBIGFLOAT_DATA (divisor));
+ bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat2);
+
+ return values2 (res0, make_bigfloat_bf (scratch_bigfloat));
+}
+#endif /* HAVE_BIGFLOAT */
+
+#ifdef HAVE_RATIO
+static Lisp_Object
+floor_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor),
+ int return_float)
+{
+ Lisp_Object res0, res1;
+
+ bignum_floor (scratch_bignum, XRATIO_NUMERATOR (number),
+ XRATIO_DENOMINATOR (number));
+
+ res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) :
+ Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+
+ if (bignum_divisible_p (XRATIO_NUMERATOR (number),
+ XRATIO_DENOMINATOR (number)))
+ {
+ res1 = Qzero;
+ }
+ else
+ {
+ ratio_set_bignum (scratch_ratio2, scratch_bignum);
+ ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2);
+ res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
+ }
+
+ return values2 (res0, res1);
+}
+#endif /* HAVE_RATIO */
+
+#ifdef HAVE_BIGFLOAT
+static Lisp_Object
+floor_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor),
+ int return_float)
+{
+ Lisp_Object res0;
+
+ bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
+ bigfloat_floor (scratch_bigfloat, XBIGFLOAT_DATA (number));
+
+ if (return_float)
+ {
+ res0 = make_bigfloat_bf (scratch_bigfloat);
+ }
+ else
+ {
+#ifdef HAVE_BIGNUM
+ bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+#else
+ res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
+#endif /* HAVE_BIGNUM */
+ }
+
+ bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat);
+ return values2 (res0, make_bigfloat_bf (scratch_bigfloat2));
+}
+#endif /* HAVE_BIGFLOAT */
+
+static Lisp_Object
+floor_two_float (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ double f1 = extract_float (number);
+ double f2 = extract_float (divisor);
+ double f0, remain;
+
+ if (f2 == 0.0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ IN_FLOAT2 (f0 = floor (f1 / f2), MAYBE_EFF ("floor"), number, divisor);
+ IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("floor"), number, divisor);
+
+ if (return_float)
+ {
+ return values2 (make_float (f0), make_float (remain));
+ }
+
+ return values2 (float_to_int (f0, MAYBE_EFF ("floor"), number, divisor),
+ make_float (remain));
+}
+
+static Lisp_Object
+floor_one_float (Lisp_Object number, int return_float)
+{
+ double d, d1;
+
+ IN_FLOAT ((d = floor (XFLOAT_DATA (number))), MAYBE_EFF ("floor"), number);
+ IN_FLOAT ((d1 = XFLOAT_DATA (number) - d), MAYBE_EFF ("floor"), number);
+
+ if (return_float)
+ {
+ return values2 (make_float (d), make_float (d1));
+ }
+ else
+ {
+ return values2 (float_to_int (d, MAYBE_EFF ("floor"), number, Qunbound),
+ make_float (d1));
+ }
+}
+
+EXFUN (Ffloor, 2);
+EXFUN (Fffloor, 2);
+
+static Lisp_Object
+floor_one_mundane_arg (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
#ifdef HAVE_BIGNUM
if (INTEGERP (number))
#else
if (INTP (number))
#endif
- return number;
+ {
+ if (return_float)
+ {
+ return values2 (make_float (extract_float (number)), Qzero);
+ }
+ else
+ {
+ return values2 (number, Qzero);
+ }
+ }
-#ifdef HAVE_RATIO
- if (RATIOP (number))
+ MAYBE_CHAR_OR_MARKER (floor);
+
+ if (return_float)
{
- bignum_ceil (scratch_bignum, XRATIO_NUMERATOR (number),
- XRATIO_DENOMINATOR (number));
- return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
- }
-#endif
-
-#ifdef HAVE_BIGFLOAT
- if (BIGFLOATP (number))
- {
- bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
- bigfloat_ceil (scratch_bigfloat, XBIGFLOAT_DATA (number));
-#ifdef HAVE_BIGNUM
- bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
- return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
-#else
- return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
-#endif /* HAVE_BIGNUM */
- }
-#endif /* HAVE_BIGFLOAT */
-
- return Fceiling (wrong_type_argument (Qnumberp, number));
-}
-
-
-DEFUN ("floor", Ffloor, 1, 2, 0, /*
-Return the largest integer no greater than NUMBER. (Round towards -inf.)
-With optional second argument DIVISOR, return the largest integer no
-greater than NUMBER/DIVISOR.
-*/
- (number, divisor))
-{
-#ifdef WITH_NUMBER_TYPES
- CHECK_REAL (number);
- if (NILP (divisor))
- {
- if (FLOATP (number))
- {
- double d;
- IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number);
- return (float_to_int (d, "floor", number, Qunbound));
- }
-#ifdef HAVE_RATIO
- else if (RATIOP (number))
- {
- bignum_floor (scratch_bignum, XRATIO_NUMERATOR (number),
- XRATIO_DENOMINATOR (number));
- return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
- }
-#endif
-#ifdef HAVE_BIGFLOAT
- else if (BIGFLOATP (number))
- {
- bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
- bigfloat_floor (scratch_bigfloat, XBIGFLOAT_DATA (number));
- return make_bigfloat_bf (scratch_bigfloat);
- }
-#endif
- return number;
+ return Fffloor (wrong_type_argument (Qnumberp, number), divisor);
}
else
{
- CHECK_REAL (divisor);
- switch (promote_args (&number, &divisor))
- {
- case FIXNUM_T:
- {
- EMACS_INT i1 = XREALINT (number);
- EMACS_INT i2 = XREALINT (divisor);
+ return Ffloor (wrong_type_argument (Qnumberp, number), divisor);
+ }
+}
- if (i2 == 0)
- Fsignal (Qarith_error, Qnil);
+/* Algorithm taken from cl-extra.el, now to be found as cl-round in
+ tests/automated/lisp-tests.el. */
+static Lisp_Object
+round_two_fixnum (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ EMACS_INT i1 = XREALINT (number);
+ EMACS_INT i2 = XREALINT (divisor);
+ EMACS_INT i0, hi2, flooring, floored, flsecond;
- /* With C's /, the result is implementation-defined if either
- operand is negative, so use only nonnegative operands. */
- i1 = (i2 < 0
- ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2))
- : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2));
-
- return make_int (i1);
- }
-#ifdef HAVE_BIGNUM
- case BIGNUM_T:
- if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
- Fsignal (Qarith_error, Qnil);
- bignum_floor (scratch_bignum, XBIGNUM_DATA (number),
- XBIGNUM_DATA (divisor));
- return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
-#endif
-#ifdef HAVE_RATIO
- case RATIO_T:
- if (ratio_sign (XRATIO_DATA (divisor)) == 0)
- Fsignal (Qarith_error, Qnil);
- ratio_div (scratch_ratio, XRATIO_DATA (number),
- XRATIO_DATA (divisor));
- bignum_floor (scratch_bignum, ratio_numerator (scratch_ratio),
- ratio_denominator (scratch_ratio));
- return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
-#endif
-#ifdef HAVE_BIGFLOAT
- case BIGFLOAT_T:
- if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
- Fsignal (Qarith_error, Qnil);
- bigfloat_set_prec (scratch_bigfloat,
- max (XBIGFLOAT_GET_PREC (number),
- XBIGFLOAT_GET_PREC (divisor)));
- bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number),
- XBIGFLOAT_DATA (divisor));
- bigfloat_floor (scratch_bigfloat, scratch_bigfloat);
- return make_bigfloat_bf (scratch_bigfloat);
-#endif
- default: /* FLOAT_T */
- {
- double f1 = extract_float (number);
- double f2 = extract_float (divisor);
-
- if (f2 == 0.0)
- Fsignal (Qarith_error, Qnil);
-
- IN_FLOAT2 (f1 = floor (f1 / f2), "floor", number, divisor);
- return float_to_int (f1, "floor", number, divisor);
- }
- }
- }
-#else /* !WITH_NUMBER_TYPES */
- CHECK_INT_OR_FLOAT (number);
-
- if (! NILP (divisor))
+ if (i2 == 0)
{
- EMACS_INT i1, i2;
-
- CHECK_INT_OR_FLOAT (divisor);
-
- if (FLOATP (number) || FLOATP (divisor))
- {
- double f1 = extract_float (number);
- double f2 = extract_float (divisor);
-
- if (f2 == 0)
- Fsignal (Qarith_error, Qnil);
-
- IN_FLOAT2 (f1 = floor (f1 / f2), "floor", number, divisor);
- return float_to_int (f1, "floor", number, divisor);
- }
-
- i1 = XINT (number);
- i2 = XINT (divisor);
-
- if (i2 == 0)
- Fsignal (Qarith_error, Qnil);
-
- /* With C's /, the result is implementation-defined if either operand
- is negative, so use only nonnegative operands. */
- i1 = (i2 < 0
- ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2))
- : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2));
-
- return (make_int (i1));
+ Fsignal (Qarith_error, Qnil);
}
- if (FLOATP (number))
+ hi2 = i2 < 0 ? -( -i2 / 2) : i2 / 2;
+
+ flooring = hi2 + i1;
+
+ floored = (i2 < 0
+ ? (flooring <= 0 ? -flooring / -i2 : -1 - ((flooring - 1) / -i2))
+ : (flooring < 0 ? -1 - ((-1 - flooring) / i2) : flooring / i2));
+
+ flsecond = flooring - (floored * i2);
+
+ if (0 == flsecond
+ && (i2 == (hi2 + hi2))
+ && (0 != (floored % 2)))
{
- double d;
- IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number);
- return (float_to_int (d, "floor", number, Qunbound));
+ i0 = floored - 1;
+ return values2 (return_float ? make_float ((double)i0) :
+ make_int (i0), make_int (hi2));
+ }
+ else
+ {
+ return values2 (return_float ? make_float ((double)floored) :
+ make_int (floored),
+ make_int (flsecond - hi2));
+ }
+}
+
+#ifdef HAVE_BIGNUM
+static void
+round_two_bignum_1 (bignum number, bignum divisor,
+ Lisp_Object *res, Lisp_Object *remain)
+{
+ bignum flooring, floored, hi2, flsecond;
+
+ if (bignum_divisible_p (number, divisor))
+ {
+ bignum_div (scratch_bignum, number, divisor);
+ *res = make_bignum_bg (scratch_bignum);
+ *remain = Qzero;
+ return;
}
- return number;
-#endif /* WITH_NUMBER_TYPES */
+ bignum_set_long (scratch_bignum, 2);
+
+ bignum_div (scratch_bignum2, divisor, scratch_bignum);
+
+ bignum_init (hi2);
+ bignum_set (hi2, scratch_bignum2);
+
+ bignum_add (scratch_bignum, scratch_bignum2, number);
+ bignum_init (flooring);
+ bignum_set (flooring, scratch_bignum);
+
+ bignum_floor (scratch_bignum, flooring, divisor);
+ bignum_init (floored);
+ bignum_set (floored, scratch_bignum);
+
+ bignum_mul (scratch_bignum2, scratch_bignum, divisor);
+ bignum_sub (scratch_bignum, flooring, scratch_bignum2);
+ bignum_init (flsecond);
+ bignum_set (flsecond, scratch_bignum);
+
+ bignum_set_long (scratch_bignum, 2);
+ bignum_mul (scratch_bignum2, scratch_bignum, hi2);
+
+ if (bignum_sign (flsecond) == 0
+ && bignum_eql (divisor, scratch_bignum2)
+ && (1 == bignum_testbit (floored, 0)))
+ {
+ bignum_set_long (scratch_bignum, 1);
+ bignum_sub (floored, floored, scratch_bignum);
+ *res = make_bignum_bg (floored);
+ *remain = make_bignum_bg (hi2);
+ }
+ else
+ {
+ bignum_sub (scratch_bignum, flsecond,
+ hi2);
+ *res = make_bignum_bg (floored);
+ *remain = make_bignum_bg (scratch_bignum);
+ }
}
-DEFUN ("round", Fround, 1, 1, 0, /*
-Return the nearest integer to NUMBER.
-*/
- (number))
+static Lisp_Object
+round_two_bignum (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
{
- if (FLOATP (number))
+ Lisp_Object res0, res1;
+
+ if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
{
- double d;
- /* Screw the prevailing rounding mode. */
- IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (number))), "round", number);
- return (float_to_int (d, "round", number, Qunbound));
+ Fsignal (Qarith_error, Qnil);
}
+ round_two_bignum_1 (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor),
+ &res0, &res1);
+
+ if (return_float)
+ {
+ res0 = make_float (bignum_to_double (XBIGNUM_DATA (res0)));
+ }
+ else
+ {
+ res0 = Fcanonicalize_number (res0);
+ }
+
+ return values2 (res0, Fcanonicalize_number (res1));
+}
+#endif /* HAVE_BIGNUM */
+
+#ifdef HAVE_RATIO
+static Lisp_Object
+round_two_ratio (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0, res1;
+
+ if (ratio_sign (XRATIO_DATA (divisor)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor));
+
+ round_two_bignum_1 (ratio_numerator (scratch_ratio),
+ ratio_denominator (scratch_ratio), &res0, &res1);
+
+ if (!ZEROP (res1))
+ {
+ /* The numerator and denominator don't round exactly, calculate a
+ ratio remainder: */
+ ratio_set_bignum (scratch_ratio2, XBIGNUM_DATA (res0));
+ ratio_mul (scratch_ratio, scratch_ratio2, XRATIO_DATA (divisor));
+ ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio);
+
+ res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
+ }
+
+ res0 = return_float ?
+ make_float ((double)bignum_to_double(XBIGNUM_DATA (res0))) :
+ Fcanonicalize_number (res0);
+
+ return values2 (res0, res1);
+}
+#endif /* HAVE_RATIO */
+
+#ifdef HAVE_BIGFLOAT
+/* This is the logic of emacs_rint above, no more and no less. */
+static Lisp_Object
+round_one_bigfloat_1 (bigfloat number)
+{
+ Lisp_Object res0;
+ unsigned long prec = bigfloat_get_prec (number);
+
+ assert ((bigfloat *)(&number) != (bigfloat *)&scratch_bigfloat
+ && (bigfloat *)(&number) != (bigfloat *)(&scratch_bigfloat2));
+
+ bigfloat_set_prec (scratch_bigfloat, prec);
+ bigfloat_set_prec (scratch_bigfloat2, prec);
+
+ bigfloat_set_double (scratch_bigfloat, 0.5);
+ bigfloat_add (scratch_bigfloat2, scratch_bigfloat, number);
+ bigfloat_floor (scratch_bigfloat, scratch_bigfloat2);
+ res0 = make_bigfloat_bf (scratch_bigfloat);
+
+ bigfloat_sub (scratch_bigfloat2, scratch_bigfloat, number);
+ bigfloat_abs (scratch_bigfloat, scratch_bigfloat2);
+
+ bigfloat_set_double (scratch_bigfloat2, 0.5);
+
+ do {
+ if (!bigfloat_ge (scratch_bigfloat, scratch_bigfloat2))
+ {
+ break;
+ }
+
+ if (!bigfloat_gt (scratch_bigfloat, scratch_bigfloat2))
+ {
+ bigfloat_set_double (scratch_bigfloat2, 2.0);
+ bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (res0),
+ scratch_bigfloat2);
+ bigfloat_floor (scratch_bigfloat2, scratch_bigfloat);
+ bigfloat_set_double (scratch_bigfloat, 2.0);
+ bigfloat_mul (scratch_bigfloat2, scratch_bigfloat2,
+ scratch_bigfloat);
+ if (bigfloat_eql (scratch_bigfloat2, XBIGFLOAT_DATA (res0)))
+ {
+ break;
+ }
+ }
+
+ if (bigfloat_lt (XBIGFLOAT_DATA (res0), number))
+ {
+ bigfloat_set_double (scratch_bigfloat2, 1.0);
+ }
+ else
+ {
+ bigfloat_set_double (scratch_bigfloat2, -1.0);
+ }
+
+ bigfloat_set (scratch_bigfloat, XBIGFLOAT_DATA (res0));
+
+ bigfloat_add (XBIGFLOAT_DATA (res0), scratch_bigfloat2,
+ scratch_bigfloat);
+
+ } while (0);
+
+ return res0;
+}
+
+static Lisp_Object
+round_two_bigfloat (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0, res1;
+ bigfloat divided;
+
+ unsigned long prec = max (XBIGFLOAT_GET_PREC (number),
+ XBIGFLOAT_GET_PREC (divisor));
+
+ if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ bigfloat_init (divided);
+ bigfloat_set_prec (divided, prec);
+
+ bigfloat_div (divided, XBIGFLOAT_DATA (number), XBIGFLOAT_DATA (divisor));
+
+ res0 = round_one_bigfloat_1 (divided);
+
+ bigfloat_set_prec (scratch_bigfloat, prec);
+ bigfloat_set_prec (scratch_bigfloat2, prec);
+
+ bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (res0),
+ XBIGFLOAT_DATA (divisor));
+ bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number),
+ scratch_bigfloat);
+
+ res1 = make_bigfloat_bf (scratch_bigfloat2);
+
+ if (!return_float)
+ {
+#ifdef HAVE_BIGNUM
+ bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (res0));
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+#else
+ res0 = make_int ((EMACS_INT) bigfloat_to_long (XBIGFLOAT_DATA (res0)));
+#endif /* HAVE_BIGNUM */
+ }
+
+ return values2 (res0, res1);
+}
+#endif /* HAVE_BIGFLOAT */
+
+#ifdef HAVE_RATIO
+static Lisp_Object
+round_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor),
+ int return_float)
+{
+ Lisp_Object res0, res1;
+
+ round_two_bignum_1 (XRATIO_NUMERATOR (number), XRATIO_DENOMINATOR (number),
+ &res0, &res1);
+
+ if (!ZEROP (res1))
+ {
+ ratio_set_bignum (scratch_ratio2, XBIGNUM_DATA (res0));
+ ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2);
+ res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio));
+ }
+
+ res0 = return_float ?
+ make_float ((double)bignum_to_double(XBIGNUM_DATA (res0))) :
+ Fcanonicalize_number (res0);
+
+ return values2 (res0, res1);
+}
+#endif /* HAVE_RATIO */
+
+#ifdef HAVE_BIGFLOAT
+static Lisp_Object
+round_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor),
+ int return_float)
+{
+ Lisp_Object res0 = round_one_bigfloat_1 (XBIGFLOAT_DATA (number));
+ Lisp_Object res1;
+
+ bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number),
+ XBIGFLOAT_DATA (res0));
+
+ res1 = make_bigfloat_bf (scratch_bigfloat);
+
+ if (!return_float)
+ {
+#ifdef HAVE_BIGNUM
+ bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (res0));
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+#else
+ res0 = make_int ((EMACS_INT) bigfloat_to_long
+ (XBIGFLOAT_DATA (res0)));
+#endif /* HAVE_BIGNUM */
+ }
+
+ return values2 (res0, res1);
+}
+#endif /* HAVE_BIGFLOAT */
+
+static Lisp_Object
+round_two_float (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ double f1 = extract_float (number);
+ double f2 = extract_float (divisor);
+ double f0, remain;
+
+ if (f2 == 0.0)
+ Fsignal (Qarith_error, Qnil);
+
+ IN_FLOAT2 ((f0 = emacs_rint (f1 / f2)), MAYBE_EFF ("round"), number,
+ divisor);
+ IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("round"), number, divisor);
+
+ if (return_float)
+ {
+ return values2 (make_float (f0), make_float (remain));
+ }
+ else
+ {
+ return values2 (float_to_int (f0, MAYBE_EFF("round"), number, divisor),
+ make_float (remain));
+ }
+}
+
+static Lisp_Object
+round_one_float (Lisp_Object number, int return_float)
+{
+ double d;
+ /* Screw the prevailing rounding mode. */
+ IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (number))), MAYBE_EFF ("round"),
+ number);
+
+ if (return_float)
+ {
+ return values2 (make_float (d), make_float (XFLOAT_DATA (number) - d));
+ }
+ else
+ {
+ return values2 ((float_to_int (d, MAYBE_EFF ("round"), number,
+ Qunbound)),
+ make_float (XFLOAT_DATA (number) - d));
+ }
+}
+
+EXFUN (Fround, 2);
+EXFUN (Ffround, 2);
+
+static Lisp_Object
+round_one_mundane_arg (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
#ifdef HAVE_BIGNUM
if (INTEGERP (number))
#else
if (INTP (number))
#endif
- return number;
-
-#ifdef HAVE_RATIO
- if (RATIOP (number))
{
- if (bignum_divisible_p (XRATIO_NUMERATOR (number),
- XRATIO_DENOMINATOR (number)))
+ if (return_float)
{
- bignum_div (scratch_bignum, XRATIO_NUMERATOR (number),
- XRATIO_DENOMINATOR (number));
+ return values2 (make_float (extract_float (number)), Qzero);
}
else
{
- bignum_add (scratch_bignum2, XRATIO_NUMERATOR (number),
- XRATIO_DENOMINATOR (number));
- bignum_div (scratch_bignum, scratch_bignum2,
- XRATIO_DENOMINATOR (number));
+ return values2 (number, Qzero);
}
- return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
}
+
+ MAYBE_CHAR_OR_MARKER (round);
+
+ if (return_float)
+ {
+ return Ffround (wrong_type_argument (Qnumberp, number), divisor);
+ }
+ else
+ {
+ return Fround (wrong_type_argument (Qnumberp, number), divisor);
+ }
+}
+
+static Lisp_Object
+truncate_two_fixnum (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ EMACS_INT i1 = XREALINT (number);
+ EMACS_INT i2 = XREALINT (divisor);
+ EMACS_INT i0;
+
+ if (i2 == 0)
+ Fsignal (Qarith_error, Qnil);
+
+ /* We're truncating towards zero, so apart from avoiding the C89
+ implementation-defined behaviour with truncation and negative numbers,
+ we don't need to do anything further: */
+ i0 = (i2 < 0
+ ? (i1 <= 0 ? -i1 / -i2 : -(i1 / -i2))
+ : (i1 < 0 ? -(-i1 / i2) : i1 / i2));
+
+ if (return_float)
+ {
+ return values2 (make_float ((double)i0), make_int (i1 - (i0 * i2)));
+ }
+ else
+ {
+ return values2 (make_int (i0), make_int (i1 - (i0 * i2)));
+ }
+}
+
+#ifdef HAVE_BIGNUM
+static Lisp_Object
+truncate_two_bignum (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0;
+
+ if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ bignum_div (scratch_bignum, XBIGNUM_DATA (number),
+ XBIGNUM_DATA (divisor));
+
+ if (return_float)
+ {
+ res0 = make_float (bignum_to_double (scratch_bignum));
+ }
+ else
+ {
+ res0 = make_bignum_bg (scratch_bignum);
+ }
+
+ if (bignum_divisible_p (XBIGNUM_DATA (number),
+ XBIGNUM_DATA (divisor)))
+ {
+ return values2 (Fcanonicalize_number (res0), Qzero);
+ }
+
+ bignum_mul (scratch_bignum2, scratch_bignum, XBIGNUM_DATA (divisor));
+ bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum2);
+
+ return values2 (Fcanonicalize_number (res0),
+ Fcanonicalize_number (make_bignum_bg (scratch_bignum)));
+}
+#endif /* HAVE_BIGNUM */
+
+#ifdef HAVE_RATIO
+static Lisp_Object
+truncate_two_ratio (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0;
+
+ if (ratio_sign (XRATIO_DATA (divisor)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor));
+
+ bignum_div (scratch_bignum, ratio_numerator (scratch_ratio),
+ ratio_denominator (scratch_ratio));
+
+ if (return_float)
+ {
+ res0 = make_float (bignum_to_double (scratch_bignum));
+ }
+ else
+ {
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ }
+
+ if (bignum_divisible_p (ratio_numerator (scratch_ratio),
+ ratio_denominator (scratch_ratio)))
+ {
+ return values2 (res0, Qzero);
+ }
+
+ ratio_set_bignum (scratch_ratio2, scratch_bignum);
+ ratio_mul (scratch_ratio, scratch_ratio2, XRATIO_DATA (divisor));
+ ratio_sub (scratch_ratio2, XRATIO_DATA (number), scratch_ratio);
+
+ return values2 (res0, Fcanonicalize_number (make_ratio_rt(scratch_ratio2)));
+}
#endif
#ifdef HAVE_BIGFLOAT
- if (BIGFLOATP (number))
+static Lisp_Object
+truncate_two_bigfloat (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ Lisp_Object res0;
+ unsigned long prec = max (XBIGFLOAT_GET_PREC (number),
+ XBIGFLOAT_GET_PREC (divisor));
+
+ if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
{
- unsigned long prec = XBIGFLOAT_GET_PREC (number);
- bigfloat_set_prec (scratch_bigfloat, prec);
- bigfloat_set_prec (scratch_bigfloat2, prec);
- bigfloat_set_double (scratch_bigfloat2,
- bigfloat_sign (XBIGFLOAT_DATA (number)) * 0.5);
- bigfloat_floor (scratch_bigfloat, scratch_bigfloat2);
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ bigfloat_set_prec (scratch_bigfloat, prec);
+ bigfloat_set_prec (scratch_bigfloat2, prec);
+
+ bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number),
+ XBIGFLOAT_DATA (divisor));
+ bigfloat_trunc (scratch_bigfloat, scratch_bigfloat);
+
+ if (return_float)
+ {
+ res0 = make_bigfloat_bf (scratch_bigfloat);
+ }
+ else
+ {
#ifdef HAVE_BIGNUM
bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
- return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
#else
- return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
+ res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
#endif /* HAVE_BIGNUM */
}
+
+ bigfloat_mul (scratch_bigfloat2, scratch_bigfloat, XBIGFLOAT_DATA (divisor));
+ bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat2);
+
+ return values2 (res0, make_bigfloat_bf (scratch_bigfloat));
+}
#endif /* HAVE_BIGFLOAT */
- return Fround (wrong_type_argument (Qnumberp, number));
+#ifdef HAVE_RATIO
+static Lisp_Object
+truncate_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor),
+ int return_float)
+{
+ Lisp_Object res0;
+
+ if (ratio_sign (XRATIO_DATA (number)) == 0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ bignum_div (scratch_bignum, XRATIO_NUMERATOR (number),
+ XRATIO_DENOMINATOR (number));
+ if (return_float)
+ {
+ res0 = make_float (bignum_to_double (scratch_bignum));
+ }
+ else
+ {
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ }
+
+ if (bignum_divisible_p (XRATIO_NUMERATOR (number),
+ XRATIO_DENOMINATOR (number)))
+ {
+ return values2 (res0, Qzero);
+ }
+
+ ratio_set_bignum (scratch_ratio2, scratch_bignum);
+ ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2);
+
+ return values2 (res0, Fcanonicalize_number (make_ratio_rt (scratch_ratio)));
+}
+#endif /* HAVE_RATIO */
+
+#ifdef HAVE_BIGFLOAT
+static Lisp_Object
+truncate_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor),
+ int return_float)
+{
+ Lisp_Object res0;
+
+ bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
+ bigfloat_set_prec (scratch_bigfloat2, XBIGFLOAT_GET_PREC (number));
+ bigfloat_trunc (scratch_bigfloat, XBIGFLOAT_DATA (number));
+
+ if (return_float)
+ {
+ res0 = make_bigfloat_bf (scratch_bigfloat);
+ }
+ else
+ {
+#ifdef HAVE_BIGNUM
+ bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
+ res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+#else
+ res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
+#endif /* HAVE_BIGNUM */
+ }
+
+ bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat);
+
+ return
+ values2 (res0,
+ Fcanonicalize_number (make_bigfloat_bf (scratch_bigfloat2)));
+}
+#endif /* HAVE_BIGFLOAT */
+
+static Lisp_Object
+truncate_two_float (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
+ double f1 = extract_float (number);
+ double f2 = extract_float (divisor);
+ double f0, remain;
+ Lisp_Object res0;
+
+ if (f2 == 0.0)
+ {
+ Fsignal (Qarith_error, Qnil);
+ }
+
+ res0 = float_to_int (f1 / f2, MAYBE_EFF ("truncate"), number, Qunbound);
+ f0 = extract_float (res0);
+
+ IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("truncate"), number, divisor);
+
+ if (return_float)
+ {
+ res0 = make_float (f0);
+ }
+
+ return values2 (res0, make_float (remain));
}
-DEFUN ("truncate", Ftruncate, 1, 1, 0, /*
-Truncate a floating point number to an integer.
-Rounds the value toward zero.
-*/
- (number))
+static Lisp_Object
+truncate_one_float (Lisp_Object number, int return_float)
{
- if (FLOATP (number))
- return float_to_int (XFLOAT_DATA (number), "truncate", number, Qunbound);
+ Lisp_Object res0
+ = float_to_int (XFLOAT_DATA (number), MAYBE_EFF ("truncate"),
+ number, Qunbound);
+ if (return_float)
+ {
+ res0 = make_float ((double)XINT(res0));
+ return values2 (res0, make_float ((XFLOAT_DATA (number)
+ - XFLOAT_DATA (res0))));
+ }
+ else
+ {
+ return values2 (res0, make_float (XFLOAT_DATA (number)
+ - XREALINT (res0)));
+ }
+}
+EXFUN (Fftruncate, 2);
+
+static Lisp_Object
+truncate_one_mundane_arg (Lisp_Object number, Lisp_Object divisor,
+ int return_float)
+{
#ifdef HAVE_BIGNUM
if (INTEGERP (number))
#else
if (INTP (number))
#endif
- return number;
+ {
+ if (return_float)
+ {
+ return values2 (make_float (extract_float (number)), Qzero);
+ }
+ else
+ {
+ return values2 (number, Qzero);
+ }
+ }
-#ifdef HAVE_RATIO
- if (RATIOP (number))
+ MAYBE_CHAR_OR_MARKER (truncate);
+
+ if (return_float)
{
- bignum_div (scratch_bignum, XRATIO_NUMERATOR (number),
- XRATIO_DENOMINATOR (number));
- return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ return Fftruncate (wrong_type_argument (Qnumberp, number), divisor);
}
-#endif
+ else
+ {
+ return Ftruncate (wrong_type_argument (Qnumberp, number), divisor);
+ }
+}
+
+/* Rounding functions that will not necessarily return floats: */
-#ifdef HAVE_BIGFLOAT
- if (BIGFLOATP (number))
- {
- bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
- bigfloat_trunc (scratch_bigfloat, XBIGFLOAT_DATA (number));
-#ifdef HAVE_BIGNUM
- bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
- return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
-#else
- return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
-#endif /* HAVE_BIGNUM */
- }
-#endif /* HAVE_BIGFLOAT */
+DEFUN ("ceiling", Fceiling, 1, 2, 0, /*
+Return the smallest integer no less than NUMBER. (Round toward +inf.)
- return Ftruncate (wrong_type_argument (Qnumberp, number));
+With optional argument DIVISOR, return the smallest integer no less than
+the quotient of NUMBER and DIVISOR.
+
+This function returns multiple values; see `multiple-value-bind' and
+`multiple-value-call'. The second returned value is the remainder in the
+calculation, which will be one minus the fractional part of NUMBER if DIVISOR
+is omitted or one.
+*/
+ (number, divisor))
+{
+ ROUNDING_CONVERT(ceiling, 0);
+}
+
+DEFUN ("floor", Ffloor, 1, 2, 0, /*
+Return the largest integer no greater than NUMBER. (Round towards -inf.)
+With optional second argument DIVISOR, return the largest integer no
+greater than the quotient of NUMBER and DIVISOR.
+
+This function returns multiple values; see `multiple-value-call' and
+`multiple-value-bind'. The second returned value is the remainder in the
+calculation, which will just be the fractional part if DIVISOR is omitted or
+one.
+*/
+ (number, divisor))
+{
+ ROUNDING_CONVERT(floor, 0);
+}
+
+DEFUN ("round", Fround, 1, 2, 0, /*
+Return the nearest integer to NUMBER.
+If NUMBER is exactly halfway between two integers, return the one that
+is even.
+
+Optional argument DIVISOR means return the nearest integer to NUMBER
+divided by DIVISOR.
+
+This function returns multiple values; see `multiple-value-call' and
+`multiple-value-bind'. The second returned value is the remainder
+in the calculation.
+*/
+ (number, divisor))
+{
+ ROUNDING_CONVERT(round, 0);
+}
+
+DEFUN ("truncate", Ftruncate, 1, 2, 0, /*
+Truncate a floating point number to an integer.
+Rounds the value toward zero.
+
+Optional argument DIVISOR means truncate NUMBER divided by DIVISOR.
+
+This function returns multiple values; see `multiple-value-call' and
+`multiple-value-bind'. The second returned value is the remainder.
+*/
+ (number, divisor))
+{
+ ROUNDING_CONVERT(truncate, 0);
}
/* Float-rounding functions. */
-DEFUN ("fceiling", Ffceiling, 1, 1, 0, /*
+DEFUN ("fceiling", Ffceiling, 1, 2, 0, /*
Return the smallest integer no less than NUMBER, as a float.
\(Round toward +inf.\)
+
+With optional argument DIVISOR, return the smallest integer no less than the
+quotient of NUMBER and DIVISOR, as a float.
+
+This function returns multiple values; the second value is the remainder in
+the calculation.
*/
- (number))
+ (number, divisor))
{
- double d = extract_float (number);
- IN_FLOAT (d = ceil (d), "fceiling", number);
- return make_float (d);
+ ROUNDING_CONVERT(ceiling, 1);
}
-DEFUN ("ffloor", Fffloor, 1, 1, 0, /*
+DEFUN ("ffloor", Fffloor, 1, 2, 0, /*
Return the largest integer no greater than NUMBER, as a float.
\(Round towards -inf.\)
+
+With optional argument DIVISOR, return the largest integer no greater than
+the quotient of NUMBER and DIVISOR, as a float.
+
+This function returns multiple values; the second value is the remainder in
+the calculation.
*/
- (number))
+ (number, divisor))
{
- double d = extract_float (number);
- IN_FLOAT (d = floor (d), "ffloor", number);
- return make_float (d);
+ ROUNDING_CONVERT(floor, 1);
}
-DEFUN ("fround", Ffround, 1, 1, 0, /*
+DEFUN ("fround", Ffround, 1, 2, 0, /*
Return the nearest integer to NUMBER, as a float.
+If NUMBER is exactly halfway between two integers, return the one that is
+even.
+
+With optional argument DIVISOR, return the nearest integer to the quotient
+of NUMBER and DIVISOR, as a float.
+
+This function returns multiple values; the second value is the remainder in
+the calculation.
*/
- (number))
+ (number, divisor))
{
- double d = extract_float (number);
- IN_FLOAT (d = emacs_rint (d), "fround", number);
- return make_float (d);
+ ROUNDING_CONVERT(round, 1);
}
-DEFUN ("ftruncate", Fftruncate, 1, 1, 0, /*
+DEFUN ("ftruncate", Fftruncate, 1, 2, 0, /*
Truncate a floating point number to an integral float value.
Rounds the value toward zero.
+
+With optional argument DIVISOR, truncate the quotient of NUMBER and DIVISOR,
+to an integral float value.
+
+This function returns multiple values; the second value is the remainder in
+the calculation.
*/
- (number))
+ (number, divisor))
{
- double d = extract_float (number);
- if (d >= 0.0)
- IN_FLOAT (d = floor (d), "ftruncate", number);
- else
- IN_FLOAT (d = ceil (d), "ftruncate", number);
- return make_float (d);
+ ROUNDING_CONVERT(truncate, 1);
}
#ifdef FLOAT_CATCH_SIGILL
diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/lisp.h
--- a/src/lisp.h Sun Aug 16 20:55:49 2009 +0100
+++ b/src/lisp.h Tue Aug 11 17:59:23 2009 +0100
＠＠ -4705,7 +4705,7 ＠＠
void unlock_buffer (struct buffer *);
/* Defined in floatfns.c */
-EXFUN (Ftruncate, 1);
+EXFUN (Ftruncate, 2);
double extract_float (Lisp_Object);
diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/number.c
--- a/src/number.c Sun Aug 16 20:55:49 2009 +0100
+++ b/src/number.c Tue Aug 11 17:59:23 2009 +0100
＠＠ -41,7 +41,7 ＠＠
bignum scratch_bignum, scratch_bignum2;
#endif
#ifdef HAVE_RATIO
-ratio scratch_ratio;
+ratio scratch_ratio, scratch_ratio2;
#endif
#ifdef HAVE_BIGFLOAT
bigfloat scratch_bigfloat, scratch_bigfloat2;
＠＠ -561,7 +561,7 ＠＠
switch (type)
{
case FIXNUM_T:
- return Ftruncate (number);
+ return Ftruncate (number, Qnil);
case BIGNUM_T:
#ifdef HAVE_BIGNUM
bignum_set_double (scratch_bignum, XFLOAT_DATA (number));
＠＠ -853,6 +853,7 ＠＠
#ifdef HAVE_RATIO
ratio_init (scratch_ratio);
+ ratio_init (scratch_ratio2);
#endif
#ifdef HAVE_BIGFLOAT
diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/number.h
--- a/src/number.h Sun Aug 16 20:55:49 2009 +0100
+++ b/src/number.h Tue Aug 11 17:59:23 2009 +0100
＠＠ -195,7 +195,7 ＠＠
extern Lisp_Object make_ratio (long, unsigned long);
extern Lisp_Object make_ratio_bg (bignum, bignum);
extern Lisp_Object make_ratio_rt (ratio);
-extern ratio scratch_ratio;
+extern ratio scratch_ratio, scratch_ratio2;
#else /* !HAVE_RATIO */
＠＠ -251,16 +251,16 ＠＠
#define XBIGFLOAT_GET_PREC(x) bigfloat_get_prec (XBIGFLOAT_DATA (x))
#define XBIGFLOAT_SET_PREC(x,p) bigfloat_set_prec (XBIGFLOAT_DATA (x), p)
-#define BIGFLOAT_ARITH_RETURN(f,op) do \
-{ \
- Lisp_Object retval = make_bigfloat_bf (f); \
+#define BIGFLOAT_ARITH_RETURN(f,op) do \
+{ \
+ Lisp_Object retval = make_bigfloat (0.0, bigfloat_get_default_prec()); \
bigfloat_##op (XBIGFLOAT_DATA (retval), XBIGFLOAT_DATA (f)); \
return retval; \
} while (0)
#define BIGFLOAT_ARITH_RETURN1(f,op,arg) do \
{ \
- Lisp_Object retval = make_bigfloat_bf (f); \
+ Lisp_Object retval = make_bigfloat (0.0, bigfloat_get_default_prec()); \
bigfloat_##op (XBIGFLOAT_DATA (retval), XBIGFLOAT_DATA (f), arg); \
return retval; \
} while (0)
diff -r 8f1ee2d15784 -r b5e1d4f6b66f tests/ChangeLog
--- a/tests/ChangeLog Sun Aug 16 20:55:49 2009 +0100
+++ b/tests/ChangeLog Tue Aug 11 17:59:23 2009 +0100
＠＠ -1,3 +1,11 ＠＠
+2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el:
+ Test the new Common Lisp-compatible rounding functions available in
+ C.
+ (generate-rounding-output): Provide a function useful for
+ generating the data for the rounding functions tests.
+
2009-08-10 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/mule-tests.el:
diff -r 8f1ee2d15784 -r b5e1d4f6b66f tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sun Aug 16 20:55:49 2009 +0100
+++ b/tests/automated/lisp-tests.el Tue Aug 11 17:59:23 2009 +0100
＠＠ -1368,5 +1368,574 ＠＠
(load test-file-name nil t nil)
(delete-file test-file-name))
+(flet ((cl-floor (x &optional y)
+ (let ((q (floor x y)))
+ (list q (- x (if y (* y q) q)))))
+ (cl-ceiling (x &optional y)
+ (let ((res (cl-floor x y)))
+ (if (= (car (cdr res)) 0) res
+ (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
+ (cl-truncate (x &optional y)
+ (if (eq (>= x 0) (or (null y) (>= y 0)))
+ (cl-floor x y) (cl-ceiling x y)))
+ (cl-round (x &optional y)
+ (if y
+ (if (and (integerp x) (integerp y))
+ (let* ((hy (/ y 2))
+ (res (cl-floor (+ x hy) y)))
+ (if (and (= (car (cdr res)) 0)
+ (= (+ hy hy) y)
+ (/= (% (car res) 2) 0))
+ (list (1- (car res)) hy)
+ (list (car res) (- (car (cdr res)) hy))))
+ (let ((q (round (/ x y))))
+ (list q (- x (* q y)))))
+ (if (integerp x) (list x 0)
+ (let ((q (round x)))
+ (list q (- x q))))))
+ (Assert-rounding (first second &key
+ one-floor-result two-floor-result
+ one-ffloor-result two-ffloor-result
+ one-ceiling-result two-ceiling-result
+ one-fceiling-result two-fceiling-result
+ one-round-result two-round-result
+ one-fround-result two-fround-result
+ one-truncate-result two-truncate-result
+ one-ftruncate-result two-ftruncate-result)
+ (Assert (equal one-floor-result (multiple-value-list
+ (floor first)))
+ (format "checking (floor %S) gives %S"
+ first one-floor-result))
+ (Assert (equal one-floor-result (multiple-value-list
+ (floor first 1)))
+ (format "checking (floor %S 1) gives %S"
+ first one-floor-result))
+ (Check-Error arith-error (floor first 0))
+ (Check-Error arith-error (floor first 0.0))
+ (Assert (equal two-floor-result (multiple-value-list
+ (floor first second)))
+ (format
+ "checking (floor %S %S) gives %S"
+ first second two-floor-result))
+ (Assert (equal (cl-floor first second)
+ (multiple-value-list (floor first second)))
+ (format
+ "checking (floor %S %S) gives the same as the old code"
+ first second))
+ (Assert (equal one-ffloor-result (multiple-value-list
+ (ffloor first)))
+ (format "checking (ffloor %S) gives %S"
+ first one-ffloor-result))
+ (Assert (equal one-ffloor-result (multiple-value-list
+ (ffloor first 1)))
+ (format "checking (ffloor %S 1) gives %S"
+ first one-ffloor-result))
+ (Check-Error arith-error (ffloor first 0))
+ (Check-Error arith-error (ffloor first 0.0))
+ (Assert (equal two-ffloor-result (multiple-value-list
+ (ffloor first second)))
+ (format "checking (ffloor %S %S) gives %S"
+ first second two-ffloor-result))
+ (Assert (equal one-ceiling-result (multiple-value-list
+ (ceiling first)))
+ (format "checking (ceiling %S) gives %S"
+ first one-ceiling-result))
+ (Assert (equal one-ceiling-result (multiple-value-list
+ (ceiling first 1)))
+ (format "checking (ceiling %S 1) gives %S"
+ first one-ceiling-result))
+ (Check-Error arith-error (ceiling first 0))
+ (Check-Error arith-error (ceiling first 0.0))
+ (Assert (equal two-ceiling-result (multiple-value-list
+ (ceiling first second)))
+ (format "checking (ceiling %S %S) gives %S"
+ first second two-ceiling-result))
+ (Assert (equal (cl-ceiling first second)
+ (multiple-value-list (ceiling first second)))
+ (format
+ "checking (ceiling %S %S) gives the same as the old code"
+ first second))
+ (Assert (equal one-fceiling-result (multiple-value-list
+ (fceiling first)))
+ (format "checking (fceiling %S) gives %S"
+ first one-fceiling-result))
+ (Assert (equal one-fceiling-result (multiple-value-list
+ (fceiling first 1)))
+ (format "checking (fceiling %S 1) gives %S"
+ first one-fceiling-result))
+ (Check-Error arith-error (fceiling first 0))
+ (Check-Error arith-error (fceiling first 0.0))
+ (Assert (equal two-fceiling-result (multiple-value-list
+ (fceiling first second)))
+ (format "checking (fceiling %S %S) gives %S"
+ first second two-fceiling-result))
+ (Assert (equal one-round-result (multiple-value-list
+ (round first)))
+ (format "checking (round %S) gives %S"
+ first one-round-result))
+ (Assert (equal one-round-result (multiple-value-list
+ (round first 1)))
+ (format "checking (round %S 1) gives %S, types %S, actual %S, types %S"
+ first one-round-result (mapcar #'type-of one-round-result)
+ (multiple-value-list (round first 1))
+ (mapcar #'type-of (multiple-value-list (round first 1)))))
+ (Check-Error arith-error (round first 0))
+ (Check-Error arith-error (round first 0.0))
+ (Assert (equal two-round-result (multiple-value-list
+ (round first second)))
+ (format "checking (round %S %S) gives %S"
+ first second two-round-result))
+ (Assert (equal one-fround-result (multiple-value-list
+ (fround first)))
+ (format "checking (fround %S) gives %S"
+ first one-fround-result))
+ (Assert (equal one-fround-result (multiple-value-list
+ (fround first 1)))
+ (format "checking (fround %S 1) gives %S"
+ first one-fround-result))
+ (Check-Error arith-error (fround first 0))
+ (Check-Error arith-error (fround first 0.0))
+ (Assert (equal two-fround-result (multiple-value-list
+ (fround first second)))
+ (format "checking (fround %S %S) gives %S"
+ first second two-fround-result))
+ (Assert (equal (cl-round first second)
+ (multiple-value-list (round first second)))
+ (format
+ "checking (round %S %S) gives the same as the old code"
+ first second))
+ (Assert (equal one-truncate-result (multiple-value-list
+ (truncate first)))
+ (format "checking (truncate %S) gives %S"
+ first one-truncate-result))
+ (Assert (equal one-truncate-result (multiple-value-list
+ (truncate first 1)))
+ (format "checking (truncate %S 1) gives %S"
+ first one-truncate-result))
+ (Check-Error arith-error (truncate first 0))
+ (Check-Error arith-error (truncate first 0.0))
+ (Assert (equal two-truncate-result (multiple-value-list
+ (truncate first second)))
+ (format "checking (truncate %S %S) gives %S"
+ first second two-truncate-result))
+ (Assert (equal (cl-truncate first second)
+ (multiple-value-list (truncate first second)))
+ (format
+ "checking (truncate %S %S) gives the same as the old code"
+ first second))
+ (Assert (equal one-ftruncate-result (multiple-value-list
+ (ftruncate first)))
+ (format "checking (ftruncate %S) gives %S"
+ first one-ftruncate-result))
+ (Assert (equal one-ftruncate-result (multiple-value-list
+ (ftruncate first 1)))
+ (format "checking (ftruncate %S 1) gives %S"
+ first one-ftruncate-result))
+ (Check-Error arith-error (ftruncate first 0))
+ (Check-Error arith-error (ftruncate first 0.0))
+ (Assert (equal two-ftruncate-result (multiple-value-list
+ (ftruncate first second)))
+ (format "checking (ftruncate %S %S) gives %S"
+ first second two-ftruncate-result)))
+ (Assert-rounding-floating (pie ee)
+ (let ((pie-type (type-of pie)))
+ (assert (eq pie-type (type-of ee)) t
+ "This code assumes the two arguments have the same type.")
+ (Assert-rounding pie ee
+:one-floor-result (list 3 (- pie 3))
+:two-floor-result (list 1 (- pie (* 1 ee)))
+:one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0))
+:two-ffloor-result (list (coerce 1 pie-type) (- pie (* 1.0 ee)))
+:one-ceiling-result (list 4 (- pie 4))
+:two-ceiling-result (list 2 (- pie (* 2 ee)))
+:one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0))
+:two-fceiling-result (list (coerce 2 pie-type) (- pie (* 2.0 ee)))
+:one-round-result (list 3 (- pie 3))
+:two-round-result (list 1 (- pie (* 1 ee)))
+:one-fround-result (list (coerce 3 pie-type) (- pie 3.0))
+:two-fround-result (list (coerce 1 pie-type) (- pie (* 1.0 ee)))
+:one-truncate-result (list 3 (- pie 3))
+:two-truncate-result (list 1 (- pie (* 1 ee)))
+:one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0))
+:two-ftruncate-result (list (coerce 1 pie-type)
+ (- pie (* 1.0 ee))))
+ (Assert-rounding pie (- ee)
+:one-floor-result (list 3 (- pie 3))
+:two-floor-result (list -2 (- pie (* -2 (- ee))))
+:one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0))
+:two-ffloor-result (list (coerce -2 pie-type)
+ (- pie (* -2.0 (- ee))))
+:one-ceiling-result (list 4 (- pie 4))
+:two-ceiling-result (list -1 (- pie (* -1 (- ee))))
+:one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0))
+:two-fceiling-result (list (coerce -1 pie-type)
+ (- pie (* -1.0 (- ee))))
+:one-round-result (list 3 (- pie 3))
+:two-round-result (list -1 (- pie (* -1 (- ee))))
+:one-fround-result (list (coerce 3 pie-type) (- pie 3.0))
+:two-fround-result (list (coerce -1 pie-type)
+ (- pie (* -1.0 (- ee))))
+:one-truncate-result (list 3 (- pie 3))
+:two-truncate-result (list -1 (- pie (* -1 (- ee))))
+:one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0))
+:two-ftruncate-result (list (coerce -1 pie-type)
+ (- pie (* -1.0 (- ee)))))
+ (Assert-rounding (- pie) ee
+:one-floor-result (list -4 (- (- pie) -4))
+:two-floor-result (list -2 (- (- pie) (* -2 ee)))
+:one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0))
+:two-ffloor-result (list (coerce -2 pie-type)
+ (- (- pie) (* -2.0 ee)))
+:one-ceiling-result (list -3 (- (- pie) -3))
+:two-ceiling-result (list -1 (- (- pie) (* -1 ee)))
+:one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0))
+:two-fceiling-result (list (coerce -1 pie-type)
+ (- (- pie) (* -1.0 ee)))
+:one-round-result (list -3 (- (- pie) -3))
+:two-round-result (list -1 (- (- pie) (* -1 ee)))
+:one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0))
+:two-fround-result (list (coerce -1 pie-type)
+ (- (- pie) (* -1.0 ee)))
+:one-truncate-result (list -3 (- (- pie) -3))
+:two-truncate-result (list -1 (- (- pie) (* -1 ee)))
+:one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0))
+:two-ftruncate-result (list (coerce -1 pie-type)
+ (- (- pie) (* -1.0 ee))))
+ (Assert-rounding (- pie) (- ee)
+:one-floor-result (list -4 (- (- pie) -4))
+:two-floor-result (list 1 (- (- pie) (* 1 (- ee))))
+:one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0))
+:two-ffloor-result (list (coerce 1 pie-type)
+ (- (- pie) (* 1.0 (- ee))))
+:one-ceiling-result (list -3 (- (- pie) -3))
+:two-ceiling-result (list 2 (- (- pie) (* 2 (- ee))))
+:one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0))
+:two-fceiling-result (list (coerce 2 pie-type)
+ (- (- pie) (* 2.0 (- ee))))
+:one-round-result (list -3 (- (- pie) -3))
+:two-round-result (list 1 (- (- pie) (* 1 (- ee))))
+:one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0))
+:two-fround-result (list (coerce 1 pie-type)
+ (- (- pie) (* 1.0 (- ee))))
+:one-truncate-result (list -3 (- (- pie) -3))
+:two-truncate-result (list 1 (- (- pie) (* 1 (- ee))))
+:one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0))
+:two-ftruncate-result (list (coerce 1 pie-type)
+ (- (- pie) (* 1.0 (- ee)))))
+ (Assert-rounding ee pie
+:one-floor-result (list 2 (- ee 2))
+:two-floor-result (list 0 ee)
+:one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0))
+:two-ffloor-result (list (coerce 0 pie-type) ee)
+:one-ceiling-result (list 3 (- ee 3))
+:two-ceiling-result (list 1 (- ee pie))
+:one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0))
+:two-fceiling-result (list (coerce 1 pie-type) (- ee pie))
+:one-round-result (list 3 (- ee 3))
+:two-round-result (list 1 (- ee (* 1 pie)))
+:one-fround-result (list (coerce 3 pie-type) (- ee 3.0))
+:two-fround-result (list (coerce 1 pie-type) (- ee (* 1.0 pie)))
+:one-truncate-result (list 2 (- ee 2))
+:two-truncate-result (list 0 ee)
+:one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0))
+:two-ftruncate-result (list (coerce 0 pie-type) ee))
+ (Assert-rounding ee (- pie)
+:one-floor-result (list 2 (- ee 2))
+:two-floor-result (list -1 (- ee (* -1 (- pie))))
+:one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0))
+:two-ffloor-result (list (coerce -1 pie-type)
+ (- ee (* -1.0 (- pie))))
+:one-ceiling-result (list 3 (- ee 3))
+:two-ceiling-result (list 0 ee)
+:one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0))
+:two-fceiling-result (list (coerce 0 pie-type) ee)
+:one-round-result (list 3 (- ee 3))
+:two-round-result (list -1 (- ee (* -1 (- pie))))
+:one-fround-result (list (coerce 3 pie-type) (- ee 3.0))
+:two-fround-result (list (coerce -1 pie-type)
+ (- ee (* -1.0 (- pie))))
+:one-truncate-result (list 2 (- ee 2))
+:two-truncate-result (list 0 ee)
+:one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0))
+:two-ftruncate-result (list (coerce 0 pie-type) ee)))))
+ ;; First, two integers:
+ (Assert-rounding 27 8 :one-floor-result '(27 0) :two-floor-result '(3 3)
+:one-ffloor-result '(27.0 0) :two-ffloor-result '(3.0 3)
+:one-ceiling-result '(27 0) :two-ceiling-result '(4 -5)
+:one-fceiling-result '(27.0 0) :two-fceiling-result '(4.0 -5)
+:one-round-result '(27 0) :two-round-result '(3 3)
+:one-fround-result '(27.0 0) :two-fround-result '(3.0 3)
+:one-truncate-result '(27 0) :two-truncate-result '(3 3)
+:one-ftruncate-result '(27.0 0) :two-ftruncate-result '(3.0 3))
+ (Assert-rounding 27 -8 :one-floor-result '(27 0) :two-floor-result '(-4 -5)
+:one-ffloor-result '(27.0 0) :two-ffloor-result '(-4.0 -5)
+:one-ceiling-result '(27 0) :two-ceiling-result '(-3 3)
+:one-fceiling-result '(27.0 0) :two-fceiling-result '(-3.0 3)
+:one-round-result '(27 0) :two-round-result '(-3 3)
+:one-fround-result '(27.0 0) :two-fround-result '(-3.0 3)
+:one-truncate-result '(27 0) :two-truncate-result '(-3 3)
+:one-ftruncate-result '(27.0 0) :two-ftruncate-result '(-3.0 3))
+ (Assert-rounding -27 8
+:one-floor-result '(-27 0) :two-floor-result '(-4 5)
+:one-ffloor-result '(-27.0 0) :two-ffloor-result '(-4.0 5)
+:one-ceiling-result '(-27 0) :two-ceiling-result '(-3 -3)
+:one-fceiling-result '(-27.0 0) :two-fceiling-result '(-3.0 -3)
+:one-round-result '(-27 0) :two-round-result '(-3 -3)
+:one-fround-result '(-27.0 0) :two-fround-result '(-3.0 -3)
+:one-truncate-result '(-27 0) :two-truncate-result '(-3 -3)
+:one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(-3.0 -3))
+ (Assert-rounding -27 -8
+:one-floor-result '(-27 0) :two-floor-result '(3 -3)
+:one-ffloor-result '(-27.0 0) :two-ffloor-result '(3.0 -3)
+:one-ceiling-result '(-27 0) :two-ceiling-result '(4 5)
+:one-fceiling-result '(-27.0 0) :two-fceiling-result '(4.0 5)
+:one-round-result '(-27 0) :two-round-result '(3 -3)
+:one-fround-result '(-27.0 0) :two-fround-result '(3.0 -3)
+:one-truncate-result '(-27 0) :two-truncate-result '(3 -3)
+:one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(3.0 -3))
+ (Assert-rounding 8 27
+:one-floor-result '(8 0) :two-floor-result '(0 8)
+:one-ffloor-result '(8.0 0) :two-ffloor-result '(0.0 8)
+:one-ceiling-result '(8 0) :two-ceiling-result '(1 -19)
+:one-fceiling-result '(8.0 0) :two-fceiling-result '(1.0 -19)
+:one-round-result '(8 0) :two-round-result '(0 8)
+:one-fround-result '(8.0 0) :two-fround-result '(0.0 8)
+:one-truncate-result '(8 0) :two-truncate-result '(0 8)
+:one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8))
+ (Assert-rounding 8 -27
+:one-floor-result '(8 0) :two-floor-result '(-1 -19)
+:one-ffloor-result '(8.0 0) :two-ffloor-result '(-1.0 -19)
+:one-ceiling-result '(8 0) :two-ceiling-result '(0 8)
+:one-fceiling-result '(8.0 0) :two-fceiling-result '(0.0 8)
+:one-round-result '(8 0) :two-round-result '(0 8)
+:one-fround-result '(8.0 0) :two-fround-result '(0.0 8)
+:one-truncate-result '(8 0) :two-truncate-result '(0 8)
+:one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8))
+ (Assert-rounding -8 27
+:one-floor-result '(-8 0) :two-floor-result '(-1 19)
+:one-ffloor-result '(-8.0 0) :two-ffloor-result '(-1.0 19)
+:one-ceiling-result '(-8 0) :two-ceiling-result '(0 -8)
+:one-fceiling-result '(-8.0 0) :two-fceiling-result '(0.0 -8)
+:one-round-result '(-8 0) :two-round-result '(0 -8)
+:one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8)
+:one-truncate-result '(-8 0) :two-truncate-result '(0 -8)
+:one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8))
+ (Assert-rounding -8 -27
+:one-floor-result '(-8 0) :two-floor-result '(0 -8)
+:one-ffloor-result '(-8.0 0) :two-ffloor-result '(0.0 -8)
+:one-ceiling-result '(-8 0) :two-ceiling-result '(1 19)
+:one-fceiling-result '(-8.0 0) :two-fceiling-result '(1.0 19)
+:one-round-result '(-8 0) :two-round-result '(0 -8)
+:one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8)
+:one-truncate-result '(-8 0) :two-truncate-result '(0 -8)
+:one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8))
+ (Assert-rounding 32 4
+:one-floor-result '(32 0) :two-floor-result '(8 0)
+:one-ffloor-result '(32.0 0) :two-ffloor-result '(8.0 0)
+:one-ceiling-result '(32 0) :two-ceiling-result '(8 0)
+:one-fceiling-result '(32.0 0) :two-fceiling-result '(8.0 0)
+:one-round-result '(32 0) :two-round-result '(8 0)
+:one-fround-result '(32.0 0) :two-fround-result '(8.0 0)
+:one-truncate-result '(32 0) :two-truncate-result '(8 0)
+:one-ftruncate-result '(32.0 0) :two-ftruncate-result '(8.0 0))
+ (Assert-rounding 32 -4
+:one-floor-result '(32 0) :two-floor-result '(-8 0)
+:one-ffloor-result '(32.0 0) :two-ffloor-result '(-8.0 0)
+:one-ceiling-result '(32 0) :two-ceiling-result '(-8 0)
+:one-fceiling-result '(32.0 0) :two-fceiling-result '(-8.0 0)
+:one-round-result '(32 0) :two-round-result '(-8 0)
+:one-fround-result '(32.0 0) :two-fround-result '(-8.0 0)
+:one-truncate-result '(32 0) :two-truncate-result '(-8 0)
+:one-ftruncate-result '(32.0 0) :two-ftruncate-result '(-8.0 0))
+ (Assert-rounding 12 9
+:one-floor-result '(12 0) :two-floor-result '(1 3)
+:one-ffloor-result '(12.0 0) :two-ffloor-result '(1.0 3)
+:one-ceiling-result '(12 0) :two-ceiling-result '(2 -6)
+:one-fceiling-result '(12.0 0) :two-fceiling-result '(2.0 -6)
+:one-round-result '(12 0) :two-round-result '(1 3)
+:one-fround-result '(12.0 0) :two-fround-result '(1.0 3)
+:one-truncate-result '(12 0) :two-truncate-result '(1 3)
+:one-ftruncate-result '(12.0 0) :two-ftruncate-result '(1.0 3))
+ (Assert-rounding 10 4
+:one-floor-result '(10 0) :two-floor-result '(2 2)
+:one-ffloor-result '(10.0 0) :two-ffloor-result '(2.0 2)
+:one-ceiling-result '(10 0) :two-ceiling-result '(3 -2)
+:one-fceiling-result '(10.0 0) :two-fceiling-result '(3.0 -2)
+:one-round-result '(10 0) :two-round-result '(2 2)
+:one-fround-result '(10.0 0) :two-fround-result '(2.0 2)
+:one-truncate-result '(10 0) :two-truncate-result '(2 2)
+:one-ftruncate-result '(10.0 0) :two-ftruncate-result '(2.0 2))
+ (Assert-rounding 14 4
+:one-floor-result '(14 0) :two-floor-result '(3 2)
+:one-ffloor-result '(14.0 0) :two-ffloor-result '(3.0 2)
+:one-ceiling-result '(14 0) :two-ceiling-result '(4 -2)
+:one-fceiling-result '(14.0 0) :two-fceiling-result '(4.0 -2)
+:one-round-result '(14 0) :two-round-result '(4 -2)
+:one-fround-result '(14.0 0) :two-fround-result '(4.0 -2)
+:one-truncate-result '(14 0) :two-truncate-result '(3 2)
+:one-ftruncate-result '(14.0 0) :two-ftruncate-result '(3.0 2))
+ ;; Now, two floats:
+ (Assert-rounding-floating pi e)
+ (when (featurep 'bigfloat)
+ (Assert-rounding-floating (coerce pi 'bigfloat) (coerce e 'bigfloat)))
+ (when (featurep 'bignum)
+ (assert (not (evenp most-positive-fixnum)) t
+ "In the unlikely event that most-positive-fixnum is even, rewrite this.")
+ (Assert-rounding (1+ most-positive-fixnum) (* 2 most-positive-fixnum)
+:one-floor-result `(,(1+ most-positive-fixnum) 0)
+:two-floor-result `(0 ,(1+ most-positive-fixnum))
+:one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0)
+:two-ffloor-result `(0.0 ,(1+ most-positive-fixnum))
+:one-ceiling-result `(,(1+ most-positive-fixnum) 0)
+:two-ceiling-result `(1 ,(1+ (- most-positive-fixnum)))
+:one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0)
+:two-fceiling-result `(1.0 ,(1+ (- most-positive-fixnum)))
+:one-round-result `(,(1+ most-positive-fixnum) 0)
+:two-round-result `(1 ,(1+ (- most-positive-fixnum)))
+:one-fround-result `(,(float (1+ most-positive-fixnum)) 0)
+:two-fround-result `(1.0 ,(1+ (- most-positive-fixnum)))
+:one-truncate-result `(,(1+ most-positive-fixnum) 0)
+:two-truncate-result `(0 ,(1+ most-positive-fixnum))
+:one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0)
+:two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum)))
+ (Assert-rounding (1+ most-positive-fixnum) (- (* 2 most-positive-fixnum))
+:one-floor-result `(,(1+ most-positive-fixnum) 0)
+:two-floor-result `(-1 ,(1+ (- most-positive-fixnum)))
+:one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0)
+:two-ffloor-result `(-1.0 ,(1+ (- most-positive-fixnum)))
+:one-ceiling-result `(,(1+ most-positive-fixnum) 0)
+:two-ceiling-result `(0 ,(1+ most-positive-fixnum))
+:one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0)
+:two-fceiling-result `(0.0 ,(1+ most-positive-fixnum))
+:one-round-result `(,(1+ most-positive-fixnum) 0)
+:two-round-result `(-1 ,(1+ (- most-positive-fixnum)))
+:one-fround-result `(,(float (1+ most-positive-fixnum)) 0)
+:two-fround-result `(-1.0 ,(1+ (- most-positive-fixnum)))
+:one-truncate-result `(,(1+ most-positive-fixnum) 0)
+:two-truncate-result `(0 ,(1+ most-positive-fixnum))
+:one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0)
+:two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum)))
+ (Assert-rounding (- (1+ most-positive-fixnum)) (* 2 most-positive-fixnum)
+:one-floor-result `(,(- (1+ most-positive-fixnum)) 0)
+:two-floor-result `(-1 ,(1- most-positive-fixnum))
+:one-ffloor-result `(,(float (- (1+ most-positive-fixnum))) 0)
+:two-ffloor-result `(-1.0 ,(1- most-positive-fixnum))
+:one-ceiling-result `(,(- (1+ most-positive-fixnum)) 0)
+:two-ceiling-result `(0 ,(- (1+ most-positive-fixnum)))
+:one-fceiling-result `(,(float (- (1+ most-positive-fixnum))) 0)
+:two-fceiling-result `(0.0 ,(- (1+ most-positive-fixnum)))
+:one-round-result `(,(- (1+ most-positive-fixnum)) 0)
+:two-round-result `(-1 ,(1- most-positive-fixnum))
+:one-fround-result `(,(float (- (1+ most-positive-fixnum))) 0)
+:two-fround-result `(-1.0 ,(1- most-positive-fixnum))
+:one-truncate-result `(,(- (1+ most-positive-fixnum)) 0)
+:two-truncate-result `(0 ,(- (1+ most-positive-fixnum)))
+:one-ftruncate-result `(,(float (- (1+ most-positive-fixnum))) 0)
+:two-ftruncate-result `(0.0 ,(- (1+ most-positive-fixnum))))
+ ;; Test the handling of values with .5:
+ (Assert-rounding (1+ (* 2 most-positive-fixnum)) 2
+:one-floor-result `(,(1+ (* 2 most-positive-fixnum)) 0)
+:two-floor-result `(,most-positive-fixnum 1)
+:one-ffloor-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
+ ;; We can't just call #'float here; we must use code that converts a
+ ;; bignum with value most-positive-fixnum (the creation of which is
+ ;; not directly possible in Lisp) to a float, not code that converts
+ ;; the fixnum with value most-positive-fixnum to a float. The eval is
+ ;; to avoid compile-time optimisation that can break this.
+:two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1)
+:one-ceiling-result `(,(1+ (* 2 most-positive-fixnum)) 0)
+:two-ceiling-result `(,(1+ most-positive-fixnum) -1)
+:one-fceiling-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
+:two-fceiling-result `(,(float (1+ most-positive-fixnum)) -1)
+:one-round-result `(,(1+ (* 2 most-positive-fixnum)) 0)
+:two-round-result `(,(1+ most-positive-fixnum) -1)
+:one-fround-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
+:two-fround-result `(,(float (1+ most-positive-fixnum)) -1)
+:one-truncate-result `(,(1+ (* 2 most-positive-fixnum)) 0)
+:two-truncate-result `(,most-positive-fixnum 1)
+:one-ftruncate-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
+ ;; See the comment above on :two-ffloor-result:
+:two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1))
+ (Assert-rounding (1+ (* 2 (1- most-positive-fixnum))) 2
+:one-floor-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
+:two-floor-result `(,(1- most-positive-fixnum) 1)
+:one-ffloor-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
+ ;; See commentary above on float conversions.
+:two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1)
+:one-ceiling-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
+:two-ceiling-result `(,most-positive-fixnum -1)
+:one-fceiling-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
+:two-fceiling-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) -1)
+:one-round-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
+:two-round-result `(,(1- most-positive-fixnum) 1)
+:one-fround-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
+:two-fround-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1)
+:one-truncate-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
+:two-truncate-result `(,(1- most-positive-fixnum) 1)
+:one-ftruncate-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
+ ;; See commentary above
+:two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0))
+ 1)))
+ (when (featurep 'ratio)
+ (Assert-rounding (read "4/3") (read "8/7")
+:one-floor-result '(1 1/3) :two-floor-result '(1 4/21)
+:one-ffloor-result '(1.0 1/3) :two-ffloor-result '(1.0 4/21)
+:one-ceiling-result '(2 -2/3) :two-ceiling-result '(2 -20/21)
+:one-fceiling-result '(2.0 -2/3) :two-fceiling-result '(2.0 -20/21)
+:one-round-result '(1 1/3) :two-round-result '(1 4/21)
+:one-fround-result '(1.0 1/3) :two-fround-result '(1.0 4/21)
+:one-truncate-result '(1 1/3) :two-truncate-result '(1 4/21)
+:one-ftruncate-result '(1.0 1/3) :two-ftruncate-result '(1.0 4/21))
+ (Assert-rounding (read "-4/3") (read "8/7")
+:one-floor-result '(-2 2/3) :two-floor-result '(-2 20/21)
+:one-ffloor-result '(-2.0 2/3) :two-ffloor-result '(-2.0 20/21)
+:one-ceiling-result '(-1 -1/3) :two-ceiling-result '(-1 -4/21)
+:one-fceiling-result '(-1.0 -1/3) :two-fceiling-result '(-1.0 -4/21)
+:one-round-result '(-1 -1/3) :two-round-result '(-1 -4/21)
+:one-fround-result '(-1.0 -1/3) :two-fround-result '(-1.0 -4/21)
+:one-truncate-result '(-1 -1/3) :two-truncate-result '(-1 -4/21)
+:one-ftruncate-result '(-1.0 -1/3) :two-ftruncate-result '(-1.0 -4/21))))
+;; Run this function in a Common Lisp with two arguments to get results that
+;; we should compare against, above. Though note the dancing-around with the
+;; bigfloats and bignums above, too; you can't necessarily just use the
+;; output here.
+
+(defun generate-rounding-output (first second)
+ (let ((print-readably t))
+ (princ first)
+ (princ " ")
+ (princ second)
+ (princ " :one-floor-result ")
+ (princ (list 'quote (multiple-value-list (floor first))))
+ (princ " :two-floor-result ")
+ (princ (list 'quote (multiple-value-list (floor first second))))
+ (princ " :one-ffloor-result ")
+ (princ (list 'quote (multiple-value-list (ffloor first))))
+ (princ " :two-ffloor-result ")
+ (princ (list 'quote (multiple-value-list (ffloor first second))))
+ (princ " :one-ceiling-result ")
+ (princ (list 'quote (multiple-value-list (ceiling first))))
+ (princ " :two-ceiling-result ")
+ (princ (list 'quote (multiple-value-list (ceiling first second))))
+ (princ " :one-fceiling-result ")
+ (princ (list 'quote (multiple-value-list (fceiling first))))
+ (princ " :two-fceiling-result ")
+ (princ (list 'quote (multiple-value-list (fceiling first second))))
+ (princ " :one-round-result ")
+ (princ (list 'quote (multiple-value-list (round first))))
+ (princ " :two-round-result ")
+ (princ (list 'quote (multiple-value-list (round first second))))
+ (princ " :one-fround-result ")
+ (princ (list 'quote (multiple-value-list (fround first))))
+ (princ " :two-fround-result ")
+ (princ (list 'quote (multiple-value-list (fround first second))))
+ (princ " :one-truncate-result ")
+ (princ (list 'quote (multiple-value-list (truncate first))))
+ (princ " :two-truncate-result ")
+ (princ (list 'quote (multiple-value-list (truncate first second))))
+ (princ " :one-ftruncate-result ")
+ (princ (list 'quote (multiple-value-list (ftruncate first))))
+ (princ " :two-ftruncate-result ")
+ (princ (list 'quote (multiple-value-list (ftruncate first second))))))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Support full Common Lisp multiple values in C.
14 years, 8 months
Aidan Kehoe
Aidan Kehoe
changeset: 4677:8f1ee2d15784
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Aug 16 20:55:49 2009 +0100
files: lisp/ChangeLog lisp/byte-optimize.el lisp/bytecomp.el lisp/cl-compat.el lisp/cl-macs.el lisp/cl.el lisp/lisp-mode.el lisp/mouse.el lisp/obsolete.el man/ChangeLog man/cl.texi src/ChangeLog src/bytecode.c src/callint.c src/device-x.c src/eval.c src/event-msw.c src/event-stream.c src/glade.c src/glyphs-widget.c src/glyphs.c src/gui-x.c src/gui.c src/inline.c src/lisp.h src/lread.c src/lrecord.h src/macros.c src/menubar-gtk.c src/menubar-msw.c src/print.c src/symbols.c src/symeval.h
description:
Support full Common Lisp multiple values in C.
lisp/ChangeLog
2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el :
Update this file to support full C-level multiple values. This
involves:
-- Four new bytecodes, and special compiler functions to compile
multiple-value-call, multiple-value-list-internal, values,
values-list, and, since it now needs to pass back multiple values
and is a special form, throw.
-- There's a new compiler variable, byte-compile-checks-on-load,
which is a list of forms that are evaluated at the very start of a
file, with an error thrown if any of them give nil.
-- The header is now inserted *after* compilation, giving a chance
for the compilation process to influence what those checks
are. There is still a check done before compilation for non-ASCII
characters, to try to turn off dynamic docstrings if appopriate,
in `byte-compile-maybe-reset-coding'.
Space is reserved for checks; comments describing the version of
the byte compiler generating the file are inserted if space
remains for them.
* bytecomp.el (byte-compile-version):
Update this, we're a newer version of the byte compiler.
* byte-optimize.el (byte-optimize-funcall):
Correct a comment.
* bytecomp.el (byte-compile-lapcode):
Discard the arg with byte-multiple-value-call.
* bytecomp.el (byte-compile-checks-and-comments-space):
New variable, describe how many octets to reserve for checks at
the start of byte-compiled files.
* cl-compat.el:
Remove the fake multiple-value implementation. Have the functions
that use it use the real multiple-value implementation instead.
* cl-macs.el (cl-block-wrapper, cl-block-throw):
Revise the byte-compile properties of these symbols to work now
we've made throw into a special form; keep the byte-compile
properties as anonymous lambdas, since we don't have docstrings
for them.
* cl-macs.el (multiple-value-bind, multiple-value-setq)
(multiple-value-list, nth-value):
Update these functions to work with the C support for multiple
values.
* cl-macs.el (values):
Modify the setf handler for this to call
#'multiple-value-list-internal appropriately.
* cl-macs.el (cl-setf-do-store):
If the store form is a cons, treat it specially as wrapping the
store value.
* cl.el (cl-block-wrapper):
Make this an alias of #'and, not #'identity, since it needs to
pass back multiple values.
* cl.el (multiple-value-apply):
We no longer support this, mark it obsolete.
* lisp-mode.el (eval-interactive-verbose):
Remove a useless space in the docstring.
* lisp-mode.el (eval-interactive):
Update this function and its docstring. It now passes back a list,
basically wrapping any eval calls with multiple-value-list. This
allows multiple values to be printed by default in *scratch*.
* lisp-mode.el (prin1-list-as-multiple-values):
New function, printing a list as multiple values in the manner of
Bruno Haible's clisp, separating each entry with " ;\n".
* lisp-mode.el (eval-last-sexp):
Call #'prin1-list-as-multiple-values on the return value of
#'eval-interactive.
* lisp-mode.el (eval-defun):
Call #'prin1-list-as-multiple-values on the return value of
#'eval-interactive.
* mouse.el (mouse-eval-sexp):
Deal with lists corresponding to multiple values from
#'eval-interactive. Call #'cl-prettyprint, which is always
available, instead of sometimes calling #'pprint and sometimes
falling back to prin1.
* obsolete.el (obsolete-throw):
New function, called from eval.c when #'funcall encounters an
attempt to call #'throw (now a special form) as a function. Only
needed for compatibility with 21.4 byte-code.
man/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
* cl.texi (Organization):
Remove references to the obsolete multiple-value emulating code.
src/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecode.c (enum Opcode /* Byte codes */):
Add four new bytecodes, to deal with multiple values.
(POP_WITH_MULTIPLE_VALUES): New macro.
(POP): Modify this macro to ignore multiple values.
(DISCARD_PRESERVING_MULTIPLE_VALUES): New macro.
(DISCARD): Modify this macro to ignore multiple values.
(TOP_WITH_MULTIPLE_VALUES): New macro.
(TOP_ADDRESS): New macro.
(TOP): Modify this macro to ignore multiple values.
(TOP_LVALUE): New macro.
(Bcall): Ignore multiple values where appropriate.
(Breturn): Pass back multiple values.
(Bdup): Preserve multiple values.
Use TOP_LVALUE with most bytecodes that assign anything to
anything.
(Bbind_multiple_value_limits, Bmultiple_value_call,
Bmultiple_value_list_internal, Bthrow): Implement the new
bytecodes.
(Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop,
BRgotoifnonnilelsepop):
Discard any multiple values.
* callint.c (Fcall_interactively):
Ignore multiple values when calling #'eval, in two places.
* device-x.c (x_IO_error_handler):
* macros.c (pop_kbd_macro_event):
* eval.c (Fsignal):
* eval.c (flagged_a_squirmer):
Call throw_or_bomb_out, not Fthrow, now that the latter is a
special form.
* eval.c:
Make Qthrow, Qobsolete_throw available as symbols.
Provide multiple_value_current_limit, multiple-values-limit (the
latter as specified by Common Lisp.
* eval.c (For):
Ignore multiple values when comparing with Qnil, but pass any
multiple values back for the last arg.
* eval.c (Fand):
Ditto.
* eval.c (Fif):
Ignore multiple values when examining the result of the
condition.
* eval.c (Fcond):
Ignore multiple values when comparing what the clauses give, but
pass them back if a clause gave non-nil.
* eval.c (Fprog2):
Never pass back multiple values.
* eval.c (FletX, Flet):
Ignore multiple when evaluating what exactly symbols should be
bound to.
* eval.c (Fwhile):
Ignore multiple values when evaluating the test.
* eval.c (Fsetq, Fdefvar, Fdefconst):
Ignore multiple values.
* eval.c (Fthrow):
Declare this as a special form; ignore multiple values for TAG,
preserve them for VALUE.
* eval.c (throw_or_bomb_out):
Make this available to other files, now Fthrow is a special form.
* eval.c (Feval):
Ignore multiple values when calling a compiled function, a
non-special-form subr, or a lambda expression.
* eval.c (Ffuncall):
If we attempt to call #'throw (now a special form) as a function,
don't error, call #'obsolete-throw instead.
* eval.c (make_multiple_value, multiple_value_aset)
(multiple_value_aref, print_multiple_value, mark_multiple_value)
(size_multiple_value):
Implement the multiple_value type. Add a long comment describing
our implementation.
* eval.c (bind_multiple_value_limits):
New function, used by the bytecode and by #'multiple-value-call,
#'multiple-value-list-internal.
* eval.c (multiple_value_call):
New function, used by the bytecode and #'multiple-value-call.
* eval.c (Fmultiple_value_call):
New special form.
* eval.c (multiple_value_list_internal):
New function, used by the byte code and
#'multiple-value-list-internal.
* eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1):
New special forms.
* eval.c (Fvalues, Fvalues_list):
New Lisp functions.
* eval.c (values2):
New function, for C code returning multiple values.
* eval.c (syms_of_eval):
Make our new Lisp functions and symbols available.
* eval.c (multiple-values-limit):
Make this available to Lisp.
* event-msw.c (dde_eval_string):
* event-stream.c (execute_help_form):
* glade.c (connector):
* glyphs-widget.c (glyph_instantiator_to_glyph):
* glyphs.c (evaluate_xpm_color_symbols):
* gui-x.c (wv_set_evalable_slot, button_item_to_widget_value):
* gui.c (gui_item_value, gui_item_display_flush_left):
* lread.c (check_if_suppressed):
* menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1):
* menubar-msw.c (populate_menu_add_item):
* print.c (Fwith_output_to_temp_buffer):
* symbols.c (Fsetq_default):
Ignore multiple values when calling Feval.
* symeval.h:
Add the header declarations necessary for the multiple-values
implementation.
* inline.c:
#include symeval.h, now that it has some inline functions.
* lisp.h:
Update Fthrow's declaration. Make throw_or_bomb_out available to
all files.
* lrecord.h (enum lrecord_type):
Add the multiple_value type here.
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Aug 16 14:58:57 2009 +0100
+++ b/lisp/ChangeLog Sun Aug 16 20:55:49 2009 +0100
＠＠ -9,6 +9,83 ＠＠
* minibuf.el (read-from-minibuffer):
Use buffer (format " *Minibuf-%d*" (minibuffer-depth)), regardless
of depth.
+
+2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecomp.el :
+ Update this file to support full C-level multiple values. This
+ involves:
+ -- Four new bytecodes, and special compiler functions to compile
+ multiple-value-call, multiple-value-list-internal, values,
+ values-list, and, since it now needs to pass back multiple values
+ and is a special form, throw.
+ -- There's a new compiler variable, byte-compile-checks-on-load,
+ which is a list of forms that are evaluated at the very start of a
+ file, with an error thrown if any of them give nil.
+ -- The header is now inserted *after* compilation, giving a chance
+ for the compilation process to influence what those checks
+ are. There is still a check done before compilation for non-ASCII
+ characters, to try to turn off dynamic docstrings if appopriate,
+ in `byte-compile-maybe-reset-coding'.
+ Space is reserved for checks; comments describing the version of
+ the byte compiler generating the file are inserted if space
+ remains for them.
+ * bytecomp.el (byte-compile-version):
+ Update this, we're a newer version of the byte compiler.
+ * byte-optimize.el (byte-optimize-funcall):
+ Correct a comment.
+ * bytecomp.el (byte-compile-lapcode):
+ Discard the arg with byte-multiple-value-call.
+ * bytecomp.el (byte-compile-checks-and-comments-space):
+ New variable, describe how many octets to reserve for checks at
+ the start of byte-compiled files.
+ * cl-compat.el:
+ Remove the fake multiple-value implementation. Have the functions
+ that use it use the real multiple-value implementation instead.
+ * cl-macs.el (cl-block-wrapper, cl-block-throw):
+ Revise the byte-compile properties of these symbols to work now
+ we've made throw into a special form; keep the byte-compile
+ properties as anonymous lambdas, since we don't have docstrings
+ for them.
+ * cl-macs.el (multiple-value-bind, multiple-value-setq)
+ (multiple-value-list, nth-value):
+ Update these functions to work with the C support for multiple
+ values.
+ * cl-macs.el (values):
+ Modify the setf handler for this to call
+ #'multiple-value-list-internal appropriately.
+ * cl-macs.el (cl-setf-do-store):
+ If the store form is a cons, treat it specially as wrapping the
+ store value.
+ * cl.el (cl-block-wrapper):
+ Make this an alias of #'and, not #'identity, since it needs to
+ pass back multiple values.
+ * cl.el (multiple-value-apply):
+ We no longer support this, mark it obsolete.
+ * lisp-mode.el (eval-interactive-verbose):
+ Remove a useless space in the docstring.
+ * lisp-mode.el (eval-interactive):
+ Update this function and its docstring. It now passes back a list,
+ basically wrapping any eval calls with multiple-value-list. This
+ allows multiple values to be printed by default in *scratch*.
+ * lisp-mode.el (prin1-list-as-multiple-values):
+ New function, printing a list as multiple values in the manner of
+ Bruno Haible's clisp, separating each entry with " ;\n".
+ * lisp-mode.el (eval-last-sexp):
+ Call #'prin1-list-as-multiple-values on the return value of
+ #'eval-interactive.
+ * lisp-mode.el (eval-defun):
+ Call #'prin1-list-as-multiple-values on the return value of
+ #'eval-interactive.
+ * mouse.el (mouse-eval-sexp):
+ Deal with lists corresponding to multiple values from
+ #'eval-interactive. Call #'cl-prettyprint, which is always
+ available, instead of sometimes calling #'pprint and sometimes
+ falling back to prin1.
+ * obsolete.el (obsolete-throw):
+ New function, called from eval.c when #'funcall encounters an
+ attempt to call #'throw (now a special form) as a function. Only
+ needed for compatibility with 21.4 byte-code.
2009-08-10 Aidan Kehoe <kehoea(a)parhasard.net>
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Sun Aug 16 14:58:57 2009 +0100
+++ b/lisp/byte-optimize.el Sun Aug 16 20:55:49 2009 +0100
＠＠ -1093,7 +1093,7 ＠＠
(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer)
(defun byte-optimize-funcall (form)
- ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...)
+ ;; (funcall #'(lambda ...) ...) ==> ((lambda ...) ...)
;; (funcall 'foo ...) ==> (foo ...)
(let ((fn (nth 1 form)))
(if (memq (car-safe fn) '(quote function))
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/bytecomp.el
--- a/lisp/bytecomp.el Sun Aug 16 14:58:57 2009 +0100
+++ b/lisp/bytecomp.el Sun Aug 16 20:55:49 2009 +0100
＠＠ -10,7 +10,7 ＠＠
;; Richard Stallman <rms(a)gnu.org>
;; Keywords: internal lisp
-(defconst byte-compile-version "2.27 XEmacs; 2000-09-12.")
+(defconst byte-compile-version "2.28 XEmacs; 2009-08-09.")
;; This file is part of XEmacs.
＠＠ -215,7 +215,7 ＠＠
(load-library "bytecomp-runtime"))
(eval-when-compile
- (defvar byte-compile-single-version nil
+ (defvar byte-compile-single-version t
"If this is true, the choice of emacs version (v19 or v20) byte-codes will
be hard-coded into bytecomp when it compiles itself. If the compiler itself
is compiled with optimization, this causes a speedup.")
＠＠ -304,6 +304,10 ＠＠
"This is completely ignored. It is only around for backwards
compatibility.")
+(defvar byte-compile-checks-on-load '((featurep 'xemacs))
+ "A list of expressions to check when first loading a file.
+Emacs will throw an error if any of them fail; checks will be made in
+reverse order.")
;; FSF enables byte-compile-dynamic-docstrings but not byte-compile-dynamic
;; by default. This would be a reasonable conservative approach except
＠＠ -440,7 +444,7 ＠＠
on the specbind stack. The cdr of each cell is an integer bitmask.")
(defvar byte-compile-force-escape-quoted nil
- "If non-nil, `byte-compile-insert-header' always adds a coding cookie.
+ "If t, `byte-compile-maybe-reset-coding' always chooses `escape-quoted'
This is for situations where the byte compiler output file needs to be
able to encode character values above ?\\xFF, but this cannot be
＠＠ -733,7 +737,10 ＠＠
(byte-defop 176 nil byte-concatN)
(byte-defop 177 nil byte-insertN)
-;; unused: 178-181
+(byte-defop 178 1 byte-bind-multiple-value-limits)
+(byte-defop 179 -3 byte-multiple-value-list-internal)
+(byte-defop 180 0 byte-multiple-value-call)
+(byte-defop 181 -1 byte-throw)
;; these ops are new to v20
(byte-defop 182 -1 byte-member)
＠＠ -833,6 +840,10 ＠＠
(<= (symbol-value op) byte-insertN))
(setq pc (+ 2 pc))
(cons off (cons (symbol-value op) bytes)))
+ ((= byte-multiple-value-call (symbol-value op))
+ (setq pc (1+ pc))
+ ;; Ignore off.
+ (cons (symbol-value op) bytes))
((< off 6)
(setq pc (1+ pc))
(cons (+ (symbol-value op) off) bytes))
＠＠ -1386,6 +1397,8 ＠＠
(byte-optimize byte-optimize)
(byte-compile-emacs19-compatibility
byte-compile-emacs19-compatibility)
+ (byte-compile-checks-on-load
+ byte-compile-checks-on-load)
(byte-compile-dynamic byte-compile-dynamic)
(byte-compile-dynamic-docstrings
byte-compile-dynamic-docstrings)
＠＠ -1718,9 +1731,7 ＠＠
;; byte-compile-warning-types
;; byte-compile-warnings))
(byte-compile-force-escape-quoted byte-compile-force-escape-quoted)
- (byte-compile-using-dynamic nil)
- (byte-compile-using-escape-quoted nil)
- )
+ (byte-compile-using-dynamic nil))
(byte-compile-close-variables
(save-excursion
(setq byte-compile-outbuffer
＠＠ -1730,9 +1741,8 ＠＠
(setq case-fold-search nil)
(and filename
(not eval)
- (byte-compile-insert-header filename
- byte-compile-inbuffer
- byte-compile-outbuffer))
+ (byte-compile-maybe-reset-coding byte-compile-inbuffer
+ byte-compile-outbuffer))
(setq byte-compile-using-dynamic
(or (symbol-value-in-buffer 'byte-compile-dynamic
byte-compile-inbuffer)
＠＠ -1763,6 +1773,8 ＠＠
;; Compile pending forms at end of file.
(byte-compile-flush-pending)
+ (byte-compile-insert-header filename byte-compile-inbuffer
+ byte-compile-outbuffer)
(byte-compile-warn-about-unresolved-functions)
;; Should we always do this? When calling multiple files, it
;; would be useful to delay this warning until all have
＠＠ -1797,11 +1809,16 ＠＠
(kill-buffer byte-compile-outbuffer)
nil)))
+(defvar byte-compile-checks-and-comments-space 475
+ "Number of octets of space for checks and comments; used by the dynamic
+docstrings code.")
+
(defun byte-compile-insert-header (filename byte-compile-inbuffer
- byte-compile-outbuffer)
+ byte-compile-outbuffer)
(set-buffer byte-compile-inbuffer)
- (let ((dynamic-docstrings byte-compile-dynamic-docstrings))
+ (let (checks-string comments)
(set-buffer byte-compile-outbuffer)
+ (delete-region 1 (1+ byte-compile-checks-and-comments-space))
(goto-char 1)
;;
;; The magic number of .elc files is ";ELC", or 0x3B454C43. After that is
＠＠ -1817,62 +1834,56 ＠＠
(insert
";ELC"
(if (byte-compile-version-cond byte-compile-emacs19-compatibility) 19 20)
- "\000\000\000\n"
- )
- (insert ";;; compiled by "
- (or (and (boundp 'user-mail-address) user-mail-address)
- (concat (user-login-name) "＠" (system-name)))
- " on "
- (current-time-string) "\n;;; from file " filename "\n")
- (insert ";;; emacs version " emacs-version ".\n")
- (insert ";;; bytecomp version " byte-compile-version "\n;;; "
- (cond
- ((eq byte-optimize 'source) "source-level optimization only")
- ((eq byte-optimize 'byte) "byte-level optimization only")
- (byte-optimize "optimization is on")
- (t "optimization is off"))
- (if (byte-compile-version-cond byte-compile-emacs19-compatibility)
- "; compiled with Emacs 19 compatibility.\n"
- ".\n"))
- (if (not (byte-compile-version-cond byte-compile-emacs19-compatibility))
- (insert ";;; this file uses opcodes which do not exist in Emacs 19.\n"
- ;; Have to check if emacs-version is bound so that this works
- ;; in files loaded early in loadup.el.
- "\n(if (and (boundp 'emacs-version)\n"
- "\t (or (and (boundp 'epoch::version) epoch::version)\n"
- "\t (string-lessp emacs-version \"20\")))\n"
- " (error \"`"
- ;; prin1-to-string is used to quote backslashes.
- (substring (prin1-to-string (file-name-nondirectory filename))
- 1 -1)
- "' was compiled for Emacs 20\"))\n\n"))
- (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n"
- "\n")
- (if (and (byte-compile-version-cond byte-compile-emacs19-compatibility)
- dynamic-docstrings)
- (insert ";;; this file uses opcodes which do not exist prior to\n"
- ";;; XEmacs 19.14/GNU Emacs 19.29 or later."
- ;; Have to check if emacs-version is bound so that this works
- ;; in files loaded early in loadup.el.
- "\n(if (and (boundp 'emacs-version)\n"
- "\t (or (and (boundp 'epoch::version) epoch::version)\n"
- "\t (and (not (string-match \"XEmacs\" emacs-version))\n"
- "\t (string-lessp emacs-version \"19.29\"))\n"
- "\t (string-lessp emacs-version \"19.14\")))\n"
- " (error \"`"
- ;; prin1-to-string is used to quote backslashes.
- (substring (prin1-to-string (file-name-nondirectory filename))
- 1 -1)
- "' was compiled for XEmacs 19.14/Emacs 19.29 or later\"))\n\n"
- )
- ))
-
- ;; back in the inbuffer; determine and set the coding system for the .elc
- ;; file if under Mule. If there are any extended characters in the
- ;; input file, use `escape-quoted' to make sure that both binary and
- ;; extended characters are output properly and distinguished properly.
- ;; Otherwise, use `raw-text' for maximum portability with non-Mule
- ;; Emacsen.
+ "\000\000\000\n")
+ (when (not (eq (find-coding-system 'raw-text-unix)
+ (find-coding-system buffer-file-coding-system)))
+ (insert (format ";;;###coding system: %s\n"
+ (coding-system-name buffer-file-coding-system))))
+ (insert (format
+ "\n(or %s\n (error \"Loading this file requires: %s\"))\n"
+ (setq checks-string
+ (let ((print-readably t))
+ (prin1-to-string (if (> (length
+ byte-compile-checks-on-load)
+ 1)
+ (cons 'and
+ (reverse
+ byte-compile-checks-on-load))
+ (car byte-compile-checks-on-load)))))
+ checks-string))
+ (setq comments
+ (with-string-as-buffer-contents ""
+ (insert "\n;;; compiled by "
+ (or (and (boundp 'user-mail-address) user-mail-address)
+ (concat (user-login-name) "＠" (system-name)))
+ " on "
+ (current-time-string) "\n;;; from file " filename "\n")
+ (insert ";;; emacs version " emacs-version ".\n")
+ (insert ";;; bytecomp version " byte-compile-version "\n;;; "
+ (cond
+ ((eq byte-optimize 'source)
+ "source-level optimization only")
+ ((eq byte-optimize 'byte) "byte-level optimization only")
+ (byte-optimize "optimization is on")
+ (t "optimization is off"))
+ "\n")))
+
+ ;; We won't trip this unless the byte-compiler changes, in which case
+ ;; it's just a matter of upping the space.
+ (assert (natnump (- (1+ byte-compile-checks-and-comments-space) (point)))
+ t "Not enough space for the feature checks!")
+
+ (if (natnump (- (1+ byte-compile-checks-and-comments-space)
+ (+ (point) (length comments))))
+ (insert comments))
+ (insert-char ?\ (- (1+ byte-compile-checks-and-comments-space)
+ (point)))))
+
+(defun byte-compile-maybe-reset-coding (byte-compile-inbuffer
+ byte-compile-outbuffer)
+ ;; We also reserve some space for the feature checks:
+ (goto-char 1)
+ (insert-char ?\ byte-compile-checks-and-comments-space)
(if (or (featurep '(not mule)) ;; Don't scan buffer if we are not muleized
(and
(not byte-compile-force-escape-quoted)
＠＠ -1885,7 +1896,8 ＠＠
;; not true of ordinary comments.
(let ((non-latin-1-re
(concat "[^\000-\377]"
- #r"\|\\u[0-9a-fA-F]\{4,4\}\|\\U[0-9a-fA-F]\{8,8\}"))
+ #r"\|\\u[0-9a-fA-F]\{4,4\}\|\\U[0-9a-fA-F]"
+ "\\{8,8\\}"))
(case-fold-search nil))
(catch 'need-to-escape-quote
(while (re-search-forward non-latin-1-re nil t)
＠＠ -1894,19 +1906,12 ＠＠
(forward-line 1))
t)))))
(setq buffer-file-coding-system 'raw-text-unix)
- (insert "(or (featurep 'mule) (error \"Loading this file requires Mule support\"))
-;;;###coding system: escape-quoted\n")
(setq buffer-file-coding-system 'escape-quoted)
- ;; #### Lazy loading not yet implemented for MULE files
- ;; mrb - Fix this someday.
+ (pushnew '(featurep 'mule) byte-compile-checks-on-load)
(save-excursion
(set-buffer byte-compile-inbuffer)
(setq byte-compile-dynamic nil
- byte-compile-dynamic-docstrings nil))
- ;;(external-debugging-output (prin1-to-string (buffer-local-variables))))
- )
- )
-
+ byte-compile-dynamic-docstrings nil))))
(defun byte-compile-output-file-form (form)
;; writes the given form to the output buffer, being careful of docstrings
＠＠ -3084,6 +3089,11 ＠＠
(byte-defop-compiler (% byte-rem) 2)
(byte-defop-compiler aset 3)
+(byte-defop-compiler-1 bind-multiple-value-limits)
+(byte-defop-compiler multiple-value-list-internal)
+(byte-defop-compiler-1 multiple-value-call)
+(byte-defop-compiler throw)
+
(byte-defop-compiler-rmsfun member 2)
(byte-defop-compiler-rmsfun assq 2)
＠＠ -3102,11 +3112,14 ＠＠
;;(byte-defop-compiler (mod byte-rem) 2)
-(defun byte-compile-subr-wrong-args (form n)
+(defun byte-compile-warn-wrong-args (form n)
(when (memq 'subr-callargs byte-compile-warnings)
(byte-compile-warn "%s called with %d arg%s, but requires %s"
(car form) (length (cdr form))
- (if (= 1 (length (cdr form))) "" "s") n))
+ (if (= 1 (length (cdr form))) "" "s") n)))
+
+(defun byte-compile-subr-wrong-args (form n)
+ (byte-compile-warn-wrong-args form n)
;; get run-time wrong-number-of-args error.
(byte-compile-normal-call form))
＠＠ -3641,6 +3654,9 ＠＠
(byte-defop-compiler-1 inline byte-compile-progn)
(byte-defop-compiler-1 progn)
(byte-defop-compiler-1 prog1)
+(byte-defop-compiler-1 multiple-value-prog1)
+(byte-defop-compiler-1 values)
+(byte-defop-compiler-1 values-list)
(byte-defop-compiler-1 prog2)
(byte-defop-compiler-1 if)
(byte-defop-compiler-1 cond)
＠＠ -3660,13 +3676,36 ＠＠
(defun byte-compile-prog1 (form)
(setq form (cdr form))
+ ;; #'prog1 never returns multiple values:
+ (byte-compile-form-do-effect (list 'values (pop form)))
+ (byte-compile-body form t))
+
+(defun byte-compile-multiple-value-prog1 (form)
+ (setq form (cdr form))
(byte-compile-form-do-effect (pop form))
(byte-compile-body form t))
+
+(defun byte-compile-values (form)
+ (if (and (= 2 (length form))
+ (byte-compile-constp (second form)))
+ (byte-compile-form-do-effect (second form))
+ (byte-compile-normal-call form)))
+
+(defun byte-compile-values-list (form)
+ (if (and (= 2 (length form))
+ (or (null (second form))
+ (and (consp (second form))
+ (eq (car (second form))
+ 'quote)
+ (not (symbolp (car-safe (cdr (second form))))))))
+ (byte-compile-form-do-effect (car-safe (cdr (second form))))
+ (byte-compile-normal-call form)))
(defun byte-compile-prog2 (form)
(setq form (cdr form))
(byte-compile-form (pop form) t)
- (byte-compile-form-do-effect (pop form))
+ ;; #'prog2 never returns multiple values:
+ (byte-compile-form-do-effect (list 'values (pop form)))
(byte-compile-body form t))
(defmacro byte-compile-goto-if (cond discard tag)
＠＠ -3952,6 +3991,65 ＠＠
(byte-compile-body (cdr (cdr form)))
(byte-compile-out 'byte-temp-output-buffer-show 0))
+(defun byte-compile-multiple-value-call (form)
+ (if (< (length form) 2)
+ (progn
+ (byte-compile-warn-wrong-args form 1)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(,(car form)
+ ,(length (cdr form))))))
+ (setq form (cdr form))
+ (byte-compile-form (car form))
+ (byte-compile-push-constant 0)
+ (byte-compile-variable-ref 'byte-varref 'multiple-values-limit)
+ ;; bind-multiple-value-limits leaves two existing values on the stack,
+ ;; and pushes a new value, the specpdl_depth() at the time it was
+ ;; called.
+ (byte-compile-out 'byte-bind-multiple-value-limits 0)
+ (mapcar 'byte-compile-form (cdr form))
+ ;; Most of the other code puts this sort of value in the program stream,
+ ;; not pushing it on the stack.
+ (byte-compile-push-constant (+ 3 (length form)))
+ (byte-compile-out 'byte-multiple-value-call (+ 3 (length form)))
+ (pushnew '(subrp (symbol-function 'multiple-value-call))
+ byte-compile-checks-on-load
+:test #'equal)))
+
+(defun byte-compile-multiple-value-list-internal (form)
+ (if (/= 4 (length form))
+ (progn
+ (byte-compile-warn-wrong-args form 3)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(,(car form)
+ ,(length (cdr form))))))
+ (byte-compile-form (nth 1 form))
+ (byte-compile-form (nth 2 form))
+ (byte-compile-out 'byte-bind-multiple-value-limits 0)
+ (byte-compile-form (nth 3 form))
+ (byte-compile-out (get (car form) 'byte-opcode) 0)
+ (pushnew '(subrp (symbol-function 'multiple-value-call))
+ byte-compile-checks-on-load
+:test #'equal)))
+
+(defun byte-compile-throw (form)
+ ;; We can't use byte-compile-two-args for throw because in the event that
+ ;; the form does not have two args, it tries to #'funcall it expecting a
+ ;; runtime wrong-number-of-arguments error. Now that #'throw is a special
+ ;; form, it provokes an invalid-function error instead (or at least it
+ ;; should; there's a kludge around for the moment in eval.c that avoids
+ ;; that, but this file should not assume that that will always be there).
+ (if (/= 2 (length (cdr form)))
+ (progn
+ (byte-compile-warn-wrong-args form 2)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(,(car form)
+ ,(length (cdr form))))))
+ (byte-compile-form (nth 1 form)) ;; Push the arguments
+ (byte-compile-form (nth 2 form))
+ (byte-compile-out (get (car form) 'byte-opcode) 0)
+ (pushnew '(null (function-max-args 'throw))
+ byte-compile-checks-on-load
+:test #'equal)))
;;; top-level forms elsewhere
＠＠ -4115,6 +4213,8 ＠＠
;; This is actually an unnecessary case, because there should be
;; no more opcodes behind byte-return.
(setq byte-compile-depth nil))
+ (byte-multiple-value-call
+ (setq byte-compile-depth (- byte-compile-depth offset)))
(t
(setq byte-compile-depth (+ byte-compile-depth
(or (aref byte-stack+-info
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/cl-compat.el
--- a/lisp/cl-compat.el Sun Aug 16 14:58:57 2009 +0100
+++ b/lisp/cl-compat.el Sun Aug 16 20:55:49 2009 +0100
＠＠ -59,52 +59,10 ＠＠
(defun keyword-of (sym)
(or (keywordp sym) (keywordp (intern (format ":%s" sym)))))
-
-;;; Multiple values. Note that the new package uses a different
-;;; convention for multiple values. The following definitions
-;;; emulate the old convention; all function names have been changed
-;;; by capitalizing the first letter: Values, Multiple-value-*,
-;;; to avoid conflict with the new-style definitions in cl-macs.
-
-(put 'Multiple-value-bind 'lisp-indent-function 2)
-(put 'Multiple-value-setq 'lisp-indent-function 2)
-(put 'Multiple-value-call 'lisp-indent-function 1)
-(put 'Multiple-value-prog1 'lisp-indent-function 1)
-
-(defvar *mvalues-values* nil)
-
-(defun Values (&rest val-forms)
- (setq *mvalues-values* val-forms)
- (car val-forms))
-
-(defun Values-list (val-forms)
- (apply 'values val-forms))
-
-(defmacro Multiple-value-list (form)
- (list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form))
- '(or (and (eq *mvalues-temp* (car *mvalues-values*)) *mvalues-values*)
- (list *mvalues-temp*))))
-
-(defmacro Multiple-value-call (function &rest args)
- (list 'apply function
- (cons 'append
- (mapcar (function (lambda (x) (list 'Multiple-value-list x)))
- args))))
-
-(defmacro Multiple-value-bind (vars form &rest body)
- (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body))
-
-(defmacro Multiple-value-setq (vars form)
- (list 'multiple-value-setq vars (list 'Multiple-value-list form)))
-
-(defmacro Multiple-value-prog1 (form &rest body)
- (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body)))
-
-
;;; Routines for parsing keyword arguments.
(defun build-klist (arglist keys &optional allow-others)
- (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist))))
+ (let ((res (multiple-value-call 'mapcar* 'cons (unzip-lists arglist))))
(or allow-others
(let ((bad (set-difference (mapcar 'car res) keys)))
(if bad (error "Bad keywords: %s not in %s" bad keys))))
＠＠ -124,25 +82,23 ＠＠
(if test-not (not (funcall test-not item elt))
(funcall (or test 'eql) item elt))))
-
;;; Rounding functions with old-style multiple value returns.
-(defun cl-floor (a &optional b) (Values-list (floor* a b)))
-(defun cl-ceiling (a &optional b) (Values-list (ceiling* a b)))
-(defun cl-round (a &optional b) (Values-list (round* a b)))
-(defun cl-truncate (a &optional b) (Values-list (truncate* a b)))
+(defun cl-floor (a &optional b) (values-list (floor* a b)))
+(defun cl-ceiling (a &optional b) (values-list (ceiling* a b)))
+(defun cl-round (a &optional b) (values-list (round* a b)))
+(defun cl-truncate (a &optional b) (values-list (truncate* a b)))
(defun safe-idiv (a b)
(let* ((q (/ (abs a) (abs b)))
(s (* (signum a) (signum b))))
- (Values q (- a (* s q b)) s)))
-
+ (values q (- a (* s q b)) s)))
;; Internal routines.
(defun pair-with-newsyms (oldforms)
(let ((newsyms (mapcar (function (lambda (x) (gensym))) oldforms)))
- (Values (mapcar* 'list newsyms oldforms) newsyms)))
+ (values (mapcar* 'list newsyms oldforms) newsyms)))
(defun zip-lists (evens odds)
(mapcan 'list evens odds))
＠＠ -151,7 +107,7 ＠＠
(let ((e nil) (o nil))
(while list
(setq e (cons (car list) e) o (cons (cadr list) o) list (cddr list)))
- (Values (nreverse e) (nreverse o))))
+ (values (nreverse e) (nreverse o))))
(defun reassemble-argslists (list)
(let ((n (apply 'min (mapcar 'length list))) (res nil))
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun Aug 16 14:58:57 2009 +0100
+++ b/lisp/cl-macs.el Sun Aug 16 20:55:49 2009 +0100
＠＠ -715,24 +715,30 ＠＠
(defvar cl-active-block-names nil)
-(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
-(defun cl-byte-compile-block (cl-form)
- (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler
- (progn
- (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
- (cl-active-block-names (cons cl-entry cl-active-block-names))
- (cl-body (byte-compile-top-level
- (cons 'progn (cddr (nth 1 cl-form))))))
- (if (cdr cl-entry)
- (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
- (byte-compile-form cl-body))))
- (byte-compile-form (nth 1 cl-form))))
+(put 'cl-block-wrapper 'byte-compile
+ #'(lambda (cl-form)
+ (if (/= (length cl-form) 2)
+ (byte-compile-warn-wrong-args cl-form 1))
-(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
-(defun cl-byte-compile-throw (cl-form)
- (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
- (if cl-found (setcdr cl-found t)))
- (byte-compile-normal-call (cons 'throw (cdr cl-form))))
+ (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing
+ ; compiler
+ (progn
+ (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
+ (cl-active-block-names (cons cl-entry
+ cl-active-block-names))
+ (cl-body (byte-compile-top-level
+ (cons 'progn (cddr (nth 1 cl-form))))))
+ (if (cdr cl-entry)
+ (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form))
+ cl-body))
+ (byte-compile-form cl-body))))
+ (byte-compile-form (nth 1 cl-form)))))
+
+(put 'cl-block-throw 'byte-compile
+ #'(lambda (cl-form)
+ (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
+ (if cl-found (setcdr cl-found t)))
+ (byte-compile-throw (cons 'throw (cdr cl-form)))))
;;;###autoload
(defmacro return (&optional result)
＠＠ -1841,47 +1847,70 ＠＠
(list 'function (cons 'lambda rest)))
(list 'quote func)))
-
-;;; Multiple values.
+;;; Multiple values. We support full Common Lisp conventions here.
;;;###autoload
-(defmacro multiple-value-bind (vars form &rest body)
- "(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values.
-FORM must return a list; the BODY is then executed with the first N elements
-of this list bound (`let'-style) to each of the symbols SYM in turn. This
-is analogous to the Common Lisp `multiple-value-bind' macro, using lists to
-simulate true multiple return values. For compatibility, (values A B C) is
-a synonym for (list A B C)."
- (let ((temp (gensym)) (n -1))
- (list* 'let* (cons (list temp form)
- (mapcar #'(lambda (v)
- (list v (list 'nth (setq n (1+ n)) temp)))
- vars))
- body)))
+(defmacro multiple-value-bind (syms form &rest body)
+ "Collect and bind multiple return values.
+
+If FORM returns multiple values, each symbol in SYMS is bound to one of
+them, in order, and BODY is executed. If FORM returns fewer multiple values
+than there are SYMS, remaining SYMS are bound to nil. If FORM does
+not return multiple values, it is treated as returning one multiple value.
+
+Returns the value given by the last element of BODY."
+ (if (null syms)
+ `(progn ,form ,＠body)
+ (if (= 1 (length syms))
+ ;; Code written to deal with other "implementations" of multiple
+ ;; values may have a one-element SYMS.
+ `(let ((,(car syms) ,form))
+ ,＠body)
+ (let ((temp (gensym)))
+ `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form))
+ ,＠(loop
+ for var in syms
+ collect `(,var (prog1 (car ,temp)
+ (setq ,temp (cdr ,temp))))))
+ ,＠body)))))
;;;###autoload
-(defmacro multiple-value-setq (vars form)
- "(multiple-value-setq (SYM SYM...) FORM): collect multiple return values.
-FORM must return a list; the first N elements of this list are stored in
-each of the symbols SYM in turn. This is analogous to the Common Lisp
-`multiple-value-setq' macro, using lists to simulate true multiple return
-values. For compatibility, (values A B C) is a synonym for (list A B C)."
- (cond ((null vars) (list 'progn form nil))
- ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
- (t
- (let* ((temp (gensym)) (n 0))
- (list 'let (list (list temp form))
- (list 'prog1 (list 'setq (pop vars) (list 'car temp))
- (cons 'setq
- (apply 'nconc
- (mapcar
- #'(lambda (v)
- (list v (list
- 'nth
- (setq n (1+ n))
- temp)))
- vars)))))))))
+(defmacro multiple-value-setq (syms form)
+ "Collect and set multiple values.
+FORM should normally return multiple values; the first N values are stored
+in the symbols in SYMS in turn. If FORM returns fewer than N values, the
+remaining symbols have their values set to nil. FORM not returning multiple
+values is treated as FORM returning one multiple value, with other elements
+of SYMS initialized to nil.
+
+Returns the first of the multiple values given by FORM."
+ (if (null syms)
+ ;; Never return multiple values from multiple-value-setq:
+ (and form `(values ,form))
+ (if (= 1 (length syms))
+ `(setq ,(car syms) ,form)
+ (let ((temp (gensym)))
+ `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form)))
+ (setq ,＠(loop
+ for sym in syms
+ nconc `(,sym (car-safe ,temp)
+ ,temp (cdr-safe ,temp))))
+ ,(car syms))))))
+
+;;;###autoload
+(defmacro multiple-value-list (form)
+ "Evaluate FORM and return a list of the multiple values it returned."
+ `(multiple-value-list-internal 0 multiple-values-limit ,form))
+
+;;;###autoload
+(defmacro nth-value (n form)
+ "Evaluate FORM and return the Nth multiple value it returned."
+ (if (integerp n)
+ `(car (multiple-value-list-internal ,n ,(1+ n) ,form))
+ (let ((temp (gensym)))
+ `(let ((,temp ,n))
+ (car (multiple-value-list-internal ,temp (1+ ,temp) ,form))))))
;;; Declarations.
＠＠ -2346,8 +2375,9 ＠＠
(store-temp (gensym "--values-store--")))
(list (apply 'append (mapcar 'first methods))
(apply 'append (mapcar 'second methods))
- (list store-temp)
- (cons 'list
+ `((,store-temp
+ (multiple-value-list-internal 0 ,(if args (length args) 1))))
+ (cons 'values
(mapcar #'(lambda (m)
(cl-setf-do-store (cons (car (third m)) (fourth m))
(list 'pop store-temp)))
＠＠ -2410,11 +2440,25 ＠＠
(defun cl-setf-do-store (spec val)
(let ((sym (car spec))
(form (cdr spec)))
- (if (or (cl-const-expr-p val)
- (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1))
- (cl-setf-simple-store-p sym form))
- (subst val sym form)
- (list 'let (list (list sym val)) form))))
+ (if (consp sym)
+ ;; XEmacs change, only used for implementing #'values at the moment.
+ (let* ((orig (copy-list sym))
+ (intermediate (last orig))
+ (circular-limit 32))
+ (while (consp (car intermediate))
+ (when (zerop circular-limit)
+ (error 'circular-list "Form seems to contain loops"))
+ (setq intermediate (last (car intermediate))
+ circular-limit (1- circular-limit)))
+ (setcdr intermediate (list val))
+ `(let (,orig)
+ ,form))
+ (if (or (cl-const-expr-p val)
+ (and (cl-simple-expr-p val)
+ (eq (cl-expr-contains form sym) 1))
+ (cl-setf-simple-store-p sym form))
+ (subst val sym form)
+ (list 'let (list (list sym val)) form)))))
(defun cl-setf-simple-store-p (sym form)
(and (consp form) (eq (cl-expr-contains form sym) 1)
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/cl.el
--- a/lisp/cl.el Sun Aug 16 14:58:57 2009 +0100
+++ b/lisp/cl.el Sun Aug 16 20:55:49 2009 +0100
＠＠ -209,48 +209,24 ＠＠
;;; Blocks and exits.
-(defalias 'cl-block-wrapper 'identity)
+;; This used to be #'identity, but that didn't preserve multiple values in
+;; interpreted code. #'and isn't great either, there's no error on too many
+;; arguments passed to it when interpreted. Fortunately most of the places
+;; where cl-block-wrapper is called are generated from old, established
+;; macros, so too many arguments resulting from human error is unlikely; and
+;; the byte compile handler in cl-macs.el warns if more than one arg is
+;; passed to it.
+(defalias 'cl-block-wrapper 'and)
+
(defalias 'cl-block-throw 'throw)
+;;; XEmacs; multiple values are in eval.c and cl-macs.el.
-;;; Multiple values. True multiple values are not supported, or even
-;;; simulated. Instead, multiple-value-bind and friends simply expect
-;;; the target form to return the values as a list.
+;;; We no longer support `multiple-value-apply', which was ill-conceived to
+;;; start with, is not specified by Common Lisp, and which nothing uses,
+;;; according to Google Code Search, as of Sat Mar 14 23:31:35 GMT 2009.
-(defsubst values (&rest values)
- "Return multiple values, Common Lisp style.
-The arguments of `values' are the values
-that the containing function should return."
- values)
-
-(defsubst values-list (list)
- "Return multiple values, Common Lisp style, taken from a list.
-LIST specifies the list of values
-that the containing function should return."
- list)
-
-(defsubst multiple-value-list (expression)
- "Return a list of the multiple values produced by EXPRESSION.
-This handles multiple values in Common Lisp style, but it does not
-work right when EXPRESSION calls an ordinary Emacs Lisp function
-that returns just one value."
- expression)
-
-(defsubst multiple-value-apply (function expression)
- "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them.
-This handles multiple values in Common Lisp style, but it does not work
-right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
-one value."
- (apply function expression))
-
-(defalias 'multiple-value-call 'apply) ; only works for one arg
-
-(defsubst nth-value (n expression)
- "Evaluate EXPRESSION to get multiple values and return the Nth one.
-This handles multiple values in Common Lisp style, but it does not work
-right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
-one value."
- (nth n expression))
+(make-obsolete 'multiple-value-apply 'multiple-value-call)
;;; Macros.
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/lisp-mode.el
--- a/lisp/lisp-mode.el Sun Aug 16 14:58:57 2009 +0100
+++ b/lisp/lisp-mode.el Sun Aug 16 20:55:49 2009 +0100
＠＠ -424,36 +424,55 ＠＠
been treated noninteractively.
The printed messages are \"defvar treated as defconst\" and \"defcustom
- evaluation forced\". See `eval-interactive' for more details."
+evaluation forced\". See `eval-interactive' for more details."
:type 'boolean
:group 'lisp)
(defun eval-interactive (expr)
- "Like `eval' except that it transforms defvars to defconsts.
-The evaluation of defcustom forms is forced."
+ "Evaluate EXPR; pass back multiple values, transform defvars to defconsts.
+
+Always returns a list. The length of this list will be something other than
+one if the form returned multiple values. It will be zero if the form
+returned a single zero-length multiple value."
(cond ((and (eq (car-safe expr) 'defvar)
(> (length expr) 2))
- (eval (cons 'defconst (cdr expr)))
+ (setq expr (multiple-value-list (eval (cons 'defconst (cdr expr)))))
(when eval-interactive-verbose
(message "defvar treated as defconst")
(sit-for 1)
(message ""))
- (nth 1 expr))
+ expr)
((and (eq (car-safe expr) 'defcustom)
(> (length expr) 2)
(default-boundp (nth 1 expr)))
;; Force variable to be bound
- ;; #### defcustom might specify a different :set method.
- (set-default (nth 1 expr) (eval (nth 2 expr)))
+ (funcall
+ (or (plist-get expr :set) #'custom-set-default)
+ (nth 1 expr) (eval (nth 2 expr)))
;; And evaluate the defcustom
- (eval expr)
+ (setq expr (multiple-value-list (eval expr)))
(when eval-interactive-verbose
(message "defcustom evaluation forced")
(sit-for 1)
(message ""))
- (nth 1 expr))
+ expr)
(t
- (eval expr))))
+ (multiple-value-list (eval expr)))))
+
+(defun prin1-list-as-multiple-values (multiple-value-list &optional stream)
+ "Call `prin1' on each element of MULTIPLE-VALUE-LIST, separated by \" ;\\n\"
+
+If MULTIPLE-VALUE-LIST is zero-length, print the text
+\"#<zero length multiple value> ;\\n\". Always returns nil."
+ (loop for value in multiple-value-list
+ with seen-first = nil
+ do
+ (if seen-first
+ (princ " ;\n" stream)
+ (setq seen-first t))
+ (prin1 value stream)
+ finally (unless seen-first
+ (princ "#<zero length multiple value> ;" stream))))
;; XEmacs change, based on Bob Weiner suggestion
(defun eval-last-sexp (eval-last-sexp-arg-internal) ;dynamic scoping wonderment
＠＠ -463,31 +482,32 ＠＠
(let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))
(opoint (point))
ignore-quotes)
- (prin1 (eval-interactive
- (letf (((syntax-table) emacs-lisp-mode-syntax-table))
- (save-excursion
- ;; If this sexp appears to be enclosed in `...' then
- ;; ignore the surrounding quotes.
- (setq ignore-quotes (or (eq (char-after) ?\')
- (eq (char-before) ?\')))
- (forward-sexp -1)
- ;; vladimir(a)cs.ualberta.ca 30-Jul-1997: skip ` in
- ;; `variable' so that the value is returned, not the
- ;; name.
- (if (and ignore-quotes
- (eq (char-after) ?\`))
- (forward-char))
- (save-restriction
- (narrow-to-region (point-min) opoint)
- (let ((expr (read (current-buffer))))
- (if (eq (car-safe expr) 'interactive)
- ;; If it's an (interactive ...) form, it's
- ;; more useful to show how an interactive call
- ;; would use it.
- `(call-interactively
- (lambda (&rest args)
- ,expr args))
- expr)))))))))
+ (prin1-list-as-multiple-values
+ (eval-interactive
+ (letf (((syntax-table) emacs-lisp-mode-syntax-table))
+ (save-excursion
+ ;; If this sexp appears to be enclosed in `...' then
+ ;; ignore the surrounding quotes.
+ (setq ignore-quotes (or (eq (char-after) ?\')
+ (eq (char-before) ?\')))
+ (forward-sexp -1)
+ ;; vladimir(a)cs.ualberta.ca 30-Jul-1997: skip ` in
+ ;; `variable' so that the value is returned, not the
+ ;; name.
+ (if (and ignore-quotes
+ (eq (char-after) ?\`))
+ (forward-char))
+ (save-restriction
+ (narrow-to-region (point-min) opoint)
+ (let ((expr (read (current-buffer))))
+ (if (eq (car-safe expr) 'interactive)
+ ;; If it's an (interactive ...) form, it's
+ ;; more useful to show how an interactive call
+ ;; would use it.
+ `(call-interactively
+ (lambda (&rest args)
+ ,expr args))
+ expr)))))))))
(defun eval-defun (eval-defun-arg-internal)
"Evaluate defun that point is in or before.
＠＠ -495,11 +515,12 ＠＠
With argument, insert value in current buffer after the defun."
(interactive "P")
(let ((standard-output (if eval-defun-arg-internal (current-buffer) t)))
- (prin1 (eval-interactive (save-excursion
- (end-of-defun)
- (beginning-of-defun)
- (read (current-buffer)))))))
-
+ (prin1-list-as-multiple-values
+ (eval-interactive
+ (save-excursion
+ (end-of-defun)
+ (beginning-of-defun)
+ (read (current-buffer)))))))
(defun lisp-comment-indent ()
(if (looking-at "\\s<\\s<\\s<")
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/mouse.el
--- a/lisp/mouse.el Sun Aug 16 14:58:57 2009 +0100
+++ b/lisp/mouse.el Sun Aug 16 20:55:49 2009 +0100
＠＠ -278,18 +278,23 ＠＠
(message "Regex \"%s\" not found" exp)
(ding nil 'quiet)))
(t (setq val (if (fboundp 'eval-interactive)
- (eval-interactive exp)
- (eval exp)))))
- (setq result-str (prin1-to-string val))
+ (eval-interactive exp)
+ (list (eval exp))))))
+ (setq result-str (mapconcat #'prin1-to-string val " ;\n"))
;; #### -- need better test
(if (and (not force-window)
- (<= (length result-str) (window-width (selected-window))))
+ (<= (length result-str) (window-width (selected-window)))
+ (not (string-match "\n" result-str)))
(message "%s" result-str)
(with-output-to-temp-buffer "*Mouse-Eval*"
- (if-fboundp 'pprint
- (pprint val)
- (prin1 val)))
- )))
+ (loop
+ for value in val
+ with seen-first = nil
+ do
+ (if seen-first
+ (princ " ;\n")
+ (setq seen-first t))
+ (cl-prettyprint value))))))
(defun mouse-line-length (event)
"Print the length of the line indicated by the pointer."
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/obsolete.el
--- a/lisp/obsolete.el Sun Aug 16 14:58:57 2009 +0100
+++ b/lisp/obsolete.el Sun Aug 16 20:55:49 2009 +0100
＠＠ -395,5 +395,18 ＠＠
(make-obsolete 'function-called-at-point 'function-at-point)
+;; As of 21.5, #'throw is a special form. This makes bytecode using it
+;; compiled for 21.4 fail; making this function available works around that.
+(defun obsolete-throw (tag value)
+ "Ugly compatibility hack.
+
+See the implementation of #'funcall in eval.c. This should be removed once
+we no longer encounter bytecode from 21.4."
+ (throw tag value))
+
+(make-obsolete
+ 'obsolete-throw
+ "it says `obsolete' in the name, you know you shouldn't be using this.")
+
(provide 'obsolete)
;;; obsolete.el ends here
diff -r e3feb329bda9 -r 8f1ee2d15784 man/ChangeLog
--- a/man/ChangeLog Sun Aug 16 14:58:57 2009 +0100
+++ b/man/ChangeLog Sun Aug 16 20:55:49 2009 +0100
＠＠ -1,3 +1,8 ＠＠
+2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl.texi (Organization):
+ Remove references to the obsolete multiple-value emulating code.
+
2009-07-28 Stephen Turnbull <stephen(a)xemacs.org>
* internals/internals.texi (Redisplay Piece by Piece):
diff -r e3feb329bda9 -r 8f1ee2d15784 man/cl.texi
--- a/man/cl.texi Sun Aug 16 14:58:57 2009 +0100
+++ b/man/cl.texi Sun Aug 16 20:55:49 2009 +0100
＠＠ -249,9 +249,8 ＠＠
There is another file, ＠file{cl-compat.el}, which defines some
routines from the older ＠file{cl.el} package that are no longer
present in the new package. This includes internal routines
-like ＠code{setelt} and ＠code{zip-lists}, deprecated features
-like ＠code{defkeyword}, and an emulation of the old-style
-multiple-values feature. ＠xref{Old CL Compatibility}.
+like ＠code{setelt} and ＠code{zip-lists}, and deprecated features
+like ＠code{defkeyword}. ＠xref{Old CL Compatibility}.
＠node Installation, Naming Conventions, Organization, Overview
＠section Installation
＠＠ -5345,14 +5344,6 ＠＠
The ＠code{loop} macro is complete except that ＠code{loop-finish}
and type specifiers are unimplemented.
-The multiple-value return facility treats lists as multiple
-values, since Emacs Lisp cannot support multiple return values
-directly. The macros will be compatible with Common Lisp if
-＠code{values} or ＠code{values-list} is always used to return to
-a ＠code{multiple-value-bind} or other multiple-value receiver;
-if ＠code{values} is used without ＠code{multiple-value-＠dots{}}
-or vice-versa the effect will be different from Common Lisp.
-
Many Common Lisp declarations are ignored, and others match
the Common Lisp standard in concept but not in detail. For
example, local ＠code{special} declarations, which are purely
＠＠ -5376,14 +5367,6 ＠＠
＠noindent
Following is a list of all known incompatibilities between this package
and the older Quiroz ＠file{cl.el} package.
-
-This package's emulation of multiple return values in functions is
-incompatible with that of the older package. That package attempted
-to come as close as possible to true Common Lisp multiple return
-values; unfortunately, it could not be 100% reliable and so was prone
-to occasional surprises if used freely. This package uses a simpler
-method, namely replacing multiple values with lists of values, which
-is more predictable though more noticeably different from Common Lisp.
The ＠code{defkeyword} form and ＠code{keywordp} function are not
implemented in this package.
＠＠ -5448,19 +5431,6 ＠＠
macro is not, however, and in any case it's best to change to
use the more natural keyword argument processing offered by
＠code{defun*}.
-
-Multiple return values are treated differently by the two
-Common Lisp packages. The old package's method was more
-compatible with true Common Lisp, though it used heuristics
-that caused it to report spurious multiple return values in
-certain cases. The ＠code{cl-compat} package defines a set
-of multiple-value macros that are compatible with the old
-CL package; again, they are heuristic in nature, but they
-are guaranteed to work in any case where the old package's
-macros worked. To avoid name collision with the ``official''
-multiple-value facilities, the ones in ＠code{cl-compat} have
-capitalized names: ＠code{Values}, ＠code{Values-list},
-＠code{Multiple-value-bind}, etc.
The functions ＠code{cl-floor}, ＠code{cl-ceiling}, ＠code{cl-truncate},
and ＠code{cl-round} are defined by ＠code{cl-compat} to use the
diff -r e3feb329bda9 -r 8f1ee2d15784 src/ChangeLog
--- a/src/ChangeLog Sun Aug 16 14:58:57 2009 +0100
+++ b/src/ChangeLog Sun Aug 16 20:55:49 2009 +0100
＠＠ -1,3 +1,118 ＠＠
+2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecode.c (enum Opcode /* Byte codes */):
+ Add four new bytecodes, to deal with multiple values.
+ (POP_WITH_MULTIPLE_VALUES): New macro.
+ (POP): Modify this macro to ignore multiple values.
+ (DISCARD_PRESERVING_MULTIPLE_VALUES): New macro.
+ (DISCARD): Modify this macro to ignore multiple values.
+ (TOP_WITH_MULTIPLE_VALUES): New macro.
+ (TOP_ADDRESS): New macro.
+ (TOP): Modify this macro to ignore multiple values.
+ (TOP_LVALUE): New macro.
+ (Bcall): Ignore multiple values where appropriate.
+ (Breturn): Pass back multiple values.
+ (Bdup): Preserve multiple values.
+ Use TOP_LVALUE with most bytecodes that assign anything to
+ anything.
+ (Bbind_multiple_value_limits, Bmultiple_value_call,
+ Bmultiple_value_list_internal, Bthrow): Implement the new
+ bytecodes.
+ (Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop,
+ BRgotoifnonnilelsepop):
+ Discard any multiple values.
+ * callint.c (Fcall_interactively):
+ Ignore multiple values when calling #'eval, in two places.
+ * device-x.c (x_IO_error_handler):
+ * macros.c (pop_kbd_macro_event):
+ * eval.c (Fsignal):
+ * eval.c (flagged_a_squirmer):
+ Call throw_or_bomb_out, not Fthrow, now that the latter is a
+ special form.
+ * eval.c:
+ Make Qthrow, Qobsolete_throw available as symbols.
+ Provide multiple_value_current_limit, multiple-values-limit (the
+ latter as specified by Common Lisp.
+ * eval.c (For):
+ Ignore multiple values when comparing with Qnil, but pass any
+ multiple values back for the last arg.
+ * eval.c (Fand):
+ Ditto.
+ * eval.c (Fif):
+ Ignore multiple values when examining the result of the
+ condition.
+ * eval.c (Fcond):
+ Ignore multiple values when comparing what the clauses give, but
+ pass them back if a clause gave non-nil.
+ * eval.c (Fprog2):
+ Never pass back multiple values.
+ * eval.c (FletX, Flet):
+ Ignore multiple when evaluating what exactly symbols should be
+ bound to.
+ * eval.c (Fwhile):
+ Ignore multiple values when evaluating the test.
+ * eval.c (Fsetq, Fdefvar, Fdefconst):
+ Ignore multiple values.
+ * eval.c (Fthrow):
+ Declare this as a special form; ignore multiple values for TAG,
+ preserve them for VALUE.
+ * eval.c (throw_or_bomb_out):
+ Make this available to other files, now Fthrow is a special form.
+ * eval.c (Feval):
+ Ignore multiple values when calling a compiled function, a
+ non-special-form subr, or a lambda expression.
+ * eval.c (Ffuncall):
+ If we attempt to call #'throw (now a special form) as a function,
+ don't error, call #'obsolete-throw instead.
+ * eval.c (make_multiple_value, multiple_value_aset)
+ (multiple_value_aref, print_multiple_value, mark_multiple_value)
+ (size_multiple_value):
+ Implement the multiple_value type. Add a long comment describing
+ our implementation.
+ * eval.c (bind_multiple_value_limits):
+ New function, used by the bytecode and by #'multiple-value-call,
+ #'multiple-value-list-internal.
+ * eval.c (multiple_value_call):
+ New function, used by the bytecode and #'multiple-value-call.
+ * eval.c (Fmultiple_value_call):
+ New special form.
+ * eval.c (multiple_value_list_internal):
+ New function, used by the byte code and
+ #'multiple-value-list-internal.
+ * eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1):
+ New special forms.
+ * eval.c (Fvalues, Fvalues_list):
+ New Lisp functions.
+ * eval.c (values2):
+ New function, for C code returning multiple values.
+ * eval.c (syms_of_eval):
+ Make our new Lisp functions and symbols available.
+ * eval.c (multiple-values-limit):
+ Make this available to Lisp.
+ * event-msw.c (dde_eval_string):
+ * event-stream.c (execute_help_form):
+ * glade.c (connector):
+ * glyphs-widget.c (glyph_instantiator_to_glyph):
+ * glyphs.c (evaluate_xpm_color_symbols):
+ * gui-x.c (wv_set_evalable_slot, button_item_to_widget_value):
+ * gui.c (gui_item_value, gui_item_display_flush_left):
+ * lread.c (check_if_suppressed):
+ * menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1):
+ * menubar-msw.c (populate_menu_add_item):
+ * print.c (Fwith_output_to_temp_buffer):
+ * symbols.c (Fsetq_default):
+ Ignore multiple values when calling Feval.
+ * symeval.h:
+ Add the header declarations necessary for the multiple-values
+ implementation.
+ * inline.c:
+ #include symeval.h, now that it has some inline functions.
+ * lisp.h:
+ Update Fthrow's declaration. Make throw_or_bomb_out available to
+ all files.
+ * lrecord.h (enum lrecord_type):
+ Add the multiple_value type here.
+
2009-07-28 Stephen Turnbull <stephen(a)xemacs.org>
* faces.c (ensure_face_cachel_contains_charset):
diff -r e3feb329bda9 -r 8f1ee2d15784 src/bytecode.c
--- a/src/bytecode.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/bytecode.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -243,6 +243,12 ＠＠
BlistN = 0257,
BconcatN = 0260,
BinsertN = 0261,
+
+ Bbind_multiple_value_limits = 0262, /* New in 21.5. */
+ Bmultiple_value_list_internal = 0263, /* New in 21.5. */
+ Bmultiple_value_call = 0264, /* New in 21.5. */
+ Bthrow = 0265, /* New in 21.5. */
+
Bmember = 0266, /* new in v20 */
Bassq = 0267, /* new in v20 */
＠＠ -653,15 +659,44 ＠＠
/* Push x onto the execution stack. */
#define PUSH(x) (*++stack_ptr = (x))
-/* Pop a value off the execution stack. */
-#define POP (*stack_ptr--)
+/* Pop a value, which may be multiple, off the execution stack. */
+#define POP_WITH_MULTIPLE_VALUES (*stack_ptr--)
+
+/* Pop a value off the execution stack, treating multiple values as single. */
+#define POP (IGNORE_MULTIPLE_VALUES (POP_WITH_MULTIPLE_VALUES))
+
+#define DISCARD_PRESERVING_MULTIPLE_VALUES(n) (stack_ptr -= (n))
/* Discard n values from the execution stack. */
-#define DISCARD(n) (stack_ptr -= (n))
+#define DISCARD(n) do { \
+ if (1 != multiple_value_current_limit) \
+ { \
+ int i, en = n; \
+ for (i = 0; i < en; i++) \
+ { \
+ *stack_ptr = ignore_multiple_values (*stack_ptr); \
+ stack_ptr--; \
+ } \
+ } \
+ else \
+ { \
+ stack_ptr -= (n); \
+ } \
+ } while (0)
+
+/* Get the value, which may be multiple, at the top of the execution stack;
+ and leave it there. */
+#define TOP_WITH_MULTIPLE_VALUES (*stack_ptr)
+
+#define TOP_ADDRESS (stack_ptr)
/* Get the value which is at the top of the execution stack,
but don't pop it. */
-#define TOP (*stack_ptr)
+#define TOP (IGNORE_MULTIPLE_VALUES (TOP_WITH_MULTIPLE_VALUES))
+
+#define TOP_LVALUE (*stack_ptr)
+
+
/* See comment before the big switch in execute_optimized_program(). */
#define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg)
＠＠ -859,7 +894,8 ＠＠
Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
}
#endif
- TOP = Ffuncall (n + 1, &TOP);
+ TOP_LVALUE = TOP; /* Ignore multiple values. */
+ TOP_LVALUE = Ffuncall (n + 1, TOP_ADDRESS);
break;
case Bunbind:
＠＠ -895,7 +931,8 ＠＠
break;
case Bgotoifnilelsepop:
- if (NILP (TOP))
+ /* Discard any multiple value: */
+ if (NILP (TOP_LVALUE = TOP))
JUMP;
else
{
＠＠ -905,7 +942,8 ＠＠
break;
case Bgotoifnonnilelsepop:
- if (!NILP (TOP))
+ /* Discard any multiple value: */
+ if (!NILP (TOP_LVALUE = TOP))
JUMP;
else
{
＠＠ -934,7 +972,7 ＠＠
break;
case BRgotoifnilelsepop:
- if (NILP (TOP))
+ if (NILP (TOP_LVALUE = TOP))
JUMPR;
else
{
＠＠ -944,7 +982,7 ＠＠
break;
case BRgotoifnonnilelsepop:
- if (!NILP (TOP))
+ if (!NILP (TOP_LVALUE = TOP))
JUMPR;
else
{
＠＠ -960,7 +998,7 ＠＠
if (specpdl_depth() != speccount)
invalid_byte_code ("unbalanced specbinding stack", Qunbound);
#endif
- return TOP;
+ return TOP_WITH_MULTIPLE_VALUES;
case Bdiscard:
DISCARD (1);
＠＠ -968,7 +1006,7 ＠＠
case Bdup:
{
- Lisp_Object arg = TOP;
+ Lisp_Object arg = TOP_WITH_MULTIPLE_VALUES;
PUSH (arg);
break;
}
＠＠ -978,17 +1016,22 ＠＠
break;
case Bcar:
- /* Fcar can GC via wrong_type_argument. */
- /* GCPRO_STACK; */
- TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
- break;
+ {
+ /* Fcar can GC via wrong_type_argument. */
+ /* GCPRO_STACK; */
+ Lisp_Object arg = TOP;
+ TOP_LVALUE = CONSP (arg) ? XCAR (arg) : Fcar (arg);
+ break;
+ }
case Bcdr:
- /* Fcdr can GC via wrong_type_argument. */
- /* GCPRO_STACK; */
- TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
- break;
-
+ {
+ /* Fcdr can GC via wrong_type_argument. */
+ /* GCPRO_STACK; */
+ Lisp_Object arg = TOP;
+ TOP_LVALUE = CONSP (arg) ? XCDR (arg) : Fcdr (arg);
+ break;
+ }
case Bunbind_all:
/* To unbind back to the beginning of this frame. Not used yet,
＠＠ -1001,62 +1044,62 ＠＠
Lisp_Object arg = POP;
/* Fcar and Fnthcdr can GC via wrong_type_argument. */
/* GCPRO_STACK; */
- TOP = Fcar (Fnthcdr (TOP, arg));
+ TOP_LVALUE = Fcar (Fnthcdr (TOP, arg));
break;
}
case Bsymbolp:
- TOP = SYMBOLP (TOP) ? Qt : Qnil;
+ TOP_LVALUE = SYMBOLP (TOP) ? Qt : Qnil;
break;
case Bconsp:
- TOP = CONSP (TOP) ? Qt : Qnil;
+ TOP_LVALUE = CONSP (TOP) ? Qt : Qnil;
break;
case Bstringp:
- TOP = STRINGP (TOP) ? Qt : Qnil;
+ TOP_LVALUE = STRINGP (TOP) ? Qt : Qnil;
break;
case Blistp:
- TOP = LISTP (TOP) ? Qt : Qnil;
+ TOP_LVALUE = LISTP (TOP) ? Qt : Qnil;
break;
case Bnumberp:
#ifdef WITH_NUMBER_TYPES
- TOP = NUMBERP (TOP) ? Qt : Qnil;
+ TOP_LVALUE = NUMBERP (TOP) ? Qt : Qnil;
#else
- TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
+ TOP_LVALUE = INT_OR_FLOATP (TOP) ? Qt : Qnil;
#endif
break;
case Bintegerp:
#ifdef HAVE_BIGNUM
- TOP = INTEGERP (TOP) ? Qt : Qnil;
+ TOP_LVALUE = INTEGERP (TOP) ? Qt : Qnil;
#else
- TOP = INTP (TOP) ? Qt : Qnil;
+ TOP_LVALUE = INTP (TOP) ? Qt : Qnil;
#endif
break;
case Beq:
{
Lisp_Object arg = POP;
- TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
+ TOP_LVALUE = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
break;
}
case Bnot:
- TOP = NILP (TOP) ? Qt : Qnil;
+ TOP_LVALUE = NILP (TOP) ? Qt : Qnil;
break;
case Bcons:
{
Lisp_Object arg = POP;
- TOP = Fcons (TOP, arg);
+ TOP_LVALUE = Fcons (TOP, arg);
break;
}
case Blist1:
- TOP = Fcons (TOP, Qnil);
+ TOP_LVALUE = Fcons (TOP, Qnil);
break;
＠＠ -1079,7 +1122,7 ＠＠
DISCARD (1);
goto list_loop;
}
- TOP = list;
+ TOP_LVALUE = list;
break;
}
＠＠ -1097,101 +1140,107 ＠＠
DISCARD (n - 1);
/* Apparently `concat' can GC; Fconcat GCPROs its arguments. */
/* GCPRO_STACK; */
- TOP = Fconcat (n, &TOP);
+ TOP_LVALUE = TOP; /* Ignore multiple values. */
+ TOP_LVALUE = Fconcat (n, TOP_ADDRESS);
break;
case Blength:
- TOP = Flength (TOP);
+ TOP_LVALUE = Flength (TOP);
break;
case Baset:
{
Lisp_Object arg2 = POP;
Lisp_Object arg1 = POP;
- TOP = Faset (TOP, arg1, arg2);
+ TOP_LVALUE = Faset (TOP, arg1, arg2);
break;
}
case Bsymbol_value:
/* Why does this need GCPRO_STACK? If not, remove others, too. */
/* GCPRO_STACK; */
- TOP = Fsymbol_value (TOP);
+ TOP_LVALUE = Fsymbol_value (TOP);
break;
case Bsymbol_function:
- TOP = Fsymbol_function (TOP);
+ TOP_LVALUE = Fsymbol_function (TOP);
break;
case Bget:
{
Lisp_Object arg = POP;
- TOP = Fget (TOP, arg, Qnil);
+ TOP_LVALUE = Fget (TOP, arg, Qnil);
break;
}
case Bsub1:
+ {
#ifdef HAVE_BIGNUM
- TOP = Fsub1 (TOP);
+ TOP_LVALUE = Fsub1 (TOP);
#else
- TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
+ Lisp_Object arg = TOP;
+ TOP_LVALUE = INTP (arg) ? INT_MINUS1 (arg) : Fsub1 (arg);
#endif
break;
-
+ }
case Badd1:
+ {
#ifdef HAVE_BIGNUM
- TOP = Fadd1 (TOP);
+ TOP_LVALUE = Fadd1 (TOP);
#else
- TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
+ Lisp_Object arg = TOP;
+ TOP_LVALUE = INTP (arg) ? INT_PLUS1 (arg) : Fadd1 (arg);
#endif
break;
-
+ }
case Beqlsign:
{
Lisp_Object arg = POP;
- TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
+ TOP_LVALUE = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
break;
}
case Bgtr:
{
Lisp_Object arg = POP;
- TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
+ TOP_LVALUE = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
break;
}
case Blss:
{
Lisp_Object arg = POP;
- TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
+ TOP_LVALUE = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
break;
}
case Bleq:
{
Lisp_Object arg = POP;
- TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
+ TOP_LVALUE = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
break;
}
case Bgeq:
{
Lisp_Object arg = POP;
- TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
+ TOP_LVALUE = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
break;
}
case Bnegate:
- TOP = bytecode_negate (TOP);
+ TOP_LVALUE = bytecode_negate (TOP);
break;
case Bnconc:
DISCARD (1);
/* nconc2 GCPROs before calling this. */
/* GCPRO_STACK; */
- TOP = bytecode_nconc2 (&TOP);
+ TOP_LVALUE = TOP; /* Ignore multiple values. */
+ TOP_LVALUE = bytecode_nconc2 (TOP_ADDRESS);
break;
case Bplus:
＠＠ -1199,9 +1248,9 ＠＠
Lisp_Object arg2 = POP;
Lisp_Object arg1 = TOP;
#ifdef HAVE_BIGNUM
- TOP = bytecode_arithop (arg1, arg2, opcode);
+ TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode);
#else
- TOP = INTP (arg1) && INTP (arg2) ?
+ TOP_LVALUE = INTP (arg1) && INTP (arg2) ?
INT_PLUS (arg1, arg2) :
bytecode_arithop (arg1, arg2, opcode);
#endif
＠＠ -1213,9 +1262,9 ＠＠
Lisp_Object arg2 = POP;
Lisp_Object arg1 = TOP;
#ifdef HAVE_BIGNUM
- TOP = bytecode_arithop (arg1, arg2, opcode);
+ TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode);
#else
- TOP = INTP (arg1) && INTP (arg2) ?
+ TOP_LVALUE = INTP (arg1) && INTP (arg2) ?
INT_MINUS (arg1, arg2) :
bytecode_arithop (arg1, arg2, opcode);
#endif
＠＠ -1228,7 +1277,7 ＠＠
case Bmin:
{
Lisp_Object arg = POP;
- TOP = bytecode_arithop (TOP, arg, opcode);
+ TOP_LVALUE = bytecode_arithop (TOP, arg, opcode);
break;
}
＠＠ -1239,7 +1288,8 ＠＠
case Binsert:
/* Says it can GC. */
/* GCPRO_STACK; */
- TOP = Finsert (1, &TOP);
+ TOP_LVALUE = TOP; /* Ignore multiple values. */
+ TOP_LVALUE = Finsert (1, TOP_ADDRESS);
break;
case BinsertN:
＠＠ -1247,20 +1297,21 ＠＠
DISCARD (n - 1);
/* See Binsert. */
/* GCPRO_STACK; */
- TOP = Finsert (n, &TOP);
+ TOP_LVALUE = TOP; /* Ignore multiple values. */
+ TOP_LVALUE = Finsert (n, TOP_ADDRESS);
break;
case Baref:
{
Lisp_Object arg = POP;
- TOP = Faref (TOP, arg);
+ TOP_LVALUE = Faref (TOP, arg);
break;
}
case Bmemq:
{
Lisp_Object arg = POP;
- TOP = Fmemq (TOP, arg);
+ TOP_LVALUE = Fmemq (TOP, arg);
break;
}
＠＠ -1269,7 +1320,7 ＠＠
Lisp_Object arg = POP;
/* Fset may call magic handlers */
/* GCPRO_STACK; */
- TOP = Fset (TOP, arg);
+ TOP_LVALUE = Fset (TOP, arg);
break;
}
＠＠ -1278,21 +1329,21 ＠＠
Lisp_Object arg = POP;
/* Can QUIT, so can GC, right? */
/* GCPRO_STACK; */
- TOP = Fequal (TOP, arg);
+ TOP_LVALUE = Fequal (TOP, arg);
break;
}
case Bnthcdr:
{
Lisp_Object arg = POP;
- TOP = Fnthcdr (TOP, arg);
+ TOP_LVALUE = Fnthcdr (TOP, arg);
break;
}
case Belt:
{
Lisp_Object arg = POP;
- TOP = Felt (TOP, arg);
+ TOP_LVALUE = Felt (TOP, arg);
break;
}
＠＠ -1301,12 +1352,12 ＠＠
Lisp_Object arg = POP;
/* Can QUIT, so can GC, right? */
/* GCPRO_STACK; */
- TOP = Fmember (TOP, arg);
+ TOP_LVALUE = Fmember (TOP, arg);
break;
}
case Bgoto_char:
- TOP = Fgoto_char (TOP, Qnil);
+ TOP_LVALUE = Fgoto_char (TOP, Qnil);
break;
case Bcurrent_buffer:
＠＠ -1321,7 +1372,7 ＠＠
/* #### WAG: set-buffer may cause Fset's of buffer locals
Didn't prevent crash. :-( */
/* GCPRO_STACK; */
- TOP = Fset_buffer (TOP);
+ TOP_LVALUE = Fset_buffer (TOP);
break;
case Bpoint_max:
＠＠ -1337,41 +1388,41 ＠＠
Lisp_Object arg = POP;
/* Can QUIT, so can GC, right? */
/* GCPRO_STACK; */
- TOP = Fskip_chars_forward (TOP, arg, Qnil);
+ TOP_LVALUE = Fskip_chars_forward (TOP, arg, Qnil);
break;
}
case Bassq:
{
Lisp_Object arg = POP;
- TOP = Fassq (TOP, arg);
+ TOP_LVALUE = Fassq (TOP, arg);
break;
}
case Bsetcar:
{
Lisp_Object arg = POP;
- TOP = Fsetcar (TOP, arg);
+ TOP_LVALUE = Fsetcar (TOP, arg);
break;
}
case Bsetcdr:
{
Lisp_Object arg = POP;
- TOP = Fsetcdr (TOP, arg);
+ TOP_LVALUE = Fsetcdr (TOP, arg);
break;
}
case Bnreverse:
- TOP = bytecode_nreverse (TOP);
+ TOP_LVALUE = bytecode_nreverse (TOP);
break;
case Bcar_safe:
- TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
+ TOP_LVALUE = CONSP (TOP) ? XCAR (TOP) : Qnil;
break;
case Bcdr_safe:
- TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
+ TOP_LVALUE = CONSP (TOP) ? XCDR (TOP) : Qnil;
break;
}
＠＠ -1390,6 +1441,8 ＠＠
const Opbyte *UNUSED (program_ptr),
Opcode opcode)
{
+ REGISTER int n;
+
switch (opcode)
{
＠＠ -1403,7 +1456,7 ＠＠
int count = specpdl_depth ();
record_unwind_protect (save_window_excursion_unwind,
call1 (Qcurrent_window_configuration, Qnil));
- TOP = Fprogn (TOP);
+ TOP_LVALUE = Fprogn (TOP);
unbind_to (count);
break;
}
＠＠ -1416,14 +1469,14 ＠＠
case Bcatch:
{
Lisp_Object arg = POP;
- TOP = internal_catch (TOP, Feval, arg, 0, 0, 0);
+ TOP_LVALUE = internal_catch (TOP, Feval, arg, 0, 0, 0);
break;
}
case Bskip_chars_backward:
{
Lisp_Object arg = POP;
- TOP = Fskip_chars_backward (TOP, arg, Qnil);
+ TOP_LVALUE = Fskip_chars_backward (TOP, arg, Qnil);
break;
}
＠＠ -1435,7 +1488,7 ＠＠
{
Lisp_Object arg2 = POP; /* handlers */
Lisp_Object arg1 = POP; /* bodyform */
- TOP = condition_case_3 (arg1, TOP, arg2);
+ TOP_LVALUE = condition_case_3 (arg1, TOP, arg2);
break;
}
＠＠ -1443,51 +1496,51 ＠＠
{
Lisp_Object arg2 = POP;
Lisp_Object arg1 = POP;
- TOP = Fset_marker (TOP, arg1, arg2);
+ TOP_LVALUE = Fset_marker (TOP, arg1, arg2);
break;
}
case Brem:
{
Lisp_Object arg = POP;
- TOP = Frem (TOP, arg);
+ TOP_LVALUE = Frem (TOP, arg);
break;
}
case Bmatch_beginning:
- TOP = Fmatch_beginning (TOP);
+ TOP_LVALUE = Fmatch_beginning (TOP);
break;
case Bmatch_end:
- TOP = Fmatch_end (TOP);
+ TOP_LVALUE = Fmatch_end (TOP);
break;
case Bupcase:
- TOP = Fupcase (TOP, Qnil);
+ TOP_LVALUE = Fupcase (TOP, Qnil);
break;
case Bdowncase:
- TOP = Fdowncase (TOP, Qnil);
+ TOP_LVALUE = Fdowncase (TOP, Qnil);
break;
case Bfset:
{
Lisp_Object arg = POP;
- TOP = Ffset (TOP, arg);
+ TOP_LVALUE = Ffset (TOP, arg);
break;
}
case Bstring_equal:
{
Lisp_Object arg = POP;
- TOP = Fstring_equal (TOP, arg);
+ TOP_LVALUE = Fstring_equal (TOP, arg);
break;
}
case Bstring_lessp:
{
Lisp_Object arg = POP;
- TOP = Fstring_lessp (TOP, arg);
+ TOP_LVALUE = Fstring_lessp (TOP, arg);
break;
}
＠＠ -1495,7 +1548,7 ＠＠
{
Lisp_Object arg2 = POP;
Lisp_Object arg1 = POP;
- TOP = Fsubstring (TOP, arg1, arg2);
+ TOP_LVALUE = Fsubstring (TOP, arg1, arg2);
break;
}
＠＠ -1504,11 +1557,11 ＠＠
break;
case Bchar_after:
- TOP = Fchar_after (TOP, Qnil);
+ TOP_LVALUE = Fchar_after (TOP, Qnil);
break;
case Bindent_to:
- TOP = Findent_to (TOP, Qnil, Qnil);
+ TOP_LVALUE = Findent_to (TOP, Qnil, Qnil);
break;
case Bwiden:
＠＠ -1549,56 +1602,56 ＠＠
break;
case Bforward_char:
- TOP = Fforward_char (TOP, Qnil);
+ TOP_LVALUE = Fforward_char (TOP, Qnil);
break;
case Bforward_word:
- TOP = Fforward_word (TOP, Qnil);
+ TOP_LVALUE = Fforward_word (TOP, Qnil);
break;
case Bforward_line:
- TOP = Fforward_line (TOP, Qnil);
+ TOP_LVALUE = Fforward_line (TOP, Qnil);
break;
case Bchar_syntax:
- TOP = Fchar_syntax (TOP, Qnil);
+ TOP_LVALUE = Fchar_syntax (TOP, Qnil);
break;
case Bbuffer_substring:
{
Lisp_Object arg = POP;
- TOP = Fbuffer_substring (TOP, arg, Qnil);
+ TOP_LVALUE = Fbuffer_substring (TOP, arg, Qnil);
break;
}
case Bdelete_region:
{
Lisp_Object arg = POP;
- TOP = Fdelete_region (TOP, arg, Qnil);
+ TOP_LVALUE = Fdelete_region (TOP, arg, Qnil);
break;
}
case Bnarrow_to_region:
{
Lisp_Object arg = POP;
- TOP = Fnarrow_to_region (TOP, arg, Qnil);
+ TOP_LVALUE = Fnarrow_to_region (TOP, arg, Qnil);
break;
}
case Bend_of_line:
- TOP = Fend_of_line (TOP, Qnil);
+ TOP_LVALUE = Fend_of_line (TOP, Qnil);
break;
case Btemp_output_buffer_setup:
temp_output_buffer_setup (TOP);
- TOP = Vstandard_output;
+ TOP_LVALUE = Vstandard_output;
break;
case Btemp_output_buffer_show:
{
Lisp_Object arg = POP;
temp_output_buffer_show (TOP, Qnil);
- TOP = arg;
+ TOP_LVALUE = arg;
/* GAG ME!! */
/* pop binding of standard-output */
unbind_to (specpdl_depth() - 1);
＠＠ -1608,36 +1661,76 ＠＠
case Bold_eq:
{
Lisp_Object arg = POP;
- TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
+ TOP_LVALUE = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
break;
}
case Bold_memq:
{
Lisp_Object arg = POP;
- TOP = Fold_memq (TOP, arg);
+ TOP_LVALUE = Fold_memq (TOP, arg);
break;
}
case Bold_equal:
{
Lisp_Object arg = POP;
- TOP = Fold_equal (TOP, arg);
+ TOP_LVALUE = Fold_equal (TOP, arg);
break;
}
case Bold_member:
{
Lisp_Object arg = POP;
- TOP = Fold_member (TOP, arg);
+ TOP_LVALUE = Fold_member (TOP, arg);
break;
}
case Bold_assq:
{
Lisp_Object arg = POP;
- TOP = Fold_assq (TOP, arg);
+ TOP_LVALUE = Fold_assq (TOP, arg);
break;
+ }
+
+ case Bbind_multiple_value_limits:
+ {
+ Lisp_Object upper = POP, first = TOP, speccount;
+
+ CHECK_NATNUM (upper);
+ CHECK_NATNUM (first);
+
+ speccount = make_int (bind_multiple_value_limits (XINT (first),
+ XINT (upper)));
+ PUSH (upper);
+ PUSH (speccount);
+ break;
+ }
+
+ case Bmultiple_value_call:
+ {
+ n = XINT (POP);
+ DISCARD_PRESERVING_MULTIPLE_VALUES (n - 1);
+ /* Discard multiple values for the first (function) argument: */
+ TOP_LVALUE = TOP;
+ TOP_LVALUE = multiple_value_call (n, TOP_ADDRESS);
+ break;
+ }
+
+ case Bmultiple_value_list_internal:
+ {
+ DISCARD_PRESERVING_MULTIPLE_VALUES (3);
+ TOP_LVALUE = multiple_value_list_internal (4, TOP_ADDRESS);
+ break;
+ }
+
+ case Bthrow:
+ {
+ Lisp_Object arg = POP_WITH_MULTIPLE_VALUES;
+
+ /* We never throw to a catch tag that is a multiple value: */
+ throw_or_bomb_out (TOP, arg, 0, Qnil, Qnil);
+ break;
}
default:
diff -r e3feb329bda9 -r 8f1ee2d15784 src/callint.c
--- a/src/callint.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/callint.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -400,7 +400,7 ＠＠
GCPRO3 (function, specs, input);
/* Compute the arg values using the user's expression. */
- specs = Feval (specs);
+ specs = IGNORE_MULTIPLE_VALUES (Feval (specs));
if (EQ (record_flag, Qlambda)) /* XEmacs addition */
{
UNGCPRO;
＠＠ -916,7 +916,7 ＠＠
{
Lisp_Object tem = call1 (Qread_expression, PROMPT ());
/* visargs[argnum] = Fprin1_to_string (tem, Qnil); */
- args[argnum] = Feval (tem);
+ args[argnum] = IGNORE_MULTIPLE_VALUES (Feval (tem));
arg_from_tty = 1;
break;
}
diff -r e3feb329bda9 -r 8f1ee2d15784 src/device-x.c
--- a/src/device-x.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/device-x.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -1280,7 +1280,8 ＠＠
enqueue_magic_eval_event (io_error_delete_device, dev);
DEVICE_X_BEING_DELETED (d) = 1;
}
- Fthrow (Qtop_level, Qnil);
+
+ throw_or_bomb_out (Qtop_level, Qnil, 0, Qnil, Qnil);
RETURN_NOT_REACHED (0);
}
diff -r e3feb329bda9 -r 8f1ee2d15784 src/eval.c
--- a/src/eval.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/eval.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -241,6 +241,16 ＠＠
Lisp_Object Vpending_warnings, Vpending_warnings_tail;
Lisp_Object Qif;
+Lisp_Object Qthrow;
+Lisp_Object Qobsolete_throw;
+
+static int first_desired_multiple_value;
+/* Used outside this file, somewhat uncleanly, in the IGNORE_MULTIPLE_VALUES
+ macro: */
+int multiple_value_current_limit;
+
+Fixnum Vmultiple_values_limit;
+
/* Flags specifying which operations are currently inhibited. */
int inhibit_flags;
＠＠ -820,6 +830,9 ＠＠
The remaining ARGS are not evalled at all.
If all args return nil, return nil.
+Any multiple values from the last form, and only from the last form, are
+passed back. See `values' and `multiple-value-bind'.
+
arguments: (&rest ARGS)
*/
(args))
＠＠ -827,13 +840,21 ＠＠
/* This function can GC */
REGISTER Lisp_Object val;
- LIST_LOOP_2 (arg, args)
- {
- if (!NILP (val = Feval (arg)))
- return val;
- }
-
- return Qnil;
+ LIST_LOOP_3 (arg, args, tail)
+ {
+ if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg))))
+ {
+ if (NILP (XCDR (tail)))
+ {
+ /* Pass back multiple values if this is the last one: */
+ return val;
+ }
+
+ return IGNORE_MULTIPLE_VALUES (val);
+ }
+ }
+
+ return val;
}
DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
＠＠ -841,6 +862,9 ＠＠
The remaining ARGS are not evalled at all.
If no arg yields nil, return the last arg's value.
+Any multiple values from the last form, and only from the last form, are
+passed back. See `values' and `multiple-value-bind'.
+
arguments: (&rest ARGS)
*/
(args))
＠＠ -848,10 +872,18 ＠＠
/* This function can GC */
REGISTER Lisp_Object val = Qt;
- LIST_LOOP_2 (arg, args)
- {
- if (NILP (val = Feval (arg)))
- return val;
+ LIST_LOOP_3 (arg, args, tail)
+ {
+ if (NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg))))
+ {
+ if (NILP (XCDR (tail)))
+ {
+ /* Pass back any multiple values for the last form: */
+ return val;
+ }
+
+ return Qnil;
+ }
}
return val;
＠＠ -872,7 +904,7 ＠＠
Lisp_Object then_form = XCAR (XCDR (args));
Lisp_Object else_forms = XCDR (XCDR (args));
- if (!NILP (Feval (condition)))
+ if (!NILP (IGNORE_MULTIPLE_VALUES (Feval (condition))))
return Feval (then_form);
else
return Fprogn (else_forms);
＠＠ -935,11 +967,12 ＠＠
LIST_LOOP_2 (clause, args)
{
CHECK_CONS (clause);
- if (!NILP (val = Feval (XCAR (clause))))
+ if (!NILP (val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (clause)))))
{
if (!NILP (clause = XCDR (clause)))
{
CHECK_TRUE_LIST (clause);
+ /* Pass back any multiple values here: */
val = Fprogn (clause);
}
return val;
＠＠ -988,7 +1021,7 ＠＠
Lisp_Object val;
struct gcpro gcpro1;
- val = Feval (XCAR (args));
+ val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args)));
GCPRO1 (val);
＠＠ -1017,7 +1050,9 ＠＠
Feval (XCAR (args));
args = XCDR (args);
- val = Feval (XCAR (args));
+
+ val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
+
args = XCDR (args);
GCPRO1 (val);
＠＠ -1062,7 +1097,7 ＠＠
else
{
CHECK_CONS (tem);
- value = Feval (XCAR (tem));
+ value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem)));
if (!NILP (XCDR (tem)))
sferror
("`let' bindings can have only one value-form", var);
＠＠ -1120,7 +1155,7 ＠＠
else
{
CHECK_CONS (tem);
- *value = Feval (XCAR (tem));
+ *value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem)));
gcpro1.nvars = idx;
if (!NILP (XCDR (tem)))
＠＠ -1157,7 +1192,7 ＠＠
Lisp_Object test = XCAR (args);
Lisp_Object body = XCDR (args);
- while (!NILP (Feval (test)))
+ while (!NILP (IGNORE_MULTIPLE_VALUES (Feval (test))))
{
QUIT;
Fprogn (body);
＠＠ -1189,6 +1224,7 ＠＠
GC_PROPERTY_LIST_LOOP_3 (symbol, val, args)
{
val = Feval (val);
+ val = IGNORE_MULTIPLE_VALUES (val);
Fset (symbol, val);
retval = val;
}
＠＠ -1311,7 +1347,7 ＠＠
{
struct gcpro gcpro1;
GCPRO1 (val);
- val = Feval (val);
+ val = IGNORE_MULTIPLE_VALUES (Feval (val));
Fset_default (sym, val);
UNGCPRO;
}
＠＠ -1360,6 +1396,8 ＠＠
struct gcpro gcpro1;
GCPRO1 (val);
+
+ val = IGNORE_MULTIPLE_VALUES (val);
Fset_default (sym, val);
＠＠ -1663,10 +1701,10 ＠＠
LONGJMP (c->jmp, 1);
}
-static DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int,
- Lisp_Object, Lisp_Object));
-
-static DOESNT_RETURN
+DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int,
+ Lisp_Object, Lisp_Object));
+
+DOESNT_RETURN
throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
Lisp_Object sig, Lisp_Object data)
{
＠＠ -1739,12 +1777,29 ＠＠
condition_case_1). See below for more info.
*/
-DEFUN_NORETURN ("throw", Fthrow, 2, 2, 0, /*
+DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /*
Throw to the catch for TAG and return VALUE from it.
-Both TAG and VALUE are evalled. Tags are the same iff they are `eq'.
-*/
- (tag, value))
-{
+
+Both TAG and VALUE are evalled, and multiple values in VALUE will be passed
+back. Tags are the same if and only if they are `eq'.
+
+arguments: (TAG VALUE)
+*/
+ (args))
+{
+ int nargs;
+ Lisp_Object tag, value;
+
+ GET_LIST_LENGTH (args, nargs);
+ if (nargs != 2)
+ {
+ Fsignal (Qwrong_number_of_arguments, list2 (Qthrow, make_int (nargs)));
+ }
+
+ tag = IGNORE_MULTIPLE_VALUES (Feval (XCAR(args)));
+
+ value = Feval (XCAR (XCDR (args)));
+
throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */
RETURN_NOT_REACHED (Qnil);
}
＠＠ -2360,7 +2415,8 ＠＠
else if (EQ (handler_data, Qt))
{
UNGCPRO;
- return Fthrow (handlers, Fcons (error_symbol, data));
+ throw_or_bomb_out (handlers, Fcons (error_symbol, data),
+ 0, Qnil, Qnil);
}
/* `error' is used similarly to the way `t' is used, but in
addition it invokes the debugger if debug_on_error.
＠＠ -2379,7 +2435,7 ＠＠
return return_from_signal (tem);
tem = Fcons (error_symbol, data);
- return Fthrow (handlers, tem);
+ throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil);
}
else
{
＠＠ -2403,7 +2459,7 ＠＠
/* Doesn't return */
tem = Fcons (Fcons (error_symbol, data), Fcdr (clause));
- return Fthrow (handlers, tem);
+ throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil);
}
}
}
＠＠ -3665,7 +3721,7 ＠＠
{
LIST_LOOP_2 (arg, original_args)
{
- *p++ = Feval (arg);
+ *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
gcpro1.nvars++;
}
}
＠＠ -3696,7 +3752,7 ＠＠
{
LIST_LOOP_2 (arg, original_args)
{
- *p++ = Feval (arg);
+ *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
gcpro1.nvars++;
}
}
＠＠ -3729,7 +3785,7 ＠＠
{
LIST_LOOP_2 (arg, original_args)
{
- *p++ = Feval (arg);
+ *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
gcpro1.nvars++;
}
}
＠＠ -3778,7 +3834,7 ＠＠
{
LIST_LOOP_2 (arg, original_args)
{
- *p++ = Feval (arg);
+ *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
gcpro1.nvars++;
}
}
＠＠ -3958,6 +4014,12 ＠＠
}
else if (max_args == UNEVALLED) /* Can't funcall a special form */
{
+ /* Ugh, ugh, ugh. */
+ if (EQ (fun, XSYMBOL_FUNCTION (Qthrow)))
+ {
+ args[0] = Qobsolete_throw;
+ goto retry;
+ }
goto invalid_function;
}
else
＠＠ -4238,7 +4300,6 ＠＠
}
}
-
/* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
return the result of evaluation. */
＠＠ -4293,6 +4354,590 ＠＠
invalid_function:
return signal_invalid_function_error (fun);
+}
+
+
+/* Multiple values.
+
+ A multiple value object is returned by #'values if:
+
+ -- The number of arguments to #'values is not one, and:
+ -- Some special form in the call stack is prepared to handle more than
+ one multiple value.
+
+ The return value of #'values-list is analogous to that of #'values.
+
+ Henry Baker, in https://eprints.kfupm.edu.sa/31898/1/31898.pdf ("CONS
+ Should not CONS its Arguments, or, a Lazy Alloc is a Smart Alloc", ACM
+ Sigplan Notices 27,3 (March 1992),24-34.) says it should be possible to
+ allocate Common Lisp multiple-value objects on the stack, but this
+ assumes that variable-length records can be allocated on the stack,
+ something not true for us. As far as I can tell, it also ignores the
+ contexts where multiple-values need to be thrown, or maybe it thinks such
+ objects should be converted to heap allocation at that point.
+
+ The specific multiple values saved and returned depend on how many
+ multiple-values special forms in the stack are interested in; for
+ example, if #'multiple-value-call is somewhere in the call stack, all
+ values passed to #'values will be saved and returned. If an expansion of
+ #'multiple-value-setq with 10 SYMS is the only part of the call stack
+ interested in multiple values, then a maximum of ten multiple values will
+ be saved and returned.
+
+ (#'throw passes back multiple values in its VALUE argument; this is why
+ we can't just take the details of the most immediate
+ #'multiple-value-{whatever} call to work out which values to save, we
+ need to look at the whole stack, or, equivalently, the dynamic variables
+ we set to reflect the whole stack.)
+
+ The first value passed to #'values will always be saved, since that is
+ needed to convert a multiple value object into a single value object,
+ something that is normally necessary independent of how many functions in
+ the call stack are interested in multiple values.
+
+ However many values (for values of "however many" that are not one) are
+ saved and restored, the multiple value object knows how many arguments it
+ would contain were none to have been discarded, and will indicate this
+ on being printed from within GDB.
+
+ In lisp-interaction-mode, no multiple values should be discarded (unless
+ they need to be for the sake of the correctness of the program);
+ #'eval-interactive-with-multiple-value-list in lisp-mode.el wraps its
+ #'eval calls with #'multiple-value-list calls to avoid this. This means
+ that there is a small performance and memory penalty for code evaluated
+ in *scratch*; use M-: EXPRESSION RET if you really need to avoid
+ this. Lisp code execution that is not ultimately from hitting C-j in
+ *scratch*--that is, the vast vast majority of Lisp code execution--does
+ not have this penalty.
+
+ Probably the most important aspect of multiple values is stated with
+ admirable clarity by CLTL2:
+
+ "No matter how many values a form produces, if the form is an argument
+ form in a function call, then exactly one value (the first one) is
+ used."
+
+ This means that most contexts, most of the time, will never see multiple
+ values. There are important exceptions; search the web for that text in
+ quotation marks and read the related chapter. This code handles all of
+ them, to my knowledge. Aidan Kehoe, Mon Mar 16 00:17:39 GMT 2009. */
+
+static Lisp_Object
+make_multiple_value (Lisp_Object first_value, Elemcount count,
+ Elemcount first_desired, Elemcount upper_limit)
+{
+ Bytecount sizem;
+ struct multiple_value *mv;
+ Elemcount i, allocated_count;
+
+ assert (count != 1);
+
+ if (1 != upper_limit && (0 == first_desired))
+ {
+ /* We always allocate element zero, and that's taken into account when
+ working out allocated_count: */
+ first_desired = 1;
+ }
+
+ if (first_desired >= count)
+ {
+ /* We can't pass anything back that our caller is interested in. Only
+ allocate for the first argument. */
+ allocated_count = 1;
+ }
+ else
+ {
+ allocated_count = 1 + ((upper_limit > count ? count : upper_limit)
+ - first_desired);
+ }
+
+ sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value,
+ Lisp_Object,
+ contents, allocated_count);
+ mv = (multiple_value *) BASIC_ALLOC_LCRECORD (sizem,
+ &lrecord_multiple_value);
+
+ mv->count = count;
+ mv->first_desired = first_desired;
+ mv->allocated_count = allocated_count;
+ mv->contents[0] = first_value;
+
+ for (i = first_desired; i < upper_limit && i < count; ++i)
+ {
+ mv->contents[1 + (i - first_desired)] = Qunbound;
+ }
+
+ return wrap_multiple_value (mv);
+}
+
+void
+multiple_value_aset (Lisp_Object obj, Elemcount index, Lisp_Object value)
+{
+ struct multiple_value *mv = XMULTIPLE_VALUE (obj);
+ Elemcount first_desired = mv->first_desired;
+ Elemcount allocated_count = mv->allocated_count;
+
+ if (index != 0 &&
+ (index < first_desired || index >= (first_desired + allocated_count)))
+ {
+ args_out_of_range (make_int (first_desired),
+ make_int (first_desired + allocated_count));
+ }
+
+ mv->contents[index == 0 ? 0 : 1 + (index - first_desired)] = value;
+}
+
+Lisp_Object
+multiple_value_aref (Lisp_Object obj, Elemcount index)
+{
+ struct multiple_value *mv = XMULTIPLE_VALUE (obj);
+ Elemcount first_desired = mv->first_desired;
+ Elemcount allocated_count = mv->allocated_count;
+
+ if (index != 0 &&
+ (index < first_desired || index >= (first_desired + allocated_count)))
+ {
+ args_out_of_range (make_int (first_desired),
+ make_int (first_desired + allocated_count));
+ }
+
+ return mv->contents[index == 0 ? 0 : 1 + (index - first_desired)];
+}
+
+static void
+print_multiple_value (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
+{
+ struct multiple_value *mv = XMULTIPLE_VALUE (obj);
+ Elemcount first_desired = mv->first_desired;
+ Elemcount allocated_count = mv->allocated_count;
+ Elemcount count = mv->count, index;
+
+ if (print_readably)
+ {
+ printing_unreadable_object ("multiple values");
+ }
+
+ if (0 == count)
+ {
+ write_c_string (printcharfun, "#<zero-length multiple value>");
+ }
+
+ for (index = 0; index < count;)
+ {
+ if (index != 0 &&
+ (index < first_desired ||
+ index >= (first_desired + (allocated_count - 1))))
+ {
+ write_fmt_string (printcharfun, "#<discarded-multiple-value %d>",
+ index);
+ }
+ else
+ {
+ print_internal (multiple_value_aref (obj, index),
+ printcharfun, escapeflag);
+ }
+
+ ++index;
+
+ if (count > 1 && index < count)
+ {
+ write_c_string (printcharfun, " ;\n");
+ }
+ }
+}
+
+static Lisp_Object
+mark_multiple_value (Lisp_Object obj)
+{
+ struct multiple_value *mv = XMULTIPLE_VALUE (obj);
+ Elemcount index, allocated_count = mv->allocated_count;
+
+ for (index = 0; index < allocated_count; ++index)
+ {
+ mark_object (mv->contents[index]);
+ }
+
+ return Qnil;
+}
+
+static Bytecount
+size_multiple_value (const void *lheader)
+{
+ return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value,
+ Lisp_Object, contents,
+ ((struct multiple_value *) lheader)->
+ allocated_count);
+}
+
+static const struct memory_description multiple_value_description[] = {
+ { XD_LONG, offsetof (struct multiple_value, count) },
+ { XD_ELEMCOUNT, offsetof (struct multiple_value, allocated_count) },
+ { XD_LONG, offsetof (struct multiple_value, first_desired) },
+ { XD_LISP_OBJECT_ARRAY, offsetof (struct multiple_value, contents),
+ XD_INDIRECT (1, 0) },
+ { XD_END }
+};
+
+DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("multiple-value", multiple_value,
+ 1, /*dumpable-flag*/
+ mark_multiple_value,
+ print_multiple_value, 0,
+ 0, /* No equal method. */
+ 0, /* No hash method. */
+ multiple_value_description,
+ size_multiple_value,
+ struct multiple_value);
+
+/* Given that FIRST and UPPER are the inclusive lower and exclusive upper
+ bounds for the multiple values we're interested in, modify (or don't) the
+ special variables used to indicate this to #'values and #'values-list.
+ Returns the specpdl_depth() value before any modification. */
+int
+bind_multiple_value_limits (int first, int upper)
+{
+ int result = specpdl_depth();
+
+ if (!(upper > first))
+ {
+ invalid_argument ("MULTIPLE-VALUE-UPPER-LIMIT must be greater than "
+ " FIRST-DESIRED-MULTIPLE-VALUE", Qunbound);
+ }
+
+ if (upper > Vmultiple_values_limit)
+ {
+ args_out_of_range (make_int (upper), make_int (Vmultiple_values_limit));
+ }
+
+ /* In the event that something back up the stack wants more multiple
+ values than we do, we need to keep its figures for
+ first_desired_multiple_value or multiple_value_current_limit both. It
+ may be that the form will throw past us.
+
+ If first_desired_multiple_value is zero, this means it hasn't ever been
+ bound, and any value we have for first is appropriate to use.
+
+ Zeroth element is always saved, no need to note that: */
+ if (0 == first)
+ {
+ first = 1;
+ }
+
+ if (0 == first_desired_multiple_value
+ || first < first_desired_multiple_value)
+ {
+ internal_bind_int (&first_desired_multiple_value, first);
+ }
+
+ if (upper > multiple_value_current_limit)
+ {
+ internal_bind_int (&multiple_value_current_limit, upper);
+ }
+
+ return result;
+}
+
+Lisp_Object
+multiple_value_call (int nargs, Lisp_Object *args)
+{
+ /* The argument order here is horrible: */
+ int i, speccount = XINT (args[3]);
+ Lisp_Object result = Qnil, head = Fcons (args[0], Qnil), list_offset;
+ struct gcpro gcpro1, gcpro2;
+ Lisp_Object apply_args[2];
+
+ GCPRO2 (head, result);
+ list_offset = head;
+
+ assert (!(MULTIPLE_VALUEP (args[0])));
+ CHECK_FUNCTION (args[0]);
+
+ /* Start at 4, to ignore the function, the speccount, and the arguments to
+ multiple-values-limit (which we don't discard because
+ #'multiple-value-list-internal needs them): */
+ for (i = 4; i < nargs; ++i)
+ {
+ result = args[i];
+ if (MULTIPLE_VALUEP (result))
+ {
+ Lisp_Object val;
+ Elemcount i, count = XMULTIPLE_VALUE_COUNT (result);
+
+ for (i = 0; i < count; i++)
+ {
+ val = multiple_value_aref (result, i);
+ assert (!UNBOUNDP (val));
+
+ XSETCDR (list_offset, Fcons (val, Qnil));
+ list_offset = XCDR (list_offset);
+ }
+ }
+ else
+ {
+ XSETCDR (list_offset, Fcons (result, Qnil));
+ list_offset = XCDR (list_offset);
+ }
+ }
+
+ apply_args [0] = XCAR (head);
+ apply_args [1] = XCDR (head);
+
+ unbind_to (speccount);
+
+ RETURN_UNGCPRO (Fapply (countof(apply_args), apply_args));
+}
+
+DEFUN ("multiple-value-call", Fmultiple_value_call, 1, UNEVALLED, 0, /*
+Call FUNCTION with arguments FORMS, using multiple values when returned.
+
+All of the (possibly multiple) values returned by each form in FORMS are
+gathered together, and given as arguments to FUNCTION; conceptually, this
+function is a version of `apply' that by-passes the multiple values
+infrastructure, treating multiple values as intercalated lists.
+
+arguments: (FUNCTION &rest FORMS)
+*/
+ (args))
+{
+ int listcount, i = 0, speccount;
+ Lisp_Object *constructed_args;
+ struct gcpro gcpro1;
+
+ GET_EXTERNAL_LIST_LENGTH (args, listcount);
+
+ constructed_args = alloca_array (Lisp_Object, listcount + 3);
+
+ /* Fcar so we error on non-cons: */
+ constructed_args[i] = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args)));
+
+ GCPRO1 (*constructed_args);
+ gcpro1.nvars = ++i;
+
+ /* The argument order is horrible here. */
+ constructed_args[i] = make_int (0);
+ gcpro1.nvars = ++i;
+ constructed_args[i] = make_int (Vmultiple_values_limit);
+ gcpro1.nvars = ++i;
+
+ speccount = bind_multiple_value_limits (0, Vmultiple_values_limit);
+ constructed_args[i] = make_int (speccount);
+ gcpro1.nvars = ++i;
+
+ {
+ LIST_LOOP_2 (elt, XCDR (args))
+ {
+ constructed_args[i] = Feval (elt);
+ gcpro1.nvars = ++i;
+ }
+ }
+
+ RETURN_UNGCPRO (multiple_value_call (listcount + 3, constructed_args));
+}
+
+Lisp_Object
+multiple_value_list_internal (int nargs, Lisp_Object *args)
+{
+ int first = XINT (args[0]), upper = XINT (args[1]),
+ speccount = XINT(args[2]);
+ Lisp_Object result = Qnil;
+
+ assert (nargs == 4);
+
+ result = args[3];
+
+ unbind_to (speccount);
+
+ if (MULTIPLE_VALUEP (result))
+ {
+ Lisp_Object head = Fcons (Qnil, Qnil);
+ Lisp_Object list_offset = head, val;
+ Elemcount count = XMULTIPLE_VALUE_COUNT(result);
+
+ for (; first < upper && first < count; ++first)
+ {
+ val = multiple_value_aref (result, first);
+ assert (!UNBOUNDP (val));
+
+ XSETCDR (list_offset, Fcons (val, Qnil));
+ list_offset = XCDR (list_offset);
+ }
+
+ return XCDR (head);
+ }
+ else
+ {
+ if (first == 0)
+ {
+ return Fcons (result, Qnil);
+ }
+ else
+ {
+ return Qnil;
+ }
+ }
+}
+
+DEFUN ("multiple-value-list-internal", Fmultiple_value_list_internal, 3,
+ UNEVALLED, 0, /*
+Evaluate FORM. Return a list of multiple vals reflecting the other two args.
+
+Don't use this. Use `multiple-value-list', the macro specified by Common
+Lisp, instead.
+
+FIRST-DESIRED-MULTIPLE-VALUE is the first element in list of multiple values
+to pass back. MULTIPLE-VALUE-UPPER-LIMIT is the exclusive upper limit on
+the indexes within the values that may be passed back; this function will
+never return a list longer than MULTIPLE-VALUE-UPPER-LIMIT -
+FIRST-DESIRED-MULTIPLE-VALUE. It may return a list shorter than that, if
+`values' or `values-list' do not supply enough elements.
+
+arguments: (FIRST-DESIRED-MULTIPLE-VALUE MULTIPLE-VALUE-UPPER-LIMIT FORM)
+*/
+ (args))
+{
+ Lisp_Object argv[4];
+ int first, upper;
+ struct gcpro gcpro1;
+
+ argv[0] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
+ CHECK_NATNUM (argv[0]);
+ first = XINT (argv[0]);
+
+ GCPRO1 (argv[0]);
+ gcpro1.nvars = 1;
+
+ args = XCDR (args);
+
+ argv[1] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
+ CHECK_NATNUM (argv[1]);
+ upper = XINT (argv[1]);
+ gcpro1.nvars = 2;
+
+ /* The unintuitive order of things here is for the sake of the bytecode;
+ the alternative would be to encode the number of arguments in the
+ bytecode stream, which complicates things if we have more than 255
+ arguments. */
+ argv[2] = make_int (bind_multiple_value_limits (first, upper));
+ gcpro1.nvars = 3;
+ args = XCDR (args);
+
+ /* GCPROing in this function is not strictly necessary, this Feval is the
+ only point that may cons up data that is not immediately discarded, and
+ within it is the only point (in Fmultiple_value_list_internal and
+ multiple_value_list) that we can garbage collect. But I'm conservative,
+ and this function is called so rarely (only from interpreted code) that
+ it doesn't matter for performance. */
+ argv[3] = Feval (XCAR (args));
+ gcpro1.nvars = 4;
+
+ RETURN_UNGCPRO (multiple_value_list_internal (countof (argv), argv));
+}
+
+DEFUN ("multiple-value-prog1", Fmultiple_value_prog1, 1, UNEVALLED, 0, /*
+Similar to `prog1', but return any multiple values from the first form.
+`prog1' itself will never return multiple values.
+
+arguments: (FIRST &rest BODY)
+*/
+ (args))
+{
+ /* This function can GC */
+ Lisp_Object val;
+ struct gcpro gcpro1;
+
+ val = Feval (XCAR (args));
+
+ GCPRO1 (val);
+
+ {
+ LIST_LOOP_2 (form, XCDR (args))
+ Feval (form);
+ }
+
+ RETURN_UNGCPRO (val);
+}
+
+DEFUN ("values", Fvalues, 0, MANY, 0, /*
+Return all ARGS as multiple values.
+
+arguments: (&rest ARGS)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object result = Qnil;
+ int counting = 1;
+
+ /* Pathological cases, no need to cons up an object: */
+ if (1 == nargs || 1 == multiple_value_current_limit)
+ {
+ return nargs ? args[0] : Qnil;
+ }
+
+ /* If nargs is zero, this code is correct and desirable. With
+ #'multiple-value-call, we want zero-length multiple values in the
+ argument list to be discarded entirely, and we can't do this if we
+ transform them to nil. */
+ result = make_multiple_value (nargs ? args[0] : Qnil, nargs,
+ first_desired_multiple_value,
+ multiple_value_current_limit);
+
+ for (; counting < nargs; ++counting)
+ {
+ if (counting >= first_desired_multiple_value &&
+ counting < multiple_value_current_limit)
+ {
+ multiple_value_aset (result, counting, args[counting]);
+ }
+ }
+
+ return result;
+}
+
+DEFUN ("values-list", Fvalues_list, 1, 1, 0, /*
+Return all the elements of LIST as multiple values.
+*/
+ (list))
+{
+ Lisp_Object result = Qnil;
+ int counting = 1, listcount;
+
+ GET_EXTERNAL_LIST_LENGTH (list, listcount);
+
+ /* Pathological cases, no need to cons up an object: */
+ if (1 == listcount || 1 == multiple_value_current_limit)
+ {
+ return Fcar_safe (list);
+ }
+
+ result = make_multiple_value (Fcar_safe (list), listcount,
+ first_desired_multiple_value,
+ multiple_value_current_limit);
+
+ list = Fcdr_safe (list);
+
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, list)
+ {
+ if (counting >= first_desired_multiple_value &&
+ counting < multiple_value_current_limit)
+ {
+ multiple_value_aset (result, counting, elt);
+ }
+ ++counting;
+ }
+ }
+
+ return result;
+}
+
+Lisp_Object
+values2 (Lisp_Object first, Lisp_Object second)
+{
+ Lisp_Object argv[2];
+
+ argv[0] = first;
+ argv[1] = second;
+
+ return Fvalues (countof (argv), argv);
}
＠＠ -4968,7 +5613,7 ＠＠
p->error_conditions = error_conditions;
p->data = data;
- Fthrow (p->catchtag, Qnil);
+ throw_or_bomb_out (p->catchtag, Qnil, 0, Qnil, Qnil);
RETURN_NOT_REACHED (Qnil);
}
＠＠ -6555,6 +7200,7 ＠＠
syms_of_eval (void)
{
INIT_LRECORD_IMPLEMENTATION (subr);
+ INIT_LRECORD_IMPLEMENTATION (multiple_value);
DEFSYMBOL (Qinhibit_quit);
DEFSYMBOL (Qautoload);
＠＠ -6578,6 +7224,8 ＠＠
DEFSYMBOL (Qrun_hooks);
DEFSYMBOL (Qfinalize_list);
DEFSYMBOL (Qif);
+ DEFSYMBOL (Qthrow);
+ DEFSYMBOL (Qobsolete_throw);
DEFSUBR (For);
DEFSUBR (Fand);
＠＠ -6611,6 +7259,11 ＠＠
DEFSUBR (Fautoload);
DEFSUBR (Feval);
DEFSUBR (Fapply);
+ DEFSUBR (Fmultiple_value_call);
+ DEFSUBR (Fmultiple_value_list_internal);
+ DEFSUBR (Fmultiple_value_prog1);
+ DEFSUBR (Fvalues);
+ DEFSUBR (Fvalues_list);
DEFSUBR (Ffuncall);
DEFSUBR (Ffunctionp);
DEFSUBR (Ffunction_min_args);
＠＠ -6636,6 +7289,9 ＠＠
debug_on_next_call = 0;
lisp_eval_depth = 0;
entering_debugger = 0;
+
+ first_desired_multiple_value = 0;
+ multiple_value_current_limit = 1;
}
void
＠＠ -6805,6 +7461,14 ＠＠
*/ );
Vdebugger = Qnil;
+ DEFVAR_CONST_INT ("multiple-values-limit", &Vmultiple_values_limit /*
+The exclusive upper bound on the number of multiple values.
+
+This applies to `values', `values-list', `multiple-value-bind' and related
+macros and special forms.
+*/);
+ Vmultiple_values_limit = EMACS_INT_MAX > INT_MAX ? INT_MAX : EMACS_INT_MAX;
+
staticpro (&Vcatch_everything_tag);
Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0);
diff -r e3feb329bda9 -r 8f1ee2d15784 src/event-msw.c
--- a/src/event-msw.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/event-msw.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -1769,7 +1769,7 ＠＠
return Qnil;
GCPRO1 (obj);
- obj = Feval (XCAR (obj));
+ obj = IGNORE_MULTIPLE_VALUES (Feval (XCAR (obj)));
RETURN_UNGCPRO (obj);
}
diff -r e3feb329bda9 -r 8f1ee2d15784 src/event-stream.c
--- a/src/event-stream.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/event-stream.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -843,7 +843,7 ＠＠
call1 (Qcurrent_window_configuration, Qnil));
reset_key_echo (command_builder, 1);
- help = Feval (Vhelp_form);
+ help = IGNORE_MULTIPLE_VALUES (Feval (Vhelp_form));
if (STRINGP (help))
internal_with_output_to_temp_buffer (build_string ("*Help*"),
print_help, help, Qnil);
diff -r e3feb329bda9 -r 8f1ee2d15784 src/glade.c
--- a/src/glade.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/glade.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -42,7 +42,8 ＠＠
if (signal_data && signal_data[0])
{
- lisp_data = Feval (Fread (build_string (signal_data)));
+ lisp_data
+ = IGNORE_MULTIPLE_VALUES (Feval (Fread (build_string (signal_data))));
}
/* obj, name, func, cb_data, object_signal, after_p */
diff -r e3feb329bda9 -r 8f1ee2d15784 src/glyphs-widget.c
--- a/src/glyphs-widget.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/glyphs-widget.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -222,7 +222,7 ＠＠
glyph = XSYMBOL (glyph)->value;
if (CONSP (glyph))
- glyph = Feval (glyph);
+ glyph = IGNORE_MULTIPLE_VALUES (Feval (glyph));
/* Be really helpful to the user. */
if (VECTORP (glyph))
diff -r e3feb329bda9 -r 8f1ee2d15784 src/glyphs.c
--- a/src/glyphs.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/glyphs.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -3079,7 +3079,7 ＠＠
value = XCDR (cons);
CHECK_CONS (value);
value = XCAR (value);
- value = Feval (value);
+ value = IGNORE_MULTIPLE_VALUES (Feval (value));
if (NILP (value))
continue;
if (!STRINGP (value) && !COLOR_SPECIFIERP (value))
diff -r e3feb329bda9 -r 8f1ee2d15784 src/gui-x.c
--- a/src/gui-x.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/gui-x.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -325,8 +325,9 ＠＠
Lisp_Object wses_form = (form); \
(slot) = (NILP (wses_form) ? 0 : \
EQ (wses_form, Qt) ? 1 : \
- !NILP (in_display ? eval_within_redisplay (wses_form) \
- : Feval (wses_form))); \
+ !NILP (in_display ? \
+ IGNORE_MULTIPLE_VALUES (eval_within_redisplay (wses_form)) \
+ : IGNORE_MULTIPLE_VALUES (Feval (wses_form)))); \
} while (0)
#else
/* Treat the activep slot of the menu item as a boolean */
＠＠ -436,7 +437,7 ＠＠
#endif /* HAVE_MENUBARS */
if (!STRINGP (pgui->name))
- pgui->name = Feval (pgui->name);
+ pgui->name = IGNORE_MULTIPLE_VALUES (Feval (pgui->name));
CHECK_STRING (pgui->name);
if (accel_p)
＠＠ -459,7 +460,7 ＠＠
suffix2 = pgui->suffix;
else
{
- suffix2 = Feval (pgui->suffix);
+ suffix2 = IGNORE_MULTIPLE_VALUES (Feval (pgui->suffix));
CHECK_STRING (suffix2);
}
diff -r e3feb329bda9 -r 8f1ee2d15784 src/gui.c
--- a/src/gui.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/gui.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -386,7 +386,6 ＠＠
gui_item_value (Lisp_Object form)
{
/* This function can call Lisp. */
-
#ifndef ERROR_CHECK_DISPLAY
/* Shortcut to avoid evaluating Qt/Qnil each time; but don't do it when
error-checking so we catch unprotected eval within redisplay quicker */
＠＠ -395,7 +394,9 ＠＠
if (EQ (form, Qt))
return 1;
#endif
- return !NILP (in_display ? eval_within_redisplay (form) : Feval (form));
+ return !NILP (in_display ?
+ IGNORE_MULTIPLE_VALUES (eval_within_redisplay (form))
+: IGNORE_MULTIPLE_VALUES (Feval (form)));
}
/*
＠＠ -511,6 +512,7 ＠＠
if (!STRINGP (suffix))
{
suffix = Feval (suffix);
+ suffix = IGNORE_MULTIPLE_VALUES (suffix);
CHECK_STRING (suffix);
}
diff -r e3feb329bda9 -r 8f1ee2d15784 src/inline.c
--- a/src/inline.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/inline.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -64,6 +64,7 ＠＠
#include "process.h"
#include "rangetab.h"
#include "specifier.h"
+#include "symeval.h"
#include "syntax.h"
#include "window.h"
diff -r e3feb329bda9 -r 8f1ee2d15784 src/lisp.h
--- a/src/lisp.h Sun Aug 16 14:58:57 2009 +0100
+++ b/src/lisp.h Sun Aug 16 20:55:49 2009 +0100
＠＠ -4269,10 +4269,14 ＠＠
EXFUN (Finteractive_p, 0);
EXFUN (Fprogn, UNEVALLED);
MODULE_API EXFUN (Fsignal, 2);
-MODULE_API EXFUN_NORETURN (Fthrow, 2);
+MODULE_API EXFUN_NORETURN (Fthrow, UNEVALLED);
MODULE_API EXFUN (Fcall_with_condition_handler, MANY);
EXFUN (Ffunction_max_args, 1);
EXFUN (Ffunction_min_args, 1);
+
+MODULE_API DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object,
+ Lisp_Object, int,
+ Lisp_Object, Lisp_Object));
MODULE_API DECLARE_DOESNT_RETURN (signal_error_1 (Lisp_Object, Lisp_Object));
void maybe_signal_error_1 (Lisp_Object, Lisp_Object, Lisp_Object,
diff -r e3feb329bda9 -r 8f1ee2d15784 src/lread.c
--- a/src/lread.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/lread.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -372,7 +372,7 ＠＠
Lisp_Object val;
GCPRO1 (reloc);
- val = Feval (XCDR (acons));
+ val = IGNORE_MULTIPLE_VALUES (Feval (XCDR (acons)));
UNGCPRO;
if (!NILP (val))
diff -r e3feb329bda9 -r 8f1ee2d15784 src/lrecord.h
--- a/src/lrecord.h Sun Aug 16 14:58:57 2009 +0100
+++ b/src/lrecord.h Sun Aug 16 20:55:49 2009 +0100
＠＠ -224,6 +224,7 ＠＠
lrecord_type_max_symbol_value_magic = lrecord_type_symbol_value_buffer_local,
lrecord_type_symbol,
lrecord_type_subr,
+ lrecord_type_multiple_value,
lrecord_type_cons,
lrecord_type_vector,
lrecord_type_string,
diff -r e3feb329bda9 -r 8f1ee2d15784 src/macros.c
--- a/src/macros.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/macros.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -197,7 +197,7 ＠＠
with Qt to force an early exit. */
signal_error (Qinvalid_state, "junk in executing-macro", Qunbound);
- Fthrow (Qexecute_kbd_macro, Qt);
+ throw_or_bomb_out (Qexecute_kbd_macro, Qt, 0, Qnil, Qnil);
}
diff -r e3feb329bda9 -r 8f1ee2d15784 src/menubar-gtk.c
--- a/src/menubar-gtk.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/menubar-gtk.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -666,13 +666,14 ＠＠
if ((!NILP (config_tag)
&& NILP (Fmemq (config_tag, Vmenubar_configuration)))
- || (included_spec && NILP (Feval (include_p))))
+ || (included_spec &&
+ NILP (IGNORE_MULTIPLE_VALUES (Feval (include_p)))))
{
return (NULL);
}
if (active_spec)
- active_p = Feval (active_p);
+ active_p = IGNORE_MULTIPLE_VALUES (Feval (active_p));
gtk_widget_set_sensitive (GTK_WIDGET (menu_item), ! NILP (active_p));
}
＠＠ -853,7 +854,8 ＠＠
#ifdef HAVE_MENUBARS
if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration)))
- || (included_spec && NILP (Feval (include_p))))
+ || (included_spec && NILP (IGNORE_MULTIPLE_VALUES (Feval (include_p)))))
+
{
/* the include specification says to ignore this item. */
return 0;
＠＠ -866,7 +868,8 ＠＠
accel = menu_name_to_accelerator (XSTRING_DATA (name));
if (!NILP (suffix))
- suffix = Feval (suffix);
+ suffix = IGNORE_MULTIPLE_VALUES (Feval (suffix));
+
if (!separator_string_p (XSTRING_DATA (name)))
{
＠＠ -901,7 +904,7 ＠＠
}
else
{
- selected_p = Feval (selected_p);
+ selected_p = IGNORE_MULTIPLE_VALUES (Feval (selected_p));
}
}
＠＠ -911,7 +914,7 ＠＠
}
else
{
- active_p = Feval (active_p);
+ active_p = IGNORE_MULTIPLE_VALUES (Feval (active_p));
}
if (0 ||
diff -r e3feb329bda9 -r 8f1ee2d15784 src/menubar-msw.c
--- a/src/menubar-msw.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/menubar-msw.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -326,7 +326,7 ＠＠
}
if (!STRINGP (pgui_item->name))
- pgui_item->name = Feval (pgui_item->name);
+ pgui_item->name = IGNORE_MULTIPLE_VALUES (Feval (pgui_item->name));
if (!gui_item_active_p (gui_item))
item_info.fState = MFS_GRAYED;
diff -r e3feb329bda9 -r 8f1ee2d15784 src/print.c
--- a/src/print.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/print.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -821,7 +821,7 ＠＠
#endif
GCPRO2 (name, val);
- name = Feval (XCAR (args));
+ name = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
CHECK_STRING (name);
diff -r e3feb329bda9 -r 8f1ee2d15784 src/symbols.c
--- a/src/symbols.c Sun Aug 16 14:58:57 2009 +0100
+++ b/src/symbols.c Sun Aug 16 20:55:49 2009 +0100
＠＠ -2146,7 +2146,7 ＠＠
GC_PROPERTY_LIST_LOOP_3 (symbol, val, args)
{
- val = Feval (val);
+ val = IGNORE_MULTIPLE_VALUES (Feval (val));
Fset_default (symbol, val);
retval = val;
}
diff -r e3feb329bda9 -r 8f1ee2d15784 src/symeval.h
--- a/src/symeval.h Sun Aug 16 14:58:57 2009 +0100
+++ b/src/symeval.h Sun Aug 16 20:55:49 2009 +0100
＠＠ -488,6 +488,83 ＠＠
void flush_all_buffer_local_cache (void);
+struct multiple_value {
+ struct LCRECORD_HEADER header;
+ Elemcount count;
+ Elemcount allocated_count;
+ Elemcount first_desired;
+ Lisp_Object contents[1];
+};
+typedef struct multiple_value multiple_value;
+
+DECLARE_LRECORD (multiple_value, multiple_value);
+#define MULTIPLE_VALUEP(x) RECORDP (x, multiple_value)
+
+#define XMULTIPLE_VALUE(x) XRECORD (x, multiple_value, multiple_value)
+#define wrap_multiple_value(p) wrap_record (p, multiple_value)
+
+#define CHECK_MULTIPLE_VALUE(x) CHECK_RECORD (x, multiple_value)
+#define CONCHECK_MULTIPLE_VALUE(x) CONCHECK_RECORD (x, multiple_value)
+
+#define multiple_value_count(x) ((x)->count)
+#define multiple_value_allocated_count(x) ((x)->allocated_count)
+#define multiple_value_first_desired(x) ((x)->first_desired)
+#define multiple_value_contents(x) ((x)->contents)
+
+#define XMULTIPLE_VALUE_COUNT(x) multiple_value_count (XMULTIPLE_VALUE (x))
+#define XMULTIPLE_VALUE_ALLOCATED_COUNT(x) \
+ multiple_value_allocated_count (XMULTIPLE_VALUE (x))
+#define XMULTIPLE_VALUE_FIRST_DESIRED(x) \
+ multiple_value_first_desired (XMULTIPLE_VALUE(x))
+#define XMULTIPLE_VALUE_CONTENTS(x) multiple_value_contents (XMULTIPLE_VALUE(x))
+
+Lisp_Object multiple_value_call (int nargs, Lisp_Object *args);
+Lisp_Object multiple_value_list_internal (int nargs, Lisp_Object *args);
+
+/* It's slightly ugly to expose this here, but it does cut down the amount
+ of work the bytecode interpreter has to do substantially. */
+extern int multiple_value_current_limit;
+
+/* Bind the multiple value limits that #'values and #'values-list pay
+ attention to. Used by bytecode and interpreted code. */
+int bind_multiple_value_limits (int first, int upper);
+
+Lisp_Object multiple_value_aref (Lisp_Object, Elemcount);
+void multiple_value_aset (Lisp_Object, Elemcount, Lisp_Object);
+
+Lisp_Object values2 (Lisp_Object first, Lisp_Object second);
+
+DECLARE_INLINE_HEADER (
+Lisp_Object
+ignore_multiple_values (Lisp_Object obj)
+)
+{
+ return MULTIPLE_VALUEP (obj) ? multiple_value_aref (obj, 0) : obj;
+}
+
+#ifdef ERROR_CHECK_MULTIPLE_VALUES
+
+DECLARE_INLINE_HEADER (
+Lisp_Object
+ignore_multiple_values_1 (Lisp_Object obj)
+)
+{
+ if (1 == multiple_value_current_limit)
+ {
+ assert (!MULTIPLE_VALUEP (obj));
+ return obj;
+ }
+
+ return ignore_multiple_values (obj);
+}
+
+#define IGNORE_MULTIPLE_VALUES(X) ignore_multiple_values_1 (X)
+
+#else
+#define IGNORE_MULTIPLE_VALUES(X) (multiple_value_current_limit == 1 ? (X) \
+: ignore_multiple_values (X))
+#endif
+
END_C_DECLS
#endif /* INCLUDED_symeval_h_ */
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Make the initialisation of xpm-color-symbols a bit more reasonable.
14 years, 8 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1250431137 -3600
# Node ID e3feb329bda9831e5b3d4ca8e2dacc643cb15e28
# Parent 9a1a59b4b75d0ffdab4f7d90db48ec666770c24d
Make the initialisation of xpm-color-symbols a bit more reasonable.
2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net>
* faces.el (xpm-color-symbols):
Call (featurep 'x) when faces.elc is dumped, not repeatedly
(myriad times) at image instantiation time.
diff -r 9a1a59b4b75d -r e3feb329bda9 lisp/ChangeLog
--- a/lisp/ChangeLog Fri Aug 14 19:14:51 2009 +0100
+++ b/lisp/ChangeLog Sun Aug 16 14:58:57 2009 +0100
＠＠ -1,3 +1,9 ＠＠
+2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * faces.el (xpm-color-symbols):
+ Call (featurep 'x) when faces.elc is dumped, not repeatedly
+ (myriad times) at image instantiation time.
+
2009-08-14 Aidan Kehoe <kehoea(a)parhasard.net>
* minibuf.el (read-from-minibuffer):
diff -r 9a1a59b4b75d -r e3feb329bda9 lisp/faces.el
--- a/lisp/faces.el Fri Aug 14 19:14:51 2009 +0100
+++ b/lisp/faces.el Sun Aug 16 14:58:57 2009 +0100
＠＠ -2068,24 +2068,20 ＠＠
(list
'("foreground" (face-foreground 'default))
'("background" (face-background 'default))
- '("backgroundToolBarColor"
- (or
- (and
- (featurep 'x)
- (x-get-resource "backgroundToolBarColor"
- "BackgroundToolBarColor" 'string
- nil nil 'warn))
-
- (face-background 'toolbar)))
- '("foregroundToolBarColor"
- (or
- (and
- (featurep 'x)
- (x-get-resource "foregroundToolBarColor"
- "ForegroundToolBarColor" 'string
- nil nil 'warn))
- (face-foreground 'toolbar)))
- )))
+ `("backgroundToolBarColor"
+ ,(if (featurep 'x)
+ '(or (x-get-resource "backgroundToolBarColor"
+ "BackgroundToolBarColor" 'string
+ nil nil 'warn)
+ (face-background 'toolbar))
+ '(face-background 'toolbar)))
+ `("foregroundToolBarColor"
+ ,(if (featurep 'x)
+ '(or (x-get-resource "foregroundToolBarColor"
+ "ForegroundToolBarColor" 'string
+ nil nil 'warn)
+ (face-foreground 'toolbar))
+ '(face-foreground 'toolbar))))))
(when (featurep 'tty)
(set-face-highlight-p 'bold t 'global '(default tty))
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Make the initialisation of xpm-color-symbols a bit more reasonable.
14 years, 8 months
Aidan Kehoe
Aidan Kehoe
changeset: 4676:e3feb329bda9
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Aug 16 14:58:57 2009 +0100
files: lisp/ChangeLog lisp/faces.el
description:
Make the initialisation of xpm-color-symbols a bit more reasonable.
2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net>
* faces.el (xpm-color-symbols):
Call (featurep 'x) when faces.elc is dumped, not repeatedly
(myriad times) at image instantiation time.
diff -r 9a1a59b4b75d -r e3feb329bda9 lisp/ChangeLog
--- a/lisp/ChangeLog Fri Aug 14 19:14:51 2009 +0100
+++ b/lisp/ChangeLog Sun Aug 16 14:58:57 2009 +0100
＠＠ -1,3 +1,9 ＠＠
+2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * faces.el (xpm-color-symbols):
+ Call (featurep 'x) when faces.elc is dumped, not repeatedly
+ (myriad times) at image instantiation time.
+
2009-08-14 Aidan Kehoe <kehoea(a)parhasard.net>
* minibuf.el (read-from-minibuffer):
diff -r 9a1a59b4b75d -r e3feb329bda9 lisp/faces.el
--- a/lisp/faces.el Fri Aug 14 19:14:51 2009 +0100
+++ b/lisp/faces.el Sun Aug 16 14:58:57 2009 +0100
＠＠ -2068,24 +2068,20 ＠＠
(list
'("foreground" (face-foreground 'default))
'("background" (face-background 'default))
- '("backgroundToolBarColor"
- (or
- (and
- (featurep 'x)
- (x-get-resource "backgroundToolBarColor"
- "BackgroundToolBarColor" 'string
- nil nil 'warn))
-
- (face-background 'toolbar)))
- '("foregroundToolBarColor"
- (or
- (and
- (featurep 'x)
- (x-get-resource "foregroundToolBarColor"
- "ForegroundToolBarColor" 'string
- nil nil 'warn))
- (face-foreground 'toolbar)))
- )))
+ `("backgroundToolBarColor"
+ ,(if (featurep 'x)
+ '(or (x-get-resource "backgroundToolBarColor"
+ "BackgroundToolBarColor" 'string
+ nil nil 'warn)
+ (face-background 'toolbar))
+ '(face-background 'toolbar)))
+ `("foregroundToolBarColor"
+ ,(if (featurep 'x)
+ '(or (x-get-resource "foregroundToolBarColor"
+ "ForegroundToolBarColor" 'string
+ nil nil 'warn)
+ (face-foreground 'toolbar))
+ '(face-foreground 'toolbar))))))
(when (featurep 'tty)
(set-face-highlight-p 'bold t 'global '(default tty))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[PATCH] edit-utils: setnu-mode: unstable function defination detecting
14 years, 8 months
FKtPp
FKtPp
Dear Developers,
I found this annoying that if you got overlay.el loaded, the setnu.el
will use overlay-api instead of XEmacs specific extents-api... And do
cause a function defination void error.
to reproduce:
1. (require 'overlay)
2. start setnu-mode in some buffer
3. insert a newline into the buffer
4. error
BTW, Do you know why don't setnu.el use (featurep 'xemacs) instead of
#'foundp some-extend-related-thing? A way to backward-compatible?
Thanks,
FKtPp
ChangeLog addition:
2009-06-17 It's me FKtPp ;) <m_pupil(a)yahoo.com.cn>
* setnu.el (setnu-extent-at): re-order the #'cond -> #'foundp
special form so that #'map-extents was detected first whether
overlay.el loaded or not.
edit-utils[Packages] source patch:
Diff command: cvs -q diff -u
Files affected: setnu.el
===================================================================
RCS
Index: setnu.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/edit-utils/setnu.el,v
retrieving revision 1.3
diff -u -r1.3 setnu.el
--- setnu.el 2002/07/24 18:36:50 1.3
+++ setnu.el 2009/06/16 16:49:32
＠＠ -340,7 +340,15 ＠＠
(setnu-set-extent-property e 'evaporate nil)
e ))
-(cond ((fboundp 'overlays-in) ;; expect to see this in 19.30
+(cond ((fboundp 'map-extents)
+ (defun setnu-extent-at (pos buf)
+ "Finds the setnu extent at the position POS in the buffer BUF."
+ (map-extents (function (lambda (e maparg)
+ (if (setnu-extent-property e 'setnu)
+ e
+ nil)))
+ buf pos pos)))
+ ((fboundp 'overlays-in) ;; expect to see this in 19.30
(defun setnu-extent-at (pos buf)
"Finds the setnu extent at the position POS in the buffer BUF."
(catch 'done
＠＠ -382,14 +390,6 ＠＠
(throw 'done (car o-list)))
(setq o-list (cdr o-list)))
nil )))))
- ((fboundp 'map-extents)
- (defun setnu-extent-at (pos buf)
- "Finds the setnu extent at the position POS in the buffer BUF."
- (map-extents (function (lambda (e maparg)
- (if (setnu-extent-property e 'setnu)
- e
- nil)))
- buf pos pos)))
(t (error "can't find overlays-in, overlays-at, or map-extents!")))
(defun setnu-extent-at-create (pos buf)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 3 participants
- 2 comments
[PATCH] pcomplete, new finding, was use #'manual-entry instead of GNU's #'man
14 years, 8 months
FKtPp
FKtPp
Dear Developers,
I find this one is also using the #'man function
Thanks,
FKtPp
ChangeLog addition:
2009-06-17 It's me FKtPp ;) <m_pupil(a)yahoo.com.cn>
* pcomplete.el (pcomplete-man-function): use #'manual-entry instead of GNU's #'man in XEmacs
pcomplete[Packages] source patch:
Diff command: cvs -q diff -u
Files affected: pcomplete.el
===================================================================
RCS
Index: pcomplete.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/pcomplete/pcomplete.el,v
retrieving revision 1.2
diff -u -r1.2 pcomplete.el
--- pcomplete.el 2005/01/23 14:01:30 1.2
+++ pcomplete.el 2009/06/16 16:13:14
＠＠ -180,7 +180,9 ＠＠
:type 'hook
:group 'pcomplete)
-(defcustom pcomplete-man-function 'man
+(defcustom pcomplete-man-function (if (featurep 'xemacs)
+ #'manual-entry
+ 'man)
"*A function to that will be called to display a manual page.
It will be passed the name of the command to document."
:type 'function
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 2 participants
- 1 comments
Re: [PATCH] Don't use #'multiple-value-bind inappropriately, ERC
14 years, 8 months
Aidan Kehoe
Aidan Kehoe
Ar an cúigiú lá déag de mí Lúnasa, scríobh Stephen J. Turnbull:
> Aidan Kehoe writes:
>
> > It would be really helpful if there were some indication, when posting to
> > erc-help(a)lists.sourceforge.net, that it was no longer active, by the way.
> > :-) . I’m about to post another mail with a patch I posted to that address
> > back near the middle of July.
>
> Er, you could in theory get in touch with the maintainer of the XEmacs
> package: Adrian Aichner <adrian(a)xemacs.org>.
He’s been in the CC lists of all my ERC communication.
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[PATCH] Don't leak memory in XEmacs with huge log files, erc
14 years, 8 months
Aidan Kehoe
Aidan Kehoe
This gives a dramatic improvement in memory usage for me, with at least one
107 MB log file constantly being written to.
xemacs-packages/erc/ChangeLog addition:
2009-07-22 Aidan Kehoe <kehoea(a)parhasard.net>
* erc-log.el (erc-log-setup-logging):
Don't insert the entire log file into the buffer if
erc-truncate-buffer is in erc-insert-post-hook (even though most
of the buffer is later deleted in this case); avoids XEmacs
keeping lots of memory around needlessly when log files are huge
but buffer sizes are tiny. GNU Emacs doesn't do this, but it
should be a win there too, there's no need to create a 100 MB
buffer needlessly.
XEmacs Packages (existing ChangeLogs) source patch:
Diff command: cvs -q diff -Nu
Files affected: xemacs-packages/erc/erc-log.el
Index: xemacs-packages/erc/erc-log.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/erc/erc-log.el,v
retrieving revision 1.10
diff -u -r1.10 erc-log.el
--- xemacs-packages/erc/erc-log.el 2008/07/23 07:23:12 1.10
+++ xemacs-packages/erc/erc-log.el 2009/07/22 10:39:43
＠＠ -230,9 +230,17 ＠＠
(set (make-local-variable 'write-file-hooks)
'(erc-save-buffer-in-logs))))
(when erc-log-insert-log-on-open
- (ignore-errors (insert-file-contents (erc-current-logfile))
- (move-marker erc-last-saved-position
- (1- (point-max)))))))
+ (let* ((log-file (erc-current-logfile))
+ (log-file-size (nth 7 (file-attributes log-file)))
+ (start (if (and log-file-size
+ (memq 'erc-truncate-buffer
+ erc-insert-post-hook))
+ (- log-file-size erc-max-buffer-size)
+ 0)))
+ (ignore-errors (insert-file-contents log-file nil start
+ log-file-size))
+ (move-marker erc-last-saved-position
+ (1- (point-max)))))))
;;; Append, so that 'erc-initialize-log-marker keeps running first.
(add-hook 'erc-connect-pre-hook 'erc-log-setup-logging 'append)
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 1 comments
[PATCH] Don't use #'multiple-value-bind inappropriately, ERC
14 years, 8 months
Aidan Kehoe
Aidan Kehoe
This functions much better in the presence of real multiple values, and is
more correct even in their absence.
xemacs-packages/erc/ChangeLog addition:
2009-08-13 Aidan Kehoe <kehoea(a)parhasard.net>
* erc-compat.el (erc-destructuring-bind): New macro, like
#'destructuring-bind, but no error if EXPR doesn't give a result
fitting into ARGS.
* erc-backend.el:
Use #'destructuring-bind instead of #'multiple-value-bind where we
know the result of EXPR will fit ARGS; use
#'erc-destructuring-bind where we know it won't.
* erc-list.el (erc-chanlist-322):
Use #'erc-destructuring-bind, not #'multiple-value-bind.
* erc.el (erc-banlist-store):
Use #'erc-destructuring-bind, not #'multiple-value-bind.
XEmacs Packages source patch:
Diff command: cvs -q diff -Nu
Files affected: xemacs-packages/erc/erc.el xemacs-packages/erc/erc-list.el xemacs-packages/erc/erc-compat.el xemacs-packages/erc/erc-backend.el
Index: xemacs-packages/erc/erc-backend.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/erc/erc-backend.el,v
retrieving revision 1.6
diff -u -r1.6 erc-backend.el
--- xemacs-packages/erc/erc-backend.el 2006/05/01 21:48:27 1.6
+++ xemacs-packages/erc/erc-backend.el 2009/08/13 14:27:37
＠＠ -1017,7 +1017,7 ＠＠
nil
(let ((target (first (erc-response.command-args parsed)))
(chnl (erc-response.contents parsed)))
- (multiple-value-bind (nick login host)
+ (destructuring-bind (nick login host)
(erc-parse-user (erc-response.sender parsed))
(setq erc-invitation chnl)
(when (string= target (erc-current-nick))
＠＠ -1031,7 +1031,7 ＠＠
nil
(let ((chnl (erc-response.contents parsed))
(buffer nil))
- (multiple-value-bind (nick login host)
+ (destructuring-bind (nick login host)
(erc-parse-user (erc-response.sender parsed))
;; strip the stupid combined JOIN facility (IRC 2.9)
(if (string-match "^\\(.*\\)?\^g.*$" chnl)
＠＠ -1072,7 +1072,7 ＠＠
(tgt (second (erc-response.command-args parsed)))
(reason (erc-trim-string (erc-response.contents parsed)))
(buffer (erc-get-buffer ch proc)))
- (multiple-value-bind (nick login host)
+ (destructuring-bind (nick login host)
(erc-parse-user (erc-response.sender parsed))
(erc-remove-channel-member buffer tgt)
(cond
＠＠ -1099,7 +1099,7 ＠＠
(let ((tgt (first (erc-response.command-args parsed)))
(mode (mapconcat 'identity (cdr (erc-response.command-args parsed))
" ")))
- (multiple-value-bind (nick login host)
+ (destructuring-bind (nick login host)
(erc-parse-user (erc-response.sender parsed))
(erc-log (format "MODE: %s -> %s: %s" nick tgt mode))
;; dirty hack
＠＠ -1124,7 +1124,7 ＠＠
"Handle nick change messages." nil
(let ((nn (erc-response.contents parsed))
bufs)
- (multiple-value-bind (nick login host)
+ (destructuring-bind (nick login host)
(erc-parse-user (erc-response.sender parsed))
(setq bufs (erc-buffer-list-with-nick nick proc))
(erc-log (format "NICK: %s -> %s" nick nn))
＠＠ -1162,7 +1162,7 ＠＠
(let* ((chnl (first (erc-response.command-args parsed)))
(reason (erc-trim-string (erc-response.contents parsed)))
(buffer (erc-get-buffer chnl proc)))
- (multiple-value-bind (nick login host)
+ (destructuring-bind (nick login host)
(erc-parse-user (erc-response.sender parsed))
(erc-remove-channel-member buffer nick)
(erc-display-message parsed 'notice buffer
＠＠ -1270,7 +1270,7 ＠＠
nil nil
(let ((reason (erc-response.contents parsed))
bufs)
- (multiple-value-bind (nick login host)
+ (destructuring-bind (nick login host)
(erc-parse-user (erc-response.sender parsed))
(setq bufs (erc-buffer-list-with-nick nick proc))
(erc-remove-user nick)
＠＠ -1284,7 +1284,7 ＠＠
(let* ((ch (first (erc-response.command-args parsed)))
(topic (erc-trim-string (erc-response.contents parsed)))
(time (format-time-string "%T %m/%d/%y" (current-time))))
- (multiple-value-bind (nick login host)
+ (destructuring-bind (nick login host)
(erc-parse-user (erc-response.sender parsed))
(erc-update-channel-member ch nick nick nil nil nil host login)
(erc-update-channel-topic ch (format "%s\C-o (%s, %s)" topic nick time))
＠＠ -1295,7 +1295,7 ＠＠
(define-erc-response-handler (WALLOPS)
nil nil
(let ((message (erc-response.contents parsed)))
- (multiple-value-bind (nick login host)
+ (destructuring-bind (nick login host)
(erc-parse-user (erc-response.sender parsed))
(erc-display-message
parsed 'notice nil
＠＠ -1325,7 +1325,7 ＠＠
(define-erc-response-handler (004)
nil nil
- (multiple-value-bind (server-name server-version)
+ (erc-destructuring-bind (server-name server-version)
(cdr (erc-response.command-args parsed))
(setq erc-server-version server-version)
(setq erc-server-announced-name server-name)
＠＠ -1419,7 +1419,7 ＠＠
"WHOIS/WHOWAS notices." nil
(let ((fname (erc-response.contents parsed))
(catalog-entry (intern (format "s%s" (erc-response.command parsed)))))
- (multiple-value-bind (nick user host)
+ (erc-destructuring-bind (nick user host)
(cdr (erc-response.command-args parsed))
(erc-update-user-nick nick nick host nil fname user)
(erc-display-message
＠＠ -1428,7 +1428,7 ＠＠
(define-erc-response-handler (312)
nil nil
- (multiple-value-bind (nick server-host)
+ (erc-destructuring-bind (nick server-host)
(cdr (erc-response.command-args parsed))
(erc-display-message
parsed 'notice 'active 's312
＠＠ -1450,7 +1450,7 ＠＠
(define-erc-response-handler (317)
"IDLE notice." nil
- (multiple-value-bind (nick seconds-idle on-since time)
+ (erc-destructuring-bind (nick seconds-idle on-since time)
(cdr (erc-response.command-args parsed))
(setq time (when on-since
(format-time-string "%T %Y/%m/%d"
＠＠ -1486,7 +1486,7 ＠＠
(define-erc-response-handler (322)
"LIST notice." nil
(let ((topic (erc-response.contents parsed)))
- (multiple-value-bind (channel num-users)
+ (erc-destructuring-bind (channel num-users)
(cdr (erc-response.command-args parsed))
(add-to-list 'erc-channel-list (list channel))
(erc-update-channel-topic channel topic)
＠＠ -1548,7 +1548,7 ＠＠
(define-erc-response-handler (333)
;; Who set the topic, and when
nil nil
- (multiple-value-bind (channel nick time)
+ (erc-destructuring-bind (channel nick time)
(cdr (erc-response.command-args parsed))
(setq time (format-time-string "%T %Y/%m/%d"
(erc-string-to-emacs-time time)))
＠＠ -1561,14 +1561,14 ＠＠
(define-erc-response-handler (341)
"Let user know when an INVITE attempt has been sent successfully."
nil
- (multiple-value-bind (nick channel)
+ (erc-destructuring-bind (nick channel)
(cdr (erc-response.command-args parsed))
(erc-display-message parsed 'notice (erc-get-buffer channel proc)
's341 ?n nick ?c channel)))
(define-erc-response-handler (352)
"WHO notice." nil
- (multiple-value-bind (channel user host server nick away-flag)
+ (erc-destructuring-bind (channel user host server nick away-flag)
(cdr (erc-response.command-args parsed))
(let ((full-name (erc-response.contents parsed))
hopcount)
＠＠ -1598,7 +1598,7 ＠＠
(define-erc-response-handler (367)
"Channel ban list entries" nil
- (multiple-value-bind (channel banmask setter time)
+ (erc-destructuring-bind (channel banmask setter time)
(cdr (erc-response.command-args parsed))
(erc-display-message parsed 'notice 'active 's367
?c channel
＠＠ -1617,7 +1617,7 ＠＠
;; FIXME: Yet more magic numbers in original code, I'm guessing this
;; command takes two arguments, and doesn't have any "contents". --
;; Lawrence 2004/05/10
- (multiple-value-bind (from to)
+ (erc-destructuring-bind (from to)
(cdr (erc-response.command-args parsed))
(erc-display-message parsed 'notice 'active
's379 ?c from ?f to)))
Index: xemacs-packages/erc/erc-compat.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/erc/erc-compat.el,v
retrieving revision 1.8
diff -u -r1.8 erc-compat.el
--- xemacs-packages/erc/erc-compat.el 2006/02/19 12:57:28 1.8
+++ xemacs-packages/erc/erc-compat.el 2009/08/13 14:27:37
＠＠ -423,6 +423,10 ＠＠
(setq i (1+ i) start (1+ start)))
res))))))
+(defmacro erc-destructuring-bind (args expr &rest body)
+ "Like `destructuring-bind', but don't error if ARGS don't fit EXPR."
+ `(loop for ,args = ,expr return (progn ,＠body)))
+
(provide 'erc-compat)
;;; erc-compat.el ends here
Index: xemacs-packages/erc/erc-list.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/erc/erc-list.el,v
retrieving revision 1.11
diff -u -r1.11 erc-list.el
--- xemacs-packages/erc/erc-list.el 2006/02/19 12:57:28 1.11
+++ xemacs-packages/erc/erc-list.el 2009/08/13 14:27:37
＠＠ -257,7 +257,7 ＠＠
The message carries information about one channel for the LIST
command."
- (multiple-value-bind (channel num-users)
+ (erc-destructuring-bind (channel num-users)
(cdr (erc-response.command-args parsed))
(let ((topic (erc-response.contents parsed)))
(with-current-buffer erc-chanlist-buffer
Index: xemacs-packages/erc/erc.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/erc/erc.el,v
retrieving revision 1.15
diff -u -r1.15 erc.el
--- xemacs-packages/erc/erc.el 2006/05/01 21:48:28 1.15
+++ xemacs-packages/erc/erc.el 2009/08/13 14:27:39
＠＠ -3934,7 +3934,7 ＠＠
(defun erc-banlist-store (proc parsed)
"Record ban entries for a channel."
- (multiple-value-bind (channel mask whoset)
+ (erc-destructuring-bind (channel mask whoset)
(cdr (erc-response.command-args parsed))
;; Determine to which buffer the message corresponds
(let ((buffer (erc-get-buffer channel proc)))
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 1 comments
[COMMIT 21.5]: lisp/minibuf.el
14 years, 8 months
Aidan Kehoe
Aidan Kehoe
Ar an ceathrú lá déag de mí Lúnasa, scríobh Julian Bradfield:
> When read-from-minibuffer is setting up things for the internal call,
> it chooses " *Minibuf-n" as the buffer for recursive minibuffers, but
> in the level 0 case it just grabs whatever buffer is currently
> displaying in the minibuffer window.
> This can't possibly be right, can it? It is partly responsible for the
> failure of quail to work in the minibuffer.
>
> Following patch fixes that. If correct, it should also be applied in
> 21.5.
There’s no history on why that code got in, it was in lemacs 19.9 and is
older than the original CVS import:
http://cvs.xemacs.org/viewcvs.cgi/XEmacs/xemacs-19/lisp/prim/minibuf.el
As far as I can tell, though, the problem you encountered was a workaround
to a typo--there should have been a trailing * in the format string, as
there is in the creation of the " *Minibuf-0*" buffer in minibuf.c. So the
code would have ended up creating both " *Minibuf-0" and " *Minibuf-0"
buffers, and if the typo wasn’t spotted, I can well imagine someone hacking
together that code.
I’m committing the change to 21.5. I don’t know if it’ll get into 21.4, but
a few months’ testing on 21.5 can only help with that.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1250273691 -3600
# Node ID 9a1a59b4b75d0ffdab4f7d90db48ec666770c24d
# Parent e95ddfd6a40963af74a093ee936a9bca77053bca
Correct an ancient typo workaround, thank you Julian Bradfield!
lisp/ChangeLog addition:
2009-08-14 Aidan Kehoe <kehoea(a)parhasard.net>
* minibuf.el (read-from-minibuffer):
Use buffer (format " *Minibuf-%d*" (minibuffer-depth)), regardless
of depth.
diff -r e95ddfd6a409 -r 9a1a59b4b75d lisp/ChangeLog
--- a/lisp/ChangeLog Mon Aug 03 10:30:47 2009 +0200
+++ b/lisp/ChangeLog Fri Aug 14 19:14:51 2009 +0100
＠＠ -1,3 +1,9 ＠＠
+2009-08-14 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * minibuf.el (read-from-minibuffer):
+ Use buffer (format " *Minibuf-%d*" (minibuffer-depth)), regardless
+ of depth.
+
2009-08-10 Aidan Kehoe <kehoea(a)parhasard.net>
* help.el (function-arglist, function-documentation):
diff -r e95ddfd6a409 -r 9a1a59b4b75d lisp/minibuf.el
--- a/lisp/minibuf.el Mon Aug 03 10:30:47 2009 +0200
+++ b/lisp/minibuf.el Fri Aug 14 19:14:51 2009 +0100
＠＠ -405,10 +405,8 ＠＠
(owindow (selected-window))
(oframe (selected-frame))
(window (minibuffer-window))
- (buffer (if (eq (minibuffer-depth) 0)
- (window-buffer window)
- (get-buffer-create (format " *Minibuf-%d"
- (minibuffer-depth)))))
+ (buffer (get-buffer-create (format " *Minibuf-%d*"
+ (minibuffer-depth))))
(frame (window-frame window))
(mconfig (if (eq frame (selected-frame))
nil (current-window-configuration frame)))
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments