xemacs-beta: src/fns.c comparison

comparison src/fns.c @ 5307:c096d8051f89

Have NATNUMP give t for positive bignums; check limits appropriately. src/ChangeLog addition: 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. tests/ChangeLog addition: 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.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Sat, 20 Nov 2010 16:49:11 +0000
parents	cde1608596d0
children	c290121b0c3f 8d29f1c4bb98

comparison

equal deleted inserted replaced

-:cde1608596d0
+:c096d8051f89
 static void
 check_sequence_range (Lisp_Object sequence, Lisp_Object start,
 		      Lisp_Object end, Lisp_Object length)
 {
-Elemcount starting = XINT (start), ending, len = XINT (length);
+Lisp_Object args[] = { Qzero, start, NILP (end) ? length : end, length };
-ending = NILP (end) ? XINT (length) : XINT (end);
+if (NILP (Fleq (countof (args), args)))
+{
-if (!(0 <= starting && starting <= ending && ending <= len))
+args_out_of_range_3 (sequence, start, end);
-{
-args_out_of_range_3 (sequence, start, make_int (ending));
 }
 }
 static Lisp_Object
 mark_bit_vector (Lisp_Object UNUSED (obj))
 if (EQ (limit, Qt))
 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
 	 quotient rather than the remainder.  At the high end of the RNG
 	 it's possible to get a quotient larger than limit; discarding
 denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit);
 do
 	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 ();
 return make_int (val);
 }
 {
 /* This function can GC */
 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);
 else if (NILP (tail))
 	return Qnil;
 if (NILP (n))
 int_n = 1;
 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;
 CONSP (hare);
 hare = XCDR (hare),
 }
 return retval;
 }
-static Lisp_Object bignum_butlast (Lisp_Object list, Lisp_Object number,
-Boolint copy);
 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
 Modify LIST to remove the last N (default 1) elements.
 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
 Otherwise, LIST may be dotted, but not circular.
 CHECK_LIST (list);
 if (!NILP (n))
 {
-if (BIGNUMP (n))
-{
-return bignum_butlast (list, n, 0);
-}
 CHECK_NATNUM (n);
-int_n = XINT (n);
+int_n = BIGNUMP (n) ? 1 + EMACS_INT_MAX : XINT (n);
 }
 if (CONSP (list))
 {
 Lisp_Object last_cons = list;
 CHECK_LIST (list);
 if (!NILP (n))
 {
-if (BIGNUMP (n))
-{
-return bignum_butlast (list, n, 1);
-}
 CHECK_NATNUM (n);
-int_n = XINT (n);
+int_n = BIGNUMP (n) ? 1 + EMACS_INT_MAX : XINT (n);
 }
 if (CONSP (list))
 {
 Lisp_Object tail = list;
 	    }
 	}
 }
 return retval;
-}
-/* This is sufficient to implement #'butlast and #'nbutlast with bignum N
-under XEmacs, because #'list-length and #'safe-length can never return a
-bignum. This means that #'nbutlast never has to modify and #'butlast
-never has to copy. */
-static Lisp_Object
-bignum_butlast (Lisp_Object list, Lisp_Object number, Boolint copy)
-{
-Boolint malformed = EQ (Fsafe_length (list), Qzero);
-Boolint circular = !malformed && EQ (Flist_length (list), Qnil);
-assert (BIGNUMP (number));
-#ifdef HAVE_BIGNUM
-if (bignum_sign (XBIGNUM_DATA (number)) < 0)
-{
-dead_wrong_type_argument (Qnatnump, number);
-}
-number = Fcanonicalize_number (number);
-if (INTP (number))
-{
-return copy ? Fbutlast (list, number) : Fnbutlast (list, number);
-}
-#endif
-if (circular)
-{
-signal_circular_list_error (list);
-}
-return Qnil;
 }
 DEFUN ("member", Fmember, 2, 2, 0, /*
 Return non-nil if ELT is an element of LIST.  Comparison done with `equal'.
 The value is actually the tail of LIST whose car is ELT.
 */
 (int nargs, Lisp_Object *args))
 {
 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:
 if (STRINGP (sequence))
 {
 CHECK_LISP_WRITEABLE (sequence);
 len = XVECTOR_LENGTH (sequence);
 check_sequence_range (sequence, start, end, make_int (len));
 ending = min (ending, len);
+starting = XINT (start);
 for (ii = starting; ii < ending; ++ii)
 {
 p[ii] = item;
 }
 CHECK_LISP_WRITEABLE (sequence);
 len = bit_vector_length (v);
 check_sequence_range (sequence, start, end, make_int (len));
 ending = min (ending, len);
+starting = XINT (start);
 for (ii = starting; ii < ending; ++ii)
 {
 set_bit_vector_bit (v, ii, bit);
 }
 }
 else if (LISTP (sequence))
 {
 Elemcount counting = 0;
+starting = BIGNUMP (start) ? EMACS_INT_MAX + 1 : XINT (start);
 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
 {
 if (counting >= starting)
 {
 arguments: (FUNCTION SEQUENCE &key (START 0) (END (length SEQUENCE)) FROM-END INITIAL-VALUE (KEY #'identity))
 */
 (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),
 (start = Qzero, initial_value = Qunbound));
 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 :			\
 			IGNORE_MULTIPLE_VALUES (call1 (key, item)))
 #define CALL2(function, accum, item)				\
 IGNORE_MULTIPLE_VALUES (call2 (function, accum, item))
-starting = XINT (start);
 if (!NILP (end))
 {
 CHECK_NATNUM (end);
-ending = XINT (end);
+ending = BIGNUMP (end) ? EMACS_INT_MAX + 1 : XINT (end);
-}
-if (!(starting <= ending))
-{
-check_sequence_range (sequence, start, end, Flength (sequence));
 }
 if (VECTORP (sequence))
 {
 Lisp_Vector *vv = XVECTOR (sequence);
 Bytecount cursor_offset, byte_len = XSTRING_LENGTH (sequence);
 const Ibyte *cursor;
 	  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);
 if (!UNBOUNDP (initial_value))
 {
 			Lisp_Object item)
 {
 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)
 {
 INC_IBYTEPTR (p);
 ending = len = ii;
 }
 else
 {
-ending = XINT (end);
+ending = BIGNUMP (end) ? EMACS_INT_MAX + 1 : XINT (end);
 while (ii < ending && pcursor < pend)
 	{
 	  INC_IBYTEPTR (pcursor);
 	  ii++;
 	}
 */
 (int nargs, Lisp_Object *args))
 {
 Lisp_Object sequence1 = args[0], sequence2 = args[1],
 result = sequence1;
-Elemcount starting1, ending1 = EMACS_INT_MAX, starting2;
+Elemcount starting1, ending1 = EMACS_INT_MAX + 1, starting2;
-Elemcount ending2 = EMACS_INT_MAX, counting = 0, startcounting;
+Elemcount ending2 = EMACS_INT_MAX + 1, counting = 0, startcounting;
 Boolint sequence1_listp, sequence2_listp,
 overwriting = EQ (sequence1, sequence2);
 PARSE_KEYWORDS (Freplace, nargs, args, 4, (start1, end1, start2, end2),
 (start1 = start2 = Qzero));
 CHECK_LISP_WRITEABLE (sequence1);
 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);
+ending1 = BIGNUMP (end1) ? EMACS_INT_MAX + 1 : XINT (end1);
-if (!(starting1 <= ending1))
-{
-args_out_of_range_3 (sequence1, start1, end1);
-}
 }
 if (!NILP (end2))
 {
 CHECK_NATNUM (end2);
-ending2 = XINT (end2);
+ending2 = BIGNUMP (end2) ? EMACS_INT_MAX + 1 : XINT (end2);
-if (!(starting2 <= ending2))
-{
-args_out_of_range_3 (sequence1, start2, end2);
-}
 }
 sequence1_listp = LISTP (sequence1);
 sequence2_listp = LISTP (sequence2);

Mercurial > hg > xemacs-beta

comparison src/fns.c @ 5307:c096d8051f89