/* Random utility Lisp functions.
- Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 2002
+ Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 02, 2003
Free Software Foundation, Inc.
This file is part of GNU Emacs.
#endif
#include <time.h>
+#ifndef MAC_OSX
+/* On Mac OS X, defining this conflicts with precompiled headers. */
+
/* Note on some machines this defines `vector' as a typedef,
so make sure we don't use that name in this file. */
#undef vector
#define vector *****
+#endif /* ! MAC_OSX */
+
#include "lisp.h"
#include "commands.h"
#include "charset.h"
-
+#include "coding.h"
#include "buffer.h"
#include "keyboard.h"
#include "keymap.h"
#endif
#ifndef NULL
-#define NULL (void *)0
+#define NULL ((POINTER_TYPE *)0)
#endif
/* Nonzero enables use of dialog boxes for questions
extern int minibuffer_auto_raise;
extern Lisp_Object minibuf_window;
+extern Lisp_Object Vlocale_coding_system;
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
Lisp_Object Qyes_or_no_p_history;
Lisp_Object Qcursor_in_echo_area;
Lisp_Object Qwidget_type;
+Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
extern Lisp_Object Qinput_method_function;
XSETFASTINT (val, SCHARS (sequence));
else if (VECTORP (sequence))
XSETFASTINT (val, XVECTOR (sequence)->size);
+ else if (SUB_CHAR_TABLE_P (sequence))
+ XSETFASTINT (val, SUB_CHAR_TABLE_ORDINARY_SLOTS);
else if (CHAR_TABLE_P (sequence))
XSETFASTINT (val, MAX_CHAR);
else if (BOOL_VECTOR_P (sequence))
return length;
}
-DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
+DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
doc: /* Return the number of bytes in STRING.
If STRING is a multibyte string, this is greater than the length of STRING. */)
(string)
return make_multibyte_string (buf, SCHARS (string), nbytes);
}
+
+/* Convert STRING to a multibyte string without changing each
+ character codes. Thus, characters 0200 trough 0237 are converted
+ to eight-bit-control characters, and characters 0240 through 0377
+ are converted eight-bit-graphic characters. */
+
+Lisp_Object
+string_to_multibyte (string)
+ Lisp_Object string;
+{
+ unsigned char *buf;
+ int nbytes;
+
+ if (STRING_MULTIBYTE (string))
+ return string;
+
+ nbytes = parse_str_to_multibyte (SDATA (string), SBYTES (string));
+ /* If all the chars are ASCII or eight-bit-graphic, they won't need
+ any more bytes once converted. */
+ if (nbytes == SBYTES (string))
+ return make_multibyte_string (SDATA (string), nbytes, nbytes);
+
+ buf = (unsigned char *) alloca (nbytes);
+ bcopy (SDATA (string), buf, SBYTES (string));
+ str_to_multibyte (buf, nbytes, SBYTES (string));
+
+ return make_multibyte_string (buf, SCHARS (string), nbytes);
+}
+
+
/* Convert STRING to a single-byte string. */
Lisp_Object
}
return string;
}
+
+DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte,
+ 1, 1, 0,
+ doc: /* Return a multibyte string with the same individual chars as STRING.
+If STRING is multibyte, the result is STRING itself.
+Otherwise it is a newly created string, with no text properties.
+Characters 0200 through 0237 are converted to eight-bit-control
+characters of the same character code. Characters 0240 through 0377
+are converted to eight-bit-control characters of the same character
+codes. */)
+ (string)
+ Lisp_Object string;
+{
+ CHECK_STRING (string);
+
+ return string_to_multibyte (string);
+}
+
\f
DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
doc: /* Return a copy of ALIST.
DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
doc: /* Return a substring of STRING, starting at index FROM and ending before TO.
TO may be nil or omitted; then the substring runs to the end of STRING.
-If FROM or TO is negative, it counts from the end.
+FROM and TO start at 0. If either is negative, it counts from the end.
This function allows vectors as well as strings. */)
(string, from, to)
Lisp_Object new;
for (new = Qnil; CONSP (list); list = XCDR (list))
- new = Fcons (XCAR (list), new);
+ {
+ QUIT;
+ new = Fcons (XCAR (list), new);
+ }
if (!NILP (list))
wrong_type_argument (Qconsp, list);
return new;
Lisp_Object prop;
{
Lisp_Object tail;
-
+
for (tail = plist;
CONSP (tail) && CONSP (XCDR (tail));
tail = XCDR (XCDR (tail)))
if (!NILP (tail))
wrong_type_argument (Qlistp, prop);
-
+
return Qnil;
}
Fsetcar (XCDR (tail), val);
return plist;
}
-
+
prev = tail;
QUIT;
}
Lisp_Object prop;
{
Lisp_Object tail;
-
+
for (tail = plist;
CONSP (tail) && CONSP (XCDR (tail));
tail = XCDR (XCDR (tail)))
if (!NILP (tail))
wrong_type_argument (Qlistp, prop);
-
+
return Qnil;
}
Fsetcar (XCDR (tail), val);
return plist;
}
-
+
prev = tail;
QUIT;
}
case Lisp_Type_Limit:
break;
}
-
+
return 0;
}
\f
}
return array;
}
+
+DEFUN ("clear-string", Fclear_string, Sclear_string,
+ 1, 1, 0,
+ doc: /* Clear the contents of STRING.
+This makes STRING unibyte and may change its length. */)
+ (string)
+ Lisp_Object string;
+{
+ int len = SBYTES (string);
+ bzero (SDATA (string), len);
+ STRING_SET_CHARS (string, len);
+ STRING_SET_UNIBYTE (string);
+ return Qnil;
+}
\f
DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
1, 1, 0,
DEFUN ("set-char-table-default", Fset_char_table_default,
Sset_char_table_default, 3, 3, 0,
- doc: /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.
+ doc: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
The generic character specifies the group of characters.
-See also the documentation of make-char. */)
+See also the documentation of `make-char'. */)
(char_table, ch, value)
Lisp_Object char_table, ch, value;
{
ARG is passed to C_FUNCTION when that is called. */
void
-map_char_table (c_function, function, subtable, arg, depth, indices)
+map_char_table (c_function, function, table, subtable, arg, depth, indices)
void (*c_function) P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
- Lisp_Object function, subtable, arg, *indices;
+ Lisp_Object function, table, subtable, arg, *indices;
int depth;
{
int i, to;
/* At first, handle ASCII and 8-bit European characters. */
for (i = 0; i < CHAR_TABLE_SINGLE_BYTE_SLOTS; i++)
{
- Lisp_Object elt = XCHAR_TABLE (subtable)->contents[i];
+ Lisp_Object elt= XCHAR_TABLE (subtable)->contents[i];
+ if (NILP (elt))
+ elt = XCHAR_TABLE (subtable)->defalt;
+ if (NILP (elt))
+ elt = Faref (subtable, make_number (i));
if (c_function)
(*c_function) (arg, make_number (i), elt);
else
{
if (depth >= 3)
error ("Too deep char table");
- map_char_table (c_function, function, elt, arg, depth + 1, indices);
+ map_char_table (c_function, function, table, elt, arg, depth + 1, indices);
}
else
{
int c1, c2, c;
- if (NILP (elt))
- elt = XCHAR_TABLE (subtable)->defalt;
c1 = depth >= 1 ? XFASTINT (indices[1]) : 0;
c2 = depth >= 2 ? XFASTINT (indices[2]) : 0;
c = MAKE_CHAR (charset, c1, c2);
+
+ if (NILP (elt))
+ elt = XCHAR_TABLE (subtable)->defalt;
+ if (NILP (elt))
+ elt = Faref (table, make_number (c));
+
if (c_function)
(*c_function) (arg, make_number (c), elt);
else
}
}
+static void void_call2 P_ ((Lisp_Object a, Lisp_Object b, Lisp_Object c));
+static void
+void_call2 (a, b, c)
+ Lisp_Object a, b, c;
+{
+ call2 (a, b, c);
+}
+
DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
2, 2, 0,
doc: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
CHECK_CHAR_TABLE (char_table);
- map_char_table ((void *) call2, Qnil, char_table, function, 0, indices);
+ /* When Lisp_Object is represented as a union, `call2' cannot directly
+ be passed to map_char_table because it returns a Lisp_Object rather
+ than returning nothing.
+ Casting leads to crashes on some architectures. -stef */
+ map_char_table (void_call2, Qnil, char_table, char_table, function, 0, indices);
return Qnil;
}
\f
DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
-
+
Each of the three load averages is multiplied by 100, then converted
to integer.
These floats are not multiplied by 100.
If the 5-minute or 15-minute load averages are not available, return a
-shortened list, containing only those averages which are available. */)
+shortened list, containing only those averages which are available.
+
+An error is thrown if the load average can't be obtained. In some
+cases making it work would require Emacs being installed setuid or
+setgid so that it can read kernel information, and that usually isn't
+advisable. */)
(use_floats)
Lisp_Object use_floats;
{
DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
doc: /* Returns t if FEATURE is present in this Emacs.
-
+
Use this to conditionalize execution of lisp code based on the
presence or absence of emacs or environment extensions.
Use `provide' to declare that a feature is available. This function
CHECK_SYMBOL (feature);
tem = Fmemq (feature, Vfeatures);
-
+
if (NILP (tem))
{
int count = SPECPDL_INDEX ();
if (! NILP (Vpurify_flag))
error ("(require %s) while preparing to dump",
SDATA (SYMBOL_NAME (feature)));
-
+
/* A certain amount of recursive `require' is legitimate,
but if we require the same feature recursively 3 times,
signal an error. */
UNGCPRO;
return result;
}
+
+#ifdef HAVE_LANGINFO_CODESET
+#include <langinfo.h>
+#endif
+
+DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0,
+ doc: /* Access locale data ITEM for the current C locale, if available.
+ITEM should be one of the following:
+
+`codeset', returning the character set as a string (locale item CODESET);
+
+`days', returning a 7-element vector of day names (locale items DAY_n);
+
+`months', returning a 12-element vector of month names (locale items MON_n);
+
+`paper', returning a list (WIDTH HEIGHT) for the default paper size,
+ both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
+
+If the system can't provide such information through a call to
+`nl_langinfo', or if ITEM isn't from the list above, return nil.
+
+See also Info node `(libc)Locales'.
+
+The data read from the system are decoded using `locale-coding-system'. */)
+ (item)
+ Lisp_Object item;
+{
+ char *str = NULL;
+#ifdef HAVE_LANGINFO_CODESET
+ Lisp_Object val;
+ if (EQ (item, Qcodeset))
+ {
+ str = nl_langinfo (CODESET);
+ return build_string (str);
+ }
+#ifdef DAY_1
+ else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */
+ {
+ Lisp_Object v = Fmake_vector (make_number (7), Qnil);
+ int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
+ int i;
+ synchronize_system_time_locale ();
+ for (i = 0; i < 7; i++)
+ {
+ str = nl_langinfo (days[i]);
+ val = make_unibyte_string (str, strlen (str));
+ /* Fixme: Is this coding system necessarily right, even if
+ it is consistent with CODESET? If not, what to do? */
+ Faset (v, make_number (i),
+ code_convert_string_norecord (val, Vlocale_coding_system,
+ 0));
+ }
+ return v;
+ }
+#endif /* DAY_1 */
+#ifdef MON_1
+ else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */
+ {
+ struct Lisp_Vector *p = allocate_vector (12);
+ int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
+ MON_8, MON_9, MON_10, MON_11, MON_12};
+ int i;
+ synchronize_system_time_locale ();
+ for (i = 0; i < 12; i++)
+ {
+ str = nl_langinfo (months[i]);
+ val = make_unibyte_string (str, strlen (str));
+ p->contents[i] =
+ code_convert_string_norecord (val, Vlocale_coding_system, 0);
+ }
+ XSETVECTOR (val, p);
+ return val;
+ }
+#endif /* MON_1 */
+/* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
+ but is in the locale files. This could be used by ps-print. */
+#ifdef PAPER_WIDTH
+ else if (EQ (item, Qpaper))
+ {
+ return list2 (make_number (nl_langinfo (PAPER_WIDTH)),
+ make_number (nl_langinfo (PAPER_HEIGHT)));
+ }
+#endif /* PAPER_WIDTH */
+#endif /* HAVE_LANGINFO_CODESET*/
+ return Qnil;
+}
\f
/* base64 encode/decode functions (RFC 2045).
Based on code from GNU recode. */
/* Make sure key and value survive. */
if (!key_known_to_survive_p)
{
- mark_object (&HASH_KEY (h, i));
+ mark_object (HASH_KEY (h, i));
marked = 1;
}
if (!value_known_to_survive_p)
{
- mark_object (&HASH_VALUE (h, i));
+ mark_object (HASH_VALUE (h, i));
marked = 1;
}
}
{
h = XHASH_TABLE (table);
next = h->next_weak;
-
+
if (h->size & ARRAY_MARK_FLAG)
{
/* TABLE is marked as used. Sweep its contents. */
DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
doc: /* Create and return a new hash table.
-
+
Arguments are specified as keyword/argument pairs. The following
arguments are defined:
DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
Sdefine_hash_table_test, 3, 3, 0,
doc: /* Define a new hash table test with name NAME, a symbol.
-
+
In hash tables created with NAME specified as test, use TEST to
compare keys, and HASH for computing hash codes of keys.
DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
doc: /* Return MD5 message digest of OBJECT, a buffer or string.
-
+
A message digest is a cryptographic checksum of a document, and the
algorithm to calculate it is defined in RFC 1321.
if (STRING_MULTIBYTE (object))
/* use default, we can't guess correct value */
coding_system = SYMBOL_VALUE (XCAR (Vcoding_category_list));
- else
+ else
coding_system = Qraw_text;
}
-
+
if (NILP (Fcoding_system_p (coding_system)))
{
/* Invalid coding system. */
-
+
if (!NILP (noerror))
coding_system = Qraw_text;
else
else
{
CHECK_NUMBER (end);
-
+
end_char = XINT (end);
if (end_char < 0)
end_char += size;
-
+
end_byte = string_char_to_byte (object, end_char);
}
-
+
if (!(0 <= start_char && start_char <= end_char && end_char <= size))
args_out_of_range_3 (object, make_number (start_char),
make_number (end_char));
CHECK_BUFFER (object);
bp = XBUFFER (object);
-
+
if (NILP (start))
b = BUF_BEGV (bp);
else
CHECK_NUMBER_COERCE_MARKER (end);
e = XINT (end);
}
-
+
if (b > e)
temp = b, b = e, e = temp;
-
+
if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
args_out_of_range (start, end);
-
+
if (NILP (coding_system))
{
- /* Decide the coding-system to encode the data with.
+ /* Decide the coding-system to encode the data with.
See fileio.c:Fwrite-region */
if (!NILP (Vcoding_system_for_write))
{
/* Check file-coding-system-alist. */
Lisp_Object args[4], val;
-
+
args[0] = Qwrite_region; args[1] = start; args[2] = end;
args[3] = Fbuffer_file_name(object);
val = Ffind_operation_coding_system (4, args);
object = code_convert_string1 (object, coding_system, Qnil, 1);
}
- md5_buffer (SDATA (object) + start_byte,
- SBYTES (object) - (size_byte - end_byte),
+ md5_buffer (SDATA (object) + start_byte,
+ SBYTES (object) - (size_byte - end_byte),
digest);
for (i = 0; i < 16; i++)
Qsubfeatures = intern ("subfeatures");
staticpro (&Qsubfeatures);
+#ifdef HAVE_LANGINFO_CODESET
+ Qcodeset = intern ("codeset");
+ staticpro (&Qcodeset);
+ Qdays = intern ("days");
+ staticpro (&Qdays);
+ Qmonths = intern ("months");
+ staticpro (&Qmonths);
+ Qpaper = intern ("paper");
+ staticpro (&Qpaper);
+#endif /* HAVE_LANGINFO_CODESET */
+
DEFVAR_BOOL ("use-dialog-box", &use_dialog_box,
doc: /* *Non-nil means mouse commands use dialog boxes to ask questions.
This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
defsubr (&Sstring_make_unibyte);
defsubr (&Sstring_as_multibyte);
defsubr (&Sstring_as_unibyte);
+ defsubr (&Sstring_to_multibyte);
defsubr (&Scopy_alist);
defsubr (&Ssubstring);
defsubr (&Ssubstring_no_properties);
defsubr (&Slax_plist_put);
defsubr (&Sequal);
defsubr (&Sfillarray);
+ defsubr (&Sclear_string);
defsubr (&Schar_table_subtype);
defsubr (&Schar_table_parent);
defsubr (&Sset_char_table_parent);
defsubr (&Sbase64_encode_string);
defsubr (&Sbase64_decode_string);
defsubr (&Smd5);
+ defsubr (&Slocale_info);
}
{
Vweak_hash_tables = Qnil;
}
+
+/* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
+ (do not change this comment) */
HCoop / bpt / emacs.git / blobdiff