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