cgit.sxemacs.org Git - sxemacs/blob - src/fns.c

   1 /* Random utility Lisp functions.
   2    Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
   3    Copyright (C) 1995, 1996 Ben Wing.
   4
   5 This file is part of SXEmacs
   6
   7 SXEmacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 SXEmacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  19
  20
  21 /* Synched up with: Mule 2.0, FSF 19.30. */
  22
  23 /* This file has been Mule-ized. */
  24
  25 /* Note: FSF 19.30 has bool vectors.  We have bit vectors. */
  26
  27 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
  28
  29 #include <config.h>
  30
  31 /* Note on some machines this defines `vector' as a typedef,
  32    so make sure we don't use that name in this file.  */
  33 #undef vector
  34 #define vector *****
  35
  36 #include "lisp.h"
  37
  38 #include "sysfile.h"
  39
  40 #include "buffer.h"
  41 #include "bytecode.h"
  42 #include "ui/device.h"
  43 #include "events/events.h"
  44 #include "extents.h"
  45 #include "ui/frame.h"
  46 #include "systime.h"
  47 #include "ui/insdel.h"
  48 #include "lstream.h"
  49 /* for the categorial views */
  50 #include "category.h"
  51 #include "seq.h"
  52 /* for all the map* funs */
  53 #include "map.h"
  54
  55 \f
  56 /* NOTE: This symbol is also used in lread.c */
  57 #define FEATUREP_SYNTAX
  58
  59 Lisp_Object Qstring_lessp, Qstring_greaterp;
  60 Lisp_Object Qidentity;
  61
  62 static int internal_old_equal(Lisp_Object, Lisp_Object, int);
  63 Lisp_Object safe_copy_tree(Lisp_Object arg, Lisp_Object vecp, int depth);
  64 int internal_equalp(Lisp_Object, Lisp_Object, int);
  65
  66 static Lisp_Object mark_bit_vector(Lisp_Object obj)
  67 {
  68         return Qnil;
  69 }
  70
  71 static void
  72 print_bit_vector(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  73 {
  74         size_t i;
  75         Lisp_Bit_Vector *v = XBIT_VECTOR(obj);
  76         size_t len = bit_vector_length(v);
  77         size_t last = len;
  78
  79         if (INTP(Vprint_length))
  80                 last = min((EMACS_INT) len, XINT(Vprint_length));
  81         write_c_string("#*", printcharfun);
  82         for (i = 0; i < last; i++) {
  83                 if (bit_vector_bit(v, i))
  84                         write_c_string("1", printcharfun);
  85                 else
  86                         write_c_string("0", printcharfun);
  87         }
  88
  89         if (last != len)
  90                 write_c_string("...", printcharfun);
  91 }
  92
  93 static int bit_vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
  94 {
  95         Lisp_Bit_Vector *v1 = XBIT_VECTOR(obj1);
  96         Lisp_Bit_Vector *v2 = XBIT_VECTOR(obj2);
  97
  98         return ((bit_vector_length(v1) == bit_vector_length(v2)) &&
  99                 !memcmp(v1->bits, v2->bits,
 100                         BIT_VECTOR_LONG_STORAGE(bit_vector_length(v1)) *
 101                         sizeof(long)));
 102 }
 103
 104 static unsigned long bit_vector_hash(Lisp_Object obj, int depth)
 105 {
 106         Lisp_Bit_Vector *v = XBIT_VECTOR(obj);
 107         return HASH2(bit_vector_length(v),
 108                      memory_hash(v->bits,
 109                                  BIT_VECTOR_LONG_STORAGE(bit_vector_length(v)) *
 110                                  sizeof(long)));
 111 }
 112
 113 static size_t size_bit_vector(const void *lheader)
 114 {
 115         const Lisp_Bit_Vector *v = (const Lisp_Bit_Vector *) lheader;
 116         return FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
 117                                             bits,
 118                                             BIT_VECTOR_LONG_STORAGE
 119                                             (bit_vector_length(v)));
 120 }
 121
 122 static const struct lrecord_description bit_vector_description[] = {
 123         {XD_LISP_OBJECT, offsetof(Lisp_Bit_Vector, next)},
 124         {XD_END}
 125 };
 126
 127 DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION("bit-vector", bit_vector,
 128                                              mark_bit_vector, print_bit_vector,
 129                                              0, bit_vector_equal,
 130                                              bit_vector_hash,
 131                                              bit_vector_description,
 132                                              size_bit_vector, Lisp_Bit_Vector);
 133 \f
 134 DEFUN("identity", Fidentity, 1, 1, 0,   /*
 135 Return the argument unchanged.
 136 */
 137       (arg))
 138 {
 139         return arg;
 140 }
 141
 142 extern long get_random(void);
 143 extern void seed_random(long arg);
 144
 145 DEFUN("random", Frandom, 0, 1, 0,       /*
 146 Return a pseudo-random number.
 147 All integers representable in Lisp are equally likely.
 148 On most systems, this is 31 bits' worth.
 149
 150 With positive integer argument LIMIT, return random number
 151 in interval [0,LIMIT). LIMIT can be a big integer, in which
 152 case the range of possible values is extended.
 153
 154 With argument t, set the random number seed from the
 155 current time and pid.
 156 */
 157       (limit))
 158 {
 159         EMACS_INT val;
 160         unsigned long denominator;
 161
 162         if (EQ(limit, Qt))
 163                 seed_random(getpid() + time(NULL));
 164         if (NATNUMP(limit) && !ZEROP(limit)) {
 165                 /* Try to take our random number from the higher bits of VAL,
 166                    not the lower, since (says Gentzel) the low bits of `random'
 167                    are less random than the higher ones.  We do this by using the
 168                    quotient rather than the remainder.  At the high end of the RNG
 169                    it's possible to get a quotient larger than limit; discarding
 170                    these values eliminates the bias that would otherwise appear
 171                    when using a large limit.  */
 172                 denominator = ((unsigned long)1 << INT_VALBITS) / XINT(limit);
 173                 do
 174                         val = get_random() / denominator;
 175                 while (val >= XINT(limit));
 176         } else if (ZEROP(limit)) {
 177                 return wrong_type_argument(Qpositivep, limit);
 178 #if defined HAVE_MPZ && defined WITH_GMP
 179         } else if (BIGZP(limit)) {
 180                 bigz bz;
 181                 Lisp_Object result;
 182
 183                 if (bigz_sign(XBIGZ_DATA(limit)) <= 0)
 184                         return wrong_type_argument(Qpositivep, limit);
 185
 186                 bigz_init(bz);
 187
 188                 bigz_random(bz, XBIGZ_DATA(limit));
 189                 result = ent_mpz_downgrade_maybe(bz);
 190
 191                 bigz_fini(bz);
 192                 return result;
 193 #endif  /* HAVE_MPZ */
 194         } else
 195                 val = get_random();
 196
 197         return make_int(val);
 198 }
 199
 200 #if defined(WITH_GMP) && defined(HAVE_MPZ)
 201 DEFUN("randomb", Frandomb, 1, 1, 0,     /*
 202 Return a uniform pseudo-random number in the range [0, 2^LIMIT).
 203 */
 204       (limit))
 205 {
 206         bigz bz;
 207         unsigned long limui;
 208         Lisp_Object result;
 209
 210         CHECK_INTEGER(limit);
 211
 212         if (NILP(Fnonnegativep(limit)))
 213                 return wrong_type_argument(Qnonnegativep, limit);
 214         else if (INTP(limit))
 215                 limui = XINT(limit);
 216         else if (BIGZP(limit) && bigz_fits_ulong_p(XBIGZ_DATA(limit)))
 217                 limui = bigz_to_ulong(XBIGZ_DATA(limit));
 218         else
 219                 return wrong_type_argument(Qintegerp, limit);
 220
 221         bigz_init(bz);
 222
 223         mpz_urandomb(bz, random_state, limui);
 224         result = make_bigz_bz(bz);
 225
 226         bigz_fini(bz);
 227         return result;
 228 }
 229 #endif  /* HAVE_MPZ */
 230
 231 \f
 232 /* Random data-structure functions */
 233
 234 #ifdef LOSING_BYTECODE
 235
 236 /* #### Delete this shit */
 237
 238 /* Charcount is a misnomer here as we might be dealing with the
 239    length of a vector or list, but emphasizes that we're not dealing
 240    with Bytecounts in strings */
 241 static Charcount length_with_bytecode_hack(Lisp_Object seq)
 242 {
 243         if (!COMPILED_FUNCTIONP(seq))
 244                 return XINT(Flength(seq));
 245         else {
 246                 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(seq);
 247
 248                 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
 249                         f->flags.domainp ? COMPILED_DOMAIN :
 250                         COMPILED_DOC_STRING)
 251                     + 1;
 252         }
 253 }
 254
 255 #endif                          /* LOSING_BYTECODE */
 256
 257 void check_losing_bytecode(const char *function, Lisp_Object seq)
 258 {
 259         if (COMPILED_FUNCTIONP(seq))
 260                 error_with_frob
 261                     (seq,
 262                      "As of 20.3, `%s' no longer works with compiled-function objects",
 263                      function);
 264 }
 265
 266 DEFUN("length", Flength, 1, 1, 0,       /*
 267 Return the length of vector, bit vector, list or string SEQUENCE.
 268 */
 269       (sequence))
 270 {
 271 #if 1
 272 /* that's whither we have to get */
 273         if (LIKELY(!NILP(sequence))) {
 274                 return make_int(seq_length((seq_t)sequence));
 275         } else {
 276                 return Qzero;
 277         }
 278 #elif 0
 279 retry:
 280         if (LIKELY(STRINGP(sequence) ||
 281                    CONSP(sequence) ||
 282                    VECTORP(sequence) ||
 283                    DLLISTP(sequence) ||
 284                    BIT_VECTORP(sequence))) {
 285                 return make_int(seq_length(sequence));
 286         } else if (NILP(sequence)) {
 287                 return Qzero;
 288         } else {
 289                 check_losing_bytecode("length", sequence);
 290                 sequence = wrong_type_argument(Qsequencep, sequence);
 291                 goto retry;
 292         }
 293 #else
 294 retry:
 295         if (STRINGP(sequence))
 296                 return make_int(XSTRING_CHAR_LENGTH(sequence));
 297         else if (CONSP(sequence)) {
 298                 return make_int(seq_length(sequence));
 299         } else if (VECTORP(sequence))
 300                 return make_int(seq_length(sequence));
 301         else if (DLLISTP(sequence))
 302                 return make_int(XDLLIST_SIZE(sequence));
 303         else if (NILP(sequence))
 304                 return Qzero;
 305         else if (BIT_VECTORP(sequence))
 306                 return make_int(bit_vector_length(XBIT_VECTOR(sequence)));
 307         else {
 308                 check_losing_bytecode("length", sequence);
 309                 sequence = wrong_type_argument(Qsequencep, sequence);
 310                 goto retry;
 311         }
 312 #endif
 313 }
 314
 315 DEFUN("safe-length", Fsafe_length, 1, 1, 0,     /*
 316 Return the length of a list, but avoid error or infinite loop.
 317 This function never gets an error.  If LIST is not really a list,
 318 it returns 0.  If LIST is circular, it returns a finite value
 319 which is at least the number of distinct elements.
 320 */
 321       (list))
 322 {
 323         Lisp_Object hare, tortoise;
 324         size_t len;
 325
 326         for (hare = tortoise = list, len = 0;
 327              CONSP(hare) && (!EQ(hare, tortoise) || len == 0);
 328              hare = XCDR(hare), len++) {
 329                 if (len & 1)
 330                         tortoise = XCDR(tortoise);
 331         }
 332
 333         return make_int(len);
 334 }
 335
 336 /*** string functions. ***/
 337
 338 DEFUN("string-equal", Fstring_equal, 2, 2, 0,   /*
 339 Return t if two strings have identical contents.
 340 Case is significant.  Text properties are ignored.
 341 \(Under SXEmacs, `equal' also ignores text properties and extents in
 342 strings, but this is not the case under FSF Emacs 19.  In FSF Emacs 20
 343 `equal' is the same as in SXEmacs, in that respect.)
 344 Symbols are also allowed; their print names are used instead.
 345 */
 346       (string1, string2))
 347 {
 348         Bytecount len;
 349         Lisp_String *p1, *p2;
 350
 351         if (SYMBOLP(string1))
 352                 p1 = XSYMBOL(string1)->name;
 353         else {
 354                 CHECK_STRING(string1);
 355                 p1 = XSTRING(string1);
 356         }
 357
 358         if (SYMBOLP(string2))
 359                 p2 = XSYMBOL(string2)->name;
 360         else {
 361                 CHECK_STRING(string2);
 362                 p2 = XSTRING(string2);
 363         }
 364
 365         return (((len = string_length(p1)) == string_length(p2)) &&
 366                 !memcmp(string_data(p1), string_data(p2), len)) ? Qt : Qnil;
 367 }
 368
 369 DEFUN("string-lessp", Fstring_lessp, 2, 2, 0,   /*
 370 Return t if first arg string is less than second in lexicographic order.
 371 If I18N2 support (but not Mule support) was compiled in, ordering is
 372 determined by the locale. (Case is significant for the default C locale.)
 373 In all other cases, comparison is simply done on a character-by-
 374 character basis using the numeric value of a character. (Note that
 375 this may not produce particularly meaningful results under Mule if
 376 characters from different charsets are being compared.)
 377
 378 Symbols are also allowed; their print names are used instead.
 379
 380 The reason that the I18N2 locale-specific collation is not used under
 381 Mule is that the locale model of internationalization does not handle
 382 multiple charsets and thus has no hope of working properly under Mule.
 383 What we really should do is create a collation table over all built-in
 384 charsets.  This is extremely difficult to do from scratch, however.
 385
 386 Unicode is a good first step towards solving this problem.  In fact,
 387 it is quite likely that a collation table exists (or will exist) for
 388 Unicode.  When Unicode support is added to SXEmacs/Mule, this problem
 389 may be solved.
 390 */
 391       (string1, string2))
 392 {
 393         Lisp_String *p1, *p2;
 394         Charcount end, len2;
 395         int i;
 396
 397         if (SYMBOLP(string1))
 398                 p1 = XSYMBOL(string1)->name;
 399         else {
 400                 CHECK_STRING(string1);
 401                 p1 = XSTRING(string1);
 402         }
 403
 404         if (SYMBOLP(string2))
 405                 p2 = XSYMBOL(string2)->name;
 406         else {
 407                 CHECK_STRING(string2);
 408                 p2 = XSTRING(string2);
 409         }
 410
 411         end = string_char_length(p1);
 412         len2 = string_char_length(p2);
 413         if (end > len2)
 414                 end = len2;
 415
 416 #if defined (I18N2) && !defined (MULE)
 417         /* There is no hope of this working under Mule.  Even if we converted
 418            the data into an external format so that strcoll() processed it
 419            properly, it would still not work because strcoll() does not
 420            handle multiple locales.  This is the fundamental flaw in the