Mercurial > hg > xemacs-beta
changeset 5438:8d29f1c4bb98
Merge with 21.5 trunk.
author | Mats Lidell <matsl@xemacs.org> |
---|---|
date | Fri, 26 Nov 2010 06:43:36 +0100 |
parents | 002cb5224e4f (current diff) 17c381a2f377 (diff) |
children | 771bf922ab2b |
files | lisp/cl-extra.el lisp/cl-macs.el src/abbrev.c src/alloc.c src/bytecode.c src/chartab.c src/cmds.c src/data.c src/elhash.c src/eval.c src/event-stream.c src/events.c src/events.h src/file-coding.c src/fileio.c src/fns.c src/font-mgr.c src/frame-msw.c src/glyphs.c src/indent.c src/intl-win32.c src/lisp.h src/lread.c src/mule-ccl.c src/number.h src/process-unix.c src/process.c src/profile.c src/unicode.c tests/automated/lisp-tests.el tests/automated/mule-tests.el |
diffstat | 34 files changed, 664 insertions(+), 191 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Mon Nov 15 22:33:52 2010 +0100 +++ b/lisp/ChangeLog Fri Nov 26 06:43:36 2010 +0100 @@ -1,3 +1,13 @@ +2010-11-17 Aidan Kehoe <kehoea@parhasard.net> + + * cl-extra.el (coerce): + In the argument list, name the first argument OBJECT, not X; the + former name was always used in the doc string and is clearer. + Handle vector type specifications which include the length of the + target sequence, error if there's a mismatch. + * cl-macs.el (cl-make-type-test): Handle type specifications + starting with the symbol 'eql. + 2010-11-14 Aidan Kehoe <kehoea@parhasard.net> * cl-macs.el (eql): Don't remove the byte-compile property of this
--- a/lisp/cl-extra.el Mon Nov 15 22:33:52 2010 +0100 +++ b/lisp/cl-extra.el Fri Nov 26 06:43:36 2010 +0100 @@ -51,47 +51,67 @@ ;;; Type coercion. -(defun coerce (x type) +(defun coerce (object type) "Coerce OBJECT to type TYPE. TYPE is a Common Lisp type specifier." - (cond ((eq type 'list) (if (listp x) x (append x nil))) - ((eq type 'vector) (if (vectorp x) x (vconcat x))) - ((eq type 'string) (if (stringp x) x (concat x))) - ((eq type 'array) (if (arrayp x) x (vconcat x))) - ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) - ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) + (cond ((eq type 'list) (if (listp object) object (append object nil))) + ((eq type 'vector) (if (vectorp object) object (vconcat object))) + ((eq type 'string) (if (stringp object) object (concat object))) + ((eq type 'array) (if (arrayp object) object (vconcat object))) + ((and (eq type 'character) (stringp object) + (eql (length object) 1)) (aref object 0)) + ((and (eq type 'character) (symbolp object)) + (coerce (symbol-name object) type)) ;; XEmacs addition character <-> integer coercions - ((and (eq type 'character) (char-int-p x)) (int-char x)) - ((and (memq type '(integer fixnum)) (characterp x)) (char-int x)) - ((eq type 'float) (float x)) + ((and (eq type 'character) (char-int-p object)) (int-char object)) + ((and (memq type '(integer fixnum)) (characterp object)) + (char-int object)) + ((eq type 'float) (float object)) ;; XEmacs addition: enhanced numeric type coercions ((and-fboundp 'coerce-number (memq type '(integer ratio bigfloat fixnum)) - (coerce-number x type))) + (coerce-number object type))) ;; XEmacs addition: bit-vector coercion ((or (eq type 'bit-vector) (eq type 'simple-bit-vector)) - (if (bit-vector-p x) x (apply 'bit-vector (append x nil)))) + (if (bit-vector-p object) + object + (apply 'bit-vector (append object nil)))) ;; XEmacs addition: weak-list coercion ((eq type 'weak-list) - (if (weak-list-p x) x + (if (weak-list-p object) object (let ((wl (make-weak-list))) - (set-weak-list-list wl (if (listp x) x (append x nil))) + (set-weak-list-list wl (if (listp object) + object + (append object nil))) wl))) ((and - (consp type) - (or (eq (car type) 'vector) - (eq (car type) 'simple-array) - (eq (car type) 'simple-vector)) - (cond - ((equal (cdr-safe type) '(*)) - (coerce x 'vector)) - ((equal (cdr-safe type) '(bit)) - (coerce x 'bit-vector)) - ((equal (cdr-safe type) '(character)) - (coerce x 'string))))) - ((typep x type) x) - (t (error "Can't coerce %s to type %s" x type)))) + (memq (car-safe type) '(vector simple-array)) + (loop + for (ignore elements length) = type + initially (declare (special ignore)) + return (if (or (memq length '(* nil)) (eql length (length object))) + (cond + ((memq elements '(t * nil)) + (coerce object 'vector)) + ((memq elements '(string-char character)) + (coerce object 'string)) + ((eq elements 'bit) + (coerce object 'bit-vector))) + (error + 'wrong-type-argument + "Type specifier length must equal sequence length" + type))))) + ((eq (car-safe type) 'simple-vector) + (coerce object (list* 'vector t (cdr type)))) + ((memq (car-safe type) + '(string simple-string base-string simple-base-string)) + (coerce object (list* 'vector 'character (cdr type)))) + ((eq (car-safe type) 'bit-vector) + (coerce object (list* 'vector 'bit (cdr type)))) + ((typep object type) object) + (t (error 'invalid-operation + "Can't coerce object to type" object type)))) ;; XEmacs; #'equalp is in C.
--- a/lisp/cl-macs.el Mon Nov 15 22:33:52 2010 +0100 +++ b/lisp/cl-macs.el Fri Nov 26 06:43:36 2010 +0100 @@ -3114,6 +3114,8 @@ (cdr type)))) ((memq (car-safe type) '(member member*)) (list 'and (list 'member* val (list 'quote (cdr type))) t)) + ((eq (car-safe type) 'eql) + (list 'eql (cadr type) val)) ((eq (car-safe type) 'satisfies) (list (cadr type) val)) (t (error "Bad type spec: %s" type)))))
--- a/src/ChangeLog Mon Nov 15 22:33:52 2010 +0100 +++ b/src/ChangeLog Fri Nov 26 06:43:36 2010 +0100 @@ -1,3 +1,90 @@ +2010-11-24 Aidan Kehoe <kehoea@parhasard.net> + + * font-mgr.c (Ffc_pattern_get): Fix my last change when both + --with-union-type and --with-xft are specified, thank you Robert + Delius Royar! + +2010-11-20 Aidan Kehoe <kehoea@parhasard.net> + + * abbrev.c (Fexpand_abbrev): + * alloc.c: + * alloc.c (Fmake_list): + * alloc.c (Fmake_vector): + * alloc.c (Fmake_bit_vector): + * alloc.c (Fmake_byte_code): + * alloc.c (Fmake_string): + * alloc.c (vars_of_alloc): + * bytecode.c (UNUSED): + * bytecode.c (Fbyte_code): + * chartab.c (decode_char_table_range): + * cmds.c (Fself_insert_command): + * data.c (check_integer_range): + * data.c (Fnatnump): + * data.c (Fnonnegativep): + * data.c (Fstring_to_number): + * elhash.c (hash_table_size_validate): + * elhash.c (decode_hash_table_size): + * eval.c (Fbacktrace_frame): + * event-stream.c (lisp_number_to_milliseconds): + * event-stream.c (Faccept_process_output): + * event-stream.c (Frecent_keys): + * event-stream.c (Fdispatch_event): + * events.c (Fmake_event): + * events.c (Fevent_timestamp): + * events.c (Fevent_timestamp_lessp): + * events.h: + * events.h (struct command_builder): + * file-coding.c (gzip_putprop): + * fns.c: + * fns.c (check_sequence_range): + * fns.c (Frandom): + * fns.c (Fnthcdr): + * fns.c (Flast): + * fns.c (Fnbutlast): + * fns.c (Fbutlast): + * fns.c (Fmember): + * fns.c (Ffill): + * fns.c (Freduce): + * fns.c (replace_string_range_1): + * fns.c (Freplace): + * font-mgr.c (Ffc_pattern_get): + * frame-msw.c (msprinter_set_frame_properties): + * glyphs.c (check_valid_xbm_inline): + * indent.c (Fmove_to_column): + * intl-win32.c (mswindows_multibyte_to_unicode_putprop): + * lisp.h: + * lisp.h (ARRAY_DIMENSION_LIMIT): + * lread.c (decode_mode_1): + * mule-ccl.c (ccl_get_compiled_code): + * number.h: + * process-unix.c (unix_open_multicast_group): + * process.c (Fset_process_window_size): + * profile.c (Fstart_profiling): + * unicode.c (Funicode_to_char): + Change NATNUMP to return 1 for positive bignums; changes uses of + it and of CHECK_NATNUM appropriately, usually by checking for an + integer in an appropriate range. + Add array-dimension-limit and use it in #'make-vector, + #'make-string. Add array-total-size-limit, array-rank-limit while + we're at it, for the sake of any Common Lisp-oriented code that + uses these limits. + Rename check_int_range to check_integer_range, have it take + Lisp_Objects (and thus bignums) instead. + Remove bignum_butlast(), just set int_n to an appropriately large + integer if N is a bignum. + Accept bignums in check_sequence_range(), change the functions + that use check_sequence_range() appropriately. + Move the definition of NATNUMP() to number.h; document why it's a + reasonable name, contradicting an old comment. + +2010-11-17 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (bignum_butlast): New. + (Fnbutlast, Fbutlast): Use it. + In #'butlast and #'nbutlast, if N is a bignum, we should always + return nil. Bug revealed by Paul Dietz' test suite, thank you + Paul. + 2010-11-15 Aidan Kehoe <kehoea@parhasard.net> * .gdbinit.in: Remove lrecord_type_popup_data,
--- a/src/abbrev.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/abbrev.c Fri Nov 26 06:43:36 2010 +0100 @@ -341,7 +341,7 @@ count = Qzero; else CHECK_NATNUM (count); - symbol_plist (abbrev_symbol) = make_int (1 + XINT (count)); + symbol_plist (abbrev_symbol) = Fadd1 (count); /* Count the case in the original text. */ abbrev_count_case (buf, abbrev_start, abbrev_length, &lccount, &uccount);
--- a/src/alloc.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/alloc.c Fri Nov 26 06:43:36 2010 +0100 @@ -94,6 +94,8 @@ static Fixnum debug_allocation_backtrace_length; #endif +Fixnum Varray_dimension_limit, Varray_total_size_limit, Varray_rank_limit; + int need_to_check_c_alloca; int need_to_signal_post_gc; int funcall_allocation_flag; @@ -1498,16 +1500,17 @@ */ (length, object)) { - CHECK_NATNUM (length); - - { - Lisp_Object val = Qnil; - EMACS_INT size = XINT (length); - - while (size--) - val = Fcons (object, val); - return val; - } + Lisp_Object val = Qnil; + Elemcount size; + + check_integer_range (length, Qzero, make_integer (EMACS_INT_MAX)); + + size = XINT (length); + + while (size--) + val = Fcons (object, val); + + return val; } @@ -1741,7 +1744,7 @@ */ (length, object)) { - CONCHECK_NATNUM (length); + check_integer_range (length, Qzero, make_int (ARRAY_DIMENSION_LIMIT)); return make_vector (XINT (length), object); } @@ -1923,8 +1926,7 @@ */ (length, bit)) { - CONCHECK_NATNUM (length); - + check_integer_range (length, Qzero, make_int (ARRAY_DIMENSION_LIMIT)); return make_bit_vector (XINT (length), bit); } @@ -2050,7 +2052,7 @@ CHECK_VECTOR (constants); f->constants = constants; - CHECK_NATNUM (stack_depth); + check_integer_range (stack_depth, Qzero, make_int (USHRT_MAX)); f->stack_depth = (unsigned short) XINT (stack_depth); #ifdef COMPILED_FUNCTION_ANNOTATION_HACK @@ -2882,7 +2884,7 @@ */ (length, character)) { - CHECK_NATNUM (length); + check_integer_range (length, Qzero, make_int (ARRAY_DIMENSION_LIMIT)); CHECK_CHAR_COERCE_INT (character); { Ibyte init_str[MAX_ICHAR_LEN]; @@ -5737,6 +5739,34 @@ void vars_of_alloc (void) { + DEFVAR_CONST_INT ("array-rank-limit", &Varray_rank_limit /* +The exclusive upper bound on the number of dimensions an array may have. + +XEmacs does not support multidimensional arrays, meaning this constant is, +for the moment, 2. +*/); + Varray_rank_limit = 2; + + DEFVAR_CONST_INT ("array-dimension-limit", &Varray_dimension_limit /* +The exclusive upper bound of an array's dimension. +Note that XEmacs may not have enough memory available to create an array +with this dimension. +*/); + Varray_dimension_limit = ARRAY_DIMENSION_LIMIT; + + DEFVAR_CONST_INT ("array-total-size-limit", &Varray_total_size_limit /* +The exclusive upper bound on the number of elements an array may contain. + +In Common Lisp, this is distinct from `array-dimension-limit', because +arrays can have more than one dimension. In XEmacs this is not the case, +and multi-dimensional arrays need to be implemented by the user with arrays +of arrays. + +Note that XEmacs may not have enough memory available to create an array +with this dimension. +*/); + Varray_total_size_limit = ARRAY_DIMENSION_LIMIT; + #ifdef DEBUG_XEMACS DEFVAR_INT ("debug-allocation", &debug_allocation /* If non-zero, print out information to stderr about all objects allocated.
--- a/src/bytecode.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/bytecode.c Fri Nov 26 06:43:36 2010 +0100 @@ -1729,8 +1729,9 @@ { Lisp_Object upper = POP, first = TOP, speccount; - CHECK_NATNUM (upper); - CHECK_NATNUM (first); + check_integer_range (upper, Qzero, + make_integer (Vmultiple_values_limit)); + check_integer_range (first, Qzero, upper); speccount = make_int (bind_multiple_value_limits (XINT (first), XINT (upper))); @@ -2755,7 +2756,7 @@ CHECK_STRING (instructions); CHECK_VECTOR (constants); - CHECK_NATNUM (stack_depth); + check_integer_range (stack_depth, Qzero, make_int (USHRT_MAX)); /* Optimize the `instructions' string, just like when executing a regular compiled function, but don't save it for later since this is
--- a/src/chartab.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/chartab.c Fri Nov 26 06:43:36 2010 +0100 @@ -255,10 +255,12 @@ sferror ("Charset in row vector must be multi-byte", outrange->charset); case CHARSET_TYPE_94X94: - check_int_range (outrange->row, 33, 126); + check_integer_range (make_int (outrange->row), make_int (33), + make_int (126)); break; case CHARSET_TYPE_96X96: - check_int_range (outrange->row, 32, 127); + check_integer_range (make_int (outrange->row), make_int (32), + make_int (127)); break; default: ABORT ();
--- a/src/cmds.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/cmds.c Fri Nov 26 06:43:36 2010 +0100 @@ -332,7 +332,9 @@ Lisp_Object c; EMACS_INT n; - CHECK_NATNUM (count); + /* Can't insert more than most-positive-fixnum characters, the buffer + won't hold that many. */ + check_integer_range (count, Qzero, make_int (EMACS_INT_MAX)); n = XINT (count); if (CHAR_OR_CHAR_INTP (Vlast_command_char))
--- a/src/data.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/data.c Fri Nov 26 06:43:36 2010 +0100 @@ -156,10 +156,18 @@ } void -check_int_range (EMACS_INT val, EMACS_INT min, EMACS_INT max) +check_integer_range (Lisp_Object val, Lisp_Object min, Lisp_Object max) { - if (val < min || val > max) - args_out_of_range_3 (make_int (val), make_int (min), make_int (max)); + Lisp_Object args[] = { min, val, max }; + int ii; + + for (ii = 0; ii < countof (args); ii++) + { + CHECK_INTEGER (args[ii]); + } + + if (NILP (Fleq (countof (args), args))) + args_out_of_range_3 (val, min, max); } @@ -502,11 +510,7 @@ */ (object)) { - return NATNUMP (object) -#ifdef HAVE_BIGNUM - || (BIGNUMP (object) && bignum_sign (XBIGNUM_DATA (object)) >= 0) -#endif - ? Qt : Qnil; + return NATNUMP (object) ? Qt : Qnil; } DEFUN ("nonnegativep", Fnonnegativep, 1, 1, 0, /* @@ -515,9 +519,6 @@ (object)) { return NATNUMP (object) -#ifdef HAVE_BIGNUM - || (BIGNUMP (object) && bignum_sign (XBIGNUM_DATA (object)) >= 0) -#endif #ifdef HAVE_RATIO || (RATIOP (object) && ratio_sign (XRATIO_DATA (object)) >= 0) #endif @@ -1293,9 +1294,8 @@ b = 10; else { - CHECK_INT (base); + check_integer_range (base, make_int (2), make_int (16)); b = XINT (base); - check_int_range (b, 2, 16); } p = XSTRING_DATA (string);
--- a/src/elhash.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/elhash.c Fri Nov 26 06:43:36 2010 +0100 @@ -731,10 +731,27 @@ Error_Behavior errb) { if (NATNUMP (value)) - return 1; + { + if (BIGNUMP (value)) + { + /* hash_table_size() can't handle excessively large sizes. */ + maybe_signal_error_1 (Qargs_out_of_range, + list3 (value, Qzero, + make_integer (EMACS_INT_MAX)), + Qhash_table, errb); + return 0; + } + else + { + return 1; + } + } + else + { + maybe_signal_error_1 (Qwrong_type_argument, list2 (Qnatnump, value), + Qhash_table, errb); + } - maybe_signal_error_1 (Qwrong_type_argument, list2 (Qnatnump, value), - Qhash_table, errb); return 0; }
--- a/src/eval.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/eval.c Fri Nov 26 06:43:36 2010 +0100 @@ -4921,17 +4921,19 @@ } 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]); + + check_integer_range (argv[1], Qzero, make_int (EMACS_INT_MAX)); + check_integer_range (argv[0], Qzero, argv[1]); + upper = XINT (argv[1]); + first = XINT (argv[0]); + gcpro1.nvars = 2; /* The unintuitive order of things here is for the sake of the bytecode; @@ -7203,7 +7205,7 @@ REGISTER int i; Lisp_Object tem; - CHECK_NATNUM (nframes); + check_integer_range (nframes, Qzero, make_integer (EMACS_INT_MAX)); /* Find the frame requested. */ for (i = XINT (nframes); backlist && (i-- > 0);)
--- a/src/event-stream.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/event-stream.c Fri Nov 26 06:43:36 2010 +0100 @@ -1236,18 +1236,30 @@ static unsigned long lisp_number_to_milliseconds (Lisp_Object secs, int allow_0) { - double fsecs; - CHECK_INT_OR_FLOAT (secs); - fsecs = XFLOATINT (secs); - if (fsecs < 0) - invalid_argument ("timeout is negative", secs); - if (!allow_0 && fsecs == 0) - invalid_argument ("timeout is non-positive", secs); - if (fsecs >= (((unsigned int) 0xFFFFFFFF) / 1000)) - invalid_argument - ("timeout would exceed 32 bits when represented in milliseconds", secs); - - return (unsigned long) (1000 * fsecs); + Lisp_Object args[] = { allow_0 ? Qzero : make_int (1), + secs, + /* (((unsigned int) 0xFFFFFFFF) / 1000) - 1 */ + make_int (4294967 - 1) }; + + if (!allow_0 && FLOATP (secs) && XFLOAT_DATA (secs) > 0) + { + args[0] = secs; + } + + if (NILP (Fleq (countof (args), args))) + { + args_out_of_range_3 (secs, args[0], args[2]); + } + + args[0] = make_int (1000); + args[0] = Ftimes (2, args); + + if (INTP (args[0])) + { + return XINT (args[0]); + } + + return (unsigned long) extract_float (args[0]); } DEFUN ("add-timeout", Fadd_timeout, 3, 4, 0, /* @@ -2613,7 +2625,8 @@ msecs = lisp_number_to_milliseconds (timeout_secs, 1); if (!NILP (timeout_msecs)) { - CHECK_NATNUM (timeout_msecs); + check_integer_range (timeout_msecs, Qzero, + make_integer (EMACS_INT_MAX)); msecs += XINT (timeout_msecs); } if (msecs) @@ -3702,7 +3715,8 @@ nwanted = recent_keys_ring_size; else { - CHECK_NATNUM (number); + check_integer_range (number, Qzero, + make_integer (ARRAY_DIMENSION_LIMIT)); nwanted = XINT (number); } @@ -4517,7 +4531,7 @@ else /* key sequence is bound to a command */ { int magic_undo = 0; - int magic_undo_count = 20; + Elemcount magic_undo_count = 20; Vthis_command = leaf; @@ -4537,7 +4551,21 @@ { Lisp_Object prop = Fget (leaf, Qself_insert_defer_undo, Qnil); if (NATNUMP (prop)) - magic_undo = 1, magic_undo_count = XINT (prop); + { + magic_undo = 1; + if (INTP (prop)) + { + magic_undo_count = XINT (prop); + } +#ifdef HAVE_BIGNUM + else if (BIGNUMP (prop) + && bignum_fits_emacs_int_p (XBIGNUM_DATA (prop))) + { + magic_undo_count + = bignum_to_emacs_int (XBIGNUM_DATA (prop)); + } +#endif + } else if (!NILP (prop)) magic_undo = 1; else if (EQ (leaf, Qself_insert_command))
--- a/src/events.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/events.c Fri Nov 26 06:43:36 2010 +0100 @@ -639,8 +639,7 @@ } else if (EQ (keyword, Qbutton)) { - CHECK_NATNUM (value); - check_int_range (XINT (value), 0, 7); + check_integer_range (value, Qzero, make_int (26)); switch (EVENT_TYPE (e)) { @@ -735,8 +734,23 @@ } else if (EQ (keyword, Qtimestamp)) { - CHECK_NATNUM (value); - SET_EVENT_TIMESTAMP (e, XINT (value)); +#ifdef HAVE_BIGNUM + check_integer_range (value, Qzero, make_integer (UINT_MAX)); + if (BIGNUMP (value)) + { + SET_EVENT_TIMESTAMP (e, bignum_to_uint (XBIGNUM_DATA (value))); + } +#else + check_integer_range (value, Qzero, make_integer (EMACS_INT_MAX)); +#endif + if (INTP (value)) + { + SET_EVENT_TIMESTAMP (e, XINT (value)); + } + else + { + ABORT (); + } } else if (EQ (keyword, Qfunction)) { @@ -1745,7 +1759,9 @@ { CHECK_LIVE_EVENT (event); /* This junk is so that timestamps don't get to be negative, but contain - as many bits as this particular emacs will allow. + as many bits as this particular emacs will allow. We could return + bignums on builds that support them, but that involves consing and + doesn't work on builds that don't support bignums. */ return make_int (EMACS_INT_MAX & XEVENT_TIMESTAMP (event)); } @@ -1761,8 +1777,9 @@ { EMACS_INT t1, t2; - CHECK_NATNUM (time1); - CHECK_NATNUM (time2); + check_integer_range (time1, Qzero, make_integer (EMACS_INT_MAX)); + check_integer_range (time2, Qzero, make_integer (EMACS_INT_MAX)); + t1 = XINT (time1); t2 = XINT (time2);
--- a/src/events.h Mon Nov 15 22:33:52 2010 +0100 +++ b/src/events.h Fri Nov 26 06:43:36 2010 +0100 @@ -1157,7 +1157,7 @@ boundary: up to 20 consecutive self-inserts can happen before an undo- boundary is pushed. This variable is that counter. */ - int self_insert_countdown; + Elemcount self_insert_countdown; }; #endif /* INCLUDED_events_h_ */
--- a/src/file-coding.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/file-coding.c Fri Nov 26 06:43:36 2010 +0100 @@ -4308,8 +4308,7 @@ data->level = -1; else { - CHECK_INT (value); - check_int_range (XINT (value), 0, 9); + check_integer_range (value, Qzero, make_int (9)); data->level = XINT (value); } }
--- a/src/fileio.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/fileio.c Fri Nov 26 06:43:36 2010 +0100 @@ -3292,7 +3292,7 @@ Lisp_Object insval = call1 (p, make_int (inserted)); if (!NILP (insval)) { - CHECK_NATNUM (insval); + check_integer_range (insval, Qzero, make_int (EMACS_INT_MAX)); inserted = XINT (insval); } }
--- a/src/fns.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/fns.c Fri Nov 26 06:43:36 2010 +0100 @@ -76,13 +76,11 @@ check_sequence_range (Lisp_Object sequence, Lisp_Object start, Lisp_Object end, Lisp_Object length) { - Elemcount starting = XINT (start), ending, len = XINT (length); - - ending = NILP (end) ? XINT (length) : XINT (end); - - if (!(0 <= starting && starting <= ending && ending <= len)) - { - args_out_of_range_3 (sequence, start, make_int (ending)); + Lisp_Object args[] = { Qzero, start, NILP (end) ? length : end, length }; + + if (NILP (Fleq (countof (args), args))) + { + args_out_of_range_3 (sequence, start, end); } } @@ -226,6 +224,13 @@ seed_random (qxe_getpid () + time (NULL)); if (NATNUMP (limit) && !ZEROP (limit)) { +#ifdef HAVE_BIGNUM + if (BIGNUMP (limit)) + { + bignum_random (scratch_bignum, XBIGNUM_DATA (limit)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } +#endif /* Try to take our random number from the higher bits of VAL, not the lower, since (says Gentzel) the low bits of `random' are less random than the higher ones. We do this by using the @@ -238,13 +243,6 @@ val = get_random () / denominator; while (val >= XINT (limit)); } -#ifdef HAVE_BIGNUM - else if (BIGNUMP (limit)) - { - bignum_random (scratch_bignum, XBIGNUM_DATA (limit)); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); - } -#endif else val = get_random (); @@ -1434,7 +1432,7 @@ REGISTER EMACS_INT i; REGISTER Lisp_Object tail = list; CHECK_NATNUM (n); - for (i = XINT (n); i; i--) + for (i = BIGNUMP (n) ? 1 + EMACS_INT_MAX : XINT (n); i; i--) { if (CONSP (tail)) tail = XCDR (tail); @@ -1554,7 +1552,7 @@ else { CHECK_NATNUM (n); - int_n = XINT (n); + int_n = BIGNUMP (n) ? 1 + EMACS_INT_MAX : XINT (n); } for (retval = tortoise = hare = list, count = 0; @@ -1589,7 +1587,7 @@ if (!NILP (n)) { CHECK_NATNUM (n); - int_n = XINT (n); + int_n = BIGNUMP (n) ? 1 + EMACS_INT_MAX : XINT (n); } if (CONSP (list)) @@ -1637,7 +1635,7 @@ if (!NILP (n)) { CHECK_NATNUM (n); - int_n = XINT (n); + int_n = BIGNUMP (n) ? 1 + EMACS_INT_MAX : XINT (n); } if (CONSP (list)) @@ -4173,17 +4171,15 @@ { Lisp_Object sequence = args[0]; Lisp_Object item = args[1]; - Elemcount starting = 0, ending = EMACS_INT_MAX, ii, len; + Elemcount starting = 0, ending = EMACS_INT_MAX + 1, ii, len; PARSE_KEYWORDS (Ffill, nargs, args, 2, (start, end), (start = Qzero)); CHECK_NATNUM (start); - starting = XINT (start); - if (!NILP (end)) { CHECK_NATNUM (end); - ending = XINT (end); + ending = BIGNUMP (end) ? EMACS_INT_MAX + 1 : XINT (end); } retry: @@ -4203,6 +4199,7 @@ check_sequence_range (sequence, start, end, make_int (len)); ending = min (ending, len); + starting = XINT (start); for (ii = starting; ii < ending; ++ii) { @@ -4221,6 +4218,7 @@ check_sequence_range (sequence, start, end, make_int (len)); ending = min (ending, len); + starting = XINT (start); for (ii = starting; ii < ending; ++ii) { @@ -4230,6 +4228,7 @@ else if (LISTP (sequence)) { Elemcount counting = 0; + starting = BIGNUMP (start) ? EMACS_INT_MAX + 1 : XINT (start); EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { @@ -5184,7 +5183,7 @@ (int nargs, Lisp_Object *args)) { Lisp_Object function = args[0], sequence = args[1], accum = Qunbound; - Elemcount starting, ending = EMACS_INT_MAX, ii = 0; + Elemcount starting, ending = EMACS_INT_MAX + 1, ii = 0; PARSE_KEYWORDS (Freduce, nargs, args, 5, (start, end, from_end, initial_value, key), @@ -5192,7 +5191,7 @@ CHECK_SEQUENCE (sequence); CHECK_NATNUM (start); - + starting = BIGNUMP (start) ? EMACS_INT_MAX + 1 : XINT (start); CHECK_KEY_ARGUMENT (key); #define KEY(key, item) (EQ (Qidentity, key) ? item : \ @@ -5200,16 +5199,10 @@ #define CALL2(function, accum, item) \ IGNORE_MULTIPLE_VALUES (call2 (function, accum, item)) - starting = XINT (start); if (!NILP (end)) { CHECK_NATNUM (end); - ending = XINT (end); - } - - if (!(starting <= ending)) - { - check_sequence_range (sequence, start, end, Flength (sequence)); + ending = BIGNUMP (end) ? EMACS_INT_MAX + 1 : XINT (end); } if (VECTORP (sequence)) @@ -5381,6 +5374,8 @@ check_sequence_range (sequence, start, end, make_int (len)); ending = min (ending, len); + starting = XINT (start); + cursor = string_char_addr (sequence, ending - 1); cursor_offset = cursor - XSTRING_DATA (sequence); @@ -5628,7 +5623,8 @@ Ibyte *destp = XSTRING_DATA (dest), *p = destp, *pend = p + XSTRING_LENGTH (dest), *pcursor, item_buf[MAX_ICHAR_LEN]; Bytecount prefix_bytecount, source_len = source_limit - source; - Charcount ii = 0, starting = XINT (start), ending, len; + Charcount ii = 0, ending, len; + Charcount starting = BIGNUMP (start) ? EMACS_INT_MAX + 1 : XINT (start); Elemcount delta; while (ii < starting && p < pend) @@ -5651,7 +5647,7 @@ } else { - ending = XINT (end); + ending = BIGNUMP (end) ? EMACS_INT_MAX + 1 : XINT (end); while (ii < ending && pcursor < pend) { INC_IBYTEPTR (pcursor); @@ -5731,8 +5727,8 @@ { Lisp_Object sequence1 = args[0], sequence2 = args[1], result = sequence1; - Elemcount starting1, ending1 = EMACS_INT_MAX, starting2; - Elemcount ending2 = EMACS_INT_MAX, counting = 0, startcounting; + Elemcount starting1, ending1 = EMACS_INT_MAX + 1, starting2; + Elemcount ending2 = EMACS_INT_MAX + 1, counting = 0, startcounting; Boolint sequence1_listp, sequence2_listp, overwriting = EQ (sequence1, sequence2); @@ -5745,30 +5741,20 @@ CHECK_SEQUENCE (sequence2); CHECK_NATNUM (start1); - starting1 = XINT (start1); + starting1 = BIGNUMP (start1) ? EMACS_INT_MAX + 1 : XINT (start1); CHECK_NATNUM (start2); - starting2 = XINT (start2); + starting2 = BIGNUMP (start2) ? EMACS_INT_MAX + 1 : XINT (start2); if (!NILP (end1)) { CHECK_NATNUM (end1); - ending1 = XINT (end1); - - if (!(starting1 <= ending1)) - { - args_out_of_range_3 (sequence1, start1, end1); - } + ending1 = BIGNUMP (end1) ? EMACS_INT_MAX + 1 : XINT (end1); } if (!NILP (end2)) { CHECK_NATNUM (end2); - ending2 = XINT (end2); - - if (!(starting2 <= ending2)) - { - args_out_of_range_3 (sequence1, start2, end2); - } + ending2 = BIGNUMP (end2) ? EMACS_INT_MAX + 1 : XINT (end2); } sequence1_listp = LISTP (sequence1);
--- a/src/font-mgr.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/font-mgr.c Fri Nov 26 06:43:36 2010 +0100 @@ -409,6 +409,7 @@ Extbyte *fc_property; FcResult fc_result; FcValue fc_value; + int int_id = 0; /* process arguments @@ -433,14 +434,21 @@ dead_wrong_type_argument (Qstringp, property); } - if (!NILP (id)) CHECK_NATNUM (id); + if (!NILP (id)) + { +#ifdef HAVE_BIGNUM + check_integer_range (id, Qzero, make_integer (INT_MAX)); + int_id = BIGNUMP (id) ? bignum_to_int (XBIGNUM_DATA (id)) : XINT (id); +#else + check_integer_range (id, Qzero, make_integer (EMACS_INT_MAX)); + int_id = XINT (id); +#endif + } if (!NILP (type)) CHECK_SYMBOL (type); /* get property */ fc_result = FcPatternGet (XFC_PATTERN_PTR (pattern), - fc_property, - NILP (id) ? 0 : XINT (id), - &fc_value); + fc_property, int_id, &fc_value); switch (fc_result) {
--- a/src/frame-msw.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/frame-msw.c Fri Nov 26 06:43:36 2010 +0100 @@ -1091,8 +1091,15 @@ maybe_error_if_job_active (f); if (!NILP (val)) { - CHECK_NATNUM (val); - FRAME_MSPRINTER_CHARWIDTH (f) = XINT (val); +#ifdef HAVE_BIGNUM + check_integer_range (val, Qzero, make_integer (INT_MAX)); + FRAME_MSPRINTER_CHARWIDTH (f) = + BIGNUMP (val) ? bignum_to_int (XBIGNUM_DATA (val)) : + XINT (val); +#else + CHECK_NATNUM (val); + FRAME_MSPRINTER_CHARWIDTH (f) = XINT (val); +#endif } } if (EQ (prop, Qheight)) @@ -1100,33 +1107,68 @@ maybe_error_if_job_active (f); if (!NILP (val)) { +#ifdef HAVE_BIGNUM + check_integer_range (val, Qzero, make_integer (INT_MAX)); + FRAME_MSPRINTER_CHARHEIGHT (f) = + BIGNUMP (val) ? bignum_to_int (XBIGNUM_DATA (val)) : + XINT (val); +#else CHECK_NATNUM (val); FRAME_MSPRINTER_CHARHEIGHT (f) = XINT (val); +#endif } } else if (EQ (prop, Qleft_margin)) { maybe_error_if_job_active (f); +#ifdef HAVE_BIGNUM + check_integer_range (val, Qzero, make_integer (INT_MAX)); + FRAME_MSPRINTER_LEFT_MARGIN (f) = + BIGNUMP (val) ? bignum_to_int (XBIGNUM_DATA (val)) : + XINT (val); +#else CHECK_NATNUM (val); FRAME_MSPRINTER_LEFT_MARGIN (f) = XINT (val); +#endif } else if (EQ (prop, Qtop_margin)) { maybe_error_if_job_active (f); +#ifdef HAVE_BIGNUM + check_integer_range (val, Qzero, make_integer (INT_MAX)); + FRAME_MSPRINTER_TOP_MARGIN (f) = + BIGNUMP (val) ? bignum_to_int (XBIGNUM_DATA (val)) : + XINT (val); +#else CHECK_NATNUM (val); FRAME_MSPRINTER_TOP_MARGIN (f) = XINT (val); +#endif } else if (EQ (prop, Qright_margin)) { maybe_error_if_job_active (f); +#ifdef HAVE_BIGNUM + check_integer_range (val, Qzero, make_integer (INT_MAX)); + FRAME_MSPRINTER_RIGHT_MARGIN (f) = + BIGNUMP (val) ? bignum_to_int (XBIGNUM_DATA (val)) : + XINT (val); +#else CHECK_NATNUM (val); FRAME_MSPRINTER_RIGHT_MARGIN (f) = XINT (val); +#endif } else if (EQ (prop, Qbottom_margin)) { maybe_error_if_job_active (f); +#ifdef HAVE_BIGNUM + check_integer_range (val, Qzero, make_integer (INT_MAX)); + FRAME_MSPRINTER_BOTTOM_MARGIN (f) = + BIGNUMP (val) ? bignum_to_int (XBIGNUM_DATA (val)) : + XINT (val); +#else CHECK_NATNUM (val); FRAME_MSPRINTER_BOTTOM_MARGIN (f) = XINT (val); +#endif } } }
--- a/src/glyphs.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/glyphs.c Fri Nov 26 06:43:36 2010 +0100 @@ -2628,7 +2628,7 @@ static void check_valid_xbm_inline (Lisp_Object data) { - Lisp_Object width, height, bits; + Lisp_Object width, height, bits, args[2]; if (!CONSP (data) || !CONSP (XCDR (data)) || @@ -2648,7 +2648,16 @@ if (!NATNUMP (height)) invalid_argument ("Height must be a natural number", height); - if (((XINT (width) * XINT (height)) / 8) > string_char_length (bits)) + args[0] = width; + args[1] = height; + + args[0] = Ftimes (countof (args), args); + args[1] = make_integer (8); + + args[0] = Fquo (countof (args), args); + args[1] = make_integer (string_char_length (bits)); + + if (!NILP (Fgtr (countof (args), args))) invalid_argument ("data is too short for width and height", vector3 (width, height, bits)); }
--- a/src/indent.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/indent.c Fri Nov 26 06:43:36 2010 +0100 @@ -410,7 +410,8 @@ buffer = wrap_buffer (buf); if (tab_width <= 0 || tab_width > 1000) tab_width = 8; - CHECK_NATNUM (column); + + check_integer_range (column, Qzero, make_integer (EMACS_INT_MAX)); goal = XINT (column); retry:
--- a/src/intl-win32.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/intl-win32.c Fri Nov 26 06:43:36 2010 +0100 @@ -1790,9 +1790,14 @@ data->cp_type = MULTIBYTE_MAC; else { - CHECK_NATNUM (value); data->locale_type = MULTIBYTE_SPECIFIED_CODE_PAGE; - data->cp = XINT (value); +#ifdef HAVE_BIGNUM + check_integer_range (value, Qzero, make_integer (INT_MAX)); + data->cp = BIGNUMP (value) ? bignum_to_int (XBIGNUM_DATA (value)) : XINT (value); +#else + CHECK_NATNUM (value); + data->cp = XINT (value); +#endif } } else if (EQ (key, Qlocale))
--- a/src/lisp.h Mon Nov 15 22:33:52 2010 +0100 +++ b/src/lisp.h Fri Nov 26 06:43:36 2010 +0100 @@ -1677,6 +1677,10 @@ #define INT_VALBITS (BITS_PER_EMACS_INT - INT_GCBITS) #define VALBITS (BITS_PER_EMACS_INT - GCBITS) +/* This is badly named; it's not the maximum value that an EMACS_INT can + have, it's the maximum value that a Lisp-visible fixnum can have (half + the maximum value an EMACS_INT can have) and as such would be better + called MOST_POSITIVE_FIXNUM. Similarly for MOST_NEGATIVE_FIXNUM. */ #define EMACS_INT_MAX ((EMACS_INT) ((1UL << (INT_VALBITS - 1)) -1UL)) #define EMACS_INT_MIN (-(EMACS_INT_MAX) - 1) /* WARNING: evaluates its arg twice. */ @@ -2921,22 +2925,6 @@ x = wrong_type_argument (Qfixnump, x); \ } while (0) -/* NOTE NOTE NOTE! This definition of "natural number" is mathematically - wrong. Mathematically, a natural number is a positive integer; 0 - isn't included. This would be better called NONNEGINT(). */ - -#define NATNUMP(x) (INTP (x) && XINT (x) >= 0) - -#define CHECK_NATNUM(x) do { \ - if (!NATNUMP (x)) \ - dead_wrong_type_argument (Qnatnump, x); \ -} while (0) - -#define CONCHECK_NATNUM(x) do { \ - if (!NATNUMP (x)) \ - x = wrong_type_argument (Qnatnump, x); \ -} while (0) - END_C_DECLS /* -------------- properties of internally-formatted text ------------- */ @@ -4316,6 +4304,8 @@ void disksave_object_finalization (void); void finish_object_memory_usage_stats (void); extern int purify_flag; +#define ARRAY_DIMENSION_LIMIT EMACS_INT_MAX +extern Fixnum Varray_dimension_limit; #ifndef NEW_GC extern EMACS_INT gc_generation_number[1]; #endif /* not NEW_GC */ @@ -4503,7 +4493,7 @@ MODULE_API Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object); MODULE_API DECLARE_DOESNT_RETURN (dead_wrong_type_argument (Lisp_Object, Lisp_Object)); -void check_int_range (EMACS_INT, EMACS_INT, EMACS_INT); +void check_integer_range (Lisp_Object, Lisp_Object, Lisp_Object); EXFUN (Fint_to_char, 1); EXFUN (Fchar_to_int, 1); @@ -4529,11 +4519,11 @@ Qnonnegativep, Qnumber_char_or_marker_p, Qnumberp, Qquote, Qtrue_list_p; extern MODULE_API Lisp_Object Qintegerp; -extern Lisp_Object Qarith_error, Qbeginning_of_buffer, Qbuffer_read_only, - Qcircular_list, Qcircular_property_list, Qconversion_error, - Qcyclic_variable_indirection, Qdomain_error, Qediting_error, - Qend_of_buffer, Qend_of_file, Qerror, Qfile_error, Qinternal_error, - Qinvalid_change, Qinvalid_constant, Qinvalid_function, +extern Lisp_Object Qargs_out_of_range, Qarith_error, Qbeginning_of_buffer, + Qbuffer_read_only, Qcircular_list, Qcircular_property_list, + Qconversion_error, Qcyclic_variable_indirection, Qdomain_error, + Qediting_error, Qend_of_buffer, Qend_of_file, Qerror, Qfile_error, + Qinternal_error, Qinvalid_change, Qinvalid_constant, Qinvalid_function, Qinvalid_keyword_argument, Qinvalid_operation, Qinvalid_read_syntax, Qinvalid_state, Qio_error, Qlist_formation_error, Qmalformed_list, Qmalformed_property_list, Qno_catch, Qout_of_memory, @@ -4542,6 +4532,7 @@ Qstructure_formation_error, Qtext_conversion_error, Qunderflow_error, Qvoid_function, Qvoid_variable, Qwrong_number_of_arguments, Qwrong_type_argument; + extern Lisp_Object Qcdr; extern Lisp_Object Qerror_lacks_explanatory_string; extern Lisp_Object Qfile_error; @@ -5008,6 +4999,7 @@ MODULE_API void warn_when_safe (Lisp_Object, Lisp_Object, const Ascbyte *, ...) PRINTF_ARGS (3, 4); extern int backtrace_with_internal_sections; +extern Fixnum Vmultiple_values_limit; extern Lisp_Object Qand_optional; extern Lisp_Object Qand_rest;
--- a/src/lread.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/lread.c Fri Nov 26 06:43:36 2010 +0100 @@ -842,9 +842,9 @@ return W_OK; else if (EQ (mode, Qreadable)) return R_OK; - else if (INTP (mode)) + else if (INTEGERP (mode)) { - check_int_range (XINT (mode), 0, 7); + check_integer_range (mode, Qzero, make_int (7)); return XINT (mode); } else
--- a/src/mule-ccl.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/mule-ccl.c Fri Nov 26 06:43:36 2010 +0100 @@ -2121,7 +2121,7 @@ val = Fget (ccl_prog, Qccl_program_idx, Qnil); if (! NATNUMP (val) - || XINT (val) >= XVECTOR_LENGTH (Vccl_program_table)) + || -1 != bytecode_arithcompare (val, Flength (Vccl_program_table))) return Qnil; slot = XVECTOR_DATA (Vccl_program_table)[XINT (val)]; if (! VECTORP (slot)
--- a/src/number.h Mon Nov 15 22:33:52 2010 +0100 +++ b/src/number.h Fri Nov 26 06:43:36 2010 +0100 @@ -151,6 +151,40 @@ EXFUN (Fevenp, 1); EXFUN (Foddp, 1); +/* There are varying mathematical definitions of what a natural number is, + differing about whether 0 is inside or outside the set. The Oxford + English Dictionary, second edition, does say that they are whole numbers, + not fractional, but it doesn't give a bound, and gives a quotation + talking about the natural numbers from 1 to 100. Since 100 is certainly + *not* the upper bound on natural numbers, we can't take 1 as the lower + bound from that example. The Real Academia Española's dictionary, not of + English but certainly sharing the western academic tradition, says of + "número natural": + + 1. m. Mat. Cada uno de los elementos de la sucesión 0, 1, 2, 3... + + that is, "each of the elements of the succession 0, 1, 2, 3 ...". The + various Wikipedia articles in languages I can read agree. It's + reasonable to call this macro and the associated Lisp function + NATNUMP. */ + +#ifdef HAVE_BIGNUM +#define NATNUMP(x) ((INTP (x) && XINT (x) >= 0) || \ + (BIGNUMP (x) && bignum_sign (XBIGNUM_DATA (x)) >= 0)) +#else +#define NATNUMP(x) (INTP (x) && XINT (x) >= 0) +#endif + +#define CHECK_NATNUM(x) do { \ + if (!NATNUMP (x)) \ + dead_wrong_type_argument (Qnatnump, x); \ +} while (0) + +#define CONCHECK_NATNUM(x) do { \ + if (!NATNUMP (x)) \ + x = wrong_type_argument (Qnatnump, x); \ +} while (0) + /********************************** Ratios **********************************/ #ifdef HAVE_RATIO
--- a/src/process-unix.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/process-unix.c Fri Nov 26 06:43:36 2010 +0100 @@ -2118,10 +2118,10 @@ CHECK_STRING (dest); - CHECK_NATNUM (port); + check_integer_range (port, Qzero, make_integer (USHRT_MAX)); theport = htons ((unsigned short) XINT (port)); - CHECK_NATNUM (ttl); + check_integer_range (ttl, Qzero, make_integer (UCHAR_MAX)); thettl = (unsigned char) XINT (ttl); if ((udp = getprotobyname ("udp")) == NULL)
--- a/src/process.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/process.c Fri Nov 26 06:43:36 2010 +0100 @@ -975,8 +975,8 @@ (process, height, width)) { CHECK_PROCESS (process); - CHECK_NATNUM (height); - CHECK_NATNUM (width); + check_integer_range (height, Qzero, make_integer (EMACS_INT_MAX)); + check_integer_range (width, Qzero, make_integer (EMACS_INT_MAX)); return MAYBE_INT_PROCMETH (set_window_size, (XPROCESS (process), XINT (height), XINT (width))) <= 0
--- a/src/profile.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/profile.c Fri Nov 26 06:43:36 2010 +0100 @@ -363,8 +363,16 @@ msecs = default_profiling_interval; else { - CHECK_NATNUM (microsecs); +#ifdef HAVE_BIGNUM + check_integer_range (microsecs, make_int (1000), make_integer (INT_MAX)); + msecs = + BIGNUMP (microsecs) ? bignum_to_int (XBIGNUM_DATA (microsecs)) : + XINT (microsecs); +#else + check_integer_range (microsecs, make_int (1000), + make_integer (EMACS_INT_MAX)); msecs = XINT (microsecs); +#endif } if (msecs <= 0) msecs = 1000;
--- a/src/unicode.c Mon Nov 15 22:33:52 2010 +0100 +++ b/src/unicode.c Fri Nov 26 06:43:36 2010 +0100 @@ -1369,7 +1369,8 @@ int ichar, unicode; CHECK_CHAR (character); - CHECK_NATNUM (code); + + check_integer_range (code, Qzero, make_integer (EMACS_INT_MAX)); unicode = XINT (code); ichar = XCHAR (character); @@ -1445,7 +1446,7 @@ int lbs[NUM_LEADING_BYTES]; int c; - CHECK_NATNUM (code); + check_integer_range (code, Qzero, make_integer (EMACS_INT_MAX)); c = XINT (code); { EXTERNAL_LIST_LOOP_2 (elt, charsets) @@ -1471,7 +1472,7 @@ return make_char (ret); } #else - CHECK_NATNUM (code); + check_integer_range (code, Qzero, make_integer (EMACS_INT_MAX)); return Fint_to_char (code); #endif /* MULE */ }
--- a/tests/ChangeLog Mon Nov 15 22:33:52 2010 +0100 +++ b/tests/ChangeLog Fri Nov 26 06:43:36 2010 +0100 @@ -1,3 +1,15 @@ +2010-11-20 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + * automated/lisp-tests.el (featurep): + * automated/lisp-tests.el (wrong-type-argument): + * automated/mule-tests.el (featurep): + Check for args-out-of-range errors instead of wrong-type-argument + errors in various places when code is handed a large bignum + instead of a fixnum. + Also check for the wrong-type-argument errors when giving the same + code a non-integer value. + 2010-11-06 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el (list-nreverse):
--- a/tests/automated/lisp-tests.el Mon Nov 15 22:33:52 2010 +0100 +++ b/tests/automated/lisp-tests.el Fri Nov 26 06:43:36 2010 +0100 @@ -211,6 +211,16 @@ (Assert (eq (butlast '()) nil)) (Assert (eq (nbutlast '()) nil)) +(when (featurep 'bignum) + (let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c))) + (y (butlast x (* 2 most-positive-fixnum))) + (z (nbutlast x (* 3 most-positive-fixnum)))) + (Assert (eq nil y) "checking butlast with a large bignum gives nil") + (Assert (eq nil z) "checking nbutlast with a large bignum gives nil") + (Check-Error wrong-type-argument + (nbutlast x (1- most-negative-fixnum)) + "checking nbutlast with a negative bignum errors"))) + ;;----------------------------------------------------- ;; Test `copy-list' ;;----------------------------------------------------- @@ -2509,4 +2519,152 @@ (mapcar fourth-bit (loop for i from 0 to 6000 collect i))))))) +(Check-Error wrong-type-argument (self-insert-command 'self-insert-command)) +(Check-Error wrong-type-argument (make-list 'make-list 'make-list)) +(Check-Error wrong-type-argument (make-vector 'make-vector 'make-vector)) +(Check-Error wrong-type-argument (make-bit-vector 'make-bit-vector + 'make-bit-vector)) +(Check-Error wrong-type-argument (make-byte-code '(&rest ignore) "\xc0\x87" [4] + 'ignore)) +(Check-Error wrong-type-argument (make-string ?a ?a)) +(Check-Error wrong-type-argument (nth-value 'nth-value (truncate pi e))) +(Check-Error wrong-type-argument (make-hash-table :test #'eql :size :size)) +(Check-Error wrong-type-argument + (accept-process-output nil 'accept-process-output)) +(Check-Error wrong-type-argument + (accept-process-output nil 2000 'accept-process-output)) +(Check-Error wrong-type-argument + (self-insert-command 'self-insert-command)) +(Check-Error wrong-type-argument (string-to-number "16" 'string-to-number)) +(Check-Error wrong-type-argument (move-to-column 'move-to-column)) +(stop-profiling) +(Check-Error wrong-type-argument (start-profiling (float most-positive-fixnum))) +(stop-profiling) +(Check-Error wrong-type-argument + (fill '(1 2 3 4 5) 1 :start (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (fill [1 2 3 4 5] 1 :start (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (fill "1 2 3 4 5" ?1 :start (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (fill #*10101010 1 :start (float most-positive-fixnum)) +(Check-Error wrong-type-argument + (fill '(1 2 3 4 5) 1 :end (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (fill [1 2 3 4 5] 1 :end (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (fill "1 2 3 4 5" ?1 :end (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (fill #*10101010 1 :end (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (reduce #'cons '(1 2 3 4 5) :start (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (reduce #'cons [1 2 3 4 5] :start (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (reduce #'cons "1 2 3 4 5" :start (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (reduce #'cons #*10101010 :start (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (reduce #'cons '(1 2 3 4 5) :end (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (reduce #'cons [1 2 3 4 5] :end (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (reduce #'cons "1 2 3 4 5" :end (float most-positive-fixnum))) +(Check-Error wrong-type-argument + (reduce #'cons #*10101010 :end (float most-positive-fixnum))) + +(when (featurep 'bignum) + (Check-Error args-out-of-range + (self-insert-command (* 2 most-positive-fixnum))) + (Check-Error args-out-of-range + (make-list (* 3 most-positive-fixnum) 'make-list)) + (Check-Error args-out-of-range + (make-vector (* 4 most-positive-fixnum) 'make-vector)) + (Check-Error args-out-of-range + (make-bit-vector (+ 2 most-positive-fixnum) 'make-bit-vector)) + (Check-Error args-out-of-range + (make-byte-code '(&rest ignore) "\xc0\x87" [4] + (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (make-byte-code '(&rest ignore) "\xc0\x87" [4] + #x10000)) + (Check-Error args-out-of-range + (make-string (* 4 most-positive-fixnum) ?a)) + (Check-Error args-out-of-range + (nth-value most-positive-fixnum (truncate pi e))) + (Check-Error args-out-of-range + (make-hash-table :test #'equalp :size (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (accept-process-output nil 4294967)) + (Check-Error args-out-of-range + (accept-process-output nil 10 (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (self-insert-command (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (string-to-number "16" (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (recent-keys (1+ most-positive-fixnum))) + (when (featurep 'xbm) + (Check-Error-Message + invalid-argument + "^data is too short for width and height" + (set-face-background-pixmap + 'left-margin + `[xbm :data (20 ,(* 2 most-positive-fixnum) "random-text")]))) + (Check-Error args-out-of-range + (move-to-column (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (move-to-column (1- most-negative-fixnum))) + (stop-profiling) + (when (< most-positive-fixnum (lsh 1 32)) + ;; We only support machines with integers of 32 bits or more. If + ;; most-positive-fixnum is less than 2^32, we're on a 32-bit machine, + ;; and it's appropriate to test start-profiling with a bignum. + (Assert (eq nil (start-profiling (* most-positive-fixnum 2))))) + (stop-profiling) + (Check-Error args-out-of-range + (fill '(1 2 3 4 5) 1 :start (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (fill [1 2 3 4 5] 1 :start (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (fill "1 2 3 4 5" ?1 :start (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (fill #*10101010 1 :start (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (fill '(1 2 3 4 5) 1 :end (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (fill [1 2 3 4 5] 1 :end (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (fill "1 2 3 4 5" ?1 :end (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (fill #*10101010 1 :end (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (reduce #'cons '(1 2 3 4 5) :start (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (reduce #'cons [1 2 3 4 5] :start (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (reduce #'cons "1 2 3 4 5" :start (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (reduce #'cons #*10101010 :start (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (reduce #'cons '(1 2 3 4 5) :end (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (reduce #'cons [1 2 3 4 5] :end (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (reduce #'cons "1 2 3 4 5" :end (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (reduce #'cons #*10101010 :end (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (replace '(1 2 3 4 5) [5 4 3 2 1] + :start1 (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (replace '(1 2 3 4 5) [5 4 3 2 1] + :start2 (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (replace '(1 2 3 4 5) [5 4 3 2 1] + :end1 (1+ most-positive-fixnum))) + (Check-Error args-out-of-range + (replace '(1 2 3 4 5) [5 4 3 2 1] + :end2 (1+ most-positive-fixnum)))) + ;;; end of lisp-tests.el
--- a/tests/automated/mule-tests.el Mon Nov 15 22:33:52 2010 +0100 +++ b/tests/automated/mule-tests.el Fri Nov 26 06:43:36 2010 +0100 @@ -459,7 +459,7 @@ (Assert (eq code (char-to-unicode scaron))) (Assert (eq scaron (unicode-to-char code '(latin-iso8859-2))))) finally (set-unicode-conversion scaron initial-unicode)) - (Check-Error wrong-type-argument (set-unicode-conversion scaron -10000))) + (Check-Error args-out-of-range (set-unicode-conversion scaron -10000))) (dolist (utf-8-char '("\xc6\x92" ;; U+0192 LATIN SMALL LETTER F WITH HOOK