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: 
    6: This file is part of GNU Emacs.
    7: 
    8: GNU Emacs is free software; you can redistribute it and/or modify
    9: it under the terms of the GNU General Public License as published by
   10: the Free Software Foundation; either version 2, or (at your option)
   11: any later version.
   12: 
   13: GNU Emacs is distributed in the hope that it will be useful,
   14: but WITHOUT ANY WARRANTY; without even the implied warranty of
   15: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   16: GNU General Public License for more details.
   17: 
   18: You should have received a copy of the GNU General Public License
   19: along with GNU Emacs; see the file COPYING.  If not, write to
   20: the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   21: Boston, 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.  */
   65: int use_dialog_box;
   66: 
   67: /* Nonzero enables use of a file dialog for file name
   68:    questions asked by mouse commands.  */
   69: int use_file_dialog;
   70: 
   71: extern int minibuffer_auto_raise;
   72: extern Lisp_Object minibuf_window;
   73: extern Lisp_Object Vlocale_coding_system;
   74: extern int load_in_progress;
   75: 
   76: Lisp_Object Qstring_lessp, Qprovide, Qrequire;
   77: Lisp_Object Qyes_or_no_p_history;
   78: Lisp_Object Qcursor_in_echo_area;
   79: Lisp_Object Qwidget_type;
   80: Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
   81: 
   82: extern Lisp_Object Qinput_method_function;
   83: 
   84: static int internal_equal P_ ((Lisp_Object , Lisp_Object, int, int));
   85: 
   86: extern long get_random ();
   87: extern void seed_random P_ ((long));
   88: 
   89: #ifndef HAVE_UNISTD_H
   90: extern long time ();
   91: #endif
   92: ^L
   93: DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
   94:        doc: /* Return the argument unchanged.  */)
   95:      (arg)
   96:      Lisp_Object arg;
   97: {
   98:   return arg;
   99: }
  100: 
  101: DEFUN ("random", Frandom, Srandom, 0, 1, 0,
  102:        doc: /* Return a pseudo-random number.
  103: All integers representable in Lisp are equally likely.
  104:   On most systems, this is 29 bits' worth.
  105: With positive integer argument N, return random number in interval [0,N).
  106: With 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: ^L
  136: /* Random data-structure functions */
  137: 
  138: DEFUN ("length", Flength, Slength, 1, 1, 0,
  139:        doc: /* Return the length of vector, list or string SEQUENCE.
  140: A byte-code function object is also allowed.
  141: If the string contains multibyte characters, this is not necessarily
  142: the number of bytes in the string; it is the number of characters.
  143: To 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: 
  192: DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
  193:        doc: /* Return the length of a list, but avoid error or infinite loop.
  194: This function never gets an error.  If LIST is not really a list,
  195: it returns 0.  If LIST is circular, it returns a finite value
  196: which 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: 
  218: DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
  219:        doc: /* Return the number of bytes in STRING.
  220: If 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: 
  228: DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
  229:        doc: /* Return t if two strings have identical contents.
  230: Case is significant, but text properties are ignored.
  231: Symbols 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: 
  249: DEFUN ("compare-strings", Fcompare_strings,
  250:        Scompare_strings, 6, 7, 0,
  251: doc: /* Compare the contents of two strings, converting to multibyte if needed.
  252: In string STR1, skip the first START1 characters and stop at END1.
  253: In string STR2, skip the first START2 characters and stop at END2.
  254: END1 and END2 default to the full lengths of the respective strings.
  255: 
  256: Case is significant in this comparison if IGNORE-CASE is nil.
  257: Unibyte strings are converted to multibyte for comparison.
  258: 
  259: The value is t if the strings (or specified portions) match.
  260: If string STR1 is less, the value is a negative number N;
  261:   - 1 - N is the number of characters that match at the beginning.
  262: If 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: 
  352: DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
  353:        doc: /* Return t if first arg string is less than second in lexicographic order.
  354: Case is significant.
  355: Symbols 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: ^L
  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.  */
  394: static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special)) __attribute__((noinline));
  395: #else  /* !__GNUC__ */
  396: static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special));
  397: #endif
  398: 
  399: /* ARGSUSED */
  400: Lisp_Object
  401: concat2 (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 */
  415: Lisp_Object
  416: concat3 (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: 
  430: DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
  431:        doc: /* Concatenate all the arguments and make the result a list.
  432: The result is a list whose elements are the elements of all the arguments.
  433: Each argument may be a list, vector or string.
  434: The last argument is not copied, just used as the tail of the new list.
  435: usage: (append &rest SEQUENCES)  */)
  436:      (nargs, args)
  437:      int nargs;
  438:      Lisp_Object *args;
  439: {
  440:   return concat (nargs, args, Lisp_Cons, 1);
  441: }
  442: 
  443: DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
  444:        doc: /* Concatenate all the arguments and make the result a string.
  445: The result is a string whose elements are the elements of all the arguments.
  446: Each argument may be a string or a list or vector of characters (integers).
  447: usage: (concat &rest SEQUENCES)  */)
  448:      (nargs, args)
  449:      int nargs;
  450:      Lisp_Object *args;
  451: {
  452:   return concat (nargs, args, Lisp_String, 0);
  453: }
  454: 
  455: DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
  456:        doc: /* Concatenate all the arguments and make the result a vector.
  457: The result is a vector whose elements are the elements of all the arguments.
  458: Each argument may be a list, vector or string.
  459: usage: (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.  */
  469: static Lisp_Object
  470: copy_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: 
  490: DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
  491:        doc: /* Return a copy of a list, vector, string or char-table.
  492: The elements of a list or vector are not copied; they are shared
  493: with 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.  */
  542: struct 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: 
  549: static Lisp_Object
  550: concat (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:     }