src/fns.c

   1 /* Random utility Lisp functions.
   2    Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 1, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20
  21 #include "config.h"
  22
  23 #ifdef LOAD_AVE_TYPE
  24 #ifdef BSD
  25 /* It appears param.h defines BSD and BSD4_3 in 4.3
  26    and is not considerate enough to avoid bombing out
  27    if they are already defined.  */
  28 #undef BSD
  29 #ifdef BSD4_3
  30 #undef BSD4_3
  31 #define XBSD4_3 /* XBSD4_3 says BSD4_3 is supposed to be defined.  */
  32 #endif
  33 #include <sys/param.h>
  34 /* Now if BSD or BSD4_3 was defined and is no longer,
  35    define it again.  */
  36 #ifndef BSD
  37 #define BSD
  38 #endif
  39 #ifdef XBSD4_3
  40 #ifndef BSD4_3
  41 #define BSD4_3
  42 #endif
  43 #endif /* XBSD4_3 */
  44 #endif /* BSD */
  45 #ifndef VMS
  46 #ifndef NLIST_STRUCT
  47 #include <a.out.h>
  48 #else /* NLIST_STRUCT */
  49 #include <nlist.h>
  50 #endif /* NLIST_STRUCT */
  51 #endif /* not VMS */
  52 #endif /* LOAD_AVE_TYPE */
  53
  54 #ifdef DGUX
  55 #include <sys/dg_sys_info.h>  /* for load average info - DJB */
  56 #endif
  57
  58 /* Note on some machines this defines `vector' as a typedef,
  59    so make sure we don't use that name in this file.  */
  60 #undef vector
  61 #define vector *****
  62
  63 #include "lisp.h"
  64 #include "commands.h"
  65
  66 #ifdef MULTI_SCREEN
  67 #include "screen.h"
  68 #endif
  69
  70 #include "buffer.h"
  71
  72 Lisp_Object Qstring_lessp;
  73
  74 static Lisp_Object internal_equal ();
  75 \f
  76 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
  77   "Return the argument unchanged.")
  78   (arg)
  79      Lisp_Object arg;
  80 {
  81   return arg;
  82 }
  83
  84 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
  85   "Return a pseudo-random number.\n\
  86 On most systems all integers representable in Lisp are equally likely.\n\
  87   This is 24 bits' worth.\n\
  88 With argument N, return random number in interval [0,N).\n\
  89 With argument t, set the random number seed from the current time and pid.")
  90   (arg)
  91      Lisp_Object arg;
  92 {
  93   int val;
  94   extern long random ();
  95   extern srandom ();
  96   extern long time ();
  97
  98   if (EQ (arg, Qt))
  99     srandom (getpid () + time (0));
 100   val = random ();
 101   if (XTYPE (arg) == Lisp_Int && XINT (arg) != 0)
 102     {
 103       /* Try to take our random number from the higher bits of VAL,
 104          not the lower, since (says Gentzel) the low bits of `random'
 105          are less random than the higher ones.  */
 106       val &= 0xfffffff;         /* Ensure positive.  */
 107       val >>= 5;
 108       if (XINT (arg) < 10000)
 109         val >>= 6;
 110       val %= XINT (arg);
 111     }
 112   return make_number (val);
 113 }
 114 \f
 115 /* Random data-structure functions */
 116
 117 DEFUN ("length", Flength, Slength, 1, 1, 0,
 118   "Return the length of vector, list or string SEQUENCE.\n\
 119 A byte-code function object is also allowed.")
 120   (obj)
 121      register Lisp_Object obj;
 122 {
 123   register Lisp_Object tail, val;
 124   register int i;
 125
 126  retry:
 127   if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String
 128       || XTYPE (obj) == Lisp_Compiled)
 129     return Farray_length (obj);
 130   else if (CONSP (obj))
 131     {
 132       for (i = 0, tail = obj; !NILP(tail); i++)
 133         {
 134           QUIT;
 135           tail = Fcdr (tail);
 136         }
 137
 138       XFASTINT (val) = i;
 139       return val;
 140     }
 141   else if (NILP(obj))
 142     {
 143       XFASTINT (val) = 0;
 144       return val;
 145     }
 146   else
 147     {
 148       obj = wrong_type_argument (Qsequencep, obj);
 149       goto retry;
 150     }
 151 }
 152
 153 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
 154   "T if two strings have identical contents.\n\
 155 Case is significant.\n\
 156 Symbols are also allowed; their print names are used instead.")
 157   (s1, s2)
 158      register Lisp_Object s1, s2;
 159 {
 160   if (XTYPE (s1) == Lisp_Symbol)
 161     XSETSTRING (s1, XSYMBOL (s1)->name), XSETTYPE (s1, Lisp_String);
 162   if (XTYPE (s2) == Lisp_Symbol)
 163     XSETSTRING (s2, XSYMBOL (s2)->name), XSETTYPE (s2, Lisp_String);
 164   CHECK_STRING (s1, 0);
 165   CHECK_STRING (s2, 1);
 166
 167   if (XSTRING (s1)->size != XSTRING (s2)->size ||
 168       bcmp (XSTRING (s1)->data, XSTRING (s2)->data, XSTRING (s1)->size))
 169     return Qnil;
 170   return Qt;
 171 }
 172
 173 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
 174   "T if first arg string is less than second in lexicographic order.\n\
 175 Case is significant.\n\
 176 Symbols are also allowed; their print names are used instead.")
 177   (s1, s2)
 178      register Lisp_Object s1, s2;
 179 {
 180   register int i;
 181   register unsigned char *p1, *p2;
 182   register int end;
 183
 184   if (XTYPE (s1) == Lisp_Symbol)
 185     XSETSTRING (s1, XSYMBOL (s1)->name), XSETTYPE (s1, Lisp_String);
 186   if (XTYPE (s2) == Lisp_Symbol)
 187     XSETSTRING (s2, XSYMBOL (s2)->name), XSETTYPE (s2, Lisp_String);
 188   CHECK_STRING (s1, 0);
 189   CHECK_STRING (s2, 1);
 190
 191   p1 = XSTRING (s1)->data;
 192   p2 = XSTRING (s2)->data;
 193   end = XSTRING (s1)->size;
 194   if (end > XSTRING (s2)->size)
 195     end = XSTRING (s2)->size;
 196
 197   for (i = 0; i < end; i++)
 198     {
 199       if (p1[i] != p2[i])
 200         return p1[i] < p2[i] ? Qt : Qnil;
 201     }
 202   return i < XSTRING (s2)->size ? Qt : Qnil;
 203 }
 204 \f
 205 static Lisp_Object concat ();
 206
 207 /* ARGSUSED */
 208 Lisp_Object
 209 concat2 (s1, s2)
 210      Lisp_Object s1, s2;
 211 {
 212 #ifdef NO_ARG_ARRAY
 213   Lisp_Object args[2];
 214   args[0] = s1;
 215   args[1] = s2;
 216   return concat (2, args, Lisp_String, 0);
 217 #else
 218   return concat (2, &s1, Lisp_String, 0);
 219 #endif /* NO_ARG_ARRAY */
 220 }
 221
 222 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
 223   "Concatenate all the arguments and make the result a list.\n\
 224 The result is a list whose elements are the elements of all the arguments.\n\
 225 Each argument may be a list, vector or string.\n\
 226 The last argument is not copied if it is a list.")
 227   (nargs, args)
 228      int nargs;
 229      Lisp_Object *args;
 230 {
 231   return concat (nargs, args, Lisp_Cons, 1);
 232 }
 233
 234 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
 235   "Concatenate all the arguments and make the result a string.\n\
 236 The result is a string whose elements are the elements of all the arguments.\n\
 237 Each argument may be a string, a list of numbers, or a vector of numbers.")
 238   (nargs, args)
 239      int nargs;
 240      Lisp_Object *args;
 241 {
 242   return concat (nargs, args, Lisp_String, 0);
 243 }
 244
 245 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
 246   "Concatenate all the arguments and make the result a vector.\n\
 247 The result is a vector whose elements are the elements of all the arguments.\n\
 248 Each argument may be a list, vector or string.")
 249   (nargs, args)
 250      int nargs;
 251      Lisp_Object *args;
 252 {
 253   return concat (nargs, args, Lisp_Vector, 0);
 254 }
 255
 256 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
 257   "Return a copy of a list, vector or string.\n\
 258 The elements of a list or vector are not copied; they are shared\n\
 259 with the original.")
 260   (arg)
 261      Lisp_Object arg;
 262 {
 263   if (NILP (arg)) return arg;
 264   if (!CONSP (arg) && XTYPE (arg) != Lisp_Vector && XTYPE (arg) != Lisp_String)
 265     arg = wrong_type_argument (Qsequencep, arg);
 266   return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
 267 }
 268
 269 static Lisp_Object
 270 concat (nargs, args, target_type, last_special)
 271      int nargs;
 272      Lisp_Object *args;
 273      enum Lisp_Type target_type;
 274      int last_special;
 275 {
 276   Lisp_Object val;
 277   Lisp_Object len;
 278   register Lisp_Object tail;
 279   register Lisp_Object this;
 280   int toindex;
 281   register int leni;
 282   register int argnum;
 283   Lisp_Object last_tail;
 284   Lisp_Object prev;
 285
 286   /* In append, the last arg isn't treated like the others */
 287   if (last_special && nargs > 0)
 288     {
 289       nargs--;
 290       last_tail = args[nargs];
 291     }
 292   else
 293     last_tail = Qnil;
 294
 295   for (argnum = 0; argnum < nargs; argnum++)
 296     {
 297       this = args[argnum];
 298       if (!(CONSP (this) || NILP (this)
 299             || XTYPE (this) == Lisp_Vector || XTYPE (this) == Lisp_String
 300             || XTYPE (this) == Lisp_Compiled))
 301         {
 302           if (XTYPE (this) == Lisp_Int)
 303             args[argnum] = Fint_to_string (this);
 304           else
 305             args[argnum] = wrong_type_argument (Qsequencep, this);
 306         }
 307     }
 308
 309   for (argnum = 0, leni = 0; argnum < nargs; argnum++)
 310     {
 311       this = args[argnum];
 312       len = Flength (this);
 313       leni += XFASTINT (len);
 314     }
 315
 316   XFASTINT (len) = leni;
 317
 318   if (target_type == Lisp_Cons)
 319     val = Fmake_list (len, Qnil);
 320   else if (target_type == Lisp_Vector)
 321     val = Fmake_vector (len, Qnil);
 322   else
 323     val = Fmake_string (len, len);
 324
 325   /* In append, if all but last arg are nil, return last arg */
 326   if (target_type == Lisp_Cons && EQ (val, Qnil))
 327     return last_tail;
 328
 329   if (CONSP (val))
 330     tail = val, toindex = -1;           /* -1 in toindex is flag we are making a list */
 331   else
 332     toindex = 0;
 333
 334   prev = Qnil;
 335
 336   for (argnum = 0; argnum < nargs; argnum++)
 337     {
 338       Lisp_Object thislen;
 339       int thisleni;
 340       register int thisindex = 0;
 341
 342       this = args[argnum];
 343       if (!CONSP (this))
 344         thislen = Flength (this), thisleni = XINT (thislen);
 345
 346       while (1)
 347         {
 348           register Lisp_Object elt;
 349
 350           /* Fetch next element of `this' arg into `elt', or break if `this' is exhausted. */
 351           if (NILP (this)) break;
 352           if (CONSP (this))
 353             elt = Fcar (this), this = Fcdr (this);
 354           else
 355             {
 356               if (thisindex >= thisleni) break;
 357               if (XTYPE (this) == Lisp_String)
 358                 XFASTINT (elt) = XSTRING (this)->data[thisindex++];
 359               else
 360                 elt = XVECTOR (this)->contents[thisindex++];
 361             }
 362
 363           /* Store into result */
 364           if (toindex < 0)
 365             {
 366               XCONS (tail)->car = elt;
 367               prev = tail;
 368               tail = XCONS (tail)->cdr;
 369             }
 370           else if (XTYPE (val) == Lisp_Vector)
 371             XVECTOR (val)->contents[toindex++] = elt;
 372           else
 373             {
 374               while (XTYPE (elt) != Lisp_Int)
 375                 elt = wrong_type_argument (Qintegerp, elt);
 376               {
 377 #ifdef MASSC_REGISTER_BUG
 378                 /* Even removing all "register"s doesn't disable this bug!
 379                    Nothing simpler than this seems to work. */
 380                 unsigned char *p = & XSTRING (val)->data[toindex++];
 381                 *p = XINT (elt);
 382 #else
 383                 XSTRING (val)->data[toindex++] = XINT (elt);
 384 #endif
 385               }
 386             }
 387         }
 388     }
 389   if (!NILP (prev))
 390     XCONS (prev)->cdr = last_tail;
 391
 392   return val;
 393 }
 394 \f
 395 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
 396   "Return a copy of ALIST.\n\
 397 This is an alist which represents the same mapping from objects to objects,\n\
 398 but does not share the alist structure with ALIST.\n\
 399 The objects mapped (cars and cdrs of elements of the alist)\n\
 400 are shared, however.\n\
 401 Elements of ALIST that are not conses are also shared.")
 402   (alist)
 403      Lisp_Object alist;
 404 {
 405   register Lisp_Object tem;
 406
 407   CHECK_LIST (alist, 0);
 408   if (NILP (alist))
 409     return alist;
 410   alist = concat (1, &alist, Lisp_Cons, 0);
 411   for (tem = alist; CONSP (tem); tem = XCONS (tem)->cdr)
 412     {
 413       register Lisp_Object car;
 414       car = XCONS (tem)->car;
 415
 416       if (CONSP (car))
 417         XCONS (tem)->car = Fcons (XCONS (car)->car, XCONS (car)->cdr);
 418     }
 419   return alist;
 420 }
 421
 422 DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
 423   "Return a substring of STRING, starting at index FROM and ending before TO.\n\
 424 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
 425 If FROM or TO is negative, it counts from the end.")
 426   (string, from, to)
 427      Lisp_Object string;
 428      register Lisp_Object from, to;
 429 {
 430   CHECK_STRING (string, 0);
 431   CHECK_NUMBER (from, 1);
 432   if (NILP (to))
 433     to = Flength (string);
 434   else
 435     CHECK_NUMBER (to, 2);
 436
 437   if (XINT (from) < 0)
 438     XSETINT (from, XINT (from) + XSTRING (string)->size);
 439   if (XINT (to) < 0)
 440     XSETINT (to, XINT (to) + XSTRING (string)->size);
 441   if (!(0 <= XINT (from) && XINT (from) <= XINT (to)
 442         && XINT (to) <= XSTRING (string)->size))
 443     args_out_of_range_3 (string, from, to);
 444
 445   return make_string (XSTRING (string)->data + XINT (from),
 446                       XINT (to) - XINT (from));
 447 }
 448 \f
 449 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
 450   "Take cdr N times on LIST, returns the result.")
 451   (n, list)
 452      Lisp_Object n;
 453      register Lisp_Object list;
 454 {
 455   register int i, num;
 456   CHECK_NUMBER (n, 0);
 457   num = XINT (n);
 458   for (i = 0; i < num && !NILP (list); i++)
 459     {
 460       QUIT;
 461       list = Fcdr (list);
 462     }
 463   return list;
 464 }
 465
 466 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
 467   "Return the Nth element of LIST.\n\
 468 N counts from zero.  If LIST is not that long, nil is returned.")
 469   (n, list)
 470      Lisp_Object n, list;
 471 {
 472   return Fcar (Fnthcdr (n, list));
 473 }
 474
 475 DEFUN ("elt", Felt, Selt, 2, 2, 0,
 476   "Return element of SEQUENCE at index N.")
 477   (seq, n)
 478      register Lisp_Object seq, n;
 479 {
 480   CHECK_NUMBER (n, 0);
 481   while (1)
 482     {
 483       if (XTYPE (seq) == Lisp_Cons || NILP (seq))
 484         return Fcar (Fnthcdr (n, seq));
 485       else if (XTYPE (seq) == Lisp_String
 486                || XTYPE (seq) == Lisp_Vector)
 487         return Faref (seq, n);
 488       else
 489         seq = wrong_type_argument (Qsequencep, seq);
 490     }
 491 }
 492
 493 DEFUN ("member", Fmember, Smember, 2, 2, 0,
 494   "Return non-nil if ELT is an element of LIST.  Comparison done with EQUAL.\n\
 495 The value is actually the tail of LIST whose car is ELT.")
 496   (elt, list)
 497      register Lisp_Object elt;
 498      Lisp_Object list;
 499 {
 500   register Lisp_Object tail;
 501   for (tail = list; !NILP (tail); tail = Fcdr (tail))
 502     {
 503       register Lisp_Object tem;
 504       tem = Fcar (tail);
 505       if (! NILP (Fequal (elt, tem)))
 506         return tail;
 507       QUIT;
 508     }
 509   return Qnil;
 510 }
 511
 512 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
 513   "Return non-nil if ELT is an element of LIST.  Comparison done with EQ.\n\
 514 The value is actually the tail of LIST whose car is ELT.")
 515   (elt, list)
 516      register Lisp_Object elt;
 517      Lisp_Object list;
 518 {
 519   register Lisp_Object tail;
 520   for (tail = list; !NILP (tail); tail = Fcdr (tail))
 521     {
 522       register Lisp_Object tem;
 523       tem = Fcar (tail);
 524       if (EQ (elt, tem)) return tail;
 525       QUIT;
 526     }
 527   return Qnil;
 528 }
 529
 530 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
 531   "Return non-nil if ELT is `eq' to the car of an element of LIST.\n\
 532 The value is actually the element of LIST whose car is ELT.\n\
 533 Elements of LIST that are not conses are ignored.")
 534   (key, list)
 535      register Lisp_Object key;
 536      Lisp_Object list;
 537 {
 538   register Lisp_Object tail;
 539   for (tail = list; !NILP (tail); tail = Fcdr (tail))
 540     {
 541       register Lisp_Object elt, tem;
 542       elt = Fcar (tail);
 543       if (!CONSP (elt)) continue;
 544       tem = Fcar (elt);
 545       if (EQ (key, tem)) return elt;
 546       QUIT;
 547     }
 548   return Qnil;
 549 }
 550
 551 /* Like Fassq but never report an error and do not allow quits.
 552    Use only on lists known never to be circular.  */
 553
 554 Lisp_Object
 555 assq_no_quit (key, list)
 556      register Lisp_Object key;
 557      Lisp_Object list;
 558 {
 559   register Lisp_Object tail;
 560   for (tail = list; CONSP (tail); tail = Fcdr (tail))
 561     {
 562       register Lisp_Object elt, tem;
 563       elt = Fcar (tail);
 564       if (!CONSP (elt)) continue;
 565       tem = Fcar (elt);
 566       if (EQ (key, tem)) return elt;
 567     }
 568   return Qnil;
 569 }
 570
 571 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
 572   "Return non-nil if ELT is `equal' to the car of an element of LIST.\n\
 573 The value is actually the element of LIST whose car is ELT.")
 574   (key, list)
 575      register Lisp_Object key;
 576      Lisp_Object list;
 577 {
 578   register Lisp_Object tail;
 579   for (tail = list; !NILP (tail); tail = Fcdr (tail))
 580     {
 581       register Lisp_Object elt, tem;
 582       elt = Fcar (tail);
 583       if (!CONSP (elt)) continue;
 584       tem = Fequal (Fcar (elt), key);
 585       if (!NILP (tem)) return elt;
 586       QUIT;
 587     }
 588   return Qnil;
 589 }
 590
 591 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
 592   "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
 593 The value is actually the element of LIST whose cdr is ELT.")
 594   (key, list)
 595      register Lisp_Object key;
 596      Lisp_Object list;
 597 {
 598   register Lisp_Object tail;
 599   for (tail = list; !NILP (tail); tail = Fcdr (tail))
 600     {
 601       register Lisp_Object elt, tem;
 602       elt = Fcar (tail);
 603       if (!CONSP (elt)) continue;
 604       tem = Fcdr (elt);
 605       if (EQ (key, tem)) return elt;
 606       QUIT;
 607     }
 608   return Qnil;
 609 }
 610 \f
 611 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
 612   "Delete by side effect any occurrences of ELT as a member of LIST.\n\
 613 The modified LIST is returned.  Comparison is done with `eq'.\n\
 614 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
 615 therefore, write `(setq foo (delq element foo))'\n\
 616 to be sure of changing the value of `foo'.")
 617   (elt, list)
 618      register Lisp_Object elt;
 619      Lisp_Object list;
 620 {
 621   register Lisp_Object tail, prev;
 622   register Lisp_Object tem;
 623
 624   tail = list;
 625   prev = Qnil;
 626   while (!NILP (tail))
 627     {
 628       tem = Fcar (tail);
 629       if (EQ (elt, tem))
 630         {
 631           if (NILP (prev))
 632             list = Fcdr (tail);
 633           else
 634             Fsetcdr (prev, Fcdr (tail));
 635         }
 636       else
 637         prev = tail;
 638       tail = Fcdr (tail);
 639       QUIT;
 640     }
 641   return list;
 642 }
 643
 644 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
 645   "Delete by side effect any occurrences of ELT as a member of LIST.\n\
 646 The modified LIST is returned.  Comparison is done with `equal'.\n\
 647 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
 648 therefore, write `(setq foo (delete element foo))'\n\
 649 to be sure of changing the value of `foo'.")
 650   (elt, list)
 651      register Lisp_Object elt;
 652      Lisp_Object list;
 653 {
 654   register Lisp_Object tail, prev;
 655   register Lisp_Object tem;
 656
 657   tail = list;
 658   prev = Qnil;
 659   while (!NILP (tail))
 660     {
 661       tem = Fcar (tail);
 662       if (Fequal (elt, tem))
 663         {
 664           if (NILP (prev))
 665             list = Fcdr (tail);
 666           else
 667             Fsetcdr (prev, Fcdr (tail));
 668         }
 669       else
 670         prev = tail;
 671       tail = Fcdr (tail);
 672       QUIT;
 673     }
 674   return list;
 675 }
 676
 677 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
 678   "Reverse LIST by modifying cdr pointers.\n\
 679 Returns the beginning of the reversed list.")
 680   (list)
 681      Lisp_Object list;
 682 {
 683   register Lisp_Object prev, tail, next;
 684
 685   if (NILP (list)) return list;
 686   prev = Qnil;
 687   tail = list;
 688   while (!NILP (tail))
 689     {
 690       QUIT;
 691       next = Fcdr (tail);
 692       Fsetcdr (tail, prev);
 693       prev = tail;
 694       tail = next;
 695     }
 696   return prev;
 697 }
 698
 699 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
 700   "Reverse LIST, copying.  Returns the beginning of the reversed list.\n\
 701 See also the function `nreverse', which is used more often.")
 702   (list)
 703      Lisp_Object list;
 704 {
 705   Lisp_Object length;
 706   register Lisp_Object *vec;
 707   register Lisp_Object tail;
 708   register int i;
 709
 710   length = Flength (list);
 711   vec = (Lisp_Object *) alloca (XINT (length) * sizeof (Lisp_Object));
 712   for (i = XINT (length) - 1, tail = list; i >= 0; i--, tail = Fcdr (tail))
 713     vec[i] = Fcar (tail);
 714
 715   return Flist (XINT (length), vec);
 716 }
 717 \f
 718 Lisp_Object merge ();
 719
 720 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
 721   "Sort LIST, stably, comparing elements using PREDICATE.\n\
 722 Returns the sorted list.  LIST is modified by side effects.\n\
 723 PREDICATE is called with two elements of LIST, and should return T\n\
 724 if the first element is \"less\" than the second.")
 725   (list, pred)
 726      Lisp_Object list, pred;
 727 {
 728   Lisp_Object front, back;
 729   register Lisp_Object len, tem;
 730   struct gcpro gcpro1, gcpro2;
 731   register int length;
 732
 733   front = list;
 734   len = Flength (list);
 735   length = XINT (len);
 736   if (length < 2)
 737     return list;
 738
 739   XSETINT (len, (length / 2) - 1);
 740   tem = Fnthcdr (len, list);
 741   back = Fcdr (tem);
 742   Fsetcdr (tem, Qnil);
 743
 744   GCPRO2 (front, back);
 745   front = Fsort (front, pred);
 746   back = Fsort (back, pred);
 747   UNGCPRO;
 748   return merge (front, back, pred);
 749 }
 750
 751 Lisp_Object
 752 merge (org_l1, org_l2, pred)
 753      Lisp_Object org_l1, org_l2;
 754      Lisp_Object pred;
 755 {
 756   Lisp_Object value;
 757   register Lisp_Object tail;
 758   Lisp_Object tem;
 759   register Lisp_Object l1, l2;
 760   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 761
 762   l1 = org_l1;
 763   l2 = org_l2;
 764   tail = Qnil;
 765   value = Qnil;
 766
 767   /* It is sufficient to protect org_l1 and org_l2.
 768      When l1 and l2 are updated, we copy the new values
 769      back into the org_ vars.  */
 770   GCPRO4 (org_l1, org_l2, pred, value);
 771
 772   while (1)
 773     {
 774       if (NILP (l1))
 775         {
 776           UNGCPRO;
 777           if (NILP (tail))
 778             return l2;
 779           Fsetcdr (tail, l2);
 780           return value;
 781         }
 782       if (NILP (l2))
 783         {
 784           UNGCPRO;
 785           if (NILP (tail))
 786             return l1;
 787           Fsetcdr (tail, l1);
 788           return value;
 789         }
 790       tem = call2 (pred, Fcar (l2), Fcar (l1));
 791       if (NILP (tem))
 792         {
 793           tem = l1;
 794           l1 = Fcdr (l1);
 795           org_l1 = l1;
 796         }
 797       else
 798         {
 799           tem = l2;
 800           l2 = Fcdr (l2);
 801           org_l2 = l2;
 802         }
 803       if (NILP (tail))
 804         value = tem;
 805       else
 806         Fsetcdr (tail, tem);
 807       tail = tem;
 808     }
 809 }
 810 \f
 811 DEFUN ("get", Fget, Sget, 2, 2, 0,
 812   "Return the value of SYMBOL's PROPNAME property.\n\
 813 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
 814   (sym, prop)
 815      Lisp_Object sym;
 816      register Lisp_Object prop;
 817 {
 818   register Lisp_Object tail;
 819   for (tail = Fsymbol_plist (sym); !NILP (tail); tail = Fcdr (Fcdr (tail)))
 820     {
 821       register Lisp_Object tem;
 822       tem = Fcar (tail);
 823       if (EQ (prop, tem))
 824         return Fcar (Fcdr (tail));
 825     }
 826   return Qnil;
 827 }
 828
 829 DEFUN ("put", Fput, Sput, 3, 3, 0,
 830   "Store SYMBOL's PROPNAME property with value VALUE.\n\
 831 It can be retrieved with `(get SYMBOL PROPNAME)'.")
 832   (sym, prop, val)
 833      Lisp_Object sym;
 834      register Lisp_Object prop;
 835      Lisp_Object val;
 836 {
 837   register Lisp_Object tail, prev;
 838   Lisp_Object newcell;
 839   prev = Qnil;
 840   for (tail = Fsymbol_plist (sym); !NILP (tail); tail = Fcdr (Fcdr (tail)))
 841     {
 842       register Lisp_Object tem;
 843       tem = Fcar (tail);
 844       if (EQ (prop, tem))
 845         return Fsetcar (Fcdr (tail), val);
 846       prev = tail;
 847     }
 848   newcell = Fcons (prop, Fcons (val, Qnil));
 849   if (NILP (prev))
 850     Fsetplist (sym, newcell);
 851   else
 852     Fsetcdr (Fcdr (prev), newcell);
 853   return val;
 854 }
 855
 856 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
 857   "T if two Lisp objects have similar structure and contents.\n\
 858 They must have the same data type.\n\
 859 Conses are compared by comparing the cars and the cdrs.\n\
 860 Vectors and strings are compared element by element.\n\
 861 Numbers are compared by value.  Symbols must match exactly.")
 862   (o1, o2)
 863      register Lisp_Object o1, o2;
 864 {
 865   return internal_equal (o1, o2, 0);
 866 }
 867
 868 static Lisp_Object
 869 internal_equal (o1, o2, depth)
 870      register Lisp_Object o1, o2;
 871      int depth;
 872 {
 873   if (depth > 200)
 874     error ("Stack overflow in equal");
 875 do_cdr:
 876   QUIT;
 877   if (XTYPE (o1) != XTYPE (o2)) return Qnil;
 878   if (XINT (o1) == XINT (o2)) return Qt;
 879   if (XTYPE (o1) == Lisp_Cons)
 880     {
 881       Lisp_Object v1;
 882       v1 = Fequal (Fcar (o1), Fcar (o2), depth + 1);
 883       if (NILP (v1))
 884         return v1;
 885       o1 = Fcdr (o1), o2 = Fcdr (o2);
 886       goto do_cdr;
 887     }
 888   if (XTYPE (o1) == Lisp_Marker)
 889     {
 890       return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
 891               && XMARKER (o1)->bufpos == XMARKER (o2)->bufpos)
 892         ? Qt : Qnil;
 893     }
 894   if (XTYPE (o1) == Lisp_Vector)
 895     {
 896       register int index;
 897       if (XVECTOR (o1)->size != XVECTOR (o2)->size)
 898         return Qnil;
 899       for (index = 0; index < XVECTOR (o1)->size; index++)
 900         {
 901           Lisp_Object v, v1, v2;
 902           v1 = XVECTOR (o1)->contents [index];
 903           v2 = XVECTOR (o2)->contents [index];
 904           v = Fequal (v1, v2, depth + 1);
 905           if (NILP (v)) return v;
 906         }
 907       return Qt;
 908     }
 909   if (XTYPE (o1) == Lisp_String)
 910     {
 911       if (XSTRING (o1)->size != XSTRING (o2)->size)
 912         return Qnil;
 913       if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data, XSTRING (o1)->size))
 914         return Qnil;
 915       return Qt;
 916     }
 917   return Qnil;
 918 }
 919 \f
 920 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
 921   "Store each element of ARRAY with ITEM.  ARRAY is a vector or string.")
 922   (array, item)
 923      Lisp_Object array, item;
 924 {
 925   register int size, index, charval;
 926  retry:
 927   if (XTYPE (array) == Lisp_Vector)
 928     {
 929       register Lisp_Object *p = XVECTOR (array)->contents;
 930       size = XVECTOR (array)->size;
 931       for (index = 0; index < size; index++)
 932         p[index] = item;
 933     }
 934   else if (XTYPE (array) == Lisp_String)
 935     {
 936       register unsigned char *p = XSTRING (array)->data;
 937       CHECK_NUMBER (item, 1);
 938       charval = XINT (item);
 939       size = XSTRING (array)->size;
 940       for (index = 0; index < size; index++)
 941         p[index] = charval;
 942     }
 943   else
 944     {
 945       array = wrong_type_argument (Qarrayp, array);
 946       goto retry;
 947     }
 948   return array;
 949 }
 950
 951 /* ARGSUSED */
 952 Lisp_Object
 953 nconc2 (s1, s2)
 954      Lisp_Object s1, s2;
 955 {
 956 #ifdef NO_ARG_ARRAY
 957   Lisp_Object args[2];
 958   args[0] = s1;
 959   args[1] = s2;
 960   return Fnconc (2, args);
 961 #else
 962   return Fnconc (2, &s1);
 963 #endif /* NO_ARG_ARRAY */
 964 }
 965
 966 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
 967   "Concatenate any number of lists by altering them.\n\
 968 Only the last argument is not altered, and need not be a list.")
 969   (nargs, args)
 970      int nargs;
 971      Lisp_Object *args;
 972 {
 973   register int argnum;
 974   register Lisp_Object tail, tem, val;
 975
 976   val = Qnil;
 977
 978   for (argnum = 0; argnum < nargs; argnum++)
 979     {
 980       tem = args[argnum];
 981       if (NILP (tem)) continue;
 982
 983       if (NILP (val))
 984         val = tem;
 985
 986       if (argnum + 1 == nargs) break;
 987
 988       if (!CONSP (tem))
 989         tem = wrong_type_argument (Qlistp, tem);
 990
 991       while (CONSP (tem))
 992         {
 993           tail = tem;
 994           tem = Fcdr (tail);
 995           QUIT;
 996         }
 997
 998       tem = args[argnum + 1];
 999       Fsetcdr (tail, tem);
1000       if (NILP (tem))
1001         args[argnum + 1] = tail;
1002     }
1003
1004   return val;
1005 }
1006 \f
1007 /* This is the guts of all mapping functions.
1008  Apply fn to each element of seq, one by one,
1009  storing the results into elements of vals, a C vector of Lisp_Objects.
1010  leni is the length of vals, which should also be the length of seq. */
1011
1012 static void
1013 mapcar1 (leni, vals, fn, seq)
1014      int leni;
1015      Lisp_Object *vals;
1016      Lisp_Object fn, seq;
1017 {
1018   register Lisp_Object tail;
1019   Lisp_Object dummy;
1020   register int i;
1021   struct gcpro gcpro1, gcpro2, gcpro3;
1022
1023   /* Don't let vals contain any garbage when GC happens.  */
1024   for (i = 0; i < leni; i++)
1025     vals[i] = Qnil;
1026
1027   GCPRO3 (dummy, fn, seq);
1028   gcpro1.var = vals;
1029   gcpro1.nvars = leni;
1030   /* We need not explicitly protect `tail' because it is used only on lists, and
1031     1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1032
1033   if (XTYPE (seq) == Lisp_Vector)
1034     {
1035       for (i = 0; i < leni; i++)
1036         {
1037           dummy = XVECTOR (seq)->contents[i];
1038           vals[i] = call1 (fn, dummy);
1039         }
1040     }
1041   else if (XTYPE (seq) == Lisp_String)
1042     {
1043       for (i = 0; i < leni; i++)
1044         {
1045           XFASTINT (dummy) = XSTRING (seq)->data[i];
1046           vals[i] = call1 (fn, dummy);
1047         }
1048     }
1049   else   /* Must be a list, since Flength did not get an error */
1050     {
1051       tail = seq;
1052       for (i = 0; i < leni; i++)
1053         {
1054           vals[i] = call1 (fn, Fcar (tail));
1055           tail = Fcdr (tail);
1056         }
1057     }
1058
1059   UNGCPRO;
1060 }
1061
1062 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
1063   "Apply FN to each element of SEQ, and concat the results as strings.\n\
1064 In between each pair of results, stick in SEP.\n\
1065 Thus, \" \" as SEP results in spaces between the values return by FN.")
1066   (fn, seq, sep)
1067      Lisp_Object fn, seq, sep;
1068 {
1069   Lisp_Object len;
1070   register int leni;
1071   int nargs;
1072   register Lisp_Object *args;
1073   register int i;
1074   struct gcpro gcpro1;
1075
1076   len = Flength (seq);
1077   leni = XINT (len);
1078   nargs = leni + leni - 1;
1079   if (nargs < 0) return build_string ("");
1080
1081   args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
1082
1083   GCPRO1 (sep);
1084   mapcar1 (leni, args, fn, seq);
1085   UNGCPRO;
1086
1087   for (i = leni - 1; i >= 0; i--)
1088     args[i + i] = args[i];
1089
1090   for (i = 1; i < nargs; i += 2)
1091     args[i] = sep;
1092
1093   return Fconcat (nargs, args);
1094 }
1095
1096 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
1097   "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1098 The result is a list just as long as SEQUENCE.\n\
1099 SEQUENCE may be a list, a vector or a string.")
1100   (fn, seq)
1101      Lisp_Object fn, seq;
1102 {
1103   register Lisp_Object len;
1104   register int leni;
1105   register Lisp_Object *args;
1106
1107   len = Flength (seq);
1108   leni = XFASTINT (len);
1109   args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
1110
1111   mapcar1 (leni, args, fn, seq);
1112
1113   return Flist (leni, args);
1114 }
1115 \f
1116 /* Anything that calls this function must protect from GC!  */
1117
1118 DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
1119   "Ask user a \"y or n\" question.  Return t if answer is \"y\".\n\
1120 No confirmation of the answer is requested; a single character is enough.\n\
1121 Also accepts Space to mean yes, or Delete to mean no.")
1122   (prompt)
1123      Lisp_Object prompt;
1124 {
1125   register Lisp_Object obj;
1126   register int ans;
1127   Lisp_Object xprompt;
1128   Lisp_Object args[2];
1129   int ocech = cursor_in_echo_area;
1130   struct gcpro gcpro1, gcpro2;
1131
1132   CHECK_STRING (prompt, 0);
1133   xprompt = prompt;
1134   GCPRO2 (prompt, xprompt);
1135
1136   while (1)
1137     {
1138       message ("%s(y or n) ", XSTRING (xprompt)->data);
1139       cursor_in_echo_area = 1;
1140
1141       obj = read_char (0);
1142       if (XTYPE (obj) == Lisp_Int)
1143         ans = XINT (obj);
1144       else
1145         continue;
1146
1147       cursor_in_echo_area = -1;
1148       message ("%s(y or n) %c", XSTRING (xprompt)->data, ans);
1149       cursor_in_echo_area = ocech;
1150       /* Accept a C-g or C-] (abort-recursive-edit) as quit requests.  */
1151       if (ans == 7 || ans == '\035')
1152         Vquit_flag = Qt;
1153       QUIT;
1154       if (ans >= 0)
1155         ans = DOWNCASE (ans);
1156       if (ans == 'y' || ans == ' ')
1157         { ans = 'y'; break; }
1158       if (ans == 'n' || ans == 127)
1159         break;
1160
1161       Fding (Qnil);
1162       Fdiscard_input ();
1163       if (EQ (xprompt, prompt))
1164         {
1165           args[0] = build_string ("Please answer y or n.  ");
1166           args[1] = prompt;
1167           xprompt = Fconcat (2, args);
1168         }
1169     }
1170   UNGCPRO;
1171   return (ans == 'y' ? Qt : Qnil);
1172 }
1173 \f
1174 /* This is how C code calls `yes-or-no-p' and allows the user
1175    to redefined it.
1176
1177    Anything that calls this function must protect from GC!  */
1178
1179 Lisp_Object
1180 do_yes_or_no_p (prompt)
1181      Lisp_Object prompt;
1182 {
1183   return call1 (intern ("yes-or-no-p"), prompt);
1184 }
1185
1186 /* Anything that calls this function must protect from GC!  */
1187
1188 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
1189   "Ask user a yes or no question.  Return t if answer is yes.\n\
1190 The user must confirm the answer with a newline,\n\
1191 and can rub it out if not confirmed.")
1192   (prompt)
1193      Lisp_Object prompt;
1194 {
1195   register Lisp_Object ans;
1196   Lisp_Object args[2];
1197   struct gcpro gcpro1;
1198
1199   CHECK_STRING (prompt, 0);
1200
1201   args[0] = prompt;
1202   args[1] = build_string ("(yes or no) ");
1203   prompt = Fconcat (2, args);
1204
1205   GCPRO1 (prompt);
1206   while (1)
1207     {
1208       ans = Fdowncase (read_minibuf (Vminibuffer_local_map,
1209                                      Qnil, prompt, Qnil, 0));
1210       if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
1211         {
1212           UNGCPRO;
1213           return Qt;
1214         }
1215       if (XSTRING (ans)->size == 2 && !strcmp (XSTRING (ans)->data, "no"))
1216         {
1217           UNGCPRO;
1218           return Qnil;
1219         }
1220
1221       Fding (Qnil);
1222       Fdiscard_input ();
1223       message ("Please answer yes or no.");
1224       Fsleep_for (make_number (2));
1225     }
1226   UNGCPRO;
1227 }
1228 \f
1229 /* Avoid static vars inside a function since in HPUX they dump as pure.  */
1230 #ifdef DGUX
1231 static struct dg_sys_info_load_info load_info;  /* what-a-mouthful! */
1232
1233 #else /* Not DGUX */
1234
1235 static int ldav_initialized;
1236 static int ldav_channel;
1237 #ifdef LOAD_AVE_TYPE
1238 #ifndef VMS
1239 static struct nlist ldav_nl[2];
1240 #endif /* VMS */
1241 #endif /* LOAD_AVE_TYPE */
1242
1243 #define channel ldav_channel
1244 #define initialized ldav_initialized
1245 #define nl ldav_nl
1246 #endif /* Not DGUX */
1247
1248 DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
1249   "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1250 Each of the three load averages is multiplied by 100,\n\
1251 then converted to integer.")
1252   ()
1253 {
1254 #ifdef DGUX
1255   /* perhaps there should be a "sys_load_avg" call in sysdep.c?! - DJB */
1256   load_info.one_minute     = 0.0;       /* just in case there is an error */
1257   load_info.five_minute    = 0.0;
1258   load_info.fifteen_minute = 0.0;
1259   dg_sys_info (&load_info, DG_SYS_INFO_LOAD_INFO_TYPE,
1260                DG_SYS_INFO_LOAD_VERSION_0);
1261
1262   return Fcons (make_number ((int)(load_info.one_minute * 100.0)),
1263                 Fcons (make_number ((int)(load_info.five_minute * 100.0)),
1264                        Fcons (make_number ((int)(load_info.fifteen_minute * 100.0)),
1265                               Qnil)));
1266 #else /* not DGUX */
1267 #ifndef LOAD_AVE_TYPE
1268   error ("load-average not implemented for this operating system");
1269
1270 #else /* LOAD_AVE_TYPE defined */
1271
1272   LOAD_AVE_TYPE load_ave[3];
1273 #ifdef VMS
1274 #ifndef eunice
1275 #include <iodef.h>
1276 #include <descrip.h>
1277 #else
1278 #include <vms/iodef.h>
1279   struct {int dsc$w_length; char *dsc$a_pointer;} descriptor;
1280 #endif /* eunice */
1281 #endif /* VMS */
1282
1283   /* If this fails for any reason, we can return (0 0 0) */
1284   load_ave[0] = 0.0; load_ave[1] = 0.0; load_ave[2] = 0.0;
1285
1286 #ifdef VMS
1287   /*
1288    *    VMS specific code -- read from the Load Ave driver
1289    */
1290
1291   /*
1292    *    Ensure that there is a channel open to the load ave device
1293    */
1294   if (initialized == 0)
1295     {
1296       /* Attempt to open the channel */
1297 #ifdef eunice
1298       descriptor.size = 18;
1299       descriptor.ptr  = "$$VMS_LOAD_AVERAGE";
1300 #else
1301       $DESCRIPTOR(descriptor, "LAV0:");
1302 #endif
1303       if (sys$assign (&descriptor, &channel, 0, 0) & 1)
1304         initialized = 1;
1305     }
1306   /*
1307    *    Read the load average vector
1308    */
1309   if (initialized)
1310     {
1311       if (!(sys$qiow (0, channel, IO$_READVBLK, 0, 0, 0,
1312                      load_ave, 12, 0, 0, 0, 0)
1313             & 1))
1314         {
1315           sys$dassgn (channel);
1316           initialized = 0;
1317         }
1318     }
1319 #else  /* not VMS */
1320   /*
1321    *    4.2BSD UNIX-specific code -- read _avenrun from /dev/kmem
1322    */
1323
1324   /*
1325    *    Make sure we have the address of _avenrun
1326    */
1327   if (nl[0].n_value == 0)
1328     {
1329       /*
1330        *        Get the address of _avenrun
1331        */
1332 #ifndef NLIST_STRUCT
1333       strcpy (nl[0].n_name, LDAV_SYMBOL);
1334       nl[1].n_zeroes = 0;
1335 #else /* NLIST_STRUCT */
1336 #ifdef convex
1337       nl[0].n_un.n_name = LDAV_SYMBOL;
1338       nl[1].n_un.n_name = 0;
1339 #else /* not convex */
1340       nl[0].n_name = LDAV_SYMBOL;
1341       nl[1].n_name = 0;
1342 #endif /* not convex */
1343 #endif /* NLIST_STRUCT */
1344
1345       nlist (KERNEL_FILE, nl);
1346
1347 #ifdef FIXUP_KERNEL_SYMBOL_ADDR
1348       FIXUP_KERNEL_SYMBOL_ADDR (nl);
1349 #endif /* FIXUP_KERNEL_SYMBOL_ADDR */
1350     }
1351   /*
1352    *    Make sure we have /dev/kmem open
1353    */
1354   if (initialized == 0)
1355     {
1356       /*
1357        *        Open /dev/kmem
1358        */
1359       channel = open ("/dev/kmem", 0);
1360       if (channel >= 0) initialized = 1;
1361     }
1362   /*
1363    *    If we can, get the load ave values
1364    */
1365   if ((nl[0].n_value != 0) && (initialized != 0))
1366     {
1367       /*
1368        *        Seek to the correct address
1369        */
1370       lseek (channel, (long) nl[0].n_value, 0);
1371       if (read (channel, load_ave, sizeof load_ave)
1372           != sizeof(load_ave))
1373         {
1374           close (channel);
1375           initialized = 0;
1376         }
1377     }
1378 #endif /* not VMS */
1379
1380   /*
1381    *    Return the list of load average values
1382    */
1383   return Fcons (make_number (LOAD_AVE_CVT (load_ave[0])),
1384                 Fcons (make_number (LOAD_AVE_CVT (load_ave[1])),
1385                        Fcons (make_number (LOAD_AVE_CVT (load_ave[2])),
1386                               Qnil)));
1387 #endif /* LOAD_AVE_TYPE */
1388 #endif /* not DGUX */
1389 }
1390
1391 #undef channel
1392 #undef initialized
1393 #undef nl
1394 \f
1395 Lisp_Object Vfeatures;
1396
1397 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
1398   "Returns t if FEATURE is present in this Emacs.\n\
1399 Use this to conditionalize execution of lisp code based on the presence or\n\
1400 absence of emacs or environment extensions.\n\
1401 Use `provide' to declare that a feature is available.\n\
1402 This function looks at the value of the variable `features'.")
1403      (feature)
1404      Lisp_Object feature;
1405 {
1406   register Lisp_Object tem;
1407   CHECK_SYMBOL (feature, 0);
1408   tem = Fmemq (feature, Vfeatures);
1409   return (NILP (tem)) ? Qnil : Qt;
1410 }
1411
1412 DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
1413   "Announce that FEATURE is a feature of the current Emacs.")
1414      (feature)
1415      Lisp_Object feature;
1416 {
1417   register Lisp_Object tem;
1418   CHECK_SYMBOL (feature, 0);
1419   if (!NILP (Vautoload_queue))
1420     Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
1421   tem = Fmemq (feature, Vfeatures);
1422   if (NILP (tem))
1423     Vfeatures = Fcons (feature, Vfeatures);
1424   return feature;
1425 }
1426
1427 DEFUN ("require", Frequire, Srequire, 1, 2, 0,
1428   "If feature FEATURE is not loaded, load it from FILENAME.\n\
1429 If FEATURE is not a member of the list `features', then the feature\n\
1430 is not loaded; so load the file FILENAME.\n\
1431 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1432      (feature, file_name)
1433      Lisp_Object feature, file_name;
1434 {
1435   register Lisp_Object tem;
1436   CHECK_SYMBOL (feature, 0);
1437   tem = Fmemq (feature, Vfeatures);
1438   if (NILP (tem))
1439     {
1440       int count = specpdl_ptr - specpdl;
1441
1442       /* Value saved here is to be restored into Vautoload_queue */
1443       record_unwind_protect (un_autoload, Vautoload_queue);
1444       Vautoload_queue = Qt;
1445
1446       Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
1447              Qnil, Qt, Qnil);
1448
1449       tem = Fmemq (feature, Vfeatures);
1450       if (NILP (tem))
1451         error ("Required feature %s was not provided",
1452                XSYMBOL (feature)->name->data );
1453
1454       /* Once loading finishes, don't undo it.  */
1455       Vautoload_queue = Qt;
1456       feature = unbind_to (count, feature);
1457     }
1458   return feature;
1459 }
1460 \f
1461 syms_of_fns ()
1462 {
1463   Qstring_lessp = intern ("string-lessp");
1464   staticpro (&Qstring_lessp);
1465
1466   DEFVAR_LISP ("features", &Vfeatures,
1467     "A list of symbols which are the features of the executing emacs.\n\
1468 Used by `featurep' and `require', and altered by `provide'.");
1469   Vfeatures = Qnil;
1470
1471   defsubr (&Sidentity);
1472   defsubr (&Srandom);
1473   defsubr (&Slength);
1474   defsubr (&Sstring_equal);
1475   defsubr (&Sstring_lessp);
1476   defsubr (&Sappend);
1477   defsubr (&Sconcat);
1478   defsubr (&Svconcat);
1479   defsubr (&Scopy_sequence);
1480   defsubr (&Scopy_alist);
1481   defsubr (&Ssubstring);
1482   defsubr (&Snthcdr);
1483   defsubr (&Snth);
1484   defsubr (&Selt);
1485   defsubr (&Smember);
1486   defsubr (&Smemq);
1487   defsubr (&Sassq);
1488   defsubr (&Sassoc);
1489   defsubr (&Srassq);
1490   defsubr (&Sdelq);
1491   defsubr (&Sdelete);
1492   defsubr (&Snreverse);
1493   defsubr (&Sreverse);
1494   defsubr (&Ssort);
1495   defsubr (&Sget);
1496   defsubr (&Sput);
1497   defsubr (&Sequal);
1498   defsubr (&Sfillarray);
1499   defsubr (&Snconc);
1500   defsubr (&Smapcar);
1501   defsubr (&Smapconcat);
1502   defsubr (&Sy_or_n_p);
1503   defsubr (&Syes_or_no_p);
1504   defsubr (&Sload_average);
1505   defsubr (&Sfeaturep);
1506   defsubr (&Srequire);
1507   defsubr (&Sprovide);
1508 }