xemacs-beta: src/fns.c comparison

comparison src/fns.c @ 771:943eaba38521

[xemacs-hg @ 2002-03-13 08:51:24 by ben] The big ben-mule-21-5 check-in! Various files were added and deleted. See CHANGES-ben-mule. There are still some test suite failures. No crashes, though. Many of the failures have to do with problems in the test suite itself rather than in the actual code. I'll be addressing these in the next day or so -- none of the test suite failures are at all critical. Meanwhile I'll be trying to address the biggest issues -- i.e. build or run failures, which will almost certainly happen on various platforms. All comments should be sent to ben@xemacs.org -- use a Cc: if necessary when sending to mailing lists. There will be pre- and post- tags, something like pre-ben-mule-21-5-merge-in, and post-ben-mule-21-5-merge-in.

author	ben
date	Wed, 13 Mar 2002 08:54:06 +0000
parents	358bd84dc7ff
children	578cb2932d72

comparison

equal deleted inserted replaced

-:336a418893b5
+:943eaba38521
 /* Random utility Lisp functions.
 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
-Copyright (C) 1995, 1996 Ben Wing.
+Copyright (C) 1995, 1996, 2000, 2001, 2002 Ben Wing.
 This file is part of XEmacs.
 XEmacs is free software; you can redistribute it and/or modify it
 under the terms of the GNU General Public License as published by the
 #define vector *****
 #include "lisp.h"
 #include "sysfile.h"
+#include "sysproc.h" /* for qxe_getpid() */
 #include "buffer.h"
 #include "bytecode.h"
 #include "device.h"
 #include "events.h"
 Lisp_Object Qstring_lessp;
 Lisp_Object Qidentity;
 Lisp_Object Qbase64_conversion_error;
+Lisp_Object Vpath_separator;
 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
 Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth);
 static Lisp_Object
 mark_bit_vector (Lisp_Object obj)
 (arg))
 {
 return arg;
 }
-extern long get_random (void);
-extern void seed_random (long arg);
 DEFUN ("random", Frandom, 0, 1, 0, /*
 Return a pseudo-random number.
 All integers representable in Lisp are equally likely.
 On most systems, this is 28 bits' worth.
 With positive integer argument N, return random number in interval [0,N).
 {
 EMACS_INT val;
 unsigned long denominator;
 if (EQ (limit, Qt))
-seed_random (getpid () + time (NULL));
+seed_random (qxe_getpid () + time (NULL));
 if (NATNUMP (limit) && !ZEROP (limit))
 {
 /* 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
 return (((len = string_length (p1)) == string_length (p2)) &&
 	  !memcmp (string_data (p1), string_data (p2), len)) ? Qt : Qnil;
 }
 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
 Return t if first arg string is less than second in lexicographic order.
-If I18N2 support (but not Mule support) was compiled in, ordering is
+Comparison is simply done on a character-by-character basis using the
-determined by the locale. (Case is significant for the default C locale.)
+numeric value of a character. (Note that this may not produce
-In all other cases, comparison is simply done on a character-by-
+particularly meaningful results under Mule if characters from
-character basis using the numeric value of a character. (Note that
+different charsets are being compared.)
-this may not produce particularly meaningful results under Mule if
-characters from different charsets are being compared.)
 Symbols are also allowed; their print names are used instead.
-The reason that the I18N2 locale-specific collation is not used under
+Currently we don't do proper language-specific collation or handle
-Mule is that the locale model of internationalization does not handle
+multiple character sets.  This may be changed when Unicode support
-multiple charsets and thus has no hope of working properly under Mule.
+is implemented.
-What we really should do is create a collation table over all built-in
-charsets.  This is extremely difficult to do from scratch, however.
-Unicode is a good first step towards solving this problem.  In fact,
-it is quite likely that a collation table exists (or will exist) for
-Unicode.  When Unicode support is added to XEmacs/Mule, this problem
-may be solved.
 */
 (string1, string2))
 {
 Lisp_String *p1, *p2;
 Charcount end, len2;
 end  = string_char_length (p1);
 len2 = string_char_length (p2);
 if (end > len2)
 end = len2;
-#if defined (I18N2) && !defined (MULE)
-/* There is no hope of this working under Mule.  Even if we converted
-the data into an external format so that strcoll() processed it
-properly, it would still not work because strcoll() does not
-handle multiple locales.  This is the fundamental flaw in the
-locale model. */
-{
-Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
-/* Compare strings using collation order of locale. */
-/* Need to be tricky to handle embedded nulls. */
-for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
-{
-	int val = strcoll ((char *) string_data (p1) + i,
-			   (char *) string_data (p2) + i);
-	if (val < 0)
-	  return Qt;
-	if (val > 0)
-	  return Qnil;
-}
-}
-#else /* not I18N2, or MULE */
 {
 Intbyte *ptr1 = string_data (p1);
 Intbyte *ptr2 = string_data (p2);
 /* #### It is not really necessary to do this: We could compare
 	  return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
 	INC_CHARPTR (ptr1);
 	INC_CHARPTR (ptr2);
 }
 }
-#endif /* not I18N2, or MULE */
 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
 won't work right in I18N2 case */
 return end < len2 ? Qt : Qnil;
 }
 CHECK_STRING (string);
 CHECK_INT (start);
 get_string_range_char (string, start, end, &ccstart, &ccend,
 			 GB_HISTORICAL_STRING_BEHAVIOR);
-bstart = charcount_to_bytecount (XSTRING_DATA (string), ccstart);
+bstart = XSTRING_INDEX_CHAR_TO_BYTE (string, ccstart);
-blen = charcount_to_bytecount (XSTRING_DATA (string) + bstart, ccend - ccstart);
+blen = XSTRING_OFFSET_CHAR_TO_BYTE_LEN (string, bstart, ccend - ccstart);
 val = make_string (XSTRING_DATA (string) + bstart, blen);
 /* Copy any applicable extent information into the new string. */
 copy_string_extents (val, string, 0, bstart, blen);
 return val;
 }
 {
 abort (); /* unreachable, since Flength (sequence) did not get
 an error */
 return Qnil;
 }
+}
+/* Split STRING into a list of substrings.  The substrings are the
+parts of original STRING separated by SEPCHAR.  */
+static Lisp_Object
+split_string_by_emchar_1 (const Intbyte *string, Bytecount size,
+			  Emchar sepchar)
+{
+Lisp_Object result = Qnil;
+const Intbyte *end = string + size;
+while (1)
+{
+const Intbyte *p = string;
+while (p < end)
+	{
+	  if (charptr_emchar (p) == sepchar)
+	    break;
+	  INC_CHARPTR (p);
+	}
+result = Fcons (make_string (string, p - string), result);
+if (p < end)
+	{
+	  string = p;
+	  INC_CHARPTR (string);	/* skip sepchar */
+	}
+else
+	break;
+}
+return Fnreverse (result);
+}
+/* The same as the above, except PATH is an external C string (it is
+converted using Qfile_name), and sepchar is hardcoded to SEPCHAR
+(':' or whatever).  */
+Lisp_Object
+split_external_path (const Extbyte *path)
+{
+Bytecount newlen;
+Intbyte *newpath;
+if (!path)
+return Qnil;
+TO_INTERNAL_FORMAT (C_STRING, path, ALLOCA, (newpath, newlen), Qfile_name);
+/* #### Does this make sense?  It certainly does for
+split_env_path(), but it looks dubious here.  Does any code
+depend on split_external_path("") returning nil instead of an empty
+string?  */
+if (!newlen)
+return Qnil;
+return split_string_by_emchar_1 (newpath, newlen, SEPCHAR);
+}
+Lisp_Object
+split_env_path (const CIntbyte *evarname, const Intbyte *default_)
+{
+const Intbyte *path = 0;
+if (evarname)
+path = egetenv (evarname);
+if (!path)
+path = default_;
+if (!path)
+return Qnil;
+return split_string_by_emchar_1 (path, qxestrlen (path), SEPCHAR);
+}
+/* Ben thinks this function should not exist or be exported to Lisp.
+We use it to define split-path-string in subr.el (not!).  */
+DEFUN ("split-string-by-char", Fsplit_string_by_char, 1, 2, 0, /*
+Split STRING into a list of substrings originally separated by SEPCHAR.
+*/
+(string, sepchar))
+{
+CHECK_STRING (string);
+CHECK_CHAR (sepchar);
+return split_string_by_emchar_1 (XSTRING_DATA (string),
+				   XSTRING_LENGTH (string),
+				   XCHAR (sepchar));
+}
+/* #### This was supposed to be in subr.el, but is used VERY early in
+the bootstrap process, so it goes here.  Damn.  */
+DEFUN ("split-path", Fsplit_path, 1, 1, 0, /*
+Explode a search path into a list of strings.
+The path components are separated with the characters specified
+with `path-separator'.
+*/
+(path))
+{
+CHECK_STRING (path);
+while (!STRINGP (Vpath_separator)
+	 || (XSTRING_CHAR_LENGTH (Vpath_separator) != 1))
+Vpath_separator = signal_continuable_error
+(Qinvalid_state,
+"`path-separator' should be set to a single-character string",
+Vpath_separator);
+return (split_string_by_emchar_1
+	  (XSTRING_DATA (path), XSTRING_LENGTH (path),
+	   charptr_emchar (XSTRING_DATA (Vpath_separator))));
 }
 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
 Take cdr N times on LIST, and return the result.
 Lisp_Object
 assoc_no_quit (Lisp_Object key, Lisp_Object alist)
 {
 int speccount = specpdl_depth ();
 specbind (Qinhibit_quit, Qt);
-return unbind_to (speccount, Fassoc (key, alist));
+return unbind_to_1 (speccount, Fassoc (key, alist));
 }
 DEFUN ("assq", Fassq, 2, 2, 0, /*
 Return non-nil if KEY is `eq' to the car of an element of ALIST.
 The value is actually the element of ALIST whose car is KEY.
 Lisp_Object
 remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
 {
 int speccount = specpdl_depth ();
 specbind (Qinhibit_quit, Qt);
-return unbind_to (speccount, Fremassoc (key, alist));
+return unbind_to_1 (speccount, Fremassoc (key, alist));
 }
 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
 Delete by side effect any elements of ALIST whose car is `eq' to KEY.
 The modified ALIST is returned.  If the first member of ALIST has a car
 Lisp_Object pred)
 {
 Lisp_Object tmp;
 /* prevents the GC from happening in call2 */
-int speccount = specpdl_depth ();
 /* Emacs' GC doesn't actually relocate pointers, so this probably
 isn't strictly necessary */
-record_unwind_protect (restore_gc_inhibit,
+int speccount = begin_gc_forbidden ();
-make_int (gc_currently_forbidden));
-gc_currently_forbidden = 1;
 tmp = call2 (pred, obj1, obj2);
-unbind_to (speccount, Qnil);
+unbind_to (speccount);
 if (NILP (tmp))
 return -1;
 else
 return 1;
 {
 if (ERRB_EQ (errb, ERROR_ME_WARN))
 	{
 	  warn_when_safe_lispobj
 	    (Qlist, Qwarning,
-	     list2 (build_string
+	     list2 (build_msg_string
 		    ("Malformed property list -- list has been truncated"),
 		    *plist));
 	  *badplace = Qnil;
 	}
 return Qunbound;
 {
 if (ERRB_EQ (errb, ERROR_ME_WARN))
 	{
 	  warn_when_safe_lispobj
 	    (Qlist, Qwarning,
-	     list2 (build_string
+	     list2 (build_msg_string
 		    ("Circular property list -- list has been truncated"),
 		    *plist));
 	  *badplace = Qnil;
 	}
 return Qunbound;
 Intbyte *end;
 CHECK_CHAR_COERCE_INT (item);
 CHECK_LISP_WRITEABLE (array);
+sledgehammer_check_ascii_begin (array);
 item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
 new_bytecount = item_bytecount * string_char_length (s);
 resize_string (s, -1, new_bytecount - old_bytecount);
 	   p < end;
 	   p += item_bytecount)
 	memcpy (p, item_buf, item_bytecount);
 *p = '\0';
+set_string_ascii_begin (s,
+			      item_bytecount == 1 ?
+			      min (new_bytecount, MAX_STRING_ASCII_BEGIN) :
+			      0);
 bump_string_modiff (array);
+sledgehammer_check_ascii_begin (array);
 }
 else if (VECTORP (array))
 {
 Lisp_Object *p = XVECTOR_DATA (array);
 Elemcount len = XVECTOR_LENGTH (array);
 return sequence;
 }
+/* Extra random functions */
 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
 Destructively replace the list OLD with NEW.
 This is like (copy-sequence NEW) except that it reuses the
 conses in OLD as much as possible.  If OLD and NEW are the same
 XCDR (prevoldtail) = Qnil;
 else
 old = Qnil;
 return old;
+}
+Lisp_Object
+add_suffix_to_symbol (Lisp_Object symbol, const Char_ASCII *ascii_string)
+{
+return Fintern (concat2 (Fsymbol_name (symbol),
+			   build_string (ascii_string)),
+		  Qnil);
+}
+Lisp_Object
+add_prefix_to_symbol (const Char_ASCII *ascii_string, Lisp_Object symbol)
+{
+return Fintern (concat2 (build_string (ascii_string),
+			   Fsymbol_name (symbol)),
+		  Qnil);
 }
 /* #### this function doesn't belong in this file! */
 if (NILP (tem))
 	invalid_state ("Required feature was not provided", feature);
 /* Once loading finishes, don't undo it.  */
 Vautoload_queue = Qt;
-return unbind_to (speccount, feature);
+return unbind_to_1 (speccount, feature);
 }
 }
 /* base64 encode/decode functions.
 ptr = alloca_array (type, XOA_len);				\
 } while (0)
 #define XMALLOC_UNBIND(ptr, len, speccount) do {		\
 if ((len) > MAX_ALLOCA)					\
-unbind_to (speccount, Qnil);				\
+unbind_to (speccount);				\
 } while (0)
 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
 Base64-encode the region between START and END.
 Return the length of the encoded text.
 DEFSUBR (Fprovide);
 DEFSUBR (Fbase64_encode_region);
 DEFSUBR (Fbase64_encode_string);
 DEFSUBR (Fbase64_decode_region);
 DEFSUBR (Fbase64_decode_string);
+DEFSUBR (Fsplit_string_by_char);
+DEFSUBR (Fsplit_path);	/* #### */
+}
+void
+vars_of_fns (void)
+{
+DEFVAR_LISP ("path-separator", &Vpath_separator /*
+The directory separator in search paths, as a string.
+*/ );
+{
+char c = SEPCHAR;
+Vpath_separator = make_string ((Intbyte *)&c, 1);
+}
 }
 void
 init_provide_once (void)
 {

Mercurial > hg > xemacs-beta

comparison src/fns.c @ 771:943eaba38521