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