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