xemacs-beta: src/data.c comparison

comparison src/data.c @ 5866:5ea790936de9

Automated merge with file:///Sources/xemacs-21.5-checked-out

author	Aidan Kehoe <kehoea@parhasard.net>
date	Mon, 16 Mar 2015 00:11:30 +0000
parents	750fab17b299
children	e0f1dfaa821e

comparison

equal deleted inserted replaced

-:15041705c196
+:5ea790936de9
 #include "buffer.h"
 #include "bytecode.h"
 #include "gc.h"
 #include "syssignal.h"
 #include "sysfloat.h"
+#include "syntax.h"
 Lisp_Object Qnil, Qt, Qlambda, Qunbound;
 Lisp_Object Qerror_conditions, Qerror_message;
 Lisp_Object Qerror, Qquit, Qsyntax_error, Qinvalid_read_syntax;
 Lisp_Object Qlist_formation_error, Qstructure_formation_error;
 Lisp_Object Qnumberp, Qnumber_char_or_marker_p;
 Lisp_Object Qbit_vectorp, Qbitp, Qcdr;
 Lisp_Object Qerror_lacks_explanatory_string;
 Lisp_Object Qfloatp;
+Lisp_Object Q_junk_allowed,  Q_radix, Q_radix_table;
+Lisp_Object Vdigit_fixnum_map, Vfixnum_to_char_map;
 Fixnum Vmost_negative_fixnum, Vmost_positive_fixnum;
 #ifdef DEBUG_XEMACS
 	}
 return make_fixnum (negative * v);
 }
 #endif /* HAVE_BIGNUM */
 }
+static int
+find_highest_value (struct chartab_range * range, Lisp_Object UNUSED (table),
+Lisp_Object val, void *extra_arg)
+{
+Lisp_Object *highest_pointer = (Lisp_Object *) extra_arg;
+Lisp_Object max_seen = *highest_pointer;
+CHECK_FIXNUM (val);
+if (range->type != CHARTAB_RANGE_CHAR)
+{
+invalid_argument ("Not an appropriate char table range", Qunbound);
+}
+if (XFIXNUM (max_seen) < XFIXNUM (val))
+{
+*highest_pointer = val;
+}
+return 0;
+}
+static int
+fill_ichar_array (struct chartab_range *range, Lisp_Object UNUSED (table),
+Lisp_Object val, void *extra_arg)
+{
+Ichar *cctable = (Ichar *) extra_arg;
+EMACS_INT valint = XFIXNUM (val);
+/* Save the value if it hasn't been seen yet. */
+if (-1 == cctable[valint])
+{
+cctable[valint] = range->ch;
+}
+else
+{
+/* Otherwise, save it if the existing value is not uppercase, and this
+	 one is. Use the standard case table rather than any buffer-specific
+	 one because a) this can be called early before current_buffer is
+	 available and b) it's better to have these independent of particular
+	 buffer case tables. */
+if (current_buffer != NULL && UPCASE (0, range->ch) == range->ch
+&& UPCASE (0, cctable[valint]) != cctable[valint])
+	{
+	  cctable[valint] = range->ch;
+	}
+/* Maybe our own case infrastructure is not available yet. Use the C
+library's. */
+else if (isupper (range->ch) && !isupper (cctable[valint]))
+{
+	  cctable[valint] = range->ch;
+}
+/* Otherwise, save it if this character has a numerically lower value
+(preferring ASCII over fullwidth Chinese and so on). */
+else if (range->ch < cctable[valint])
+	{
+	  cctable[valint] = range->ch;
+	}
+}
+return 0;
+}
+static Lisp_Object
+build_fixnum_to_char_map (Lisp_Object radix_table)
+{
+Lisp_Object highest_value, result;
+struct chartab_range ctr = { CHARTAB_RANGE_ALL, 0, Qnil, 0 };
+Ichar *cctable;
+EMACS_INT ii, cclen;
+Ibyte *data;
+/* What's the greatest fixnum value seen? In passing, check all the char
+table values are fixnums. */
+CHECK_FIXNUM (XCHAR_TABLE (radix_table)->default_);
+highest_value = XFIXNUM (XCHAR_TABLE (radix_table)->default_);
+map_char_table (radix_table, &ctr, find_highest_value, &highest_value);
+cclen = XFIXNUM (highest_value) + 1;
+cctable = malloc (sizeof (Ichar) * cclen);
+if (cctable == NULL)
+{
+out_of_memory ("Could not allocate data for `digit-char'", Qunbound);
+}
+for (ii = 0; ii < cclen; ++ii)
+{
+cctable[ii] = (Ichar) -1;
+}
+map_char_table (radix_table, &ctr, fill_ichar_array, cctable);
+for (ii = 0; ii < cclen; ++ii)
+{
+if (cctable[ii] < 0)
+	{
+	  free (cctable);
+	  invalid_argument ("No digit specified for weight", make_fixnum (ii));
+	}
+}
+result = Fmake_string (make_fixnum (cclen * MAX_ICHAR_LEN), make_char (0));
+data = XSTRING_DATA (result);
+for (ii = 0; ii < cclen; ii++)
+{
+set_itext_ichar (data + (MAX_ICHAR_LEN * ii), cctable[ii]);
+}
+init_string_ascii_begin (result);
+bump_string_modiff (result);
+sledgehammer_check_ascii_begin (result);
+free (cctable);
+return result;
+}
+DEFUN ("set-digit-fixnum-map", Fset_digit_fixnum_map, 1, 1, 0, /*
+Set the value of `digit-fixnum-map', which see.
+Also check that RADIX-TABLE is well-formed from the perspective of
+`parse-integer' and `digit-char-p', and create an internal inverse mapping
+for `digit-char', so that all three functions behave consistently.
+RADIX-TABLE itself is not saved, a read-only copy of it is made and returned.
+*/
+(radix_table))
+{
+Lisp_Object ftctable = Qnil;
+CHECK_CHAR_TABLE (radix_table);
+/* Create a table for `digit-char', checking the consistency of
+radix_table while doing so. */
+ftctable = build_fixnum_to_char_map (radix_table);
+Vdigit_fixnum_map = Fcopy_char_table (radix_table);
+LISP_READONLY (Vdigit_fixnum_map) = 1;
+Vfixnum_to_char_map = ftctable;
+return Vdigit_fixnum_map;
+}
+DEFUN ("digit-char-p", Fdigit_char_p, 1, 3, 0, /*
+Return non-nil if CHARACTER represents a digit in base RADIX.
+RADIX defaults to ten.  The actual non-nil value returned is the integer
+value of the character in base RADIX.
+RADIX-TABLE, if non-nil, is a character table describing characters' numeric
+values. See `parse-integer' and `digit-fixnum-map'.
+*/
+(character, radix, radix_table))
+{
+Lisp_Object got = Qnil;
+EMACS_INT radixing, val;
+Ichar cc;
+CHECK_CHAR (character);
+cc = XCHAR (character);
+if (!NILP (radix))
+{
+check_integer_range (radix, Qzero,
+NILP (radix_table) ?
+/* If we are using the default radix table, the
+maximum possible value for the radix is
+available to us now. */
+make_fixnum
+(XSTRING_LENGTH (Vfixnum_to_char_map)
+/ MAX_ICHAR_LEN)
+/* Otherwise, calculating that is expensive. Check
+at least that the radix is not a bignum, the
+maximum count of characters available will not
+exceed the size of a fixnum. */
+: make_fixnum (MOST_POSITIVE_FIXNUM));
+radixing = XFIXNUM (radix);
+}
+else
+{
+radixing = 10;
+}
+if (NILP (radix_table))
+{
+radix_table = Vdigit_fixnum_map;
+}
+got = get_char_table (cc, radix_table);
+CHECK_FIXNUM (got);
+val = XFIXNUM (got);
+if (val < 0 || val >= radixing)
+{
+return Qnil;
+}
+return make_fixnum (val);
+}
+DEFUN ("digit-char", Fdigit_char, 1, 3, 0, /*
+Return a character representing the integer WEIGHT in base RADIX.
+RADIX defaults to ten.  If no such character exists, return nil. `digit-char'
+prefers an upper case character if available.  RADIX must be a non-negative
+integer of value less than the maximum value in RADIX-TABLE.
+RADIX-TABLE, if non-nil, is a character table describing characters' numeric
+values. It defaults to the value of `digit-fixnum-map'; see the documentation
+for that variable and for `parse-integer'. This is not specified by Common
+Lisp, and using a value other than the default in `digit-char' is expensive,
+since the inverse map needs to be calculated.
+*/
+(weight, radix, radix_table))
+{
+EMACS_INT radixing = 10, weighting;
+Lisp_Object fixnum_to_char_table = Qnil;
+Ichar cc;
+CHECK_NATNUM (weight);
+if (!NILP (radix_table) && !EQ (radix_table, Vdigit_fixnum_map))
+{
+CHECK_CHAR_TABLE (radix_table);
+/* The result of this isn't GCPROd, but the rest of this function
+	 won't GC and continue. */
+fixnum_to_char_table = build_fixnum_to_char_map (radix_table);
+}
+else
+{
+fixnum_to_char_table = Vfixnum_to_char_map;
+}
+if (!NILP (radix))
+{
+check_integer_range (radix, Qzero,
+make_fixnum (XSTRING_LENGTH (fixnum_to_char_table)
+/ MAX_ICHAR_LEN));
+radixing = XFIXNUM (radix);
+}
+/* If weight is in its canonical form (and there's no reason to think it
+isn't), Vfixnum_to_char_map can't be long enough to handle
+this. */
+if (BIGNUMP (weight))
+{
+return Qnil;
+}
+weighting = XFIXNUM (weight);
+if (weighting < radixing)
+{
+cc = itext_ichar (XSTRING_DATA (fixnum_to_char_table)
+			+ MAX_ICHAR_LEN * weighting);
+return make_char (cc);
+}
+return Qnil;
+}
+Lisp_Object
+parse_integer (const Ibyte *buf, Ibyte **buf_end_out, Bytecount len,
+EMACS_INT base, Boolint junk_allowed, Lisp_Object radix_table)
+{
+const Ibyte *lim = buf + len, *p = buf;
+EMACS_UINT num = 0, onum = (EMACS_UINT) -1;
+EMACS_UINT fixnum_limit = MOST_POSITIVE_FIXNUM;
+EMACS_INT cint = 0;
+Boolint negativland = 0;
+Ichar c = -1;
+Lisp_Object result = Qnil, got = Qnil;
+if (NILP (radix_table))
+{
+radix_table = Vdigit_fixnum_map;
+}
+/* This function ignores the current buffer's syntax table.
+Respecting it will probably introduce more bugs than it fixes. */
+update_mirror_syntax_if_dirty (XCHAR_TABLE (Vstandard_syntax_table)->
+mirror_table);
+/* Ignore leading whitespace, if that leading whitespace has no
+numeric value. */
+while (p < lim)
+{
+c = itext_ichar (p);
+if (!(((got = get_char_table (c, radix_table), FIXNUMP (got))
+&& ((cint = XFIXNUM (got), cint < 0) || cint >= base))
+&& (SYNTAX (XCHAR_TABLE (Vstandard_syntax_table)->mirror_table,
+c) == Swhitespace)))
+{
+break;
+}
+INC_IBYTEPTR (p);
+}
+/* Drop sign information if appropriate. */
+if (c == '-')
+{
+negativland = 1;
+fixnum_limit = - MOST_NEGATIVE_FIXNUM;
+INC_IBYTEPTR (p);
+}
+else if (c == '+')
+{
+got = get_char_table (c, radix_table);
+cint = FIXNUMP (got) ? XFIXNUM (got) : -1;
+/* If ?+ has no integer weight, drop it. */
+if (cint < 0 || cint >= base)
+{
+INC_IBYTEPTR (p);
+}
+}
+while (p < lim)
+{
+c = itext_ichar (p);
+got = get_char_table (c, radix_table);
+if (!FIXNUMP (got))
+{
+goto loser;
+}
+cint = XFIXNUM (got);
+if (cint < 0 || cint >= base)
+{
+goto loser;
+}
+onum = num;
+num *= base;
+if (num > fixnum_limit)
+{
+goto overflow;
+}
+num += cint;
+if (num > fixnum_limit)
+{
+goto overflow;
+}
+INC_IBYTEPTR (p);
+}
+if (onum == (EMACS_UINT) -1)
+{
+/* No digits seen, we may need to error. */
+goto loser;
+}
+if (negativland)
+{
+result = make_fixnum (- (EMACS_INT) num);
+}
+else
+{
+result = make_fixnum (num);
+}
+*buf_end_out = (Ibyte *) p;
+return result;
+overflow:
+#ifndef HAVE_BIGNUM
+return Fsignal (Qinvalid_argument,
+list3 (build_msg_string ("Integer constant overflow"),
+make_string (buf, len), make_fixnum (base)));
+#else /* HAVE_BIGNUM */
+result = make_bignum_emacs_uint (onum);
+bignum_set_emacs_int (scratch_bignum, base);
+bignum_set_emacs_int (scratch_bignum2, cint);
+bignum_mul (XBIGNUM_DATA (result), XBIGNUM_DATA (result), scratch_bignum);
+bignum_add (XBIGNUM_DATA (result), XBIGNUM_DATA (result), scratch_bignum2);
+INC_IBYTEPTR (p);
+assert (!bignum_fits_emacs_int_p (XBIGNUM_DATA (result))
+|| (fixnum_limit
+< (EMACS_UINT) bignum_to_emacs_int (XBIGNUM_DATA (result))));
+while (p < lim)
+{
+c = itext_ichar (p);
+got = get_char_table (c, radix_table);
+if (!FIXNUMP (got))
+	{
+	  goto loser;
+	}
+cint = XFIXNUM (got);
+if (cint < 0 || cint >= base)
+	{
+	  goto loser;
+	}
+bignum_set_emacs_int (scratch_bignum2, cint);
+bignum_mul (XBIGNUM_DATA (result), XBIGNUM_DATA (result),
+scratch_bignum);
+bignum_add (XBIGNUM_DATA (result), XBIGNUM_DATA (result),
+scratch_bignum2);
+INC_IBYTEPTR (p);
+}
+if (negativland)
+{
+bignum_set_long (scratch_bignum, -1L);
+bignum_mul (XBIGNUM_DATA (result), XBIGNUM_DATA (result),
+scratch_bignum);
+}
+*buf_end_out = (Ibyte *)  p;
+return result;
+#endif /* HAVE_BIGNUM */
+loser:
+if (p < lim && !junk_allowed)
+{
+/* JUNK-ALLOWED is zero. If we have stopped parsing because we
+	 encountered whitespace, then we need to check that the rest if the
+	 string is whitespace and whitespace alone if we are not to error.
+Perhaps surprisingly, if JUNK-ALLOWED is zero, the parse is regarded
+as including the trailing whitespace, so the second value returned is
+always the length of the string. */
+while (p < lim)
+	{
+	  c = itext_ichar (p);
+	  if (!(SYNTAX (XCHAR_TABLE (Vstandard_syntax_table)->mirror_table, c)
+== Swhitespace))
+	    {
+	      break;
+	    }
+	  INC_IBYTEPTR (p);
+	}
+}
+*buf_end_out = (Ibyte *) p;
+if (junk_allowed || (p == lim && onum != (EMACS_UINT) -1))
+{
+#ifdef HAVE_BIGNUM
+if (!NILP (result))
+{
+/* Bignum terminated by whitespace or by non-digit. */
+return Fcanonicalize_number (result);
+}
+#endif
+if (onum == (EMACS_UINT) -1)
+{
+/* No integer digits seen, but junk allowed, so no indication to
+error. Return nil. */
+return Qnil;
+}
+if (negativland)
+{
+assert ((- (EMACS_INT) num) >= MOST_NEGATIVE_FIXNUM);
+result = make_fixnum (- (EMACS_INT) num);
+}
+else
+{
+assert ((EMACS_INT) num <= MOST_POSITIVE_FIXNUM);
+result = make_fixnum (num);
+}
+return result;
+}
+return Fsignal (Qinvalid_argument,
+list3 (build_msg_string ("Invalid integer syntax"),
+make_string (buf, len), make_fixnum (base)));
+}
+DEFUN ("parse-integer", Fparse_integer, 1, MANY, 0, /*
+Parse and return the integer represented by STRING using RADIX.
+START and END are bounding index designators, as used in `remove*'.  START
+defaults to 0 and END defaults to nil, meaning the end of STRING.
+If JUNK-ALLOWED is nil, error if STRING does not consist in its entirety of
+the representation of an integer, with or without surrounding whitespace
+characters.
+If RADIX-TABLE is non-nil, it is a char table mapping from characters to
+fixnums used with RADIX. Otherwise, `digit-fixnum-map' provides the
+correspondence to use.
+RADIX must always be a non-negative fixnum.  RADIX-TABLE constrains its
+possible values further, and the maximum RADIX available is always the largest
+positive value available RADIX-TABLE.
+arguments: (STRING &key (START 0) end (RADIX 10) junk-allowed radix-table)
+*/
+(int nargs, Lisp_Object *args))
+{
+Lisp_Object string = args[0], result;
+Charcount starting = 0, ending = MOST_POSITIVE_FIXNUM + 1, ii = 0;
+Bytecount byte_len;
+Ibyte *startp, *cursor, *end_read, *limit, *saved_start;
+EMACS_INT radixing;
+PARSE_KEYWORDS (Fparse_integer, nargs, args, 5,
+(start, end, radix, junk_allowed, radix_table),
+(start = Qzero, radix = make_fixnum (10)));
+CHECK_STRING (string);
+CHECK_NATNUM (start);
+starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start);
+if (!NILP (end))
+{
+CHECK_NATNUM (end);
+ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end);
+}
+if (!NILP (radix_table))
+{
+CHECK_CHAR_TABLE (radix_table);
+}
+else
+{
+radix_table = Vdigit_fixnum_map;
+}
+check_integer_range (radix, Qzero,
+EQ (radix_table, Vdigit_fixnum_map) ?
+make_fixnum (XSTRING_LENGTH (Vfixnum_to_char_map)
+/ MAX_ICHAR_LEN)
+/* Non-default radix table; calculating the upper limit
+is is expensive. Check at least that the radix is
+not a bignum, the maximum count of characters
+available in our XEmacs will not exceed the size of
+a fixnum. */
+: make_fixnum (MOST_POSITIVE_FIXNUM));
+radixing = XFIXNUM (radix);
+startp = cursor = saved_start = XSTRING_DATA (string);
+byte_len = XSTRING_LENGTH (string);
+limit = startp + byte_len;
+while (cursor < limit && ii < ending)
+{
+INC_IBYTEPTR (cursor);
+if (ii < starting)
+{
+startp = cursor;
+}
+ii++;
+}
+if (ii < starting || (ii < ending && !NILP (end)))
+{
+check_sequence_range (string, start, end, Flength (string));
+}
+result = parse_integer (startp, &end_read, cursor - startp, radixing,
+!NILP (junk_allowed), radix_table);
+/* This code hasn't been written to handle relocating string data. */
+assert (saved_start == XSTRING_DATA (string));
+return values2 (result, make_fixnum (string_index_byte_to_char
+(string, end_read - saved_start)));
+}
 DEFUN ("+", Fplus, 0, MANY, 0, /*
 Return sum of any number of arguments.
 The arguments should all be numbers, characters or markers.
 arguments: (&rest ARGS)
 DEFSYMBOL (Qnumber_char_or_marker_p);
 DEFSYMBOL (Qcdr);
 DEFSYMBOL (Qerror_lacks_explanatory_string);
 DEFSYMBOL_MULTIWORD_PREDICATE (Qweak_listp);
 DEFSYMBOL (Qfloatp);
+DEFKEYWORD (Q_radix);
+DEFKEYWORD (Q_junk_allowed);
+DEFKEYWORD (Q_radix_table);
 DEFSUBR (Fwrong_type_argument);
 #ifdef HAVE_RATIO
 DEFSUBR (Fdiv);
 DEFSUBR (Faref);
 DEFSUBR (Faset);
 DEFSUBR (Fnumber_to_string);
 DEFSUBR (Fstring_to_number);
+DEFSUBR (Fset_digit_fixnum_map);
+DEFSUBR (Fdigit_char_p);
+DEFSUBR (Fdigit_char);
+DEFSUBR (Fparse_integer);
 DEFSUBR (Feqlsign);
 DEFSUBR (Flss);
 DEFSUBR (Fgtr);
 DEFSUBR (Fleq);
 DEFSUBR (Fgeq);
 DEFVAR_CONST_INT ("most-positive-fixnum", &Vmost_positive_fixnum /*
 The fixnum closest in value to positive infinity.
 */);
 Vmost_positive_fixnum = MOST_POSITIVE_FIXNUM;
+DEFVAR_CONST_LISP ("digit-fixnum-map", &Vdigit_fixnum_map /*
+Table used to determine a character's numeric value when parsing.
+This is a character table with fixnum values. A value of -1 indicates this
+character does not have an assigned numeric value. See `parse-integer',
+`digit-char-p', and `digit-char'.
+*/);
+Vdigit_fixnum_map = Fmake_char_table (Qgeneric);
+set_char_table_default (Vdigit_fixnum_map, make_fixnum (-1));
+{
+int ii = 0;
+for (ii = 0; ii < 10; ++ii)
+{
+XCHAR_TABLE (Vdigit_fixnum_map)->ascii['0' + ii] = make_fixnum(ii);
+}
+for (ii = 10; ii < 36; ++ii)
+{
+XCHAR_TABLE (Vdigit_fixnum_map)->ascii['a' + (ii - 10)]
+= make_fixnum(ii);
+XCHAR_TABLE (Vdigit_fixnum_map)->ascii['A' + (ii - 10)]
+= make_fixnum(ii);
+}
+}
+{
+Ascbyte *fixnum_tab = alloca_ascbytes (36 * MAX_ICHAR_LEN), *ptr;
+int ii;
+Ichar cc;
+memset ((void *)fixnum_tab, 0, 36 * MAX_ICHAR_LEN);
+/* The whole point of fixnum_to_character_table is access as an array,
+avoid O(N) issues by giving every character MAX_ICHAR_LEN of
+bytes.  */
+for (ii = 0, ptr = fixnum_tab; ii < 36; ++ii, ptr += MAX_ICHAR_LEN)
+{
+	cc = ii < 10 ? '0' + ii : 'A' + (ii - 10);
+	set_itext_ichar ((Ibyte *) ptr, cc);
+}
+/* Sigh, we can't call build_fixnum_to_char_map() on Vdigit_fixnum_map,
+this is too early in the boot sequence to map across a char table. Do
+it by hand. */
+Vfixnum_to_char_map = build_ascstring (fixnum_tab);
+staticpro (&Vfixnum_to_char_map);
+}
 #ifdef DEBUG_XEMACS
 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
 If non-zero, note when your code may be suffering from char-int confoundance.
 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
 etc. where an int and a char with the same value are being compared,

Mercurial > hg > xemacs-beta

comparison src/data.c @ 5866:5ea790936de9