1/* Random utility Lisp functions. 2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997, 3 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4 2005, 2006, 2007 Free Software Foundation, Inc. 5 6This file is part of GNU Emacs. 7 8GNU Emacs is free software; you can redistribute it and/or modify 9it under the terms of the GNU General Public License as published by 10the Free Software Foundation; either version 2, or (at your option) 11any later version. 12 13GNU Emacs is distributed in the hope that it will be useful, 14but WITHOUT ANY WARRANTY; without even the implied warranty of 15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16GNU General Public License for more details. 17 18You should have received a copy of the GNU General Public License 19along with GNU Emacs; see the file COPYING. If not, write to 20the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 21Boston, MA 02110-1301, USA. */ 22 23#include <config.h> 24 25#ifdef HAVE_UNISTD_H 26#include <unistd.h> 27#endif 28#include <time.h> 29 30#ifndef MAC_OS 31/* On Mac OS, defining this conflicts with precompiled headers. */ 32 33/* Note on some machines this defines `vector' as a typedef, 34 so make sure we don't use that name in this file. */ 35#undef vector 36#define vector ***** 37 38#endif /* ! MAC_OSX */ 39 40#include "lisp.h" 41#include "commands.h" 42#include "charset.h" 43#include "coding.h" 44#include "buffer.h" 45#include "keyboard.h" 46#include "keymap.h" 47#include "intervals.h" 48#include "frame.h" 49#include "window.h" 50#include "blockinput.h" 51#ifdef HAVE_MENUS 52#if defined (HAVE_X_WINDOWS) 53#include "xterm.h" 54#elif defined (MAC_OS) 55#include "macterm.h" 56#endif 57#endif 58 59#ifndef NULL 60#define NULL ((POINTER_TYPE *)0) 61#endif 62 63/* Nonzero enables use of dialog boxes for questions 64 asked by mouse commands. */ 65int use_dialog_box; 66 67/* Nonzero enables use of a file dialog for file name 68 questions asked by mouse commands. */ 69int use_file_dialog; 70 71extern int minibuffer_auto_raise; 72extern Lisp_Object minibuf_window; 73extern Lisp_Object Vlocale_coding_system; 74extern int load_in_progress; 75 76Lisp_Object Qstring_lessp, Qprovide, Qrequire; 77Lisp_Object Qyes_or_no_p_history; 78Lisp_Object Qcursor_in_echo_area; 79Lisp_Object Qwidget_type; 80Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper; 81 82extern Lisp_Object Qinput_method_function; 83 84static int internal_equal P_ ((Lisp_Object , Lisp_Object, int, int)); 85 86extern long get_random (); 87extern void seed_random P_ ((long)); 88 89#ifndef HAVE_UNISTD_H 90extern long time (); 91#endif 92 93DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, 94 doc: /* Return the argument unchanged. */) 95 (arg) 96 Lisp_Object arg; 97{ 98 return arg; 99} 100 101DEFUN ("random", Frandom, Srandom, 0, 1, 0, 102 doc: /* Return a pseudo-random number. 103All integers representable in Lisp are equally likely. 104 On most systems, this is 29 bits' worth. 105With positive integer argument N, return random number in interval [0,N). 106With argument t, set the random number seed from the current time and pid. */) 107 (n) 108 Lisp_Object n; 109{ 110 EMACS_INT val; 111 Lisp_Object lispy_val; 112 unsigned long denominator; 113 114 if (EQ (n, Qt)) 115 seed_random (getpid () + time (NULL)); 116 if (NATNUMP (n) && XFASTINT (n) != 0) 117 { 118 /* Try to take our random number from the higher bits of VAL, 119 not the lower, since (says Gentzel) the low bits of `random' 120 are less random than the higher ones. We do this by using the 121 quotient rather than the remainder. At the high end of the RNG 122 it's possible to get a quotient larger than n; discarding 123 these values eliminates the bias that would otherwise appear 124 when using a large n. */ 125 denominator = ((unsigned long)1 << VALBITS) / XFASTINT (n); 126 do 127 val = get_random () / denominator; 128 while (val >= XFASTINT (n)); 129 } 130 else 131 val = get_random (); 132 XSETINT (lispy_val, val); 133 return lispy_val; 134} 135 136/* Random data-structure functions */ 137 138DEFUN ("length", Flength, Slength, 1, 1, 0, 139 doc: /* Return the length of vector, list or string SEQUENCE. 140A byte-code function object is also allowed. 141If the string contains multibyte characters, this is not necessarily 142the number of bytes in the string; it is the number of characters. 143To get the number of bytes, use `string-bytes'. */) 144 (sequence) 145 register Lisp_Object sequence; 146{ 147 register Lisp_Object val; 148 register int i; 149 150 if (STRINGP (sequence)) 151 XSETFASTINT (val, SCHARS (sequence)); 152 else if (VECTORP (sequence)) 153 XSETFASTINT (val, ASIZE (sequence)); 154 else if (SUB_CHAR_TABLE_P (sequence)) 155 XSETFASTINT (val, SUB_CHAR_TABLE_ORDINARY_SLOTS); 156 else if (CHAR_TABLE_P (sequence)) 157 XSETFASTINT (val, MAX_CHAR); 158 else if (BOOL_VECTOR_P (sequence)) 159 XSETFASTINT (val, XBOOL_VECTOR (sequence)->size); 160 else if (COMPILEDP (sequence)) 161 XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK); 162 else if (CONSP (sequence)) 163 { 164 i = 0; 165 while (CONSP (sequence)) 166 { 167 sequence = XCDR (sequence); 168 ++i; 169 170 if (!CONSP (sequence)) 171 break; 172 173 sequence = XCDR (sequence); 174 ++i; 175 QUIT; 176 } 177 178 CHECK_LIST_END (sequence, sequence); 179 180 val = make_number (i); 181 } 182 else if (NILP (sequence)) 183 XSETFASTINT (val, 0); 184 else 185 wrong_type_argument (Qsequencep, sequence); 186 187 return val; 188} 189 190/* This does not check for quits. That is safe since it must terminate. */ 191 192DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0, 193 doc: /* Return the length of a list, but avoid error or infinite loop. 194This function never gets an error. If LIST is not really a list, 195it returns 0. If LIST is circular, it returns a finite value 196which is at least the number of distinct elements. */) 197 (list) 198 Lisp_Object list; 199{ 200 Lisp_Object tail, halftail, length; 201 int len = 0; 202 203 /* halftail is used to detect circular lists. */ 204 halftail = list; 205 for (tail = list; CONSP (tail); tail = XCDR (tail)) 206 { 207 if (EQ (tail, halftail) && len != 0) 208 break; 209 len++; 210 if ((len & 1) == 0) 211 halftail = XCDR (halftail); 212 } 213 214 XSETINT (length, len); 215 return length; 216} 217 218DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0, 219 doc: /* Return the number of bytes in STRING. 220If STRING is a multibyte string, this is greater than the length of STRING. */) 221 (string) 222 Lisp_Object string; 223{ 224 CHECK_STRING (string); 225 return make_number (SBYTES (string)); 226} 227 228DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0, 229 doc: /* Return t if two strings have identical contents. 230Case is significant, but text properties are ignored. 231Symbols are also allowed; their print names are used instead. */) 232 (s1, s2) 233 register Lisp_Object s1, s2; 234{ 235 if (SYMBOLP (s1)) 236 s1 = SYMBOL_NAME (s1); 237 if (SYMBOLP (s2)) 238 s2 = SYMBOL_NAME (s2); 239 CHECK_STRING (s1); 240 CHECK_STRING (s2); 241 242 if (SCHARS (s1) != SCHARS (s2) 243 || SBYTES (s1) != SBYTES (s2) 244 || bcmp (SDATA (s1), SDATA (s2), SBYTES (s1))) 245 return Qnil; 246 return Qt; 247} 248 249DEFUN ("compare-strings", Fcompare_strings, 250 Scompare_strings, 6, 7, 0, 251doc: /* Compare the contents of two strings, converting to multibyte if needed. 252In string STR1, skip the first START1 characters and stop at END1. 253In string STR2, skip the first START2 characters and stop at END2. 254END1 and END2 default to the full lengths of the respective strings. 255 256Case is significant in this comparison if IGNORE-CASE is nil. 257Unibyte strings are converted to multibyte for comparison. 258 259The value is t if the strings (or specified portions) match. 260If string STR1 is less, the value is a negative number N; 261 - 1 - N is the number of characters that match at the beginning. 262If string STR1 is greater, the value is a positive number N; 263 N - 1 is the number of characters that match at the beginning. */) 264 (str1, start1, end1, str2, start2, end2, ignore_case) 265 Lisp_Object str1, start1, end1, start2, str2, end2, ignore_case; 266{ 267 register int end1_char, end2_char; 268 register int i1, i1_byte, i2, i2_byte; 269 270 CHECK_STRING (str1); 271 CHECK_STRING (str2); 272 if (NILP (start1)) 273 start1 = make_number (0); 274 if (NILP (start2)) 275 start2 = make_number (0); 276 CHECK_NATNUM (start1); 277 CHECK_NATNUM (start2); 278 if (! NILP (end1)) 279 CHECK_NATNUM (end1); 280 if (! NILP (end2)) 281 CHECK_NATNUM (end2); 282 283 i1 = XINT (start1); 284 i2 = XINT (start2); 285 286 i1_byte = string_char_to_byte (str1, i1); 287 i2_byte = string_char_to_byte (str2, i2); 288 289 end1_char = SCHARS (str1); 290 if (! NILP (end1) && end1_char > XINT (end1)) 291 end1_char = XINT (end1); 292 293 end2_char = SCHARS (str2); 294 if (! NILP (end2) && end2_char > XINT (end2)) 295 end2_char = XINT (end2); 296 297 while (i1 < end1_char && i2 < end2_char) 298 { 299 /* When we find a mismatch, we must compare the 300 characters, not just the bytes. */ 301 int c1, c2; 302 303 if (STRING_MULTIBYTE (str1)) 304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte); 305 else 306 { 307 c1 = SREF (str1, i1++); 308 c1 = unibyte_char_to_multibyte (c1); 309 } 310 311 if (STRING_MULTIBYTE (str2)) 312 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte); 313 else 314 { 315 c2 = SREF (str2, i2++); 316 c2 = unibyte_char_to_multibyte (c2); 317 } 318 319 if (c1 == c2) 320 continue; 321 322 if (! NILP (ignore_case)) 323 { 324 Lisp_Object tem; 325 326 tem = Fupcase (make_number (c1)); 327 c1 = XINT (tem); 328 tem = Fupcase (make_number (c2)); 329 c2 = XINT (tem); 330 } 331 332 if (c1 == c2) 333 continue; 334 335 /* Note that I1 has already been incremented 336 past the character that we are comparing; 337 hence we don't add or subtract 1 here. */ 338 if (c1 < c2) 339 return make_number (- i1 + XINT (start1)); 340 else 341 return make_number (i1 - XINT (start1)); 342 } 343 344 if (i1 < end1_char) 345 return make_number (i1 - XINT (start1) + 1); 346 if (i2 < end2_char) 347 return make_number (- i1 + XINT (start1) - 1); 348 349 return Qt; 350} 351 352DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0, 353 doc: /* Return t if first arg string is less than second in lexicographic order. 354Case is significant. 355Symbols are also allowed; their print names are used instead. */) 356 (s1, s2) 357 register Lisp_Object s1, s2; 358{ 359 register int end; 360 register int i1, i1_byte, i2, i2_byte; 361 362 if (SYMBOLP (s1)) 363 s1 = SYMBOL_NAME (s1); 364 if (SYMBOLP (s2)) 365 s2 = SYMBOL_NAME (s2); 366 CHECK_STRING (s1); 367 CHECK_STRING (s2); 368 369 i1 = i1_byte = i2 = i2_byte = 0; 370 371 end = SCHARS (s1); 372 if (end > SCHARS (s2)) 373 end = SCHARS (s2); 374 375 while (i1 < end) 376 { 377 /* When we find a mismatch, we must compare the 378 characters, not just the bytes. */ 379 int c1, c2; 380 381 FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte); 382 FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte); 383 384 if (c1 != c2) 385 return c1 < c2 ? Qt : Qnil; 386 } 387 return i1 < SCHARS (s2) ? Qt : Qnil; 388} 389 390#if __GNUC__ 391/* "gcc -O3" enables automatic function inlining, which optimizes out 392 the arguments for the invocations of this function, whereas it 393 expects these values on the stack. */ 394static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special)) __attribute__((noinline)); 395#else /* !__GNUC__ */ 396static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special)); 397#endif 398 399/* ARGSUSED */ 400Lisp_Object 401concat2 (s1, s2) 402 Lisp_Object s1, s2; 403{ 404#ifdef NO_ARG_ARRAY 405 Lisp_Object args[2]; 406 args[0] = s1; 407 args[1] = s2; 408 return concat (2, args, Lisp_String, 0); 409#else 410 return concat (2, &s1, Lisp_String, 0); 411#endif /* NO_ARG_ARRAY */ 412} 413 414/* ARGSUSED */ 415Lisp_Object 416concat3 (s1, s2, s3) 417 Lisp_Object s1, s2, s3; 418{ 419#ifdef NO_ARG_ARRAY 420 Lisp_Object args[3]; 421 args[0] = s1; 422 args[1] = s2; 423 args[2] = s3; 424 return concat (3, args, Lisp_String, 0); 425#else 426 return concat (3, &s1, Lisp_String, 0); 427#endif /* NO_ARG_ARRAY */ 428} 429 430DEFUN ("append", Fappend, Sappend, 0, MANY, 0, 431 doc: /* Concatenate all the arguments and make the result a list. 432The result is a list whose elements are the elements of all the arguments. 433Each argument may be a list, vector or string. 434The last argument is not copied, just used as the tail of the new list. 435usage: (append &rest SEQUENCES) */) 436 (nargs, args) 437 int nargs; 438 Lisp_Object *args; 439{ 440 return concat (nargs, args, Lisp_Cons, 1); 441} 442 443DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0, 444 doc: /* Concatenate all the arguments and make the result a string. 445The result is a string whose elements are the elements of all the arguments. 446Each argument may be a string or a list or vector of characters (integers). 447usage: (concat &rest SEQUENCES) */) 448 (nargs, args) 449 int nargs; 450 Lisp_Object *args; 451{ 452 return concat (nargs, args, Lisp_String, 0); 453} 454 455DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0, 456 doc: /* Concatenate all the arguments and make the result a vector. 457The result is a vector whose elements are the elements of all the arguments. 458Each argument may be a list, vector or string. 459usage: (vconcat &rest SEQUENCES) */) 460 (nargs, args) 461 int nargs; 462 Lisp_Object *args; 463{ 464 return concat (nargs, args, Lisp_Vectorlike, 0); 465} 466 467/* Return a copy of a sub char table ARG. The elements except for a 468 nested sub char table are not copied. */ 469static Lisp_Object 470copy_sub_char_table (arg) 471 Lisp_Object arg; 472{ 473 Lisp_Object copy = make_sub_char_table (Qnil); 474 int i; 475 476 XCHAR_TABLE (copy)->defalt = XCHAR_TABLE (arg)->defalt; 477 /* Copy all the contents. */ 478 bcopy (XCHAR_TABLE (arg)->contents, XCHAR_TABLE (copy)->contents, 479 SUB_CHAR_TABLE_ORDINARY_SLOTS * sizeof (Lisp_Object)); 480 /* Recursively copy any sub char-tables in the ordinary slots. */ 481 for (i = 32; i < SUB_CHAR_TABLE_ORDINARY_SLOTS; i++) 482 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i])) 483 XCHAR_TABLE (copy)->contents[i] 484 = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]); 485 486 return copy; 487} 488 489 490DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0, 491 doc: /* Return a copy of a list, vector, string or char-table. 492The elements of a list or vector are not copied; they are shared 493with the original. */) 494 (arg) 495 Lisp_Object arg; 496{ 497 if (NILP (arg)) return arg; 498 499 if (CHAR_TABLE_P (arg)) 500 { 501 int i; 502 Lisp_Object copy; 503 504 copy = Fmake_char_table (XCHAR_TABLE (arg)->purpose, Qnil); 505 /* Copy all the slots, including the extra ones. */ 506 bcopy (XVECTOR (arg)->contents, XVECTOR (copy)->contents, 507 ((XCHAR_TABLE (arg)->size & PSEUDOVECTOR_SIZE_MASK) 508 * sizeof (Lisp_Object))); 509 510 /* Recursively copy any sub char tables in the ordinary slots 511 for multibyte characters. */ 512 for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS; 513 i < CHAR_TABLE_ORDINARY_SLOTS; i++) 514 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i])) 515 XCHAR_TABLE (copy)->contents[i] 516 = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]); 517 518 return copy; 519 } 520 521 if (BOOL_VECTOR_P (arg)) 522 { 523 Lisp_Object val; 524 int size_in_chars 525 = ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1) 526 / BOOL_VECTOR_BITS_PER_CHAR); 527 528 val = Fmake_bool_vector (Flength (arg), Qnil); 529 bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data, 530 size_in_chars); 531 return val; 532 } 533 534 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg)) 535 wrong_type_argument (Qsequencep, arg); 536 537 return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0); 538} 539 540/* This structure holds information of an argument of `concat' that is 541 a string and has text properties to be copied. */ 542struct textprop_rec 543{ 544 int argnum; /* refer to ARGS (arguments of `concat') */ 545 int from; /* refer to ARGS[argnum] (argument string) */ 546 int to; /* refer to VAL (the target string) */ 547}; 548 549static Lisp_Object 550concat (nargs, args, target_type, last_special) 551 int nargs; 552 Lisp_Object *args; 553 enum Lisp_Type target_type; 554 int last_special; 555{ 556 Lisp_Object val; 557 register Lisp_Object tail; 558 register Lisp_Object this; 559 int toindex; 560 int toindex_byte = 0; 561 register int result_len; 562 register int result_len_byte; 563 register int argnum; 564 Lisp_Object last_tail; 565 Lisp_Object prev; 566 int some_multibyte; 567 /* When we make a multibyte string, we can't copy text properties 568 while concatinating each string because the length of resulting 569 string can't be decided until we finish the whole concatination. 570 So, we record strings that have text properties to be copied 571 here, and copy the text properties after the concatination. */ 572 struct textprop_rec *textprops = NULL; 573 /* Number of elments in textprops. */ 574 int num_textprops = 0; 575 USE_SAFE_ALLOCA; 576 577 tail = Qnil; 578 579 /* In append, the last arg isn't treated like the others */ 580 if (last_special && nargs > 0) 581 { 582 nargs--; 583 last_tail = args[nargs]; 584 } 585 else 586 last_tail = Qnil; 587 588 /* Check each argument. */ 589 for (argnum = 0; argnum < nargs; argnum++) 590 { 591 this = args[argnum]; 592 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this) 593 || COMPILEDP (this) || BOOL_VECTOR_P (this))) 594 wrong_type_argument (Qsequencep, this); 595 } 596 597 /* Compute total length in chars of arguments in RESULT_LEN. 598 If desired output is a string, also compute length in bytes 599 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE 600 whether the result should be a multibyte string. */ 601 result_len_byte = 0; 602 result_len = 0; 603 some_multibyte = 0; 604 for (argnum = 0; argnum < nargs; argnum++) 605 { 606 int len; 607 this = args[argnum]; 608 len = XFASTINT (Flength (this)); 609 if (target_type == Lisp_String) 610 { 611 /* We must count the number of bytes needed in the string 612 as well as the number of characters. */ 613 int i; 614 Lisp_Object ch; 615 int this_len_byte; 616 617 if (VECTORP (this)) 618 for (i = 0; i < len; i++) 619 { 620 ch = AREF (this, i); 621 CHECK_NUMBER (ch); 622 this_len_byte = CHAR_BYTES (XINT (ch)); 623 result_len_byte += this_len_byte; 624 if (!SINGLE_BYTE_CHAR_P (XINT (ch))) 625 some_multibyte = 1; 626 } 627 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0) 628 wrong_type_argument (Qintegerp, Faref (this, make_number (0))); 629 else if (CONSP (this)) 630 for (; CONSP (this); this = XCDR (this)) 631 { 632 ch = XCAR (this); 633 CHECK_NUMBER (ch); 634 this_len_byte = CHAR_BYTES (XINT (ch)); 635 result_len_byte += this_len_byte; 636 if (!SINGLE_BYTE_CHAR_P (XINT (ch))) 637 some_multibyte = 1; 638 } 639 else if (STRINGP (this)) 640 { 641 if (STRING_MULTIBYTE (this)) 642 { 643 some_multibyte = 1; 644 result_len_byte += SBYTES (this); 645 } 646 else 647 result_len_byte += count_size_as_multibyte (SDATA (this), 648 SCHARS (this)); 649 } 650 } 651 652 result_len += len; 653 } 654 655 if (! some_multibyte) 656 result_len_byte = result_len; 657 658 /* Create the output object. */ 659 if (target_type == Lisp_Cons) 660 val = Fmake_list (make_number (result_len), Qnil); 661 else if (target_type == Lisp_Vectorlike) 662 val = Fmake_vector (make_number (result_len), Qnil); 663 else if (some_multibyte) 664 val = make_uninit_multibyte_string (result_len, result_len_byte); 665 else 666 val = make_uninit_string (result_len); 667 668 /* In `append', if all but last arg are nil, return last arg. */ 669 if (target_type == Lisp_Cons && EQ (val, Qnil)) 670 return last_tail; 671 672 /* Copy the contents of the args into the result. */ 673 if (CONSP (val)) 674 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */ 675 else 676 toindex = 0, toindex_byte = 0; 677 678 prev = Qnil; 679 if (STRINGP (val)) 680 SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs); 681 682 for (argnum = 0; argnum < nargs; argnum++) 683 { 684 Lisp_Object thislen; 685 int thisleni = 0; 686 register unsigned int thisindex = 0; 687 register unsigned int thisindex_byte = 0; 688 689 this = args[argnum]; 690 if (!CONSP (this)) 691 thislen = Flength (this), thisleni = XINT (thislen); 692 693 /* Between strings of the same kind, copy fast. */ 694 if (STRINGP (this) && STRINGP (val) 695 && STRING_MULTIBYTE (this) == some_multibyte) 696 { 697 int thislen_byte = SBYTES (this); 698 699 bcopy (SDATA (this), SDATA (val) + toindex_byte, 700 SBYTES (this)); 701 if (! NULL_INTERVAL_P (STRING_INTERVALS (this))) 702 { 703 textprops[num_textprops].argnum = argnum; 704 textprops[num_textprops].from = 0; 705 textprops[num_textprops++].to = toindex; 706 } 707 toindex_byte += thislen_byte; 708 toindex += thisleni; 709 STRING_SET_CHARS (val, SCHARS (val)); 710 } 711 /* Copy a single-byte string to a multibyte string. */ 712 else if (STRINGP (this) && STRINGP (val)) 713 { 714 if (! NULL_INTERVAL_P (STRING_INTERVALS (this))) 715 { 716 textprops[num_textprops].argnum = argnum; 717 textprops[num_textprops].from = 0; 718 textprops[num_textprops++].to = toindex; 719 } 720 toindex_byte += copy_text (SDATA (this), 721 SDATA (val) + toindex_byte, 722 SCHARS (this), 0, 1); 723 toindex += thisleni; 724 } 725 else 726 /* Copy element by element. */ 727 while (1) 728 { 729 register Lisp_Object elt; 730 731 /* Fetch next element of `this' arg into `elt', or break if 732 `this' is exhausted. */ 733 if (NILP (this)) break; 734 if (CONSP (this)) 735 elt = XCAR (this), this = XCDR (this); 736 else if (thisindex >= thisleni) 737 break; 738 else if (STRINGP (this)) 739 { 740 int c; 741 if (STRING_MULTIBYTE (this)) 742 { 743 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this, 744 thisindex, 745 thisindex_byte); 746 XSETFASTINT (elt, c); 747 } 748 else 749 { 750 XSETFASTINT (elt, SREF (this, thisindex)); thisindex++; 751 if (some_multibyte 752 && (XINT (elt) >= 0240 753 || (XINT (elt) >= 0200 754 && ! NILP (Vnonascii_translation_table))) 755 && XINT (elt) < 0400) 756 { 757 c = unibyte_char_to_multibyte (XINT (elt)); 758 XSETINT (elt, c); 759 } 760 } 761 } 762 else if (BOOL_VECTOR_P (this)) 763 { 764 int byte; 765 byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR]; 766 if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR))) 767 elt = Qt; 768 else 769 elt = Qnil; 770 thisindex++; 771 } 772 else 773 elt = AREF (this, thisindex++); 774 775 /* Store this element into the result. */ 776 if (toindex < 0) 777 { 778 XSETCAR (tail, elt); 779 prev = tail; 780 tail = XCDR (tail); 781 } 782 else if (VECTORP (val)) 783 AREF (val, toindex++) = elt; 784 else 785 { 786 CHECK_NUMBER (elt); 787 if (SINGLE_BYTE_CHAR_P (XINT (elt))) 788 { 789 if (some_multibyte) 790 toindex_byte 791 += CHAR_STRING (XINT (elt), 792 SDATA (val) + toindex_byte); 793 else 794 SSET (val, toindex_byte++, XINT (elt)); 795 toindex++; 796 } 797 else 798 /* If we have any multibyte characters, 799 we already decided to make a multibyte string. */ 800 { 801 int c = XINT (elt); 802 /* P exists as a variable 803 to avoid a bug on the Masscomp C compiler. */ 804 unsigned char *p = SDATA (val) + toindex_byte; 805 806 toindex_byte += CHAR_STRING (c, p); 807 toindex++; 808 } 809 } 810 } 811 } 812 if (!NILP (prev)) 813 XSETCDR (prev, last_tail); 814 815 if (num_textprops > 0) 816 { 817 Lisp_Object props; 818 int last_to_end = -1; 819 820 for (argnum = 0; argnum < num_textprops; argnum++) 821 { 822 this = args[textprops[argnum].argnum]; 823 props = text_property_list (this, 824 make_number (0), 825 make_number (SCHARS (this)), 826 Qnil); 827 /* If successive arguments have properites, be sure that the 828 value of `composition' property be the copy. */ 829 if (last_to_end == textprops[argnum].to) 830 make_composition_value_copy (props); 831 add_text_properties_from_list (val, props, 832 make_number (textprops[argnum].to)); 833 last_to_end = textprops[argnum].to + SCHARS (this); 834 } 835 } 836 837 SAFE_FREE (); 838 return val; 839} 840 841static Lisp_Object string_char_byte_cache_string; 842static int string_char_byte_cache_charpos; 843static int string_char_byte_cache_bytepos; 844 845void 846clear_string_char_byte_cache () 847{ 848 string_char_byte_cache_string = Qnil; 849} 850 851/* Return the character index corresponding to CHAR_INDEX in STRING. */ 852 853int 854string_char_to_byte (string, char_index) 855 Lisp_Object string; 856 int char_index; 857{ 858 int i, i_byte; 859 int best_below, best_below_byte; 860 int best_above, best_above_byte; 861 862 best_below = best_below_byte = 0; 863 best_above = SCHARS (string); 864 best_above_byte = SBYTES (string); 865 if (best_above == best_above_byte) 866 return char_index; 867 868 if (EQ (string, string_char_byte_cache_string)) 869 { 870 if (string_char_byte_cache_charpos < char_index) 871 { 872 best_below = string_char_byte_cache_charpos; 873 best_below_byte = string_char_byte_cache_bytepos; 874 } 875 else 876 { 877 best_above = string_char_byte_cache_charpos; 878 best_above_byte = string_char_byte_cache_bytepos; 879 } 880 } 881 882 if (char_index - best_below < best_above - char_index) 883 { 884 while (best_below < char_index) 885 { 886 int c; 887 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, 888 best_below, best_below_byte); 889 } 890 i = best_below; 891 i_byte = best_below_byte; 892 } 893 else 894 { 895 while (best_above > char_index) 896 { 897 unsigned char *pend = SDATA (string) + best_above_byte; 898 unsigned char *pbeg = pend - best_above_byte; 899 unsigned char *p = pend - 1; 900 int bytes; 901 902 while (p > pbeg && !CHAR_HEAD_P (*p)) p--; 903 PARSE_MULTIBYTE_SEQ (p, pend - p, bytes); 904 if (bytes == pend - p) 905 best_above_byte -= bytes; 906 else if (bytes > pend - p) 907 best_above_byte -= (pend - p); 908 else 909 best_above_byte--; 910 best_above--; 911 } 912 i = best_above; 913 i_byte = best_above_byte; 914 } 915 916 string_char_byte_cache_bytepos = i_byte; 917 string_char_byte_cache_charpos = i; 918 string_char_byte_cache_string = string; 919 920 return i_byte; 921} 922 923/* Return the character index corresponding to BYTE_INDEX in STRING. */ 924 925int 926string_byte_to_char (string, byte_index) 927 Lisp_Object string; 928 int byte_index; 929{ 930 int i, i_byte; 931 int best_below, best_below_byte; 932 int best_above, best_above_byte; 933 934 best_below = best_below_byte = 0; 935 best_above = SCHARS (string); 936 best_above_byte = SBYTES (string); 937 if (best_above == best_above_byte) 938 return byte_index; 939 940 if (EQ (string, string_char_byte_cache_string)) 941 { 942 if (string_char_byte_cache_bytepos < byte_index) 943 { 944 best_below = string_char_byte_cache_charpos; 945 best_below_byte = string_char_byte_cache_bytepos; 946 } 947 else 948 { 949 best_above = string_char_byte_cache_charpos; 950 best_above_byte = string_char_byte_cache_bytepos; 951 } 952 } 953 954 if (byte_index - best_below_byte < best_above_byte - byte_index) 955 { 956 while (best_below_byte < byte_index) 957 { 958 int c; 959 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, 960 best_below, best_below_byte); 961 } 962 i = best_below; 963 i_byte = best_below_byte; 964 } 965 else 966 { 967 while (best_above_byte > byte_index) 968 { 969 unsigned char *pend = SDATA (string) + best_above_byte; 970 unsigned char *pbeg = pend - best_above_byte; 971 unsigned char *p = pend - 1; 972 int bytes; 973 974 while (p > pbeg && !CHAR_HEAD_P (*p)) p--; 975 PARSE_MULTIBYTE_SEQ (p, pend - p, bytes); 976 if (bytes == pend - p) 977 best_above_byte -= bytes; 978 else if (bytes > pend - p) 979 best_above_byte -= (pend - p); 980 else 981 best_above_byte--; 982 best_above--; 983 } 984 i = best_above; 985 i_byte = best_above_byte; 986 } 987 988 string_char_byte_cache_bytepos = i_byte; 989 string_char_byte_cache_charpos = i; 990 string_char_byte_cache_string = string; 991 992 return i; 993} 994 995/* Convert STRING to a multibyte string. 996 Single-byte characters 0240 through 0377 are converted 997 by adding nonascii_insert_offset to each. */ 998 999Lisp_Object 1000string_make_multibyte (string) 1001 Lisp_Object string; 1002{ 1003 unsigned char *buf; 1004 int nbytes; 1005 Lisp_Object ret; 1006 USE_SAFE_ALLOCA; 1007 1008 if (STRING_MULTIBYTE (string)) 1009 return string; 1010 1011 nbytes = count_size_as_multibyte (SDATA (string), 1012 SCHARS (string)); 1013 /* If all the chars are ASCII, they won't need any more bytes 1014 once converted. In that case, we can return STRING itself. */ 1015 if (nbytes == SBYTES (string)) 1016 return string; 1017 1018 SAFE_ALLOCA (buf, unsigned char *, nbytes); 1019 copy_text (SDATA (string), buf, SBYTES (string), 1020 0, 1); 1021 1022 ret = make_multibyte_string (buf, SCHARS (string), nbytes); 1023 SAFE_FREE (); 1024 1025 return ret; 1026} 1027 1028 1029/* Convert STRING to a multibyte string without changing each 1030 character codes. Thus, characters 0200 trough 0237 are converted 1031 to eight-bit-control characters, and characters 0240 through 0377 1032 are converted eight-bit-graphic characters. */ 1033 1034Lisp_Object 1035string_to_multibyte (string) 1036 Lisp_Object string; 1037{ 1038 unsigned char *buf; 1039 int nbytes; 1040 Lisp_Object ret; 1041 USE_SAFE_ALLOCA; 1042 1043 if (STRING_MULTIBYTE (string)) 1044 return string; 1045 1046 nbytes = parse_str_to_multibyte (SDATA (string), SBYTES (string)); 1047 /* If all the chars are ASCII or eight-bit-graphic, they won't need 1048 any more bytes once converted. */ 1049 if (nbytes == SBYTES (string)) 1050 return make_multibyte_string (SDATA (string), nbytes, nbytes); 1051 1052 SAFE_ALLOCA (buf, unsigned char *, nbytes); 1053 bcopy (SDATA (string), buf, SBYTES (string)); 1054 str_to_multibyte (buf, nbytes, SBYTES (string)); 1055 1056 ret = make_multibyte_string (buf, SCHARS (string), nbytes); 1057 SAFE_FREE (); 1058 1059 return ret; 1060} 1061 1062 1063/* Convert STRING to a single-byte string. */ 1064 1065Lisp_Object 1066string_make_unibyte (string) 1067 Lisp_Object string; 1068{ 1069 int nchars; 1070 unsigned char *buf; 1071 Lisp_Object ret; 1072 USE_SAFE_ALLOCA; 1073 1074 if (! STRING_MULTIBYTE (string)) 1075 return string; 1076 1077 nchars = SCHARS (string); 1078 1079 SAFE_ALLOCA (buf, unsigned char *, nchars); 1080 copy_text (SDATA (string), buf, SBYTES (string), 1081 1, 0); 1082 1083 ret = make_unibyte_string (buf, nchars); 1084 SAFE_FREE (); 1085 1086 return ret; 1087} 1088 1089DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte, 1090 1, 1, 0, 1091 doc: /* Return the multibyte equivalent of STRING. 1092If STRING is unibyte and contains non-ASCII characters, the function 1093`unibyte-char-to-multibyte' is used to convert each unibyte character 1094to a multibyte character. In this case, the returned string is a 1095newly created string with no text properties. If STRING is multibyte 1096or entirely ASCII, it is returned unchanged. In particular, when 1097STRING is unibyte and entirely ASCII, the returned string is unibyte. 1098\(When the characters are all ASCII, Emacs primitives will treat the 1099string the same way whether it is unibyte or multibyte.) */) 1100 (string) 1101 Lisp_Object string; 1102{ 1103 CHECK_STRING (string); 1104 1105 return string_make_multibyte (string); 1106} 1107 1108DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte, 1109 1, 1, 0, 1110 doc: /* Return the unibyte equivalent of STRING. 1111Multibyte character codes are converted to unibyte according to 1112`nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'. 1113If the lookup in the translation table fails, this function takes just 1114the low 8 bits of each character. */) 1115 (string) 1116 Lisp_Object string; 1117{ 1118 CHECK_STRING (string); 1119 1120 return string_make_unibyte (string); 1121} 1122 1123DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte, 1124 1, 1, 0, 1125 doc: /* Return a unibyte string with the same individual bytes as STRING. 1126If STRING is unibyte, the result is STRING itself. 1127Otherwise it is a newly created string, with no text properties. 1128If STRING is multibyte and contains a character of charset 1129`eight-bit-control' or `eight-bit-graphic', it is converted to the 1130corresponding single byte. */) 1131 (string) 1132 Lisp_Object string; 1133{ 1134 CHECK_STRING (string); 1135 1136 if (STRING_MULTIBYTE (string)) 1137 { 1138 int bytes = SBYTES (string); 1139 unsigned char *str = (unsigned char *) xmalloc (bytes); 1140 1141 bcopy (SDATA (string), str, bytes); 1142 bytes = str_as_unibyte (str, bytes); 1143 string = make_unibyte_string (str, bytes); 1144 xfree (str); 1145 } 1146 return string; 1147} 1148 1149DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte, 1150 1, 1, 0, 1151 doc: /* Return a multibyte string with the same individual bytes as STRING. 1152If STRING is multibyte, the result is STRING itself. 1153Otherwise it is a newly created string, with no text properties. 1154If STRING is unibyte and contains an individual 8-bit byte (i.e. not 1155part of a multibyte form), it is converted to the corresponding 1156multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. 1157Beware, this often doesn't really do what you think it does. 1158It is similar to (decode-coding-string STRING 'emacs-mule-unix). 1159If you're not sure, whether to use `string-as-multibyte' or 1160`string-to-multibyte', use `string-to-multibyte'. Beware: 1161 (aref (string-as-multibyte "\\201") 0) -> 129 (aka ?\\201) 1162 (aref (string-as-multibyte "\\300") 0) -> 192 (aka ?\\300) 1163 (aref (string-as-multibyte "\\300\\201") 0) -> 192 (aka ?\\300) 1164 (aref (string-as-multibyte "\\300\\201") 1) -> 129 (aka ?\\201) 1165but 1166 (aref (string-as-multibyte "\\201\\300") 0) -> 2240 1167 (aref (string-as-multibyte "\\201\\300") 1) -> <error> */) 1168 (string) 1169 Lisp_Object string; 1170{ 1171 CHECK_STRING (string); 1172 1173 if (! STRING_MULTIBYTE (string)) 1174 { 1175 Lisp_Object new_string; 1176 int nchars, nbytes; 1177 1178 parse_str_as_multibyte (SDATA (string), 1179 SBYTES (string), 1180 &nchars, &nbytes); 1181 new_string = make_uninit_multibyte_string (nchars, nbytes); 1182 bcopy (SDATA (string), SDATA (new_string), 1183 SBYTES (string)); 1184 if (nbytes != SBYTES (string)) 1185 str_as_multibyte (SDATA (new_string), nbytes, 1186 SBYTES (string), NULL); 1187 string = new_string; 1188 STRING_SET_INTERVALS (string, NULL_INTERVAL); 1189 } 1190 return string; 1191} 1192 1193DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte, 1194 1, 1, 0, 1195 doc: /* Return a multibyte string with the same individual chars as STRING. 1196If STRING is multibyte, the result is STRING itself. 1197Otherwise it is a newly created string, with no text properties. 1198Characters 0200 through 0237 are converted to eight-bit-control 1199characters of the same character code. Characters 0240 through 0377 1200are converted to eight-bit-graphic characters of the same character 1201codes. 1202This is similar to (decode-coding-string STRING 'binary) */) 1203 (string) 1204 Lisp_Object string; 1205{ 1206 CHECK_STRING (string); 1207 1208 return string_to_multibyte (string); 1209} 1210 1211 1212DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0, 1213 doc: /* Return a copy of ALIST. 1214This is an alist which represents the same mapping from objects to objects, 1215but does not share the alist structure with ALIST. 1216The objects mapped (cars and cdrs of elements of the alist) 1217are shared, however. 1218Elements of ALIST that are not conses are also shared. */) 1219 (alist) 1220 Lisp_Object alist; 1221{ 1222 register Lisp_Object tem; 1223 1224 CHECK_LIST (alist); 1225 if (NILP (alist)) 1226 return alist; 1227 alist = concat (1, &alist, Lisp_Cons, 0); 1228 for (tem = alist; CONSP (tem); tem = XCDR (tem)) 1229 { 1230 register Lisp_Object car; 1231 car = XCAR (tem); 1232 1233 if (CONSP (car)) 1234 XSETCAR (tem, Fcons (XCAR (car), XCDR (car))); 1235 } 1236 return alist; 1237} 1238 1239DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0, 1240 doc: /* Return a substring of STRING, starting at index FROM and ending before TO. 1241TO may be nil or omitted; then the substring runs to the end of STRING. 1242FROM and TO start at 0. If either is negative, it counts from the end. 1243 1244This function allows vectors as well as strings. */) 1245 (string, from, to) 1246 Lisp_Object string; 1247 register Lisp_Object from, to; 1248{ 1249 Lisp_Object res; 1250 int size; 1251 int size_byte = 0; 1252 int from_char, to_char; 1253 int from_byte = 0, to_byte = 0; 1254 1255 CHECK_VECTOR_OR_STRING (string); 1256 CHECK_NUMBER (from); 1257 1258 if (STRINGP (string)) 1259 { 1260 size = SCHARS (string); 1261 size_byte = SBYTES (string); 1262 } 1263 else 1264 size = ASIZE (string); 1265 1266 if (NILP (to)) 1267 { 1268 to_char = size; 1269 to_byte = size_byte; 1270 } 1271 else 1272 { 1273 CHECK_NUMBER (to); 1274 1275 to_char = XINT (to); 1276 if (to_char < 0) 1277 to_char += size; 1278 1279 if (STRINGP (string)) 1280 to_byte = string_char_to_byte (string, to_char); 1281 } 1282 1283 from_char = XINT (from); 1284 if (from_char < 0) 1285 from_char += size; 1286 if (STRINGP (string)) 1287 from_byte = string_char_to_byte (string, from_char); 1288 1289 if (!(0 <= from_char && from_char <= to_char && to_char <= size)) 1290 args_out_of_range_3 (string, make_number (from_char), 1291 make_number (to_char)); 1292 1293 if (STRINGP (string)) 1294 { 1295 res = make_specified_string (SDATA (string) + from_byte, 1296 to_char - from_char, to_byte - from_byte, 1297 STRING_MULTIBYTE (string)); 1298 copy_text_properties (make_number (from_char), make_number (to_char), 1299 string, make_number (0), res, Qnil); 1300 } 1301 else 1302 res = Fvector (to_char - from_char, &AREF (string, from_char)); 1303 1304 return res; 1305} 1306 1307 1308DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0, 1309 doc: /* Return a substring of STRING, without text properties. 1310It starts at index FROM and ending before TO. 1311TO may be nil or omitted; then the substring runs to the end of STRING. 1312If FROM is nil or omitted, the substring starts at the beginning of STRING. 1313If FROM or TO is negative, it counts from the end. 1314 1315With one argument, just copy STRING without its properties. */) 1316 (string, from, to) 1317 Lisp_Object string; 1318 register Lisp_Object from, to; 1319{ 1320 int size, size_byte; 1321 int from_char, to_char; 1322 int from_byte, to_byte; 1323 1324 CHECK_STRING (string); 1325 1326 size = SCHARS (string); 1327 size_byte = SBYTES (string); 1328 1329 if (NILP (from)) 1330 from_char = from_byte = 0; 1331 else 1332 { 1333 CHECK_NUMBER (from); 1334 from_char = XINT (from); 1335 if (from_char < 0) 1336 from_char += size; 1337 1338 from_byte = string_char_to_byte (string, from_char); 1339 } 1340 1341 if (NILP (to)) 1342 { 1343 to_char = size; 1344 to_byte = size_byte; 1345 } 1346 else 1347 { 1348 CHECK_NUMBER (to); 1349 1350 to_char = XINT (to); 1351 if (to_char < 0) 1352 to_char += size; 1353 1354 to_byte = string_char_to_byte (string, to_char); 1355 } 1356 1357 if (!(0 <= from_char && from_char <= to_char && to_char <= size)) 1358 args_out_of_range_3 (string, make_number (from_char), 1359 make_number (to_char)); 1360 1361 return make_specified_string (SDATA (string) + from_byte, 1362 to_char - from_char, to_byte - from_byte, 1363 STRING_MULTIBYTE (string)); 1364} 1365 1366/* Extract a substring of STRING, giving start and end positions 1367 both in characters and in bytes. */ 1368 1369Lisp_Object 1370substring_both (string, from, from_byte, to, to_byte) 1371 Lisp_Object string; 1372 int from, from_byte, to, to_byte; 1373{ 1374 Lisp_Object res; 1375 int size; 1376 int size_byte; 1377 1378 CHECK_VECTOR_OR_STRING (string); 1379 1380 if (STRINGP (string)) 1381 { 1382 size = SCHARS (string); 1383 size_byte = SBYTES (string); 1384 } 1385 else 1386 size = ASIZE (string); 1387 1388 if (!(0 <= from && from <= to && to <= size)) 1389 args_out_of_range_3 (string, make_number (from), make_number (to)); 1390 1391 if (STRINGP (string)) 1392 { 1393 res = make_specified_string (SDATA (string) + from_byte, 1394 to - from, to_byte - from_byte, 1395 STRING_MULTIBYTE (string)); 1396 copy_text_properties (make_number (from), make_number (to), 1397 string, make_number (0), res, Qnil); 1398 } 1399 else 1400 res = Fvector (to - from, &AREF (string, from)); 1401 1402 return res; 1403} 1404 1405DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0, 1406 doc: /* Take cdr N times on LIST, returns the result. */) 1407 (n, list) 1408 Lisp_Object n; 1409 register Lisp_Object list; 1410{ 1411 register int i, num; 1412 CHECK_NUMBER (n); 1413 num = XINT (n); 1414 for (i = 0; i < num && !NILP (list); i++) 1415 { 1416 QUIT; 1417 CHECK_LIST_CONS (list, list); 1418 list = XCDR (list); 1419 } 1420 return list; 1421} 1422 1423DEFUN ("nth", Fnth, Snth, 2, 2, 0, 1424 doc: /* Return the Nth element of LIST. 1425N counts from zero. If LIST is not that long, nil is returned. */) 1426 (n, list) 1427 Lisp_Object n, list; 1428{ 1429 return Fcar (Fnthcdr (n, list)); 1430} 1431 1432DEFUN ("elt", Felt, Selt, 2, 2, 0, 1433 doc: /* Return element of SEQUENCE at index N. */) 1434 (sequence, n) 1435 register Lisp_Object sequence, n; 1436{ 1437 CHECK_NUMBER (n); 1438 if (CONSP (sequence) || NILP (sequence)) 1439 return Fcar (Fnthcdr (n, sequence)); 1440 1441 /* Faref signals a "not array" error, so check here. */ 1442 CHECK_ARRAY (sequence, Qsequencep); 1443 return Faref (sequence, n); 1444} 1445 1446DEFUN ("member", Fmember, Smember, 2, 2, 0, 1447doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'. 1448The value is actually the tail of LIST whose car is ELT. */) 1449 (elt, list) 1450 register Lisp_Object elt; 1451 Lisp_Object list; 1452{ 1453 register Lisp_Object tail; 1454 for (tail = list; !NILP (tail); tail = XCDR (tail)) 1455 { 1456 register Lisp_Object tem; 1457 CHECK_LIST_CONS (tail, list); 1458 tem = XCAR (tail); 1459 if (! NILP (Fequal (elt, tem))) 1460 return tail; 1461 QUIT; 1462 } 1463 return Qnil; 1464} 1465 1466DEFUN ("memq", Fmemq, Smemq, 2, 2, 0, 1467doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'. 1468The value is actually the tail of LIST whose car is ELT. */) 1469 (elt, list) 1470 register Lisp_Object elt, list; 1471{ 1472 while (1) 1473 { 1474 if (!CONSP (list) || EQ (XCAR (list), elt)) 1475 break; 1476 1477 list = XCDR (list); 1478 if (!CONSP (list) || EQ (XCAR (list), elt)) 1479 break; 1480 1481 list = XCDR (list); 1482 if (!CONSP (list) || EQ (XCAR (list), elt)) 1483 break; 1484 1485 list = XCDR (list); 1486 QUIT; 1487 } 1488 1489 CHECK_LIST (list); 1490 return list; 1491} 1492 1493DEFUN ("memql", Fmemql, Smemql, 2, 2, 0, 1494doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'. 1495The value is actually the tail of LIST whose car is ELT. */) 1496 (elt, list) 1497 register Lisp_Object elt; 1498 Lisp_Object list; 1499{ 1500 register Lisp_Object tail; 1501 1502 if (!FLOATP (elt)) 1503 return Fmemq (elt, list); 1504 1505 for (tail = list; !NILP (tail); tail = XCDR (tail)) 1506 { 1507 register Lisp_Object tem; 1508 CHECK_LIST_CONS (tail, list); 1509 tem = XCAR (tail); 1510 if (FLOATP (tem) && internal_equal (elt, tem, 0, 0)) 1511 return tail; 1512 QUIT; 1513 } 1514 return Qnil; 1515} 1516 1517DEFUN ("assq", Fassq, Sassq, 2, 2, 0, 1518 doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST. 1519The value is actually the first element of LIST whose car is KEY. 1520Elements of LIST that are not conses are ignored. */) 1521 (key, list) 1522 Lisp_Object key, list; 1523{ 1524 while (1) 1525 { 1526 if (!CONSP (list) 1527 || (CONSP (XCAR (list)) 1528 && EQ (XCAR (XCAR (list)), key))) 1529 break; 1530 1531 list = XCDR (list); 1532 if (!CONSP (list) 1533 || (CONSP (XCAR (list)) 1534 && EQ (XCAR (XCAR (list)), key))) 1535 break; 1536 1537 list = XCDR (list); 1538 if (!CONSP (list) 1539 || (CONSP (XCAR (list)) 1540 && EQ (XCAR (XCAR (list)), key))) 1541 break; 1542 1543 list = XCDR (list); 1544 QUIT; 1545 } 1546 1547 return CAR (list); 1548} 1549 1550/* Like Fassq but never report an error and do not allow quits. 1551 Use only on lists known never to be circular. */ 1552 1553Lisp_Object 1554assq_no_quit (key, list) 1555 Lisp_Object key, list; 1556{ 1557 while (CONSP (list) 1558 && (!CONSP (XCAR (list)) 1559 || !EQ (XCAR (XCAR (list)), key))) 1560 list = XCDR (list); 1561 1562 return CAR_SAFE (list); 1563} 1564 1565DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0, 1566 doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST. 1567The value is actually the first element of LIST whose car equals KEY. */) 1568 (key, list) 1569 Lisp_Object key, list; 1570{ 1571 Lisp_Object car; 1572 1573 while (1) 1574 { 1575 if (!CONSP (list) 1576 || (CONSP (XCAR (list)) 1577 && (car = XCAR (XCAR (list)), 1578 EQ (car, key) || !NILP (Fequal (car, key))))) 1579 break; 1580 1581 list = XCDR (list); 1582 if (!CONSP (list) 1583 || (CONSP (XCAR (list)) 1584 && (car = XCAR (XCAR (list)), 1585 EQ (car, key) || !NILP (Fequal (car, key))))) 1586 break; 1587 1588 list = XCDR (list); 1589 if (!CONSP (list) 1590 || (CONSP (XCAR (list)) 1591 && (car = XCAR (XCAR (list)), 1592 EQ (car, key) || !NILP (Fequal (car, key))))) 1593 break; 1594 1595 list = XCDR (list); 1596 QUIT; 1597 } 1598 1599 return CAR (list); 1600} 1601 1602DEFUN ("rassq", Frassq, Srassq, 2, 2, 0, 1603 doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST. 1604The value is actually the first element of LIST whose cdr is KEY. */) 1605 (key, list) 1606 register Lisp_Object key; 1607 Lisp_Object list; 1608{ 1609 while (1) 1610 { 1611 if (!CONSP (list) 1612 || (CONSP (XCAR (list)) 1613 && EQ (XCDR (XCAR (list)), key))) 1614 break; 1615 1616 list = XCDR (list); 1617 if (!CONSP (list) 1618 || (CONSP (XCAR (list)) 1619 && EQ (XCDR (XCAR (list)), key))) 1620 break; 1621 1622 list = XCDR (list); 1623 if (!CONSP (list) 1624 || (CONSP (XCAR (list)) 1625 && EQ (XCDR (XCAR (list)), key))) 1626 break; 1627 1628 list = XCDR (list); 1629 QUIT; 1630 } 1631 1632 return CAR (list); 1633} 1634 1635DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0, 1636 doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST. 1637The value is actually the first element of LIST whose cdr equals KEY. */) 1638 (key, list) 1639 Lisp_Object key, list; 1640{ 1641 Lisp_Object cdr; 1642 1643 while (1) 1644 { 1645 if (!CONSP (list) 1646 || (CONSP (XCAR (list)) 1647 && (cdr = XCDR (XCAR (list)), 1648 EQ (cdr, key) || !NILP (Fequal (cdr, key))))) 1649 break; 1650 1651 list = XCDR (list); 1652 if (!CONSP (list) 1653 || (CONSP (XCAR (list)) 1654 && (cdr = XCDR (XCAR (list)), 1655 EQ (cdr, key) || !NILP (Fequal (cdr, key))))) 1656 break; 1657 1658 list = XCDR (list); 1659 if (!CONSP (list) 1660 || (CONSP (XCAR (list)) 1661 && (cdr = XCDR (XCAR (list)), 1662 EQ (cdr, key) || !NILP (Fequal (cdr, key))))) 1663 break; 1664 1665 list = XCDR (list); 1666 QUIT; 1667 } 1668 1669 return CAR (list); 1670} 1671 1672DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0, 1673 doc: /* Delete by side effect any occurrences of ELT as a member of LIST. 1674The modified LIST is returned. Comparison is done with `eq'. 1675If the first member of LIST is ELT, there is no way to remove it by side effect; 1676therefore, write `(setq foo (delq element foo))' 1677to be sure of changing the value of `foo'. */) 1678 (elt, list) 1679 register Lisp_Object elt; 1680 Lisp_Object list; 1681{ 1682 register Lisp_Object tail, prev; 1683 register Lisp_Object tem; 1684 1685 tail = list; 1686 prev = Qnil; 1687 while (!NILP (tail)) 1688 { 1689 CHECK_LIST_CONS (tail, list); 1690 tem = XCAR (tail); 1691 if (EQ (elt, tem)) 1692 { 1693 if (NILP (prev)) 1694 list = XCDR (tail); 1695 else 1696 Fsetcdr (prev, XCDR (tail)); 1697 } 1698 else 1699 prev = tail; 1700 tail = XCDR (tail); 1701 QUIT; 1702 } 1703 return list; 1704} 1705 1706DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0, 1707 doc: /* Delete by side effect any occurrences of ELT as a member of SEQ. 1708SEQ must be a list, a vector, or a string. 1709The modified SEQ is returned. Comparison is done with `equal'. 1710If SEQ is not a list, or the first member of SEQ is ELT, deleting it 1711is not a side effect; it is simply using a different sequence. 1712Therefore, write `(setq foo (delete element foo))' 1713to be sure of changing the value of `foo'. */) 1714 (elt, seq) 1715 Lisp_Object elt, seq; 1716{ 1717 if (VECTORP (seq)) 1718 { 1719 EMACS_INT i, n; 1720 1721 for (i = n = 0; i < ASIZE (seq); ++i) 1722 if (NILP (Fequal (AREF (seq, i), elt))) 1723 ++n; 1724 1725 if (n != ASIZE (seq)) 1726 { 1727 struct Lisp_Vector *p = allocate_vector (n); 1728 1729 for (i = n = 0; i < ASIZE (seq); ++i) 1730 if (NILP (Fequal (AREF (seq, i), elt))) 1731 p->contents[n++] = AREF (seq, i); 1732 1733 XSETVECTOR (seq, p); 1734 } 1735 } 1736 else if (STRINGP (seq)) 1737 { 1738 EMACS_INT i, ibyte, nchars, nbytes, cbytes; 1739 int c; 1740 1741 for (i = nchars = nbytes = ibyte = 0; 1742 i < SCHARS (seq); 1743 ++i, ibyte += cbytes) 1744 { 1745 if (STRING_MULTIBYTE (seq)) 1746 { 1747 c = STRING_CHAR (SDATA (seq) + ibyte, 1748 SBYTES (seq) - ibyte); 1749 cbytes = CHAR_BYTES (c); 1750 } 1751 else 1752 { 1753 c = SREF (seq, i); 1754 cbytes = 1; 1755 } 1756 1757 if (!INTEGERP (elt) || c != XINT (elt)) 1758 { 1759 ++nchars; 1760 nbytes += cbytes; 1761 } 1762 } 1763 1764 if (nchars != SCHARS (seq)) 1765 { 1766 Lisp_Object tem; 1767 1768 tem = make_uninit_multibyte_string (nchars, nbytes); 1769 if (!STRING_MULTIBYTE (seq)) 1770 STRING_SET_UNIBYTE (tem); 1771 1772 for (i = nchars = nbytes = ibyte = 0; 1773 i < SCHARS (seq); 1774 ++i, ibyte += cbytes) 1775 { 1776 if (STRING_MULTIBYTE (seq)) 1777 { 1778 c = STRING_CHAR (SDATA (seq) + ibyte, 1779 SBYTES (seq) - ibyte); 1780 cbytes = CHAR_BYTES (c); 1781 } 1782 else 1783 { 1784 c = SREF (seq, i); 1785 cbytes = 1; 1786 } 1787 1788 if (!INTEGERP (elt) || c != XINT (elt)) 1789 { 1790 unsigned char *from = SDATA (seq) + ibyte; 1791 unsigned char *to = SDATA (tem) + nbytes; 1792 EMACS_INT n; 1793 1794 ++nchars; 1795 nbytes += cbytes; 1796 1797 for (n = cbytes; n--; ) 1798 *to++ = *from++; 1799 } 1800 } 1801 1802 seq = tem; 1803 } 1804 } 1805 else 1806 { 1807 Lisp_Object tail, prev; 1808 1809 for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail)) 1810 { 1811 CHECK_LIST_CONS (tail, seq); 1812 1813 if (!NILP (Fequal (elt, XCAR (tail)))) 1814 { 1815 if (NILP (prev)) 1816 seq = XCDR (tail); 1817 else 1818 Fsetcdr (prev, XCDR (tail)); 1819 } 1820 else 1821 prev = tail; 1822 QUIT; 1823 } 1824 } 1825 1826 return seq; 1827} 1828 1829DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0, 1830 doc: /* Reverse LIST by modifying cdr pointers. 1831Return the reversed list. */) 1832 (list) 1833 Lisp_Object list; 1834{ 1835 register Lisp_Object prev, tail, next; 1836 1837 if (NILP (list)) return list; 1838 prev = Qnil; 1839 tail = list; 1840 while (!NILP (tail)) 1841 { 1842 QUIT; 1843 CHECK_LIST_CONS (tail, list); 1844 next = XCDR (tail); 1845 Fsetcdr (tail, prev); 1846 prev = tail; 1847 tail = next; 1848 } 1849 return prev; 1850} 1851 1852DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0, 1853 doc: /* Reverse LIST, copying. Return the reversed list. 1854See also the function `nreverse', which is used more often. */) 1855 (list) 1856 Lisp_Object list; 1857{ 1858 Lisp_Object new; 1859 1860 for (new = Qnil; CONSP (list); list = XCDR (list)) 1861 { 1862 QUIT; 1863 new = Fcons (XCAR (list), new); 1864 } 1865 CHECK_LIST_END (list, list); 1866 return new; 1867} 1868 1869Lisp_Object merge (); 1870 1871DEFUN ("sort", Fsort, Ssort, 2, 2, 0, 1872 doc: /* Sort LIST, stably, comparing elements using PREDICATE. 1873Returns the sorted list. LIST is modified by side effects. 1874PREDICATE is called with two elements of LIST, and should return non-nil 1875if the first element should sort before the second. */) 1876 (list, predicate) 1877 Lisp_Object list, predicate; 1878{ 1879 Lisp_Object front, back; 1880 register Lisp_Object len, tem; 1881 struct gcpro gcpro1, gcpro2; 1882 register int length; 1883 1884 front = list; 1885 len = Flength (list); 1886 length = XINT (len); 1887 if (length < 2) 1888 return list; 1889 1890 XSETINT (len, (length / 2) - 1); 1891 tem = Fnthcdr (len, list); 1892 back = Fcdr (tem); 1893 Fsetcdr (tem, Qnil); 1894 1895 GCPRO2 (front, back); 1896 front = Fsort (front, predicate); 1897 back = Fsort (back, predicate); 1898 UNGCPRO; 1899 return merge (front, back, predicate); 1900} 1901 1902Lisp_Object 1903merge (org_l1, org_l2, pred) 1904 Lisp_Object org_l1, org_l2; 1905 Lisp_Object pred; 1906{ 1907 Lisp_Object value; 1908 register Lisp_Object tail; 1909 Lisp_Object tem; 1910 register Lisp_Object l1, l2; 1911 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; 1912 1913 l1 = org_l1; 1914 l2 = org_l2; 1915 tail = Qnil; 1916 value = Qnil; 1917 1918 /* It is sufficient to protect org_l1 and org_l2. 1919 When l1 and l2 are updated, we copy the new values 1920 back into the org_ vars. */ 1921 GCPRO4 (org_l1, org_l2, pred, value); 1922 1923 while (1) 1924 { 1925 if (NILP (l1)) 1926 { 1927 UNGCPRO; 1928 if (NILP (tail)) 1929 return l2; 1930 Fsetcdr (tail, l2); 1931 return value; 1932 } 1933 if (NILP (l2)) 1934 { 1935 UNGCPRO; 1936 if (NILP (tail)) 1937 return l1; 1938 Fsetcdr (tail, l1); 1939 return value; 1940 } 1941 tem = call2 (pred, Fcar (l2), Fcar (l1)); 1942 if (NILP (tem)) 1943 { 1944 tem = l1; 1945 l1 = Fcdr (l1); 1946 org_l1 = l1; 1947 } 1948 else 1949 { 1950 tem = l2; 1951 l2 = Fcdr (l2); 1952 org_l2 = l2; 1953 } 1954 if (NILP (tail)) 1955 value = tem; 1956 else 1957 Fsetcdr (tail, tem); 1958 tail = tem; 1959 } 1960} 1961 1962 1963#if 0 /* Unsafe version. */ 1964DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0, 1965 doc: /* Extract a value from a property list. 1966PLIST is a property list, which is a list of the form 1967\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value 1968corresponding to the given PROP, or nil if PROP is not 1969one of the properties on the list. */) 1970 (plist, prop) 1971 Lisp_Object plist; 1972 Lisp_Object prop; 1973{ 1974 Lisp_Object tail; 1975 1976 for (tail = plist; 1977 CONSP (tail) && CONSP (XCDR (tail)); 1978 tail = XCDR (XCDR (tail))) 1979 { 1980 if (EQ (prop, XCAR (tail))) 1981 return XCAR (XCDR (tail)); 1982 1983 /* This function can be called asynchronously 1984 (setup_coding_system). Don't QUIT in that case. */ 1985 if (!interrupt_input_blocked) 1986 QUIT; 1987 } 1988 1989 CHECK_LIST_END (tail, prop); 1990 1991 return Qnil; 1992} 1993#endif 1994 1995/* This does not check for quits. That is safe since it must terminate. */ 1996 1997DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0, 1998 doc: /* Extract a value from a property list. 1999PLIST is a property list, which is a list of the form 2000\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value 2001corresponding to the given PROP, or nil if PROP is not one of the 2002properties on the list. This function never signals an error. */) 2003 (plist, prop) 2004 Lisp_Object plist; 2005 Lisp_Object prop; 2006{ 2007 Lisp_Object tail, halftail; 2008 2009 /* halftail is used to detect circular lists. */ 2010 tail = halftail = plist; 2011 while (CONSP (tail) && CONSP (XCDR (tail))) 2012 { 2013 if (EQ (prop, XCAR (tail))) 2014 return XCAR (XCDR (tail)); 2015 2016 tail = XCDR (XCDR (tail)); 2017 halftail = XCDR (halftail); 2018 if (EQ (tail, halftail)) 2019 break; 2020 } 2021 2022 return Qnil; 2023} 2024 2025DEFUN ("get", Fget, Sget, 2, 2, 0, 2026 doc: /* Return the value of SYMBOL's PROPNAME property. 2027This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */) 2028 (symbol, propname) 2029 Lisp_Object symbol, propname; 2030{ 2031 CHECK_SYMBOL (symbol); 2032 return Fplist_get (XSYMBOL (symbol)->plist, propname); 2033} 2034 2035DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0, 2036 doc: /* Change value in PLIST of PROP to VAL. 2037PLIST is a property list, which is a list of the form 2038\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object. 2039If PROP is already a property on the list, its value is set to VAL, 2040otherwise the new PROP VAL pair is added. The new plist is returned; 2041use `(setq x (plist-put x prop val))' to be sure to use the new value. 2042The PLIST is modified by side effects. */) 2043 (plist, prop, val) 2044 Lisp_Object plist; 2045 register Lisp_Object prop; 2046 Lisp_Object val; 2047{ 2048 register Lisp_Object tail, prev; 2049 Lisp_Object newcell; 2050 prev = Qnil; 2051 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail)); 2052 tail = XCDR (XCDR (tail))) 2053 { 2054 if (EQ (prop, XCAR (tail))) 2055 { 2056 Fsetcar (XCDR (tail), val); 2057 return plist; 2058 } 2059 2060 prev = tail; 2061 QUIT; 2062 } 2063 newcell = Fcons (prop, Fcons (val, Qnil)); 2064 if (NILP (prev)) 2065 return newcell; 2066 else 2067 Fsetcdr (XCDR (prev), newcell); 2068 return plist; 2069} 2070 2071DEFUN ("put", Fput, Sput, 3, 3, 0, 2072 doc: /* Store SYMBOL's PROPNAME property with value VALUE. 2073It can be retrieved with `(get SYMBOL PROPNAME)'. */) 2074 (symbol, propname, value) 2075 Lisp_Object symbol, propname, value; 2076{ 2077 CHECK_SYMBOL (symbol); 2078 XSYMBOL (symbol)->plist 2079 = Fplist_put (XSYMBOL (symbol)->plist, propname, value); 2080 return value; 2081} 2082 2083DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0, 2084 doc: /* Extract a value from a property list, comparing with `equal'. 2085PLIST is a property list, which is a list of the form 2086\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value 2087corresponding to the given PROP, or nil if PROP is not 2088one of the properties on the list. */) 2089 (plist, prop) 2090 Lisp_Object plist; 2091 Lisp_Object prop; 2092{ 2093 Lisp_Object tail; 2094 2095 for (tail = plist; 2096 CONSP (tail) && CONSP (XCDR (tail)); 2097 tail = XCDR (XCDR (tail))) 2098 { 2099 if (! NILP (Fequal (prop, XCAR (tail)))) 2100 return XCAR (XCDR (tail)); 2101 2102 QUIT; 2103 } 2104 2105 CHECK_LIST_END (tail, prop); 2106 2107 return Qnil; 2108} 2109 2110DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0, 2111 doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'. 2112PLIST is a property list, which is a list of the form 2113\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects. 2114If PROP is already a property on the list, its value is set to VAL, 2115otherwise the new PROP VAL pair is added. The new plist is returned; 2116use `(setq x (lax-plist-put x prop val))' to be sure to use the new value. 2117The PLIST is modified by side effects. */) 2118 (plist, prop, val) 2119 Lisp_Object plist; 2120 register Lisp_Object prop; 2121 Lisp_Object val; 2122{ 2123 register Lisp_Object tail, prev; 2124 Lisp_Object newcell; 2125 prev = Qnil; 2126 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail)); 2127 tail = XCDR (XCDR (tail))) 2128 { 2129 if (! NILP (Fequal (prop, XCAR (tail)))) 2130 { 2131 Fsetcar (XCDR (tail), val); 2132 return plist; 2133 } 2134 2135 prev = tail; 2136 QUIT; 2137 } 2138 newcell = Fcons (prop, Fcons (val, Qnil)); 2139 if (NILP (prev)) 2140 return newcell; 2141 else 2142 Fsetcdr (XCDR (prev), newcell); 2143 return plist; 2144} 2145 2146DEFUN ("eql", Feql, Seql, 2, 2, 0, 2147 doc: /* Return t if the two args are the same Lisp object. 2148Floating-point numbers of equal value are `eql', but they may not be `eq'. */) 2149 (obj1, obj2) 2150 Lisp_Object obj1, obj2; 2151{ 2152 if (FLOATP (obj1)) 2153 return internal_equal (obj1, obj2, 0, 0) ? Qt : Qnil; 2154 else 2155 return EQ (obj1, obj2) ? Qt : Qnil; 2156} 2157 2158DEFUN ("equal", Fequal, Sequal, 2, 2, 0, 2159 doc: /* Return t if two Lisp objects have similar structure and contents. 2160They must have the same data type. 2161Conses are compared by comparing the cars and the cdrs. 2162Vectors and strings are compared element by element. 2163Numbers are compared by value, but integers cannot equal floats. 2164 (Use `=' if you want integers and floats to be able to be equal.) 2165Symbols must match exactly. */) 2166 (o1, o2) 2167 register Lisp_Object o1, o2; 2168{ 2169 return internal_equal (o1, o2, 0, 0) ? Qt : Qnil; 2170} 2171 2172DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0, 2173 doc: /* Return t if two Lisp objects have similar structure and contents. 2174This is like `equal' except that it compares the text properties 2175of strings. (`equal' ignores text properties.) */) 2176 (o1, o2) 2177 register Lisp_Object o1, o2; 2178{ 2179 return internal_equal (o1, o2, 0, 1) ? Qt : Qnil; 2180} 2181 2182/* DEPTH is current depth of recursion. Signal an error if it 2183 gets too deep. 2184 PROPS, if non-nil, means compare string text properties too. */ 2185 2186static int 2187internal_equal (o1, o2, depth, props) 2188 register Lisp_Object o1, o2; 2189 int depth, props; 2190{ 2191 if (depth > 200) 2192 error ("Stack overflow in equal"); 2193 2194 tail_recurse: 2195 QUIT; 2196 if (EQ (o1, o2)) 2197 return 1; 2198 if (XTYPE (o1) != XTYPE (o2)) 2199 return 0; 2200 2201 switch (XTYPE (o1)) 2202 { 2203 case Lisp_Float: 2204 { 2205 double d1, d2; 2206 2207 d1 = extract_float (o1); 2208 d2 = extract_float (o2); 2209 /* If d is a NaN, then d != d. Two NaNs should be `equal' even 2210 though they are not =. */ 2211 return d1 == d2 || (d1 != d1 && d2 != d2); 2212 } 2213 2214 case Lisp_Cons: 2215 if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props)) 2216 return 0; 2217 o1 = XCDR (o1); 2218 o2 = XCDR (o2); 2219 goto tail_recurse; 2220 2221 case Lisp_Misc: 2222 if (XMISCTYPE (o1) != XMISCTYPE (o2)) 2223 return 0; 2224 if (OVERLAYP (o1)) 2225 { 2226 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2), 2227 depth + 1, props) 2228 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2), 2229 depth + 1, props)) 2230 return 0; 2231 o1 = XOVERLAY (o1)->plist; 2232 o2 = XOVERLAY (o2)->plist; 2233 goto tail_recurse; 2234 } 2235 if (MARKERP (o1)) 2236 { 2237 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer 2238 && (XMARKER (o1)->buffer == 0 2239 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos)); 2240 } 2241 break; 2242 2243 case Lisp_Vectorlike: 2244 { 2245 register int i; 2246 EMACS_INT size = ASIZE (o1); 2247 /* Pseudovectors have the type encoded in the size field, so this test 2248 actually checks that the objects have the same type as well as the 2249 same size. */ 2250 if (ASIZE (o2) != size) 2251 return 0; 2252 /* Boolvectors are compared much like strings. */ 2253 if (BOOL_VECTOR_P (o1)) 2254 { 2255 int size_in_chars 2256 = ((XBOOL_VECTOR (o1)->size + BOOL_VECTOR_BITS_PER_CHAR - 1) 2257 / BOOL_VECTOR_BITS_PER_CHAR); 2258 2259 if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size) 2260 return 0; 2261 if (bcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data, 2262 size_in_chars)) 2263 return 0; 2264 return 1; 2265 } 2266 if (WINDOW_CONFIGURATIONP (o1)) 2267 return compare_window_configurations (o1, o2, 0); 2268 2269 /* Aside from them, only true vectors, char-tables, and compiled 2270 functions are sensible to compare, so eliminate the others now. */ 2271 if (size & PSEUDOVECTOR_FLAG) 2272 { 2273 if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE))) 2274 return 0; 2275 size &= PSEUDOVECTOR_SIZE_MASK; 2276 } 2277 for (i = 0; i < size; i++) 2278 { 2279 Lisp_Object v1, v2; 2280 v1 = AREF (o1, i); 2281 v2 = AREF (o2, i); 2282 if (!internal_equal (v1, v2, depth + 1, props)) 2283 return 0; 2284 } 2285 return 1; 2286 } 2287 break; 2288 2289 case Lisp_String: 2290 if (SCHARS (o1) != SCHARS (o2)) 2291 return 0; 2292 if (SBYTES (o1) != SBYTES (o2)) 2293 return 0; 2294 if (bcmp (SDATA (o1), SDATA (o2), 2295 SBYTES (o1))) 2296 return 0; 2297 if (props && !compare_string_intervals (o1, o2)) 2298 return 0; 2299 return 1; 2300 2301 case Lisp_Int: 2302 case Lisp_Symbol: 2303 case Lisp_Type_Limit: 2304 break; 2305 } 2306 2307 return 0; 2308} 2309 2310extern Lisp_Object Fmake_char_internal (); 2311 2312DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0, 2313 doc: /* Store each element of ARRAY with ITEM. 2314ARRAY is a vector, string, char-table, or bool-vector. */) 2315 (array, item) 2316 Lisp_Object array, item; 2317{ 2318 register int size, index, charval; 2319 if (VECTORP (array)) 2320 { 2321 register Lisp_Object *p = XVECTOR (array)->contents; 2322 size = ASIZE (array); 2323 for (index = 0; index < size; index++) 2324 p[index] = item; 2325 } 2326 else if (CHAR_TABLE_P (array)) 2327 { 2328 register Lisp_Object *p = XCHAR_TABLE (array)->contents; 2329 size = CHAR_TABLE_ORDINARY_SLOTS; 2330 for (index = 0; index < size; index++) 2331 p[index] = item; 2332 XCHAR_TABLE (array)->defalt = Qnil; 2333 } 2334 else if (STRINGP (array)) 2335 { 2336 register unsigned char *p = SDATA (array); 2337 CHECK_NUMBER (item); 2338 charval = XINT (item); 2339 size = SCHARS (array); 2340 if (STRING_MULTIBYTE (array)) 2341 { 2342 unsigned char str[MAX_MULTIBYTE_LENGTH]; 2343 int len = CHAR_STRING (charval, str); 2344 int size_byte = SBYTES (array); 2345 unsigned char *p1 = p, *endp = p + size_byte; 2346 int i; 2347 2348 if (size != size_byte) 2349 while (p1 < endp) 2350 { 2351 int this_len = MULTIBYTE_FORM_LENGTH (p1, endp - p1); 2352 if (len != this_len) 2353 error ("Attempt to change byte length of a string"); 2354 p1 += this_len; 2355 } 2356 for (i = 0; i < size_byte; i++) 2357 *p++ = str[i % len]; 2358 } 2359 else 2360 for (index = 0; index < size; index++) 2361 p[index] = charval; 2362 } 2363 else if (BOOL_VECTOR_P (array)) 2364 { 2365 register unsigned char *p = XBOOL_VECTOR (array)->data; 2366 int size_in_chars 2367 = ((XBOOL_VECTOR (array)->size + BOOL_VECTOR_BITS_PER_CHAR - 1) 2368 / BOOL_VECTOR_BITS_PER_CHAR); 2369 2370 charval = (! NILP (item) ? -1 : 0); 2371 for (index = 0; index < size_in_chars - 1; index++) 2372 p[index] = charval; 2373 if (index < size_in_chars) 2374 { 2375 /* Mask out bits beyond the vector size. */ 2376 if (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR) 2377 charval &= (1 << (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)) - 1; 2378 p[index] = charval; 2379 } 2380 } 2381 else 2382 wrong_type_argument (Qarrayp, array); 2383 return array; 2384} 2385 2386DEFUN ("clear-string", Fclear_string, Sclear_string, 2387 1, 1, 0, 2388 doc: /* Clear the contents of STRING. 2389This makes STRING unibyte and may change its length. */) 2390 (string) 2391 Lisp_Object string; 2392{ 2393 int len; 2394 CHECK_STRING (string); 2395 len = SBYTES (string); 2396 bzero (SDATA (string), len); 2397 STRING_SET_CHARS (string, len); 2398 STRING_SET_UNIBYTE (string); 2399 return Qnil; 2400} 2401 2402DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype, 2403 1, 1, 0, 2404 doc: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */) 2405 (char_table) 2406 Lisp_Object char_table; 2407{ 2408 CHECK_CHAR_TABLE (char_table); 2409 2410 return XCHAR_TABLE (char_table)->purpose; 2411} 2412 2413DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent, 2414 1, 1, 0, 2415 doc: /* Return the parent char-table of CHAR-TABLE. 2416The value is either nil or another char-table. 2417If CHAR-TABLE holds nil for a given character, 2418then the actual applicable value is inherited from the parent char-table 2419\(or from its parents, if necessary). */) 2420 (char_table) 2421 Lisp_Object char_table; 2422{ 2423 CHECK_CHAR_TABLE (char_table); 2424 2425 return XCHAR_TABLE (char_table)->parent; 2426} 2427 2428DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent, 2429 2, 2, 0, 2430 doc: /* Set the parent char-table of CHAR-TABLE to PARENT. 2431Return PARENT. PARENT must be either nil or another char-table. */) 2432 (char_table, parent) 2433 Lisp_Object char_table, parent; 2434{ 2435 Lisp_Object temp; 2436 2437 CHECK_CHAR_TABLE (char_table); 2438 2439 if (!NILP (parent)) 2440 { 2441 CHECK_CHAR_TABLE (parent); 2442 2443 for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent) 2444 if (EQ (temp, char_table)) 2445 error ("Attempt to make a chartable be its own parent"); 2446 } 2447 2448 XCHAR_TABLE (char_table)->parent = parent; 2449 2450 return parent; 2451} 2452 2453DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot, 2454 2, 2, 0, 2455 doc: /* Return the value of CHAR-TABLE's extra-slot number N. */) 2456 (char_table, n) 2457 Lisp_Object char_table, n; 2458{ 2459 CHECK_CHAR_TABLE (char_table); 2460 CHECK_NUMBER (n); 2461 if (XINT (n) < 0 2462 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table))) 2463 args_out_of_range (char_table, n); 2464 2465 return XCHAR_TABLE (char_table)->extras[XINT (n)]; 2466} 2467 2468DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot, 2469 Sset_char_table_extra_slot, 2470 3, 3, 0, 2471 doc: /* Set CHAR-TABLE's extra-slot number N to VALUE. */) 2472 (char_table, n, value) 2473 Lisp_Object char_table, n, value; 2474{ 2475 CHECK_CHAR_TABLE (char_table); 2476 CHECK_NUMBER (n); 2477 if (XINT (n) < 0 2478 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table))) 2479 args_out_of_range (char_table, n); 2480 2481 return XCHAR_TABLE (char_table)->extras[XINT (n)] = value; 2482} 2483 2484static Lisp_Object 2485char_table_range (table, from, to, defalt) 2486 Lisp_Object table; 2487 int from, to; 2488 Lisp_Object defalt; 2489{ 2490 Lisp_Object val; 2491 2492 if (! NILP (XCHAR_TABLE (table)->defalt)) 2493 defalt = XCHAR_TABLE (table)->defalt; 2494 val = XCHAR_TABLE (table)->contents[from]; 2495 if (SUB_CHAR_TABLE_P (val)) 2496 val = char_table_range (val, 32, 127, defalt); 2497 else if (NILP (val)) 2498 val = defalt; 2499 for (from++; from <= to; from++) 2500 { 2501 Lisp_Object this_val; 2502 2503 this_val = XCHAR_TABLE (table)->contents[from]; 2504 if (SUB_CHAR_TABLE_P (this_val)) 2505 this_val = char_table_range (this_val, 32, 127, defalt); 2506 else if (NILP (this_val)) 2507 this_val = defalt; 2508 if (! EQ (val, this_val)) 2509 error ("Characters in the range have inconsistent values"); 2510 } 2511 return val; 2512} 2513 2514 2515DEFUN ("char-table-range", Fchar_table_range, Schar_table_range, 2516 2, 2, 0, 2517 doc: /* Return the value in CHAR-TABLE for a range of characters RANGE. 2518RANGE should be nil (for the default value), 2519a vector which identifies a character set or a row of a character set, 2520a character set name, or a character code. 2521If the characters in the specified range have different values, 2522an error is signaled. 2523 2524Note that this function doesn't check the parent of CHAR-TABLE. */) 2525 (char_table, range) 2526 Lisp_Object char_table, range; 2527{ 2528 int charset_id, c1 = 0, c2 = 0; 2529 int size; 2530 Lisp_Object ch, val, current_default; 2531 2532 CHECK_CHAR_TABLE (char_table); 2533 2534 if (EQ (range, Qnil)) 2535 return XCHAR_TABLE (char_table)->defalt; 2536 if (INTEGERP (range)) 2537 { 2538 int c = XINT (range); 2539 if (! CHAR_VALID_P (c, 0)) 2540 error ("Invalid character code: %d", c); 2541 ch = range; 2542 SPLIT_CHAR (c, charset_id, c1, c2); 2543 } 2544 else if (SYMBOLP (range)) 2545 { 2546 Lisp_Object charset_info; 2547 2548 charset_info = Fget (range, Qcharset); 2549 CHECK_VECTOR (charset_info); 2550 charset_id = XINT (AREF (charset_info, 0)); 2551 ch = Fmake_char_internal (make_number (charset_id), 2552 make_number (0), make_number (0)); 2553 } 2554 else if (VECTORP (range)) 2555 { 2556 size = ASIZE (range); 2557 if (size == 0) 2558 args_out_of_range (range, make_number (0)); 2559 CHECK_NUMBER (AREF (range, 0)); 2560 charset_id = XINT (AREF (range, 0)); 2561 if (size > 1) 2562 { 2563 CHECK_NUMBER (AREF (range, 1)); 2564 c1 = XINT (AREF (range, 1)); 2565 if (size > 2) 2566 { 2567 CHECK_NUMBER (AREF (range, 2)); 2568 c2 = XINT (AREF (range, 2)); 2569 } 2570 } 2571 2572 /* This checks if charset_id, c0, and c1 are all valid or not. */ 2573 ch = Fmake_char_internal (make_number (charset_id), 2574 make_number (c1), make_number (c2)); 2575 } 2576 else 2577 error ("Invalid RANGE argument to `char-table-range'"); 2578 2579 if (c1 > 0 && (CHARSET_DIMENSION (charset_id) == 1 || c2 > 0)) 2580 { 2581 /* Fully specified character. */ 2582 Lisp_Object parent = XCHAR_TABLE (char_table)->parent; 2583 2584 XCHAR_TABLE (char_table)->parent = Qnil; 2585 val = Faref (char_table, ch); 2586 XCHAR_TABLE (char_table)->parent = parent; 2587 return val; 2588 } 2589 2590 current_default = XCHAR_TABLE (char_table)->defalt; 2591 if (charset_id == CHARSET_ASCII 2592 || charset_id == CHARSET_8_BIT_CONTROL 2593 || charset_id == CHARSET_8_BIT_GRAPHIC) 2594 { 2595 int from, to, defalt; 2596 2597 if (charset_id == CHARSET_ASCII) 2598 from = 0, to = 127, defalt = CHAR_TABLE_DEFAULT_SLOT_ASCII; 2599 else if (charset_id == CHARSET_8_BIT_CONTROL) 2600 from = 128, to = 159, defalt = CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL; 2601 else 2602 from = 160, to = 255, defalt = CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC; 2603 if (! NILP (XCHAR_TABLE (char_table)->contents[defalt])) 2604 current_default = XCHAR_TABLE (char_table)->contents[defalt]; 2605 return char_table_range (char_table, from, to, current_default); 2606 } 2607 2608 val = XCHAR_TABLE (char_table)->contents[128 + charset_id]; 2609 if (! SUB_CHAR_TABLE_P (val)) 2610 return (NILP (val) ? current_default : val); 2611 if (! NILP (XCHAR_TABLE (val)->defalt)) 2612 current_default = XCHAR_TABLE (val)->defalt; 2613 if (c1 == 0) 2614 return char_table_range (val, 32, 127, current_default); 2615 val = XCHAR_TABLE (val)->contents[c1]; 2616 if (! SUB_CHAR_TABLE_P (val)) 2617 return (NILP (val) ? current_default : val); 2618 if (! NILP (XCHAR_TABLE (val)->defalt)) 2619 current_default = XCHAR_TABLE (val)->defalt; 2620 return char_table_range (val, 32, 127, current_default); 2621} 2622 2623DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range, 2624 3, 3, 0, 2625 doc: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE. 2626RANGE should be t (for all characters), nil (for the default value), 2627a character set, a vector which identifies a character set, a row of a 2628character set, or a character code. Return VALUE. */) 2629 (char_table, range, value) 2630 Lisp_Object char_table, range, value; 2631{ 2632 int i; 2633 2634 CHECK_CHAR_TABLE (char_table); 2635 2636 if (EQ (range, Qt)) 2637 for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++) 2638 { 2639 /* Don't set these special slots used for default values of 2640 ascii, eight-bit-control, and eight-bit-graphic. */ 2641 if (i != CHAR_TABLE_DEFAULT_SLOT_ASCII 2642 && i != CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL 2643 && i != CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC) 2644 XCHAR_TABLE (char_table)->contents[i] = value; 2645 } 2646 else if (EQ (range, Qnil)) 2647 XCHAR_TABLE (char_table)->defalt = value; 2648 else if (SYMBOLP (range)) 2649 { 2650 Lisp_Object charset_info; 2651 int charset_id; 2652 2653 charset_info = Fget (range, Qcharset); 2654 if (! VECTORP (charset_info) 2655 || ! NATNUMP (AREF (charset_info, 0)) 2656 || (charset_id = XINT (AREF (charset_info, 0)), 2657 ! CHARSET_DEFINED_P (charset_id))) 2658 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range))); 2659 2660 if (charset_id == CHARSET_ASCII) 2661 for (i = 0; i < 128; i++) 2662 XCHAR_TABLE (char_table)->contents[i] = value; 2663 else if (charset_id == CHARSET_8_BIT_CONTROL) 2664 for (i = 128; i < 160; i++) 2665 XCHAR_TABLE (char_table)->contents[i] = value; 2666 else if (charset_id == CHARSET_8_BIT_GRAPHIC) 2667 for (i = 160; i < 256; i++) 2668 XCHAR_TABLE (char_table)->contents[i] = value; 2669 else 2670 XCHAR_TABLE (char_table)->contents[charset_id + 128] = value; 2671 } 2672 else if (INTEGERP (range)) 2673 Faset (char_table, range, value); 2674 else if (VECTORP (range)) 2675 { 2676 int size = ASIZE (range); 2677 Lisp_Object *val = XVECTOR (range)->contents; 2678 Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0], 2679 size <= 1 ? Qnil : val[1], 2680 size <= 2 ? Qnil : val[2]); 2681 Faset (char_table, ch, value); 2682 } 2683 else 2684 error ("Invalid RANGE argument to `set-char-table-range'"); 2685 2686 return value; 2687} 2688 2689DEFUN ("set-char-table-default", Fset_char_table_default, 2690 Sset_char_table_default, 3, 3, 0, 2691 doc: /* Set the default value in CHAR-TABLE for generic character CH to VALUE. 2692The generic character specifies the group of characters. 2693If CH is a normal character, set the default value for a group of 2694characters to which CH belongs. 2695See also the documentation of `make-char'. */) 2696 (char_table, ch, value) 2697 Lisp_Object char_table, ch, value; 2698{ 2699 int c, charset, code1, code2; 2700 Lisp_Object temp; 2701 2702 CHECK_CHAR_TABLE (char_table); 2703 CHECK_NUMBER (ch); 2704 2705 c = XINT (ch); 2706 SPLIT_CHAR (c, charset, code1, code2); 2707 2708 /* Since we may want to set the default value for a character set 2709 not yet defined, we check only if the character set is in the 2710 valid range or not, instead of it is already defined or not. */ 2711 if (! CHARSET_VALID_P (charset)) 2712 invalid_character (c); 2713 2714 if (SINGLE_BYTE_CHAR_P (c)) 2715 { 2716 /* We use special slots for the default values of single byte 2717 characters. */ 2718 int default_slot 2719 = (c < 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII 2720 : c < 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL 2721 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC); 2722 2723 return (XCHAR_TABLE (char_table)->contents[default_slot] = value); 2724 } 2725 2726 /* Even if C is not a generic char, we had better behave as if a 2727 generic char is specified. */ 2728 if (!CHARSET_DEFINED_P (charset) || CHARSET_DIMENSION (charset) == 1) 2729 code1 = 0; 2730 temp = XCHAR_TABLE (char_table)->contents[charset + 128]; 2731 if (! SUB_CHAR_TABLE_P (temp)) 2732 { 2733 temp = make_sub_char_table (temp); 2734 XCHAR_TABLE (char_table)->contents[charset + 128] = temp; 2735 } 2736 if (!code1) 2737 { 2738 XCHAR_TABLE (temp)->defalt = value; 2739 return value; 2740 } 2741 char_table = temp; 2742 temp = XCHAR_TABLE (char_table)->contents[code1]; 2743 if (SUB_CHAR_TABLE_P (temp)) 2744 XCHAR_TABLE (temp)->defalt = value; 2745 else 2746 XCHAR_TABLE (char_table)->contents[code1] = value; 2747 return value; 2748} 2749 2750/* Look up the element in TABLE at index CH, 2751 and return it as an integer. 2752 If the element is nil, return CH itself. 2753 (Actually we do that for any non-integer.) */ 2754 2755int 2756char_table_translate (table, ch) 2757 Lisp_Object table; 2758 int ch; 2759{ 2760 Lisp_Object value; 2761 value = Faref (table, make_number (ch)); 2762 if (! INTEGERP (value)) 2763 return ch; 2764 return XINT (value); 2765} 2766 2767static void 2768optimize_sub_char_table (table, chars) 2769 Lisp_Object *table; 2770 int chars; 2771{ 2772 Lisp_Object elt; 2773 int from, to; 2774 2775 if (chars == 94) 2776 from = 33, to = 127; 2777 else 2778 from = 32, to = 128; 2779 2780 if (!SUB_CHAR_TABLE_P (*table) 2781 || ! NILP (XCHAR_TABLE (*table)->defalt)) 2782 return; 2783 elt = XCHAR_TABLE (*table)->contents[from++]; 2784 for (; from < to; from++) 2785 if (NILP (Fequal (elt, XCHAR_TABLE (*table)->contents[from]))) 2786 return; 2787 *table = elt; 2788} 2789 2790DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table, 2791 1, 1, 0, doc: /* Optimize char table TABLE. */) 2792 (table) 2793 Lisp_Object table; 2794{ 2795 Lisp_Object elt; 2796 int dim, chars; 2797 int i, j; 2798 2799 CHECK_CHAR_TABLE (table); 2800 2801 for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS; i < CHAR_TABLE_ORDINARY_SLOTS; i++) 2802 { 2803 elt = XCHAR_TABLE (table)->contents[i]; 2804 if (!SUB_CHAR_TABLE_P (elt)) 2805 continue; 2806 dim = CHARSET_DIMENSION (i - 128); 2807 chars = CHARSET_CHARS (i - 128); 2808 if (dim == 2) 2809 for (j = 32; j < SUB_CHAR_TABLE_ORDINARY_SLOTS; j++) 2810 optimize_sub_char_table (XCHAR_TABLE (elt)->contents + j, chars); 2811 optimize_sub_char_table (XCHAR_TABLE (table)->contents + i, chars); 2812 } 2813 return Qnil; 2814} 2815 2816 2817/* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each 2818 character or group of characters that share a value. 2819 DEPTH is the current depth in the originally specified 2820 chartable, and INDICES contains the vector indices 2821 for the levels our callers have descended. 2822 2823 ARG is passed to C_FUNCTION when that is called. */ 2824 2825void 2826map_char_table (c_function, function, table, subtable, arg, depth, indices) 2827 void (*c_function) P_ ((Lisp_Object, Lisp_Object, Lisp_Object)); 2828 Lisp_Object function, table, subtable, arg, *indices; 2829 int depth; 2830{ 2831 int i, to; 2832 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; 2833 2834 GCPRO4 (arg, table, subtable, function); 2835 2836 if (depth == 0) 2837 { 2838 /* At first, handle ASCII and 8-bit European characters. */ 2839 for (i = 0; i < CHAR_TABLE_SINGLE_BYTE_SLOTS; i++) 2840 { 2841 Lisp_Object elt= XCHAR_TABLE (subtable)->contents[i]; 2842 if (NILP (elt)) 2843 elt = XCHAR_TABLE (subtable)->defalt; 2844 if (NILP (elt)) 2845 elt = Faref (subtable, make_number (i)); 2846 if (c_function) 2847 (*c_function) (arg, make_number (i), elt); 2848 else 2849 call2 (function, make_number (i), elt); 2850 } 2851#if 0 /* If the char table has entries for higher characters, 2852 we should report them. */ 2853 if (NILP (current_buffer->enable_multibyte_characters)) 2854 { 2855 UNGCPRO; 2856 return; 2857 } 2858#endif 2859 to = CHAR_TABLE_ORDINARY_SLOTS; 2860 } 2861 else 2862 { 2863 int charset = XFASTINT (indices[0]) - 128; 2864 2865 i = 32; 2866 to = SUB_CHAR_TABLE_ORDINARY_SLOTS; 2867 if (CHARSET_CHARS (charset) == 94) 2868 i++, to--; 2869 } 2870 2871 for (; i < to; i++) 2872 { 2873 Lisp_Object elt; 2874 int charset; 2875 2876 elt = XCHAR_TABLE (subtable)->contents[i]; 2877 XSETFASTINT (indices[depth], i); 2878 charset = XFASTINT (indices[0]) - 128; 2879 if (depth == 0 2880 && (!CHARSET_DEFINED_P (charset) 2881 || charset == CHARSET_8_BIT_CONTROL 2882 || charset == CHARSET_8_BIT_GRAPHIC)) 2883 continue; 2884 2885 if (SUB_CHAR_TABLE_P (elt)) 2886 { 2887 if (depth >= 3) 2888 error ("Too deep char table"); 2889 map_char_table (c_function, function, table, elt, arg, depth + 1, indices); 2890 } 2891 else 2892 { 2893 int c1, c2, c; 2894 2895 c1 = depth >= 1 ? XFASTINT (indices[1]) : 0; 2896 c2 = depth >= 2 ? XFASTINT (indices[2]) : 0; 2897 c = MAKE_CHAR (charset, c1, c2); 2898 2899 if (NILP (elt)) 2900 elt = XCHAR_TABLE (subtable)->defalt; 2901 if (NILP (elt)) 2902 elt = Faref (table, make_number (c)); 2903 2904 if (c_function) 2905 (*c_function) (arg, make_number (c), elt); 2906 else 2907 call2 (function, make_number (c), elt); 2908 } 2909 } 2910 UNGCPRO; 2911} 2912 2913static void void_call2 P_ ((Lisp_Object a, Lisp_Object b, Lisp_Object c)); 2914static void 2915void_call2 (a, b, c) 2916 Lisp_Object a, b, c; 2917{ 2918 call2 (a, b, c); 2919} 2920 2921DEFUN ("map-char-table", Fmap_char_table, Smap_char_table, 2922 2, 2, 0, 2923 doc: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE. 2924FUNCTION is called with two arguments--a key and a value. 2925The key is always a possible IDX argument to `aref'. */) 2926 (function, char_table) 2927 Lisp_Object function, char_table; 2928{ 2929 /* The depth of char table is at most 3. */ 2930 Lisp_Object indices[3]; 2931 2932 CHECK_CHAR_TABLE (char_table); 2933 2934 /* When Lisp_Object is represented as a union, `call2' cannot directly 2935 be passed to map_char_table because it returns a Lisp_Object rather 2936 than returning nothing. 2937 Casting leads to crashes on some architectures. -stef */ 2938 map_char_table (void_call2, Qnil, char_table, char_table, function, 0, indices); 2939 return Qnil; 2940} 2941 2942/* Return a value for character C in char-table TABLE. Store the 2943 actual index for that value in *IDX. Ignore the default value of 2944 TABLE. */ 2945 2946Lisp_Object 2947char_table_ref_and_index (table, c, idx) 2948 Lisp_Object table; 2949 int c, *idx; 2950{ 2951 int charset, c1, c2; 2952 Lisp_Object elt; 2953 2954 if (SINGLE_BYTE_CHAR_P (c)) 2955 { 2956 *idx = c; 2957 return XCHAR_TABLE (table)->contents[c]; 2958 } 2959 SPLIT_CHAR (c, charset, c1, c2); 2960 elt = XCHAR_TABLE (table)->contents[charset + 128]; 2961 *idx = MAKE_CHAR (charset, 0, 0); 2962 if (!SUB_CHAR_TABLE_P (elt)) 2963 return elt; 2964 if (c1 < 32 || NILP (XCHAR_TABLE (elt)->contents[c1])) 2965 return XCHAR_TABLE (elt)->defalt; 2966 elt = XCHAR_TABLE (elt)->contents[c1]; 2967 *idx = MAKE_CHAR (charset, c1, 0); 2968 if (!SUB_CHAR_TABLE_P (elt)) 2969 return elt; 2970 if (c2 < 32 || NILP (XCHAR_TABLE (elt)->contents[c2])) 2971 return XCHAR_TABLE (elt)->defalt; 2972 *idx = c; 2973 return XCHAR_TABLE (elt)->contents[c2]; 2974} 2975 2976 2977/* ARGSUSED */ 2978Lisp_Object 2979nconc2 (s1, s2) 2980 Lisp_Object s1, s2; 2981{ 2982#ifdef NO_ARG_ARRAY 2983 Lisp_Object args[2]; 2984 args[0] = s1; 2985 args[1] = s2; 2986 return Fnconc (2, args); 2987#else 2988 return Fnconc (2, &s1); 2989#endif /* NO_ARG_ARRAY */ 2990} 2991 2992DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0, 2993 doc: /* Concatenate any number of lists by altering them. 2994Only the last argument is not altered, and need not be a list. 2995usage: (nconc &rest LISTS) */) 2996 (nargs, args) 2997 int nargs; 2998 Lisp_Object *args; 2999{ 3000 register int argnum; 3001 register Lisp_Object tail, tem, val; 3002 3003 val = tail = Qnil; 3004 3005 for (argnum = 0; argnum < nargs; argnum++) 3006 { 3007 tem = args[argnum]; 3008 if (NILP (tem)) continue; 3009 3010 if (NILP (val)) 3011 val = tem; 3012 3013 if (argnum + 1 == nargs) break; 3014 3015 CHECK_LIST_CONS (tem, tem); 3016 3017 while (CONSP (tem)) 3018 { 3019 tail = tem; 3020 tem = XCDR (tail); 3021 QUIT; 3022 } 3023 3024 tem = args[argnum + 1]; 3025 Fsetcdr (tail, tem); 3026 if (NILP (tem)) 3027 args[argnum + 1] = tail; 3028 } 3029 3030 return val; 3031} 3032 3033/* This is the guts of all mapping functions. 3034 Apply FN to each element of SEQ, one by one, 3035 storing the results into elements of VALS, a C vector of Lisp_Objects. 3036 LENI is the length of VALS, which should also be the length of SEQ. */ 3037 3038static void 3039mapcar1 (leni, vals, fn, seq) 3040 int leni; 3041 Lisp_Object *vals; 3042 Lisp_Object fn, seq; 3043{ 3044 register Lisp_Object tail; 3045 Lisp_Object dummy; 3046 register int i; 3047 struct gcpro gcpro1, gcpro2, gcpro3; 3048 3049 if (vals) 3050 { 3051 /* Don't let vals contain any garbage when GC happens. */ 3052 for (i = 0; i < leni; i++) 3053 vals[i] = Qnil; 3054 3055 GCPRO3 (dummy, fn, seq); 3056 gcpro1.var = vals; 3057 gcpro1.nvars = leni; 3058 } 3059 else 3060 GCPRO2 (fn, seq); 3061 /* We need not explicitly protect `tail' because it is used only on lists, and 3062 1) lists are not relocated and 2) the list is marked via `seq' so will not 3063 be freed */ 3064 3065 if (VECTORP (seq)) 3066 { 3067 for (i = 0; i < leni; i++) 3068 { 3069 dummy = call1 (fn, AREF (seq, i)); 3070 if (vals) 3071 vals[i] = dummy; 3072 } 3073 } 3074 else if (BOOL_VECTOR_P (seq)) 3075 { 3076 for (i = 0; i < leni; i++) 3077 { 3078 int byte; 3079 byte = XBOOL_VECTOR (seq)->data[i / BOOL_VECTOR_BITS_PER_CHAR]; 3080 dummy = (byte & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))) ? Qt : Qnil; 3081 dummy = call1 (fn, dummy); 3082 if (vals) 3083 vals[i] = dummy; 3084 } 3085 } 3086 else if (STRINGP (seq)) 3087 { 3088 int i_byte; 3089 3090 for (i = 0, i_byte = 0; i < leni;) 3091 { 3092 int c; 3093 int i_before = i; 3094 3095 FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte); 3096 XSETFASTINT (dummy, c); 3097 dummy = call1 (fn, dummy); 3098 if (vals) 3099 vals[i_before] = dummy; 3100 } 3101 } 3102 else /* Must be a list, since Flength did not get an error */ 3103 { 3104 tail = seq; 3105 for (i = 0; i < leni && CONSP (tail); i++) 3106 { 3107 dummy = call1 (fn, XCAR (tail)); 3108 if (vals) 3109 vals[i] = dummy; 3110 tail = XCDR (tail); 3111 } 3112 } 3113 3114 UNGCPRO; 3115} 3116 3117DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0, 3118 doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings. 3119In between each pair of results, stick in SEPARATOR. Thus, " " as 3120SEPARATOR results in spaces between the values returned by FUNCTION. 3121SEQUENCE may be a list, a vector, a bool-vector, or a string. */) 3122 (function, sequence, separator) 3123 Lisp_Object function, sequence, separator; 3124{ 3125 Lisp_Object len; 3126 register int leni; 3127 int nargs; 3128 register Lisp_Object *args; 3129 register int i; 3130 struct gcpro gcpro1; 3131 Lisp_Object ret; 3132 USE_SAFE_ALLOCA; 3133 3134 len = Flength (sequence); 3135 leni = XINT (len); 3136 nargs = leni + leni - 1; 3137 if (nargs < 0) return build_string (""); 3138 3139 SAFE_ALLOCA_LISP (args, nargs); 3140 3141 GCPRO1 (separator); 3142 mapcar1 (leni, args, function, sequence); 3143 UNGCPRO; 3144 3145 for (i = leni - 1; i > 0; i--) 3146 args[i + i] = args[i]; 3147 3148 for (i = 1; i < nargs; i += 2) 3149 args[i] = separator; 3150 3151 ret = Fconcat (nargs, args); 3152 SAFE_FREE (); 3153 3154 return ret; 3155} 3156 3157DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0, 3158 doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results. 3159The result is a list just as long as SEQUENCE. 3160SEQUENCE may be a list, a vector, a bool-vector, or a string. */) 3161 (function, sequence) 3162 Lisp_Object function, sequence; 3163{ 3164 register Lisp_Object len; 3165 register int leni; 3166 register Lisp_Object *args; 3167 Lisp_Object ret; 3168 USE_SAFE_ALLOCA; 3169 3170 len = Flength (sequence); 3171 leni = XFASTINT (len); 3172 3173 SAFE_ALLOCA_LISP (args, leni); 3174 3175 mapcar1 (leni, args, function, sequence); 3176 3177 ret = Flist (leni, args); 3178 SAFE_FREE (); 3179 3180 return ret; 3181} 3182 3183DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0, 3184 doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only. 3185Unlike `mapcar', don't accumulate the results. Return SEQUENCE. 3186SEQUENCE may be a list, a vector, a bool-vector, or a string. */) 3187 (function, sequence) 3188 Lisp_Object function, sequence; 3189{ 3190 register int leni; 3191 3192 leni = XFASTINT (Flength (sequence)); 3193 mapcar1 (leni, 0, function, sequence); 3194 3195 return sequence; 3196} 3197 3198/* Anything that calls this function must protect from GC! */ 3199 3200DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0, 3201 doc: /* Ask user a "y or n" question. Return t if answer is "y". 3202Takes one argument, which is the string to display to ask the question. 3203It should end in a space; `y-or-n-p' adds `(y or n) ' to it. 3204No confirmation of the answer is requested; a single character is enough. 3205Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses 3206the bindings in `query-replace-map'; see the documentation of that variable 3207for more information. In this case, the useful bindings are `act', `skip', 3208`recenter', and `quit'.\) 3209 3210Under a windowing system a dialog box will be used if `last-nonmenu-event' 3211is nil and `use-dialog-box' is non-nil. */) 3212 (prompt) 3213 Lisp_Object prompt; 3214{ 3215 register Lisp_Object obj, key, def, map; 3216 register int answer; 3217 Lisp_Object xprompt; 3218 Lisp_Object args[2]; 3219 struct gcpro gcpro1, gcpro2; 3220 int count = SPECPDL_INDEX (); 3221 3222 specbind (Qcursor_in_echo_area, Qt); 3223 3224 map = Fsymbol_value (intern ("query-replace-map")); 3225 3226 CHECK_STRING (prompt); 3227 xprompt = prompt; 3228 GCPRO2 (prompt, xprompt); 3229 3230#ifdef HAVE_X_WINDOWS 3231 if (display_hourglass_p) 3232 cancel_hourglass (); 3233#endif 3234 3235 while (1) 3236 { 3237 3238#ifdef HAVE_MENUS 3239 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event)) 3240 && use_dialog_box 3241 && have_menus_p ()) 3242 { 3243 Lisp_Object pane, menu; 3244 redisplay_preserve_echo_area (3); 3245 pane = Fcons (Fcons (build_string ("Yes"), Qt), 3246 Fcons (Fcons (build_string ("No"), Qnil), 3247 Qnil)); 3248 menu = Fcons (prompt, pane); 3249 obj = Fx_popup_dialog (Qt, menu, Qnil); 3250 answer = !NILP (obj); 3251 break; 3252 } 3253#endif /* HAVE_MENUS */ 3254 cursor_in_echo_area = 1; 3255 choose_minibuf_frame (); 3256 3257 { 3258 Lisp_Object pargs[3]; 3259 3260 /* Colorize prompt according to `minibuffer-prompt' face. */ 3261 pargs[0] = build_string ("%s(y or n) "); 3262 pargs[1] = intern ("face"); 3263 pargs[2] = intern ("minibuffer-prompt"); 3264 args[0] = Fpropertize (3, pargs); 3265 args[1] = xprompt; 3266 Fmessage (2, args); 3267 } 3268 3269 if (minibuffer_auto_raise) 3270 { 3271 Lisp_Object mini_frame; 3272 3273 mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window)); 3274 3275 Fraise_frame (mini_frame); 3276 } 3277 3278 obj = read_filtered_event (1, 0, 0, 0, Qnil); 3279 cursor_in_echo_area = 0; 3280 /* If we need to quit, quit with cursor_in_echo_area = 0. */ 3281 QUIT; 3282 3283 key = Fmake_vector (make_number (1), obj); 3284 def = Flookup_key (map, key, Qt); 3285 3286 if (EQ (def, intern ("skip"))) 3287 { 3288 answer = 0; 3289 break; 3290 } 3291 else if (EQ (def, intern ("act"))) 3292 { 3293 answer = 1; 3294 break; 3295 } 3296 else if (EQ (def, intern ("recenter"))) 3297 { 3298 Frecenter (Qnil); 3299 xprompt = prompt; 3300 continue; 3301 } 3302 else if (EQ (def, intern ("quit"))) 3303 Vquit_flag = Qt; 3304 /* We want to exit this command for exit-prefix, 3305 and this is the only way to do it. */ 3306 else if (EQ (def, intern ("exit-prefix"))) 3307 Vquit_flag = Qt; 3308 3309 QUIT; 3310 3311 /* If we don't clear this, then the next call to read_char will 3312 return quit_char again, and we'll enter an infinite loop. */ 3313 Vquit_flag = Qnil; 3314 3315 Fding (Qnil); 3316 Fdiscard_input (); 3317 if (EQ (xprompt, prompt)) 3318 { 3319 args[0] = build_string ("Please answer y or n. "); 3320 args[1] = prompt; 3321 xprompt = Fconcat (2, args); 3322 } 3323 } 3324 UNGCPRO; 3325 3326 if (! noninteractive) 3327 { 3328 cursor_in_echo_area = -1; 3329 message_with_string (answer ? "%s(y or n) y" : "%s(y or n) n", 3330 xprompt, 0); 3331 } 3332 3333 unbind_to (count, Qnil); 3334 return answer ? Qt : Qnil; 3335} 3336 3337/* This is how C code calls `yes-or-no-p' and allows the user 3338 to redefined it. 3339 3340 Anything that calls this function must protect from GC! */ 3341 3342Lisp_Object 3343do_yes_or_no_p (prompt) 3344 Lisp_Object prompt; 3345{ 3346 return call1 (intern ("yes-or-no-p"), prompt); 3347} 3348 3349/* Anything that calls this function must protect from GC! */ 3350 3351DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0, 3352 doc: /* Ask user a yes-or-no question. Return t if answer is yes. 3353Takes one argument, which is the string to display to ask the question. 3354It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. 3355The user must confirm the answer with RET, 3356and can edit it until it has been confirmed. 3357 3358Under a windowing system a dialog box will be used if `last-nonmenu-event' 3359is nil, and `use-dialog-box' is non-nil. */) 3360 (prompt) 3361 Lisp_Object prompt; 3362{ 3363 register Lisp_Object ans; 3364 Lisp_Object args[2]; 3365 struct gcpro gcpro1; 3366 3367 CHECK_STRING (prompt); 3368 3369#ifdef HAVE_MENUS 3370 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event)) 3371 && use_dialog_box 3372 && have_menus_p ()) 3373 { 3374 Lisp_Object pane, menu, obj; 3375 redisplay_preserve_echo_area (4); 3376 pane = Fcons (Fcons (build_string ("Yes"), Qt), 3377 Fcons (Fcons (build_string ("No"), Qnil), 3378 Qnil)); 3379 GCPRO1 (pane); 3380 menu = Fcons (prompt, pane); 3381 obj = Fx_popup_dialog (Qt, menu, Qnil); 3382 UNGCPRO; 3383 return obj; 3384 } 3385#endif /* HAVE_MENUS */ 3386 3387 args[0] = prompt; 3388 args[1] = build_string ("(yes or no) "); 3389 prompt = Fconcat (2, args); 3390 3391 GCPRO1 (prompt); 3392 3393 while (1) 3394 { 3395 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil, 3396 Qyes_or_no_p_history, Qnil, 3397 Qnil)); 3398 if (SCHARS (ans) == 3 && !strcmp (SDATA (ans), "yes")) 3399 { 3400 UNGCPRO; 3401 return Qt; 3402 } 3403 if (SCHARS (ans) == 2 && !strcmp (SDATA (ans), "no")) 3404 { 3405 UNGCPRO; 3406 return Qnil; 3407 } 3408 3409 Fding (Qnil); 3410 Fdiscard_input (); 3411 message ("Please answer yes or no."); 3412 Fsleep_for (make_number (2), Qnil); 3413 } 3414} 3415 3416DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0, 3417 doc: /* Return list of 1 minute, 5 minute and 15 minute load averages. 3418 3419Each of the three load averages is multiplied by 100, then converted 3420to integer. 3421 3422When USE-FLOATS is non-nil, floats will be used instead of integers. 3423These floats are not multiplied by 100. 3424 3425If the 5-minute or 15-minute load averages are not available, return a 3426shortened list, containing only those averages which are available. 3427 3428An error is thrown if the load average can't be obtained. In some 3429cases making it work would require Emacs being installed setuid or 3430setgid so that it can read kernel information, and that usually isn't 3431advisable. */) 3432 (use_floats) 3433 Lisp_Object use_floats; 3434{ 3435 double load_ave[3]; 3436 int loads = getloadavg (load_ave, 3); 3437 Lisp_Object ret = Qnil; 3438 3439 if (loads < 0) 3440 error ("load-average not implemented for this operating system"); 3441 3442 while (loads-- > 0) 3443 { 3444 Lisp_Object load = (NILP (use_floats) ? 3445 make_number ((int) (100.0 * load_ave[loads])) 3446 : make_float (load_ave[loads])); 3447 ret = Fcons (load, ret); 3448 } 3449 3450 return ret; 3451} 3452 3453Lisp_Object Vfeatures, Qsubfeatures; 3454extern Lisp_Object Vafter_load_alist; 3455 3456DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0, 3457 doc: /* Returns t if FEATURE is present in this Emacs. 3458 3459Use this to conditionalize execution of lisp code based on the 3460presence or absence of Emacs or environment extensions. 3461Use `provide' to declare that a feature is available. This function 3462looks at the value of the variable `features'. The optional argument 3463SUBFEATURE can be used to check a specific subfeature of FEATURE. */) 3464 (feature, subfeature) 3465 Lisp_Object feature, subfeature; 3466{ 3467 register Lisp_Object tem; 3468 CHECK_SYMBOL (feature); 3469 tem = Fmemq (feature, Vfeatures); 3470 if (!NILP (tem) && !NILP (subfeature)) 3471 tem = Fmember (subfeature, Fget (feature, Qsubfeatures)); 3472 return (NILP (tem)) ? Qnil : Qt; 3473} 3474 3475DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0, 3476 doc: /* Announce that FEATURE is a feature of the current Emacs. 3477The optional argument SUBFEATURES should be a list of symbols listing 3478particular subfeatures supported in this version of FEATURE. */) 3479 (feature, subfeatures) 3480 Lisp_Object feature, subfeatures; 3481{ 3482 register Lisp_Object tem; 3483 CHECK_SYMBOL (feature); 3484 CHECK_LIST (subfeatures); 3485 if (!NILP (Vautoload_queue)) 3486 Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures), 3487 Vautoload_queue); 3488 tem = Fmemq (feature, Vfeatures); 3489 if (NILP (tem)) 3490 Vfeatures = Fcons (feature, Vfeatures); 3491 if (!NILP (subfeatures)) 3492 Fput (feature, Qsubfeatures, subfeatures); 3493 LOADHIST_ATTACH (Fcons (Qprovide, feature)); 3494 3495 /* Run any load-hooks for this file. */ 3496 tem = Fassq (feature, Vafter_load_alist); 3497 if (CONSP (tem)) 3498 Fprogn (XCDR (tem)); 3499 3500 return feature; 3501} 3502 3503/* `require' and its subroutines. */ 3504 3505/* List of features currently being require'd, innermost first. */ 3506 3507Lisp_Object require_nesting_list; 3508 3509Lisp_Object 3510require_unwind (old_value) 3511 Lisp_Object old_value; 3512{ 3513 return require_nesting_list = old_value; 3514} 3515 3516DEFUN ("require", Frequire, Srequire, 1, 3, 0, 3517 doc: /* If feature FEATURE is not loaded, load it from FILENAME. 3518If FEATURE is not a member of the list `features', then the feature 3519is not loaded; so load the file FILENAME. 3520If FILENAME is omitted, the printname of FEATURE is used as the file name, 3521and `load' will try to load this name appended with the suffix `.elc' or 3522`.el', in that order. The name without appended suffix will not be used. 3523If the optional third argument NOERROR is non-nil, 3524then return nil if the file is not found instead of signaling an error. 3525Normally the return value is FEATURE. 3526The normal messages at start and end of loading FILENAME are suppressed. */) 3527 (feature, filename, noerror) 3528 Lisp_Object feature, filename, noerror; 3529{ 3530 register Lisp_Object tem; 3531 struct gcpro gcpro1, gcpro2; 3532 int from_file = load_in_progress; 3533 3534 CHECK_SYMBOL (feature); 3535 3536 /* Record the presence of `require' in this file 3537 even if the feature specified is already loaded. 3538 But not more than once in any file, 3539 and not when we aren't loading or reading from a file. */ 3540 if (!from_file) 3541 for (tem = Vcurrent_load_list; CONSP (tem); tem = XCDR (tem)) 3542 if (NILP (XCDR (tem)) && STRINGP (XCAR (tem))) 3543 from_file = 1; 3544 3545 if (from_file) 3546 { 3547 tem = Fcons (Qrequire, feature); 3548 if (NILP (Fmember (tem, Vcurrent_load_list))) 3549 LOADHIST_ATTACH (tem); 3550 } 3551 tem = Fmemq (feature, Vfeatures); 3552 3553 if (NILP (tem)) 3554 { 3555 int count = SPECPDL_INDEX (); 3556 int nesting = 0; 3557 3558 /* This is to make sure that loadup.el gives a clear picture 3559 of what files are preloaded and when. */ 3560 if (! NILP (Vpurify_flag)) 3561 error ("(require %s) while preparing to dump", 3562 SDATA (SYMBOL_NAME (feature))); 3563 3564 /* A certain amount of recursive `require' is legitimate, 3565 but if we require the same feature recursively 3 times, 3566 signal an error. */ 3567 tem = require_nesting_list; 3568 while (! NILP (tem)) 3569 { 3570 if (! NILP (Fequal (feature, XCAR (tem)))) 3571 nesting++; 3572 tem = XCDR (tem); 3573 } 3574 if (nesting > 3) 3575 error ("Recursive `require' for feature `%s'", 3576 SDATA (SYMBOL_NAME (feature))); 3577 3578 /* Update the list for any nested `require's that occur. */ 3579 record_unwind_protect (require_unwind, require_nesting_list); 3580 require_nesting_list = Fcons (feature, require_nesting_list); 3581 3582 /* Value saved here is to be restored into Vautoload_queue */ 3583 record_unwind_protect (un_autoload, Vautoload_queue); 3584 Vautoload_queue = Qt; 3585 3586 /* Load the file. */ 3587 GCPRO2 (feature, filename); 3588 tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename, 3589 noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil)); 3590 UNGCPRO; 3591 3592 /* If load failed entirely, return nil. */ 3593 if (NILP (tem)) 3594 return unbind_to (count, Qnil); 3595 3596 tem = Fmemq (feature, Vfeatures); 3597 if (NILP (tem)) 3598 error ("Required feature `%s' was not provided", 3599 SDATA (SYMBOL_NAME (feature))); 3600 3601 /* Once loading finishes, don't undo it. */ 3602 Vautoload_queue = Qt; 3603 feature = unbind_to (count, feature); 3604 } 3605 3606 return feature; 3607} 3608 3609/* Primitives for work of the "widget" library. 3610 In an ideal world, this section would not have been necessary. 3611 However, lisp function calls being as slow as they are, it turns 3612 out that some functions in the widget library (wid-edit.el) are the 3613 bottleneck of Widget operation. Here is their translation to C, 3614 for the sole reason of efficiency. */ 3615 3616DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0, 3617 doc: /* Return non-nil if PLIST has the property PROP. 3618PLIST is a property list, which is a list of the form 3619\(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol. 3620Unlike `plist-get', this allows you to distinguish between a missing 3621property and a property with the value nil. 3622The value is actually the tail of PLIST whose car is PROP. */) 3623 (plist, prop) 3624 Lisp_Object plist, prop; 3625{ 3626 while (CONSP (plist) && !EQ (XCAR (plist), prop)) 3627 { 3628 QUIT; 3629 plist = XCDR (plist); 3630 plist = CDR (plist); 3631 } 3632 return plist; 3633} 3634 3635DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0, 3636 doc: /* In WIDGET, set PROPERTY to VALUE. 3637The value can later be retrieved with `widget-get'. */) 3638 (widget, property, value) 3639 Lisp_Object widget, property, value; 3640{ 3641 CHECK_CONS (widget); 3642 XSETCDR (widget, Fplist_put (XCDR (widget), property, value)); 3643 return value; 3644} 3645 3646DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0, 3647 doc: /* In WIDGET, get the value of PROPERTY. 3648The value could either be specified when the widget was created, or 3649later with `widget-put'. */) 3650 (widget, property) 3651 Lisp_Object widget, property; 3652{ 3653 Lisp_Object tmp; 3654 3655 while (1) 3656 { 3657 if (NILP (widget)) 3658 return Qnil; 3659 CHECK_CONS (widget); 3660 tmp = Fplist_member (XCDR (widget), property); 3661 if (CONSP (tmp)) 3662 { 3663 tmp = XCDR (tmp); 3664 return CAR (tmp); 3665 } 3666 tmp = XCAR (widget); 3667 if (NILP (tmp)) 3668 return Qnil; 3669 widget = Fget (tmp, Qwidget_type); 3670 } 3671} 3672 3673DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0, 3674 doc: /* Apply the value of WIDGET's PROPERTY to the widget itself. 3675ARGS are passed as extra arguments to the function. 3676usage: (widget-apply WIDGET PROPERTY &rest ARGS) */) 3677 (nargs, args) 3678 int nargs; 3679 Lisp_Object *args; 3680{ 3681 /* This function can GC. */ 3682 Lisp_Object newargs[3]; 3683 struct gcpro gcpro1, gcpro2; 3684 Lisp_Object result; 3685 3686 newargs[0] = Fwidget_get (args[0], args[1]); 3687 newargs[1] = args[0]; 3688 newargs[2] = Flist (nargs - 2, args + 2); 3689 GCPRO2 (newargs[0], newargs[2]); 3690 result = Fapply (3, newargs); 3691 UNGCPRO; 3692 return result; 3693} 3694 3695#ifdef HAVE_LANGINFO_CODESET 3696#include <langinfo.h> 3697#endif 3698 3699DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0, 3700 doc: /* Access locale data ITEM for the current C locale, if available. 3701ITEM should be one of the following: 3702 3703`codeset', returning the character set as a string (locale item CODESET); 3704 3705`days', returning a 7-element vector of day names (locale items DAY_n); 3706 3707`months', returning a 12-element vector of month names (locale items MON_n); 3708 3709`paper', returning a list (WIDTH HEIGHT) for the default paper size, 3710 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT). 3711 3712If the system can't provide such information through a call to 3713`nl_langinfo', or if ITEM isn't from the list above, return nil. 3714 3715See also Info node `(libc)Locales'. 3716 3717The data read from the system are decoded using `locale-coding-system'. */) 3718 (item) 3719 Lisp_Object item; 3720{ 3721 char *str = NULL; 3722#ifdef HAVE_LANGINFO_CODESET 3723 Lisp_Object val; 3724 if (EQ (item, Qcodeset)) 3725 { 3726 str = nl_langinfo (CODESET); 3727 return build_string (str); 3728 } 3729#ifdef DAY_1 3730 else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */ 3731 { 3732 Lisp_Object v = Fmake_vector (make_number (7), Qnil); 3733 int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7}; 3734 int i; 3735 synchronize_system_time_locale (); 3736 for (i = 0; i < 7; i++) 3737 { 3738 str = nl_langinfo (days[i]); 3739 val = make_unibyte_string (str, strlen (str)); 3740 /* Fixme: Is this coding system necessarily right, even if 3741 it is consistent with CODESET? If not, what to do? */ 3742 Faset (v, make_number (i), 3743 code_convert_string_norecord (val, Vlocale_coding_system, 3744 0)); 3745 } 3746 return v; 3747 } 3748#endif /* DAY_1 */ 3749#ifdef MON_1 3750 else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */ 3751 { 3752 struct Lisp_Vector *p = allocate_vector (12); 3753 int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7, 3754 MON_8, MON_9, MON_10, MON_11, MON_12}; 3755 int i; 3756 synchronize_system_time_locale (); 3757 for (i = 0; i < 12; i++) 3758 { 3759 str = nl_langinfo (months[i]); 3760 val = make_unibyte_string (str, strlen (str)); 3761 p->contents[i] = 3762 code_convert_string_norecord (val, Vlocale_coding_system, 0); 3763 } 3764 XSETVECTOR (val, p); 3765 return val; 3766 } 3767#endif /* MON_1 */ 3768/* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1, 3769 but is in the locale files. This could be used by ps-print. */ 3770#ifdef PAPER_WIDTH 3771 else if (EQ (item, Qpaper)) 3772 { 3773 return list2 (make_number (nl_langinfo (PAPER_WIDTH)), 3774 make_number (nl_langinfo (PAPER_HEIGHT))); 3775 } 3776#endif /* PAPER_WIDTH */ 3777#endif /* HAVE_LANGINFO_CODESET*/ 3778 return Qnil; 3779} 3780 3781/* base64 encode/decode functions (RFC 2045). 3782 Based on code from GNU recode. */ 3783 3784#define MIME_LINE_LENGTH 76 3785 3786#define IS_ASCII(Character) \ 3787 ((Character) < 128) 3788#define IS_BASE64(Character) \ 3789 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0) 3790#define IS_BASE64_IGNORABLE(Character) \ 3791 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \ 3792 || (Character) == '\f' || (Character) == '\r') 3793 3794/* Used by base64_decode_1 to retrieve a non-base64-ignorable 3795 character or return retval if there are no characters left to 3796 process. */ 3797#define READ_QUADRUPLET_BYTE(retval) \ 3798 do \ 3799 { \ 3800 if (i == length) \ 3801 { \ 3802 if (nchars_return) \ 3803 *nchars_return = nchars; \ 3804 return (retval); \ 3805 } \ 3806 c = from[i++]; \ 3807 } \ 3808 while (IS_BASE64_IGNORABLE (c)) 3809 3810/* Table of characters coding the 64 values. */ 3811static char base64_value_to_char[64] = 3812{ 3813 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */ 3814 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */ 3815 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */ 3816 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */ 3817 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */ 3818 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */ 3819 '8', '9', '+', '/' /* 60-63 */ 3820}; 3821 3822/* Table of base64 values for first 128 characters. */ 3823static short base64_char_to_value[128] = 3824{ 3825 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */ 3826 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */ 3827 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */ 3828 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */ 3829 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */ 3830 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */ 3831 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */ 3832 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */ 3833 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */ 3834 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */ 3835 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */ 3836 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */ 3837 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */ 3838}; 3839 3840/* The following diagram shows the logical steps by which three octets 3841 get transformed into four base64 characters. 3842 3843 .--------. .--------. .--------. 3844 |aaaaaabb| |bbbbcccc| |ccdddddd| 3845 `--------' `--------' `--------' 3846 6 2 4 4 2 6 3847 .--------+--------+--------+--------. 3848 |00aaaaaa|00bbbbbb|00cccccc|00dddddd| 3849 `--------+--------+--------+--------' 3850 3851 .--------+--------+--------+--------. 3852 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD| 3853 `--------+--------+--------+--------' 3854 3855 The octets are divided into 6 bit chunks, which are then encoded into 3856 base64 characters. */ 3857 3858 3859static int base64_encode_1 P_ ((const char *, char *, int, int, int)); 3860static int base64_decode_1 P_ ((const char *, char *, int, int, int *)); 3861 3862DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region, 3863 2, 3, "r", 3864 doc: /* Base64-encode the region between BEG and END. 3865Return the length of the encoded text. 3866Optional third argument NO-LINE-BREAK means do not break long lines 3867into shorter lines. */) 3868 (beg, end, no_line_break) 3869 Lisp_Object beg, end, no_line_break; 3870{ 3871 char *encoded; 3872 int allength, length; 3873 int ibeg, iend, encoded_length; 3874 int old_pos = PT; 3875 USE_SAFE_ALLOCA; 3876 3877 validate_region (&beg, &end); 3878 3879 ibeg = CHAR_TO_BYTE (XFASTINT (beg)); 3880 iend = CHAR_TO_BYTE (XFASTINT (end)); 3881 move_gap_both (XFASTINT (beg), ibeg); 3882 3883 /* We need to allocate enough room for encoding the text. 3884 We need 33 1/3% more space, plus a newline every 76 3885 characters, and then we round up. */ 3886 length = iend - ibeg; 3887 allength = length + length/3 + 1; 3888 allength += allength / MIME_LINE_LENGTH + 1 + 6; 3889 3890 SAFE_ALLOCA (encoded, char *, allength); 3891 encoded_length = base64_encode_1 (BYTE_POS_ADDR (ibeg), encoded, length, 3892 NILP (no_line_break), 3893 !NILP (current_buffer->enable_multibyte_characters)); 3894 if (encoded_length > allength) 3895 abort (); 3896 3897 if (encoded_length < 0) 3898 { 3899 /* The encoding wasn't possible. */ 3900 SAFE_FREE (); 3901 error ("Multibyte character in data for base64 encoding"); 3902 } 3903 3904 /* Now we have encoded the region, so we insert the new contents 3905 and delete the old. (Insert first in order to preserve markers.) */ 3906 SET_PT_BOTH (XFASTINT (beg), ibeg); 3907 insert (encoded, encoded_length); 3908 SAFE_FREE (); 3909 del_range_byte (ibeg + encoded_length, iend + encoded_length, 1); 3910 3911 /* If point was outside of the region, restore it exactly; else just 3912 move to the beginning of the region. */ 3913 if (old_pos >= XFASTINT (end)) 3914 old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg)); 3915 else if (old_pos > XFASTINT (beg)) 3916 old_pos = XFASTINT (beg); 3917 SET_PT (old_pos); 3918 3919 /* We return the length of the encoded text. */ 3920 return make_number (encoded_length); 3921} 3922 3923DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string, 3924 1, 2, 0, 3925 doc: /* Base64-encode STRING and return the result. 3926Optional second argument NO-LINE-BREAK means do not break long lines 3927into shorter lines. */) 3928 (string, no_line_break) 3929 Lisp_Object string, no_line_break; 3930{ 3931 int allength, length, encoded_length; 3932 char *encoded; 3933 Lisp_Object encoded_string; 3934 USE_SAFE_ALLOCA; 3935 3936 CHECK_STRING (string); 3937 3938 /* We need to allocate enough room for encoding the text. 3939 We need 33 1/3% more space, plus a newline every 76 3940 characters, and then we round up. */ 3941 length = SBYTES (string); 3942 allength = length + length/3 + 1; 3943 allength += allength / MIME_LINE_LENGTH + 1 + 6; 3944 3945 /* We need to allocate enough room for decoding the text. */ 3946 SAFE_ALLOCA (encoded, char *, allength); 3947 3948 encoded_length = base64_encode_1 (SDATA (string), 3949 encoded, length, NILP (no_line_break), 3950 STRING_MULTIBYTE (string)); 3951 if (encoded_length > allength) 3952 abort (); 3953 3954 if (encoded_length < 0) 3955 { 3956 /* The encoding wasn't possible. */ 3957 SAFE_FREE (); 3958 error ("Multibyte character in data for base64 encoding"); 3959 } 3960 3961 encoded_string = make_unibyte_string (encoded, encoded_length); 3962 SAFE_FREE (); 3963 3964 return encoded_string; 3965} 3966 3967static int 3968base64_encode_1 (from, to, length, line_break, multibyte) 3969 const char *from; 3970 char *to; 3971 int length; 3972 int line_break; 3973 int multibyte; 3974{ 3975 int counter = 0, i = 0; 3976 char *e = to; 3977 int c; 3978 unsigned int value; 3979 int bytes; 3980 3981 while (i < length) 3982 { 3983 if (multibyte) 3984 { 3985 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes); 3986 if (c >= 256) 3987 return -1; 3988 i += bytes; 3989 } 3990 else 3991 c = from[i++]; 3992 3993 /* Wrap line every 76 characters. */ 3994 3995 if (line_break) 3996 { 3997 if (counter < MIME_LINE_LENGTH / 4) 3998 counter++; 3999 else 4000 { 4001 *e++ = '\n'; 4002 counter = 1; 4003 } 4004 } 4005 4006 /* Process first byte of a triplet. */ 4007 4008 *e++ = base64_value_to_char[0x3f & c >> 2]; 4009 value = (0x03 & c) << 4; 4010 4011 /* Process second byte of a triplet. */ 4012 4013 if (i == length) 4014 { 4015 *e++ = base64_value_to_char[value]; 4016 *e++ = '='; 4017 *e++ = '='; 4018 break; 4019 } 4020 4021 if (multibyte) 4022 { 4023 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes); 4024 if (c >= 256) 4025 return -1; 4026 i += bytes; 4027 } 4028 else 4029 c = from[i++]; 4030 4031 *e++ = base64_value_to_char[value | (0x0f & c >> 4)]; 4032 value = (0x0f & c) << 2; 4033 4034 /* Process third byte of a triplet. */ 4035 4036 if (i == length) 4037 { 4038 *e++ = base64_value_to_char[value]; 4039 *e++ = '='; 4040 break; 4041 } 4042 4043 if (multibyte) 4044 { 4045 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes); 4046 if (c >= 256) 4047 return -1; 4048 i += bytes; 4049 } 4050 else 4051 c = from[i++]; 4052 4053 *e++ = base64_value_to_char[value | (0x03 & c >> 6)]; 4054 *e++ = base64_value_to_char[0x3f & c]; 4055 } 4056 4057 return e - to; 4058} 4059 4060 4061DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region, 4062 2, 2, "r", 4063 doc: /* Base64-decode the region between BEG and END. 4064Return the length of the decoded text. 4065If the region can't be decoded, signal an error and don't modify the buffer. */) 4066 (beg, end) 4067 Lisp_Object beg, end; 4068{ 4069 int ibeg, iend, length, allength; 4070 char *decoded; 4071 int old_pos = PT; 4072 int decoded_length; 4073 int inserted_chars; 4074 int multibyte = !NILP (current_buffer->enable_multibyte_characters); 4075 USE_SAFE_ALLOCA; 4076 4077 validate_region (&beg, &end); 4078 4079 ibeg = CHAR_TO_BYTE (XFASTINT (beg)); 4080 iend = CHAR_TO_BYTE (XFASTINT (end)); 4081 4082 length = iend - ibeg; 4083 4084 /* We need to allocate enough room for decoding the text. If we are 4085 working on a multibyte buffer, each decoded code may occupy at 4086 most two bytes. */ 4087 allength = multibyte ? length * 2 : length; 4088 SAFE_ALLOCA (decoded, char *, allength); 4089 4090 move_gap_both (XFASTINT (beg), ibeg); 4091 decoded_length = base64_decode_1 (BYTE_POS_ADDR (ibeg), decoded, length, 4092 multibyte, &inserted_chars); 4093 if (decoded_length > allength) 4094 abort (); 4095 4096 if (decoded_length < 0) 4097 { 4098 /* The decoding wasn't possible. */ 4099 SAFE_FREE (); 4100 error ("Invalid base64 data"); 4101 } 4102 4103 /* Now we have decoded the region, so we insert the new contents 4104 and delete the old. (Insert first in order to preserve markers.) */ 4105 TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg); 4106 insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0); 4107 SAFE_FREE (); 4108 4109 /* Delete the original text. */ 4110 del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars, 4111 iend + decoded_length, 1); 4112 4113 /* If point was outside of the region, restore it exactly; else just 4114 move to the beginning of the region. */ 4115 if (old_pos >= XFASTINT (end)) 4116 old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg)); 4117 else if (old_pos > XFASTINT (beg)) 4118 old_pos = XFASTINT (beg); 4119 SET_PT (old_pos > ZV ? ZV : old_pos); 4120 4121 return make_number (inserted_chars); 4122} 4123 4124DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string, 4125 1, 1, 0, 4126 doc: /* Base64-decode STRING and return the result. */) 4127 (string) 4128 Lisp_Object string; 4129{ 4130 char *decoded; 4131 int length, decoded_length; 4132 Lisp_Object decoded_string; 4133 USE_SAFE_ALLOCA; 4134 4135 CHECK_STRING (string); 4136 4137 length = SBYTES (string); 4138 /* We need to allocate enough room for decoding the text. */ 4139 SAFE_ALLOCA (decoded, char *, length); 4140 4141 /* The decoded result should be unibyte. */ 4142 decoded_length = base64_decode_1 (SDATA (string), decoded, length, 4143 0, NULL); 4144 if (decoded_length > length) 4145 abort (); 4146 else if (decoded_length >= 0) 4147 decoded_string = make_unibyte_string (decoded, decoded_length); 4148 else 4149 decoded_string = Qnil; 4150 4151 SAFE_FREE (); 4152 if (!STRINGP (decoded_string)) 4153 error ("Invalid base64 data"); 4154 4155 return decoded_string; 4156} 4157 4158/* Base64-decode the data at FROM of LENGHT bytes into TO. If 4159 MULTIBYTE is nonzero, the decoded result should be in multibyte 4160 form. If NCHARS_RETRUN is not NULL, store the number of produced 4161 characters in *NCHARS_RETURN. */ 4162 4163static int 4164base64_decode_1 (from, to, length, multibyte, nchars_return) 4165 const char *from; 4166 char *to; 4167 int length; 4168 int multibyte; 4169 int *nchars_return; 4170{ 4171 int i = 0; 4172 char *e = to; 4173 unsigned char c; 4174 unsigned long value; 4175 int nchars = 0; 4176 4177 while (1) 4178 { 4179 /* Process first byte of a quadruplet. */ 4180 4181 READ_QUADRUPLET_BYTE (e-to); 4182 4183 if (!IS_BASE64 (c)) 4184 return -1; 4185 value = base64_char_to_value[c] << 18; 4186 4187 /* Process second byte of a quadruplet. */ 4188 4189 READ_QUADRUPLET_BYTE (-1); 4190 4191 if (!IS_BASE64 (c)) 4192 return -1; 4193 value |= base64_char_to_value[c] << 12; 4194 4195 c = (unsigned char) (value >> 16); 4196 if (multibyte) 4197 e += CHAR_STRING (c, e); 4198 else 4199 *e++ = c; 4200 nchars++; 4201 4202 /* Process third byte of a quadruplet. */ 4203 4204 READ_QUADRUPLET_BYTE (-1); 4205 4206 if (c == '=') 4207 { 4208 READ_QUADRUPLET_BYTE (-1); 4209 4210 if (c != '=') 4211 return -1; 4212 continue; 4213 } 4214 4215 if (!IS_BASE64 (c)) 4216 return -1; 4217 value |= base64_char_to_value[c] << 6; 4218 4219 c = (unsigned char) (0xff & value >> 8); 4220 if (multibyte) 4221 e += CHAR_STRING (c, e); 4222 else 4223 *e++ = c; 4224 nchars++; 4225 4226 /* Process fourth byte of a quadruplet. */ 4227 4228 READ_QUADRUPLET_BYTE (-1); 4229 4230 if (c == '=') 4231 continue; 4232 4233 if (!IS_BASE64 (c)) 4234 return -1; 4235 value |= base64_char_to_value[c]; 4236 4237 c = (unsigned char) (0xff & value); 4238 if (multibyte) 4239 e += CHAR_STRING (c, e); 4240 else 4241 *e++ = c; 4242 nchars++; 4243 } 4244} 4245 4246 4247 4248/*********************************************************************** 4249 ***** ***** 4250 ***** Hash Tables ***** 4251 ***** ***** 4252 ***********************************************************************/ 4253 4254/* Implemented by gerd@gnu.org. This hash table implementation was 4255 inspired by CMUCL hash tables. */ 4256 4257/* Ideas: 4258 4259 1. For small tables, association lists are probably faster than 4260 hash tables because they have lower overhead. 4261 4262 For uses of hash tables where the O(1) behavior of table 4263 operations is not a requirement, it might therefore be a good idea 4264 not to hash. Instead, we could just do a linear search in the 4265 key_and_value vector of the hash table. This could be done 4266 if a `:linear-search t' argument is given to make-hash-table. */ 4267 4268 4269/* The list of all weak hash tables. Don't staticpro this one. */ 4270 4271Lisp_Object Vweak_hash_tables; 4272 4273/* Various symbols. */ 4274 4275Lisp_Object Qhash_table_p, Qeq, Qeql, Qequal, Qkey, Qvalue; 4276Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness; 4277Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value; 4278 4279/* Function prototypes. */ 4280 4281static struct Lisp_Hash_Table *check_hash_table P_ ((Lisp_Object)); 4282static int get_key_arg P_ ((Lisp_Object, int, Lisp_Object *, char *)); 4283static void maybe_resize_hash_table P_ ((struct Lisp_Hash_Table *)); 4284static int cmpfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned, 4285 Lisp_Object, unsigned)); 4286static int cmpfn_equal P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned, 4287 Lisp_Object, unsigned)); 4288static int cmpfn_user_defined P_ ((struct Lisp_Hash_Table *, Lisp_Object, 4289 unsigned, Lisp_Object, unsigned)); 4290static unsigned hashfn_eq P_ ((struct Lisp_Hash_Table *, Lisp_Object)); 4291static unsigned hashfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object)); 4292static unsigned hashfn_equal P_ ((struct Lisp_Hash_Table *, Lisp_Object)); 4293static unsigned hashfn_user_defined P_ ((struct Lisp_Hash_Table *, 4294 Lisp_Object)); 4295static unsigned sxhash_string P_ ((unsigned char *, int)); 4296static unsigned sxhash_list P_ ((Lisp_Object, int)); 4297static unsigned sxhash_vector P_ ((Lisp_Object, int)); 4298static unsigned sxhash_bool_vector P_ ((Lisp_Object)); 4299static int sweep_weak_table P_ ((struct Lisp_Hash_Table *, int)); 4300 4301 4302 4303/*********************************************************************** 4304 Utilities 4305 ***********************************************************************/ 4306 4307/* If OBJ is a Lisp hash table, return a pointer to its struct 4308 Lisp_Hash_Table. Otherwise, signal an error. */ 4309 4310static struct Lisp_Hash_Table * 4311check_hash_table (obj) 4312 Lisp_Object obj; 4313{ 4314 CHECK_HASH_TABLE (obj); 4315 return XHASH_TABLE (obj); 4316} 4317 4318 4319/* Value is the next integer I >= N, N >= 0 which is "almost" a prime 4320 number. */ 4321 4322int 4323next_almost_prime (n) 4324 int n; 4325{ 4326 if (n % 2 == 0) 4327 n += 1; 4328 if (n % 3 == 0) 4329 n += 2; 4330 if (n % 7 == 0) 4331 n += 4; 4332 return n; 4333} 4334 4335 4336/* Find KEY in ARGS which has size NARGS. Don't consider indices for 4337 which USED[I] is non-zero. If found at index I in ARGS, set 4338 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return 4339 -1. This function is used to extract a keyword/argument pair from 4340 a DEFUN parameter list. */ 4341 4342static int 4343get_key_arg (key, nargs, args, used) 4344 Lisp_Object key; 4345 int nargs; 4346 Lisp_Object *args; 4347 char *used; 4348{ 4349 int i; 4350 4351 for (i = 0; i < nargs - 1; ++i) 4352 if (!used[i] && EQ (args[i], key)) 4353 break; 4354 4355 if (i >= nargs - 1) 4356 i = -1; 4357 else 4358 { 4359 used[i++] = 1; 4360 used[i] = 1; 4361 } 4362 4363 return i; 4364} 4365 4366 4367/* Return a Lisp vector which has the same contents as VEC but has 4368 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting 4369 vector that are not copied from VEC are set to INIT. */ 4370 4371Lisp_Object 4372larger_vector (vec, new_size, init) 4373 Lisp_Object vec; 4374 int new_size; 4375 Lisp_Object init; 4376{ 4377 struct Lisp_Vector *v; 4378 int i, old_size; 4379 4380 xassert (VECTORP (vec)); 4381 old_size = ASIZE (vec); 4382 xassert (new_size >= old_size); 4383 4384 v = allocate_vector (new_size); 4385 bcopy (XVECTOR (vec)->contents, v->contents, 4386 old_size * sizeof *v->contents); 4387 for (i = old_size; i < new_size; ++i) 4388 v->contents[i] = init; 4389 XSETVECTOR (vec, v); 4390 return vec; 4391} 4392 4393 4394/*********************************************************************** 4395 Low-level Functions 4396 ***********************************************************************/ 4397 4398/* Compare KEY1 which has hash code HASH1 and KEY2 with hash code 4399 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and 4400 KEY2 are the same. */ 4401 4402static int 4403cmpfn_eql (h, key1, hash1, key2, hash2) 4404 struct Lisp_Hash_Table *h; 4405 Lisp_Object key1, key2; 4406 unsigned hash1, hash2; 4407{ 4408 return (FLOATP (key1) 4409 && FLOATP (key2) 4410 && XFLOAT_DATA (key1) == XFLOAT_DATA (key2)); 4411} 4412 4413 4414/* Compare KEY1 which has hash code HASH1 and KEY2 with hash code 4415 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and 4416 KEY2 are the same. */ 4417 4418static int 4419cmpfn_equal (h, key1, hash1, key2, hash2) 4420 struct Lisp_Hash_Table *h; 4421 Lisp_Object key1, key2; 4422 unsigned hash1, hash2; 4423{ 4424 return hash1 == hash2 && !NILP (Fequal (key1, key2)); 4425} 4426 4427 4428/* Compare KEY1 which has hash code HASH1, and KEY2 with hash code 4429 HASH2 in hash table H using H->user_cmp_function. Value is non-zero 4430 if KEY1 and KEY2 are the same. */ 4431 4432static int 4433cmpfn_user_defined (h, key1, hash1, key2, hash2) 4434 struct Lisp_Hash_Table *h; 4435 Lisp_Object key1, key2; 4436 unsigned hash1, hash2; 4437{ 4438 if (hash1 == hash2) 4439 { 4440 Lisp_Object args[3]; 4441 4442 args[0] = h->user_cmp_function; 4443 args[1] = key1; 4444 args[2] = key2; 4445 return !NILP (Ffuncall (3, args)); 4446 } 4447 else 4448 return 0; 4449} 4450 4451 4452/* Value is a hash code for KEY for use in hash table H which uses 4453 `eq' to compare keys. The hash code returned is guaranteed to fit 4454 in a Lisp integer. */ 4455 4456static unsigned 4457hashfn_eq (h, key) 4458 struct Lisp_Hash_Table *h; 4459 Lisp_Object key; 4460{ 4461 unsigned hash = XUINT (key) ^ XGCTYPE (key); 4462 xassert ((hash & ~INTMASK) == 0); 4463 return hash; 4464} 4465 4466 4467/* Value is a hash code for KEY for use in hash table H which uses 4468 `eql' to compare keys. The hash code returned is guaranteed to fit 4469 in a Lisp integer. */ 4470 4471static unsigned 4472hashfn_eql (h, key) 4473 struct Lisp_Hash_Table *h; 4474 Lisp_Object key; 4475{ 4476 unsigned hash; 4477 if (FLOATP (key)) 4478 hash = sxhash (key, 0); 4479 else 4480 hash = XUINT (key) ^ XGCTYPE (key); 4481 xassert ((hash & ~INTMASK) == 0); 4482 return hash; 4483} 4484 4485 4486/* Value is a hash code for KEY for use in hash table H which uses 4487 `equal' to compare keys. The hash code returned is guaranteed to fit 4488 in a Lisp integer. */ 4489 4490static unsigned 4491hashfn_equal (h, key) 4492 struct Lisp_Hash_Table *h; 4493 Lisp_Object key; 4494{ 4495 unsigned hash = sxhash (key, 0); 4496 xassert ((hash & ~INTMASK) == 0); 4497 return hash; 4498} 4499 4500 4501/* Value is a hash code for KEY for use in hash table H which uses as 4502 user-defined function to compare keys. The hash code returned is 4503 guaranteed to fit in a Lisp integer. */ 4504 4505static unsigned 4506hashfn_user_defined (h, key) 4507 struct Lisp_Hash_Table *h; 4508 Lisp_Object key; 4509{ 4510 Lisp_Object args[2], hash; 4511 4512 args[0] = h->user_hash_function; 4513 args[1] = key; 4514 hash = Ffuncall (2, args); 4515 if (!INTEGERP (hash)) 4516 signal_error ("Invalid hash code returned from user-supplied hash function", hash); 4517 return XUINT (hash); 4518} 4519 4520 4521/* Create and initialize a new hash table. 4522 4523 TEST specifies the test the hash table will use to compare keys. 4524 It must be either one of the predefined tests `eq', `eql' or 4525 `equal' or a symbol denoting a user-defined test named TEST with 4526 test and hash functions USER_TEST and USER_HASH. 4527 4528 Give the table initial capacity SIZE, SIZE >= 0, an integer. 4529 4530 If REHASH_SIZE is an integer, it must be > 0, and this hash table's 4531 new size when it becomes full is computed by adding REHASH_SIZE to 4532 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the 4533 table's new size is computed by multiplying its old size with 4534 REHASH_SIZE. 4535 4536 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will 4537 be resized when the ratio of (number of entries in the table) / 4538 (table size) is >= REHASH_THRESHOLD. 4539 4540 WEAK specifies the weakness of the table. If non-nil, it must be 4541 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */ 4542 4543Lisp_Object 4544make_hash_table (test, size, rehash_size, rehash_threshold, weak, 4545 user_test, user_hash) 4546 Lisp_Object test, size, rehash_size, rehash_threshold, weak; 4547 Lisp_Object user_test, user_hash; 4548{ 4549 struct Lisp_Hash_Table *h; 4550 Lisp_Object table; 4551 int index_size, i, sz; 4552 4553 /* Preconditions. */ 4554 xassert (SYMBOLP (test)); 4555 xassert (INTEGERP (size) && XINT (size) >= 0); 4556 xassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0) 4557 || (FLOATP (rehash_size) && XFLOATINT (rehash_size) > 1.0)); 4558 xassert (FLOATP (rehash_threshold) 4559 && XFLOATINT (rehash_threshold) > 0 4560 && XFLOATINT (rehash_threshold) <= 1.0); 4561 4562 if (XFASTINT (size) == 0) 4563 size = make_number (1); 4564 4565 /* Allocate a table and initialize it. */ 4566 h = allocate_hash_table (); 4567 4568 /* Initialize hash table slots. */ 4569 sz = XFASTINT (size); 4570 4571 h->test = test; 4572 if (EQ (test, Qeql)) 4573 { 4574 h->cmpfn = cmpfn_eql; 4575 h->hashfn = hashfn_eql; 4576 } 4577 else if (EQ (test, Qeq)) 4578 { 4579 h->cmpfn = NULL; 4580 h->hashfn = hashfn_eq; 4581 } 4582 else if (EQ (test, Qequal)) 4583 { 4584 h->cmpfn = cmpfn_equal; 4585 h->hashfn = hashfn_equal; 4586 } 4587 else 4588 { 4589 h->user_cmp_function = user_test; 4590 h->user_hash_function = user_hash; 4591 h->cmpfn = cmpfn_user_defined; 4592 h->hashfn = hashfn_user_defined; 4593 } 4594 4595 h->weak = weak; 4596 h->rehash_threshold = rehash_threshold; 4597 h->rehash_size = rehash_size; 4598 h->count = make_number (0); 4599 h->key_and_value = Fmake_vector (make_number (2 * sz), Qnil); 4600 h->hash = Fmake_vector (size, Qnil); 4601 h->next = Fmake_vector (size, Qnil); 4602 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */ 4603 index_size = next_almost_prime ((int) (sz / XFLOATINT (rehash_threshold))); 4604 h->index = Fmake_vector (make_number (index_size), Qnil); 4605 4606 /* Set up the free list. */ 4607 for (i = 0; i < sz - 1; ++i) 4608 HASH_NEXT (h, i) = make_number (i + 1); 4609 h->next_free = make_number (0); 4610 4611 XSET_HASH_TABLE (table, h); 4612 xassert (HASH_TABLE_P (table)); 4613 xassert (XHASH_TABLE (table) == h); 4614 4615 /* Maybe add this hash table to the list of all weak hash tables. */ 4616 if (NILP (h->weak)) 4617 h->next_weak = Qnil; 4618 else 4619 { 4620 h->next_weak = Vweak_hash_tables; 4621 Vweak_hash_tables = table; 4622 } 4623 4624 return table; 4625} 4626 4627 4628/* Return a copy of hash table H1. Keys and values are not copied, 4629 only the table itself is. */ 4630 4631Lisp_Object 4632copy_hash_table (h1) 4633 struct Lisp_Hash_Table *h1; 4634{ 4635 Lisp_Object table; 4636 struct Lisp_Hash_Table *h2; 4637 struct Lisp_Vector *next; 4638 4639 h2 = allocate_hash_table (); 4640 next = h2->vec_next; 4641 bcopy (h1, h2, sizeof *h2); 4642 h2->vec_next = next; 4643 h2->key_and_value = Fcopy_sequence (h1->key_and_value); 4644 h2->hash = Fcopy_sequence (h1->hash); 4645 h2->next = Fcopy_sequence (h1->next); 4646 h2->index = Fcopy_sequence (h1->index); 4647 XSET_HASH_TABLE (table, h2); 4648 4649 /* Maybe add this hash table to the list of all weak hash tables. */ 4650 if (!NILP (h2->weak)) 4651 { 4652 h2->next_weak = Vweak_hash_tables; 4653 Vweak_hash_tables = table; 4654 } 4655 4656 return table; 4657} 4658 4659 4660/* Resize hash table H if it's too full. If H cannot be resized 4661 because it's already too large, throw an error. */ 4662 4663static INLINE void 4664maybe_resize_hash_table (h) 4665 struct Lisp_Hash_Table *h; 4666{ 4667 if (NILP (h->next_free)) 4668 { 4669 int old_size = HASH_TABLE_SIZE (h); 4670 int i, new_size, index_size; 4671 EMACS_INT nsize; 4672 4673 if (INTEGERP (h->rehash_size)) 4674 new_size = old_size + XFASTINT (h->rehash_size); 4675 else 4676 new_size = old_size * XFLOATINT (h->rehash_size); 4677 new_size = max (old_size + 1, new_size); 4678 index_size = next_almost_prime ((int) 4679 (new_size 4680 / XFLOATINT (h->rehash_threshold))); 4681 /* Assignment to EMACS_INT stops GCC whining about limited range 4682 of data type. */ 4683 nsize = max (index_size, 2 * new_size); 4684 if (nsize > MOST_POSITIVE_FIXNUM) 4685 error ("Hash table too large to resize"); 4686 4687 h->key_and_value = larger_vector (h->key_and_value, 2 * new_size, Qnil); 4688 h->next = larger_vector (h->next, new_size, Qnil); 4689 h->hash = larger_vector (h->hash, new_size, Qnil); 4690 h->index = Fmake_vector (make_number (index_size), Qnil); 4691 4692 /* Update the free list. Do it so that new entries are added at 4693 the end of the free list. This makes some operations like 4694 maphash faster. */ 4695 for (i = old_size; i < new_size - 1; ++i) 4696 HASH_NEXT (h, i) = make_number (i + 1); 4697 4698 if (!NILP (h->next_free)) 4699 { 4700 Lisp_Object last, next; 4701 4702 last = h->next_free; 4703 while (next = HASH_NEXT (h, XFASTINT (last)), 4704 !NILP (next)) 4705 last = next; 4706 4707 HASH_NEXT (h, XFASTINT (last)) = make_number (old_size); 4708 } 4709 else 4710 XSETFASTINT (h->next_free, old_size); 4711 4712 /* Rehash. */ 4713 for (i = 0; i < old_size; ++i) 4714 if (!NILP (HASH_HASH (h, i))) 4715 { 4716 unsigned hash_code = XUINT (HASH_HASH (h, i)); 4717 int start_of_bucket = hash_code % ASIZE (h->index); 4718 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket); 4719 HASH_INDEX (h, start_of_bucket) = make_number (i); 4720 } 4721 } 4722} 4723 4724 4725/* Lookup KEY in hash table H. If HASH is non-null, return in *HASH 4726 the hash code of KEY. Value is the index of the entry in H 4727 matching KEY, or -1 if not found. */ 4728 4729int 4730hash_lookup (h, key, hash) 4731 struct Lisp_Hash_Table *h; 4732 Lisp_Object key; 4733 unsigned *hash; 4734{ 4735 unsigned hash_code; 4736 int start_of_bucket; 4737 Lisp_Object idx; 4738 4739 hash_code = h->hashfn (h, key); 4740 if (hash) 4741 *hash = hash_code; 4742 4743 start_of_bucket = hash_code % ASIZE (h->index); 4744 idx = HASH_INDEX (h, start_of_bucket); 4745 4746 /* We need not gcpro idx since it's either an integer or nil. */ 4747 while (!NILP (idx)) 4748 { 4749 int i = XFASTINT (idx); 4750 if (EQ (key, HASH_KEY (h, i)) 4751 || (h->cmpfn 4752 && h->cmpfn (h, key, hash_code, 4753 HASH_KEY (h, i), XUINT (HASH_HASH (h, i))))) 4754 break; 4755 idx = HASH_NEXT (h, i); 4756 } 4757 4758 return NILP (idx) ? -1 : XFASTINT (idx); 4759} 4760 4761 4762/* Put an entry into hash table H that associates KEY with VALUE. 4763 HASH is a previously computed hash code of KEY. 4764 Value is the index of the entry in H matching KEY. */ 4765 4766int 4767hash_put (h, key, value, hash) 4768 struct Lisp_Hash_Table *h; 4769 Lisp_Object key, value; 4770 unsigned hash; 4771{ 4772 int start_of_bucket, i; 4773 4774 xassert ((hash & ~INTMASK) == 0); 4775 4776 /* Increment count after resizing because resizing may fail. */ 4777 maybe_resize_hash_table (h); 4778 h->count = make_number (XFASTINT (h->count) + 1); 4779 4780 /* Store key/value in the key_and_value vector. */ 4781 i = XFASTINT (h->next_free); 4782 h->next_free = HASH_NEXT (h, i); 4783 HASH_KEY (h, i) = key; 4784 HASH_VALUE (h, i) = value; 4785 4786 /* Remember its hash code. */ 4787 HASH_HASH (h, i) = make_number (hash); 4788 4789 /* Add new entry to its collision chain. */ 4790 start_of_bucket = hash % ASIZE (h->index); 4791 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket); 4792 HASH_INDEX (h, start_of_bucket) = make_number (i); 4793 return i; 4794} 4795 4796 4797/* Remove the entry matching KEY from hash table H, if there is one. */ 4798 4799void 4800hash_remove (h, key) 4801 struct Lisp_Hash_Table *h; 4802 Lisp_Object key; 4803{ 4804 unsigned hash_code; 4805 int start_of_bucket; 4806 Lisp_Object idx, prev; 4807 4808 hash_code = h->hashfn (h, key); 4809 start_of_bucket = hash_code % ASIZE (h->index); 4810 idx = HASH_INDEX (h, start_of_bucket); 4811 prev = Qnil; 4812 4813 /* We need not gcpro idx, prev since they're either integers or nil. */ 4814 while (!NILP (idx)) 4815 { 4816 int i = XFASTINT (idx); 4817 4818 if (EQ (key, HASH_KEY (h, i)) 4819 || (h->cmpfn 4820 && h->cmpfn (h, key, hash_code, 4821 HASH_KEY (h, i), XUINT (HASH_HASH (h, i))))) 4822 { 4823 /* Take entry out of collision chain. */ 4824 if (NILP (prev)) 4825 HASH_INDEX (h, start_of_bucket) = HASH_NEXT (h, i); 4826 else 4827 HASH_NEXT (h, XFASTINT (prev)) = HASH_NEXT (h, i); 4828 4829 /* Clear slots in key_and_value and add the slots to 4830 the free list. */ 4831 HASH_KEY (h, i) = HASH_VALUE (h, i) = HASH_HASH (h, i) = Qnil; 4832 HASH_NEXT (h, i) = h->next_free; 4833 h->next_free = make_number (i); 4834 h->count = make_number (XFASTINT (h->count) - 1); 4835 xassert (XINT (h->count) >= 0); 4836 break; 4837 } 4838 else 4839 { 4840 prev = idx; 4841 idx = HASH_NEXT (h, i); 4842 } 4843 } 4844} 4845 4846 4847/* Clear hash table H. */ 4848 4849void 4850hash_clear (h) 4851 struct Lisp_Hash_Table *h; 4852{ 4853 if (XFASTINT (h->count) > 0) 4854 { 4855 int i, size = HASH_TABLE_SIZE (h); 4856 4857 for (i = 0; i < size; ++i) 4858 { 4859 HASH_NEXT (h, i) = i < size - 1 ? make_number (i + 1) : Qnil; 4860 HASH_KEY (h, i) = Qnil; 4861 HASH_VALUE (h, i) = Qnil; 4862 HASH_HASH (h, i) = Qnil; 4863 } 4864 4865 for (i = 0; i < ASIZE (h->index); ++i) 4866 AREF (h->index, i) = Qnil; 4867 4868 h->next_free = make_number (0); 4869 h->count = make_number (0); 4870 } 4871} 4872 4873 4874 4875/************************************************************************ 4876 Weak Hash Tables 4877 ************************************************************************/ 4878 4879/* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove 4880 entries from the table that don't survive the current GC. 4881 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is 4882 non-zero if anything was marked. */ 4883 4884static int 4885sweep_weak_table (h, remove_entries_p) 4886 struct Lisp_Hash_Table *h; 4887 int remove_entries_p; 4888{ 4889 int bucket, n, marked; 4890 4891 n = ASIZE (h->index) & ~ARRAY_MARK_FLAG; 4892 marked = 0; 4893 4894 for (bucket = 0; bucket < n; ++bucket) 4895 { 4896 Lisp_Object idx, next, prev; 4897 4898 /* Follow collision chain, removing entries that 4899 don't survive this garbage collection. */ 4900 prev = Qnil; 4901 for (idx = HASH_INDEX (h, bucket); !GC_NILP (idx); idx = next) 4902 { 4903 int i = XFASTINT (idx); 4904 int key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i)); 4905 int value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i)); 4906 int remove_p; 4907 4908 if (EQ (h->weak, Qkey)) 4909 remove_p = !key_known_to_survive_p; 4910 else if (EQ (h->weak, Qvalue)) 4911 remove_p = !value_known_to_survive_p; 4912 else if (EQ (h->weak, Qkey_or_value)) 4913 remove_p = !(key_known_to_survive_p || value_known_to_survive_p); 4914 else if (EQ (h->weak, Qkey_and_value)) 4915 remove_p = !(key_known_to_survive_p && value_known_to_survive_p); 4916 else 4917 abort (); 4918 4919 next = HASH_NEXT (h, i); 4920 4921 if (remove_entries_p) 4922 { 4923 if (remove_p) 4924 { 4925 /* Take out of collision chain. */ 4926 if (GC_NILP (prev)) 4927 HASH_INDEX (h, bucket) = next; 4928 else 4929 HASH_NEXT (h, XFASTINT (prev)) = next; 4930 4931 /* Add to free list. */ 4932 HASH_NEXT (h, i) = h->next_free; 4933 h->next_free = idx; 4934 4935 /* Clear key, value, and hash. */ 4936 HASH_KEY (h, i) = HASH_VALUE (h, i) = Qnil; 4937 HASH_HASH (h, i) = Qnil; 4938 4939 h->count = make_number (XFASTINT (h->count) - 1); 4940 } 4941 else 4942 { 4943 prev = idx; 4944 } 4945 } 4946 else 4947 { 4948 if (!remove_p) 4949 { 4950 /* Make sure key and value survive. */ 4951 if (!key_known_to_survive_p) 4952 { 4953 mark_object (HASH_KEY (h, i)); 4954 marked = 1; 4955 } 4956 4957 if (!value_known_to_survive_p) 4958 { 4959 mark_object (HASH_VALUE (h, i)); 4960 marked = 1; 4961 } 4962 } 4963 } 4964 } 4965 } 4966 4967 return marked; 4968} 4969 4970/* Remove elements from weak hash tables that don't survive the 4971 current garbage collection. Remove weak tables that don't survive 4972 from Vweak_hash_tables. Called from gc_sweep. */ 4973 4974void 4975sweep_weak_hash_tables () 4976{ 4977 Lisp_Object table, used, next; 4978 struct Lisp_Hash_Table *h; 4979 int marked; 4980 4981 /* Mark all keys and values that are in use. Keep on marking until 4982 there is no more change. This is necessary for cases like 4983 value-weak table A containing an entry X -> Y, where Y is used in a 4984 key-weak table B, Z -> Y. If B comes after A in the list of weak 4985 tables, X -> Y might be removed from A, although when looking at B 4986 one finds that it shouldn't. */ 4987 do 4988 { 4989 marked = 0; 4990 for (table = Vweak_hash_tables; !GC_NILP (table); table = h->next_weak) 4991 { 4992 h = XHASH_TABLE (table); 4993 if (h->size & ARRAY_MARK_FLAG) 4994 marked |= sweep_weak_table (h, 0); 4995 } 4996 } 4997 while (marked); 4998 4999 /* Remove tables and entries that aren't used. */ 5000 for (table = Vweak_hash_tables, used = Qnil; !GC_NILP (table); table = next) 5001 { 5002 h = XHASH_TABLE (table); 5003 next = h->next_weak; 5004 5005 if (h->size & ARRAY_MARK_FLAG) 5006 { 5007 /* TABLE is marked as used. Sweep its contents. */ 5008 if (XFASTINT (h->count) > 0) 5009 sweep_weak_table (h, 1); 5010 5011 /* Add table to the list of used weak hash tables. */ 5012 h->next_weak = used; 5013 used = table; 5014 } 5015 } 5016 5017 Vweak_hash_tables = used; 5018} 5019 5020 5021 5022/*********************************************************************** 5023 Hash Code Computation 5024 ***********************************************************************/ 5025 5026/* Maximum depth up to which to dive into Lisp structures. */ 5027 5028#define SXHASH_MAX_DEPTH 3 5029 5030/* Maximum length up to which to take list and vector elements into 5031 account. */ 5032 5033#define SXHASH_MAX_LEN 7 5034 5035/* Combine two integers X and Y for hashing. */ 5036 5037#define SXHASH_COMBINE(X, Y) \ 5038 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \ 5039 + (unsigned)(Y)) 5040 5041 5042/* Return a hash for string PTR which has length LEN. The hash 5043 code returned is guaranteed to fit in a Lisp integer. */ 5044 5045static unsigned 5046sxhash_string (ptr, len) 5047 unsigned char *ptr; 5048 int len; 5049{ 5050 unsigned char *p = ptr; 5051 unsigned char *end = p + len; 5052 unsigned char c; 5053 unsigned hash = 0; 5054 5055 while (p != end) 5056 { 5057 c = *p++; 5058 if (c >= 0140) 5059 c -= 40; 5060 hash = ((hash << 4) + (hash >> 28) + c); 5061 } 5062 5063 return hash & INTMASK; 5064} 5065 5066 5067/* Return a hash for list LIST. DEPTH is the current depth in the 5068 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */ 5069 5070static unsigned 5071sxhash_list (list, depth) 5072 Lisp_Object list; 5073 int depth; 5074{ 5075 unsigned hash = 0; 5076 int i; 5077 5078 if (depth < SXHASH_MAX_DEPTH) 5079 for (i = 0; 5080 CONSP (list) && i < SXHASH_MAX_LEN; 5081 list = XCDR (list), ++i) 5082 { 5083 unsigned hash2 = sxhash (XCAR (list), depth + 1); 5084 hash = SXHASH_COMBINE (hash, hash2); 5085 } 5086 5087 if (!NILP (list)) 5088 { 5089 unsigned hash2 = sxhash (list, depth + 1); 5090 hash = SXHASH_COMBINE (hash, hash2); 5091 } 5092 5093 return hash; 5094} 5095 5096 5097/* Return a hash for vector VECTOR. DEPTH is the current depth in 5098 the Lisp structure. */ 5099 5100static unsigned 5101sxhash_vector (vec, depth) 5102 Lisp_Object vec; 5103 int depth; 5104{ 5105 unsigned hash = ASIZE (vec); 5106 int i, n; 5107 5108 n = min (SXHASH_MAX_LEN, ASIZE (vec)); 5109 for (i = 0; i < n; ++i) 5110 { 5111 unsigned hash2 = sxhash (AREF (vec, i), depth + 1); 5112 hash = SXHASH_COMBINE (hash, hash2); 5113 } 5114 5115 return hash; 5116} 5117 5118 5119/* Return a hash for bool-vector VECTOR. */ 5120 5121static unsigned 5122sxhash_bool_vector (vec) 5123 Lisp_Object vec; 5124{ 5125 unsigned hash = XBOOL_VECTOR (vec)->size; 5126 int i, n; 5127 5128 n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->vector_size); 5129 for (i = 0; i < n; ++i) 5130 hash = SXHASH_COMBINE (hash, XBOOL_VECTOR (vec)->data[i]); 5131 5132 return hash; 5133} 5134 5135 5136/* Return a hash code for OBJ. DEPTH is the current depth in the Lisp 5137 structure. Value is an unsigned integer clipped to INTMASK. */ 5138 5139unsigned 5140sxhash (obj, depth) 5141 Lisp_Object obj; 5142 int depth; 5143{ 5144 unsigned hash; 5145 5146 if (depth > SXHASH_MAX_DEPTH) 5147 return 0; 5148 5149 switch (XTYPE (obj)) 5150 { 5151 case Lisp_Int: 5152 hash = XUINT (obj); 5153 break; 5154 5155 case Lisp_Misc: 5156 hash = XUINT (obj); 5157 break; 5158 5159 case Lisp_Symbol: 5160 obj = SYMBOL_NAME (obj); 5161 /* Fall through. */ 5162 5163 case Lisp_String: 5164 hash = sxhash_string (SDATA (obj), SCHARS (obj)); 5165 break; 5166 5167 /* This can be everything from a vector to an overlay. */ 5168 case Lisp_Vectorlike: 5169 if (VECTORP (obj)) 5170 /* According to the CL HyperSpec, two arrays are equal only if 5171 they are `eq', except for strings and bit-vectors. In 5172 Emacs, this works differently. We have to compare element 5173 by element. */ 5174 hash = sxhash_vector (obj, depth); 5175 else if (BOOL_VECTOR_P (obj)) 5176 hash = sxhash_bool_vector (obj); 5177 else 5178 /* Others are `equal' if they are `eq', so let's take their 5179 address as hash. */ 5180 hash = XUINT (obj); 5181 break; 5182 5183 case Lisp_Cons: 5184 hash = sxhash_list (obj, depth); 5185 break; 5186 5187 case Lisp_Float: 5188 { 5189 unsigned char *p = (unsigned char *) &XFLOAT_DATA (obj); 5190 unsigned char *e = p + sizeof XFLOAT_DATA (obj); 5191 for (hash = 0; p < e; ++p) 5192 hash = SXHASH_COMBINE (hash, *p); 5193 break; 5194 } 5195 5196 default: 5197 abort (); 5198 } 5199 5200 return hash & INTMASK; 5201} 5202 5203 5204 5205/*********************************************************************** 5206 Lisp Interface 5207 ***********************************************************************/ 5208 5209 5210DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0, 5211 doc: /* Compute a hash code for OBJ and return it as integer. */) 5212 (obj) 5213 Lisp_Object obj; 5214{ 5215 unsigned hash = sxhash (obj, 0);; 5216 return make_number (hash); 5217} 5218 5219 5220DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0, 5221 doc: /* Create and return a new hash table. 5222 5223Arguments are specified as keyword/argument pairs. The following 5224arguments are defined: 5225 5226:test TEST -- TEST must be a symbol that specifies how to compare 5227keys. Default is `eql'. Predefined are the tests `eq', `eql', and 5228`equal'. User-supplied test and hash functions can be specified via 5229`define-hash-table-test'. 5230 5231:size SIZE -- A hint as to how many elements will be put in the table. 5232Default is 65. 5233 5234:rehash-size REHASH-SIZE - Indicates how to expand the table when it 5235fills up. If REHASH-SIZE is an integer, add that many space. If it 5236is a float, it must be > 1.0, and the new size is computed by 5237multiplying the old size with that factor. Default is 1.5. 5238 5239:rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0. 5240Resize the hash table when ratio of the number of entries in the 5241table. Default is 0.8. 5242 5243:weakness WEAK -- WEAK must be one of nil, t, `key', `value', 5244`key-or-value', or `key-and-value'. If WEAK is not nil, the table 5245returned is a weak table. Key/value pairs are removed from a weak 5246hash table when there are no non-weak references pointing to their 5247key, value, one of key or value, or both key and value, depending on 5248WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK 5249is nil. 5250 5251usage: (make-hash-table &rest KEYWORD-ARGS) */) 5252 (nargs, args) 5253 int nargs; 5254 Lisp_Object *args; 5255{ 5256 Lisp_Object test, size, rehash_size, rehash_threshold, weak; 5257 Lisp_Object user_test, user_hash; 5258 char *used; 5259 int i; 5260 5261 /* The vector `used' is used to keep track of arguments that 5262 have been consumed. */ 5263 used = (char *) alloca (nargs * sizeof *used); 5264 bzero (used, nargs * sizeof *used); 5265 5266 /* See if there's a `:test TEST' among the arguments. */ 5267 i = get_key_arg (QCtest, nargs, args, used); 5268 test = i < 0 ? Qeql : args[i]; 5269 if (!EQ (test, Qeq) && !EQ (test, Qeql) && !EQ (test, Qequal)) 5270 { 5271 /* See if it is a user-defined test. */ 5272 Lisp_Object prop; 5273 5274 prop = Fget (test, Qhash_table_test); 5275 if (!CONSP (prop) || !CONSP (XCDR (prop))) 5276 signal_error ("Invalid hash table test", test); 5277 user_test = XCAR (prop); 5278 user_hash = XCAR (XCDR (prop)); 5279 } 5280 else 5281 user_test = user_hash = Qnil; 5282 5283 /* See if there's a `:size SIZE' argument. */ 5284 i = get_key_arg (QCsize, nargs, args, used); 5285 size = i < 0 ? Qnil : args[i]; 5286 if (NILP (size)) 5287 size = make_number (DEFAULT_HASH_SIZE); 5288 else if (!INTEGERP (size) || XINT (size) < 0) 5289 signal_error ("Invalid hash table size", size); 5290 5291 /* Look for `:rehash-size SIZE'. */ 5292 i = get_key_arg (QCrehash_size, nargs, args, used); 5293 rehash_size = i < 0 ? make_float (DEFAULT_REHASH_SIZE) : args[i]; 5294 if (!NUMBERP (rehash_size) 5295 || (INTEGERP (rehash_size) && XINT (rehash_size) <= 0) 5296 || XFLOATINT (rehash_size) <= 1.0) 5297 signal_error ("Invalid hash table rehash size", rehash_size); 5298 5299 /* Look for `:rehash-threshold THRESHOLD'. */ 5300 i = get_key_arg (QCrehash_threshold, nargs, args, used); 5301 rehash_threshold = i < 0 ? make_float (DEFAULT_REHASH_THRESHOLD) : args[i]; 5302 if (!FLOATP (rehash_threshold) 5303 || XFLOATINT (rehash_threshold) <= 0.0 5304 || XFLOATINT (rehash_threshold) > 1.0) 5305 signal_error ("Invalid hash table rehash threshold", rehash_threshold); 5306 5307 /* Look for `:weakness WEAK'. */ 5308 i = get_key_arg (QCweakness, nargs, args, used); 5309 weak = i < 0 ? Qnil : args[i]; 5310 if (EQ (weak, Qt)) 5311 weak = Qkey_and_value; 5312 if (!NILP (weak) 5313 && !EQ (weak, Qkey) 5314 && !EQ (weak, Qvalue) 5315 && !EQ (weak, Qkey_or_value) 5316 && !EQ (weak, Qkey_and_value)) 5317 signal_error ("Invalid hash table weakness", weak); 5318 5319 /* Now, all args should have been used up, or there's a problem. */ 5320 for (i = 0; i < nargs; ++i) 5321 if (!used[i]) 5322 signal_error ("Invalid argument list", args[i]); 5323 5324 return make_hash_table (test, size, rehash_size, rehash_threshold, weak, 5325 user_test, user_hash); 5326} 5327 5328 5329DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0, 5330 doc: /* Return a copy of hash table TABLE. */) 5331 (table) 5332 Lisp_Object table; 5333{ 5334 return copy_hash_table (check_hash_table (table)); 5335} 5336 5337 5338DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0, 5339 doc: /* Return the number of elements in TABLE. */) 5340 (table) 5341 Lisp_Object table; 5342{ 5343 return check_hash_table (table)->count; 5344} 5345 5346 5347DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 5348 Shash_table_rehash_size, 1, 1, 0, 5349 doc: /* Return the current rehash size of TABLE. */) 5350 (table) 5351 Lisp_Object table; 5352{ 5353 return check_hash_table (table)->rehash_size; 5354} 5355 5356 5357DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 5358 Shash_table_rehash_threshold, 1, 1, 0, 5359 doc: /* Return the current rehash threshold of TABLE. */) 5360 (table) 5361 Lisp_Object table; 5362{ 5363 return check_hash_table (table)->rehash_threshold; 5364} 5365 5366 5367DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0, 5368 doc: /* Return the size of TABLE. 5369The size can be used as an argument to `make-hash-table' to create 5370a hash table than can hold as many elements of TABLE holds 5371without need for resizing. */) 5372 (table) 5373 Lisp_Object table; 5374{ 5375 struct Lisp_Hash_Table *h = check_hash_table (table); 5376 return make_number (HASH_TABLE_SIZE (h)); 5377} 5378 5379 5380DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0, 5381 doc: /* Return the test TABLE uses. */) 5382 (table) 5383 Lisp_Object table; 5384{ 5385 return check_hash_table (table)->test; 5386} 5387 5388 5389DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness, 5390 1, 1, 0, 5391 doc: /* Return the weakness of TABLE. */) 5392 (table) 5393 Lisp_Object table; 5394{ 5395 return check_hash_table (table)->weak; 5396} 5397 5398 5399DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0, 5400 doc: /* Return t if OBJ is a Lisp hash table object. */) 5401 (obj) 5402 Lisp_Object obj; 5403{ 5404 return HASH_TABLE_P (obj) ? Qt : Qnil; 5405} 5406 5407 5408DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0, 5409 doc: /* Clear hash table TABLE. */) 5410 (table) 5411 Lisp_Object table; 5412{ 5413 hash_clear (check_hash_table (table)); 5414 return Qnil; 5415} 5416 5417 5418DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0, 5419 doc: /* Look up KEY in TABLE and return its associated value. 5420If KEY is not found, return DFLT which defaults to nil. */) 5421 (key, table, dflt) 5422 Lisp_Object key, table, dflt; 5423{ 5424 struct Lisp_Hash_Table *h = check_hash_table (table); 5425 int i = hash_lookup (h, key, NULL); 5426 return i >= 0 ? HASH_VALUE (h, i) : dflt; 5427} 5428 5429 5430DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0, 5431 doc: /* Associate KEY with VALUE in hash table TABLE. 5432If KEY is already present in table, replace its current value with 5433VALUE. */) 5434 (key, value, table) 5435 Lisp_Object key, value, table; 5436{ 5437 struct Lisp_Hash_Table *h = check_hash_table (table); 5438 int i; 5439 unsigned hash; 5440 5441 i = hash_lookup (h, key, &hash); 5442 if (i >= 0) 5443 HASH_VALUE (h, i) = value; 5444 else 5445 hash_put (h, key, value, hash); 5446 5447 return value; 5448} 5449 5450 5451DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0, 5452 doc: /* Remove KEY from TABLE. */) 5453 (key, table) 5454 Lisp_Object key, table; 5455{ 5456 struct Lisp_Hash_Table *h = check_hash_table (table); 5457 hash_remove (h, key); 5458 return Qnil; 5459} 5460 5461 5462DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0, 5463 doc: /* Call FUNCTION for all entries in hash table TABLE. 5464FUNCTION is called with two arguments, KEY and VALUE. */) 5465 (function, table) 5466 Lisp_Object function, table; 5467{ 5468 struct Lisp_Hash_Table *h = check_hash_table (table); 5469 Lisp_Object args[3]; 5470 int i; 5471 5472 for (i = 0; i < HASH_TABLE_SIZE (h); ++i) 5473 if (!NILP (HASH_HASH (h, i))) 5474 { 5475 args[0] = function; 5476 args[1] = HASH_KEY (h, i); 5477 args[2] = HASH_VALUE (h, i); 5478 Ffuncall (3, args); 5479 } 5480 5481 return Qnil; 5482} 5483 5484 5485DEFUN ("define-hash-table-test", Fdefine_hash_table_test, 5486 Sdefine_hash_table_test, 3, 3, 0, 5487 doc: /* Define a new hash table test with name NAME, a symbol. 5488 5489In hash tables created with NAME specified as test, use TEST to 5490compare keys, and HASH for computing hash codes of keys. 5491 5492TEST must be a function taking two arguments and returning non-nil if 5493both arguments are the same. HASH must be a function taking one 5494argument and return an integer that is the hash code of the argument. 5495Hash code computation should use the whole value range of integers, 5496including negative integers. */) 5497 (name, test, hash) 5498 Lisp_Object name, test, hash; 5499{ 5500 return Fput (name, Qhash_table_test, list2 (test, hash)); 5501} 5502 5503 5504 5505/************************************************************************ 5506 MD5 5507 ************************************************************************/ 5508 5509#include "md5.h" 5510#include "coding.h" 5511 5512DEFUN ("md5", Fmd5, Smd5, 1, 5, 0, 5513 doc: /* Return MD5 message digest of OBJECT, a buffer or string. 5514 5515A message digest is a cryptographic checksum of a document, and the 5516algorithm to calculate it is defined in RFC 1321. 5517 5518The two optional arguments START and END are character positions 5519specifying for which part of OBJECT the message digest should be 5520computed. If nil or omitted, the digest is computed for the whole 5521OBJECT. 5522 5523The MD5 message digest is computed from the result of encoding the 5524text in a coding system, not directly from the internal Emacs form of 5525the text. The optional fourth argument CODING-SYSTEM specifies which 5526coding system to encode the text with. It should be the same coding 5527system that you used or will use when actually writing the text into a 5528file. 5529 5530If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If 5531OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding 5532system would be chosen by default for writing this text into a file. 5533 5534If OBJECT is a string, the most preferred coding system (see the 5535command `prefer-coding-system') is used. 5536 5537If NOERROR is non-nil, silently assume the `raw-text' coding if the 5538guesswork fails. Normally, an error is signaled in such case. */) 5539 (object, start, end, coding_system, noerror) 5540 Lisp_Object object, start, end, coding_system, noerror; 5541{ 5542 unsigned char digest[16]; 5543 unsigned char value[33]; 5544 int i; 5545 int size; 5546 int size_byte = 0; 5547 int start_char = 0, end_char = 0; 5548 int start_byte = 0, end_byte = 0; 5549 register int b, e; 5550 register struct buffer *bp; 5551 int temp; 5552 5553 if (STRINGP (object)) 5554 { 5555 if (NILP (coding_system)) 5556 { 5557 /* Decide the coding-system to encode the data with. */ 5558 5559 if (STRING_MULTIBYTE (object)) 5560 /* use default, we can't guess correct value */ 5561 coding_system = SYMBOL_VALUE (XCAR (Vcoding_category_list)); 5562 else 5563 coding_system = Qraw_text; 5564 } 5565 5566 if (NILP (Fcoding_system_p (coding_system))) 5567 { 5568 /* Invalid coding system. */ 5569 5570 if (!NILP (noerror)) 5571 coding_system = Qraw_text; 5572 else 5573 xsignal1 (Qcoding_system_error, coding_system); 5574 } 5575 5576 if (STRING_MULTIBYTE (object)) 5577 object = code_convert_string1 (object, coding_system, Qnil, 1); 5578 5579 size = SCHARS (object); 5580 size_byte = SBYTES (object); 5581 5582 if (!NILP (start)) 5583 { 5584 CHECK_NUMBER (start); 5585 5586 start_char = XINT (start); 5587 5588 if (start_char < 0) 5589 start_char += size; 5590 5591 start_byte = string_char_to_byte (object, start_char); 5592 } 5593 5594 if (NILP (end)) 5595 { 5596 end_char = size; 5597 end_byte = size_byte; 5598 } 5599 else 5600 { 5601 CHECK_NUMBER (end); 5602 5603 end_char = XINT (end); 5604 5605 if (end_char < 0) 5606 end_char += size; 5607 5608 end_byte = string_char_to_byte (object, end_char); 5609 } 5610 5611 if (!(0 <= start_char && start_char <= end_char && end_char <= size)) 5612 args_out_of_range_3 (object, make_number (start_char), 5613 make_number (end_char)); 5614 } 5615 else 5616 { 5617 struct buffer *prev = current_buffer; 5618 5619 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); 5620 5621 CHECK_BUFFER (object); 5622 5623 bp = XBUFFER (object); 5624 if (bp != current_buffer) 5625 set_buffer_internal (bp); 5626 5627 if (NILP (start)) 5628 b = BEGV; 5629 else 5630 { 5631 CHECK_NUMBER_COERCE_MARKER (start); 5632 b = XINT (start); 5633 } 5634 5635 if (NILP (end)) 5636 e = ZV; 5637 else 5638 { 5639 CHECK_NUMBER_COERCE_MARKER (end); 5640 e = XINT (end); 5641 } 5642 5643 if (b > e) 5644 temp = b, b = e, e = temp; 5645 5646 if (!(BEGV <= b && e <= ZV)) 5647 args_out_of_range (start, end); 5648 5649 if (NILP (coding_system)) 5650 { 5651 /* Decide the coding-system to encode the data with. 5652 See fileio.c:Fwrite-region */ 5653 5654 if (!NILP (Vcoding_system_for_write)) 5655 coding_system = Vcoding_system_for_write; 5656 else 5657 { 5658 int force_raw_text = 0; 5659 5660 coding_system = XBUFFER (object)->buffer_file_coding_system; 5661 if (NILP (coding_system) 5662 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil))) 5663 { 5664 coding_system = Qnil; 5665 if (NILP (current_buffer->enable_multibyte_characters)) 5666 force_raw_text = 1; 5667 } 5668 5669 if (NILP (coding_system) && !NILP (Fbuffer_file_name(object))) 5670 { 5671 /* Check file-coding-system-alist. */ 5672 Lisp_Object args[4], val; 5673 5674 args[0] = Qwrite_region; args[1] = start; args[2] = end; 5675 args[3] = Fbuffer_file_name(object); 5676 val = Ffind_operation_coding_system (4, args); 5677 if (CONSP (val) && !NILP (XCDR (val))) 5678 coding_system = XCDR (val); 5679 } 5680 5681 if (NILP (coding_system) 5682 && !NILP (XBUFFER (object)->buffer_file_coding_system)) 5683 { 5684 /* If we still have not decided a coding system, use the 5685 default value of buffer-file-coding-system. */ 5686 coding_system = XBUFFER (object)->buffer_file_coding_system; 5687 } 5688 5689 if (!force_raw_text 5690 && !NILP (Ffboundp (Vselect_safe_coding_system_function))) 5691 /* Confirm that VAL can surely encode the current region. */ 5692 coding_system = call4 (Vselect_safe_coding_system_function, 5693 make_number (b), make_number (e), 5694 coding_system, Qnil); 5695 5696 if (force_raw_text) 5697 coding_system = Qraw_text; 5698 } 5699 5700 if (NILP (Fcoding_system_p (coding_system))) 5701 { 5702 /* Invalid coding system. */ 5703 5704 if (!NILP (noerror)) 5705 coding_system = Qraw_text; 5706 else 5707 xsignal1 (Qcoding_system_error, coding_system); 5708 } 5709 } 5710 5711 object = make_buffer_string (b, e, 0); 5712 if (prev != current_buffer) 5713 set_buffer_internal (prev); 5714 /* Discard the unwind protect for recovering the current 5715 buffer. */ 5716 specpdl_ptr--; 5717 5718 if (STRING_MULTIBYTE (object)) 5719 object = code_convert_string1 (object, coding_system, Qnil, 1); 5720 } 5721 5722 md5_buffer (SDATA (object) + start_byte, 5723 SBYTES (object) - (size_byte - end_byte), 5724 digest); 5725 5726 for (i = 0; i < 16; i++) 5727 sprintf (&value[2 * i], "%02x", digest[i]); 5728 value[32] = '\0'; 5729 5730 return make_string (value, 32); 5731} 5732 5733 5734void 5735syms_of_fns () 5736{ 5737 /* Hash table stuff. */ 5738 Qhash_table_p = intern ("hash-table-p"); 5739 staticpro (&Qhash_table_p); 5740 Qeq = intern ("eq"); 5741 staticpro (&Qeq); 5742 Qeql = intern ("eql"); 5743 staticpro (&Qeql); 5744 Qequal = intern ("equal"); 5745 staticpro (&Qequal); 5746 QCtest = intern (":test"); 5747 staticpro (&QCtest); 5748 QCsize = intern (":size"); 5749 staticpro (&QCsize); 5750 QCrehash_size = intern (":rehash-size"); 5751 staticpro (&QCrehash_size); 5752 QCrehash_threshold = intern (":rehash-threshold"); 5753 staticpro (&QCrehash_threshold); 5754 QCweakness = intern (":weakness"); 5755 staticpro (&QCweakness); 5756 Qkey = intern ("key"); 5757 staticpro (&Qkey); 5758 Qvalue = intern ("value"); 5759 staticpro (&Qvalue); 5760 Qhash_table_test = intern ("hash-table-test"); 5761 staticpro (&Qhash_table_test); 5762 Qkey_or_value = intern ("key-or-value"); 5763 staticpro (&Qkey_or_value); 5764 Qkey_and_value = intern ("key-and-value"); 5765 staticpro (&Qkey_and_value); 5766 5767 defsubr (&Ssxhash); 5768 defsubr (&Smake_hash_table); 5769 defsubr (&Scopy_hash_table); 5770 defsubr (&Shash_table_count); 5771 defsubr (&Shash_table_rehash_size); 5772 defsubr (&Shash_table_rehash_threshold); 5773 defsubr (&Shash_table_size); 5774 defsubr (&Shash_table_test); 5775 defsubr (&Shash_table_weakness); 5776 defsubr (&Shash_table_p); 5777 defsubr (&Sclrhash); 5778 defsubr (&Sgethash); 5779 defsubr (&Sputhash); 5780 defsubr (&Sremhash); 5781 defsubr (&Smaphash); 5782 defsubr (&Sdefine_hash_table_test); 5783 5784 Qstring_lessp = intern ("string-lessp"); 5785 staticpro (&Qstring_lessp); 5786 Qprovide = intern ("provide"); 5787 staticpro (&Qprovide); 5788 Qrequire = intern ("require"); 5789 staticpro (&Qrequire); 5790 Qyes_or_no_p_history = intern ("yes-or-no-p-history"); 5791 staticpro (&Qyes_or_no_p_history); 5792 Qcursor_in_echo_area = intern ("cursor-in-echo-area"); 5793 staticpro (&Qcursor_in_echo_area); 5794 Qwidget_type = intern ("widget-type"); 5795 staticpro (&Qwidget_type); 5796 5797 staticpro (&string_char_byte_cache_string); 5798 string_char_byte_cache_string = Qnil; 5799 5800 require_nesting_list = Qnil; 5801 staticpro (&require_nesting_list); 5802 5803 Fset (Qyes_or_no_p_history, Qnil); 5804 5805 DEFVAR_LISP ("features", &Vfeatures, 5806 doc: /* A list of symbols which are the features of the executing Emacs. 5807Used by `featurep' and `require', and altered by `provide'. */); 5808 Vfeatures = Fcons (intern ("emacs"), Qnil); 5809 Qsubfeatures = intern ("subfeatures"); 5810 staticpro (&Qsubfeatures); 5811 5812#ifdef HAVE_LANGINFO_CODESET 5813 Qcodeset = intern ("codeset"); 5814 staticpro (&Qcodeset); 5815 Qdays = intern ("days"); 5816 staticpro (&Qdays); 5817 Qmonths = intern ("months"); 5818 staticpro (&Qmonths); 5819 Qpaper = intern ("paper"); 5820 staticpro (&Qpaper); 5821#endif /* HAVE_LANGINFO_CODESET */ 5822 5823 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box, 5824 doc: /* *Non-nil means mouse commands use dialog boxes to ask questions. 5825This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands 5826invoked by mouse clicks and mouse menu items. */); 5827 use_dialog_box = 1; 5828 5829 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog, 5830 doc: /* *Non-nil means mouse commands use a file dialog to ask for files. 5831This applies to commands from menus and tool bar buttons. The value of 5832`use-dialog-box' takes precedence over this variable, so a file dialog is only 5833used if both `use-dialog-box' and this variable are non-nil. */); 5834 use_file_dialog = 1; 5835 5836 defsubr (&Sidentity); 5837 defsubr (&Srandom); 5838 defsubr (&Slength); 5839 defsubr (&Ssafe_length); 5840 defsubr (&Sstring_bytes); 5841 defsubr (&Sstring_equal); 5842 defsubr (&Scompare_strings); 5843 defsubr (&Sstring_lessp); 5844 defsubr (&Sappend); 5845 defsubr (&Sconcat); 5846 defsubr (&Svconcat); 5847 defsubr (&Scopy_sequence); 5848 defsubr (&Sstring_make_multibyte); 5849 defsubr (&Sstring_make_unibyte); 5850 defsubr (&Sstring_as_multibyte); 5851 defsubr (&Sstring_as_unibyte); 5852 defsubr (&Sstring_to_multibyte); 5853 defsubr (&Scopy_alist); 5854 defsubr (&Ssubstring); 5855 defsubr (&Ssubstring_no_properties); 5856 defsubr (&Snthcdr); 5857 defsubr (&Snth); 5858 defsubr (&Selt); 5859 defsubr (&Smember); 5860 defsubr (&Smemq); 5861 defsubr (&Smemql); 5862 defsubr (&Sassq); 5863 defsubr (&Sassoc); 5864 defsubr (&Srassq); 5865 defsubr (&Srassoc); 5866 defsubr (&Sdelq); 5867 defsubr (&Sdelete); 5868 defsubr (&Snreverse); 5869 defsubr (&Sreverse); 5870 defsubr (&Ssort); 5871 defsubr (&Splist_get); 5872 defsubr (&Sget); 5873 defsubr (&Splist_put); 5874 defsubr (&Sput); 5875 defsubr (&Slax_plist_get); 5876 defsubr (&Slax_plist_put); 5877 defsubr (&Seql); 5878 defsubr (&Sequal); 5879 defsubr (&Sequal_including_properties); 5880 defsubr (&Sfillarray); 5881 defsubr (&Sclear_string); 5882 defsubr (&Schar_table_subtype); 5883 defsubr (&Schar_table_parent); 5884 defsubr (&Sset_char_table_parent); 5885 defsubr (&Schar_table_extra_slot); 5886 defsubr (&Sset_char_table_extra_slot); 5887 defsubr (&Schar_table_range); 5888 defsubr (&Sset_char_table_range); 5889 defsubr (&Sset_char_table_default); 5890 defsubr (&Soptimize_char_table); 5891 defsubr (&Smap_char_table); 5892 defsubr (&Snconc); 5893 defsubr (&Smapcar); 5894 defsubr (&Smapc); 5895 defsubr (&Smapconcat); 5896 defsubr (&Sy_or_n_p); 5897 defsubr (&Syes_or_no_p); 5898 defsubr (&Sload_average); 5899 defsubr (&Sfeaturep); 5900 defsubr (&Srequire); 5901 defsubr (&Sprovide); 5902 defsubr (&Splist_member); 5903 defsubr (&Swidget_put); 5904 defsubr (&Swidget_get); 5905 defsubr (&Swidget_apply); 5906 defsubr (&Sbase64_encode_region); 5907 defsubr (&Sbase64_decode_region); 5908 defsubr (&Sbase64_encode_string); 5909 defsubr (&Sbase64_decode_string); 5910 defsubr (&Smd5); 5911 defsubr (&Slocale_info); 5912} 5913 5914 5915void 5916init_fns () 5917{ 5918 Vweak_hash_tables = Qnil; 5919} 5920 5921/* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31 5922 (do not change this comment) */ 5923