Merge remote-tracking branch 'origin/master' into njsf-cov

[sxemacs] / src / fns.c

/* Random utility Lisp functions.
   Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
   Copyright (C) 1995, 1996 Ben Wing.

This file is part of SXEmacs

SXEmacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

SXEmacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>. */


/* Synched up with: Mule 2.0, FSF 19.30. */

/* This file has been Mule-ized. */

/* Note: FSF 19.30 has bool vectors.  We have bit vectors. */

/* Hacked on for Mule by Ben Wing, December 1994, January 1995. */

#include <config.h>

/* Note on some machines this defines `vector' as a typedef,
   so make sure we don't use that name in this file.  */
#undef vector
#define vector *****

#include "lisp.h"

#include "sysfile.h"

#include "buffer.h"
#include "bytecode.h"
#include "ui/device.h"
#include "events/events.h"
#include "extents.h"
#include "ui/frame.h"
#include "systime.h"
#include "ui/insdel.h"
#include "lstream.h"
/* for the categorial views */
#include "category.h"
#include "seq.h"
/* for all the map* funs */
#include "map.h"

\f
/* NOTE: This symbol is also used in lread.c */
#define FEATUREP_SYNTAX

Lisp_Object Qstring_lessp, Qstring_greaterp;
Lisp_Object Qidentity;

static int internal_old_equal(Lisp_Object, Lisp_Object, int);
Lisp_Object safe_copy_tree(Lisp_Object arg, Lisp_Object vecp, int depth);
int internal_equalp(Lisp_Object, Lisp_Object, int);

static Lisp_Object mark_bit_vector(Lisp_Object obj)
{
        return Qnil;
}

static void
print_bit_vector(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
        size_t i;
        Lisp_Bit_Vector *v = XBIT_VECTOR(obj);
        size_t len = bit_vector_length(v);
        size_t last = len;

        if (INTP(Vprint_length))
                last = min((EMACS_INT) len, XINT(Vprint_length));
        write_c_string("#*", printcharfun);
        for (i = 0; i < last; i++) {
                if (bit_vector_bit(v, i))
                        write_c_string("1", printcharfun);
                else
                        write_c_string("0", printcharfun);
        }

        if (last != len)
                write_c_string("...", printcharfun);
}

static int bit_vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
{
        Lisp_Bit_Vector *v1 = XBIT_VECTOR(obj1);
        Lisp_Bit_Vector *v2 = XBIT_VECTOR(obj2);

        return ((bit_vector_length(v1) == bit_vector_length(v2)) &&
                !memcmp(v1->bits, v2->bits,
                        BIT_VECTOR_LONG_STORAGE(bit_vector_length(v1)) *
                        sizeof(long)));
}

static unsigned long bit_vector_hash(Lisp_Object obj, int depth)
{
        Lisp_Bit_Vector *v = XBIT_VECTOR(obj);
        return HASH2(bit_vector_length(v),
                     memory_hash(v->bits,
                                 BIT_VECTOR_LONG_STORAGE(bit_vector_length(v)) *
                                 sizeof(long)));
}

static size_t size_bit_vector(const void *lheader)
{
        const Lisp_Bit_Vector *v = (const Lisp_Bit_Vector *) lheader;
        return FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
                                            bits,
                                            BIT_VECTOR_LONG_STORAGE
                                            (bit_vector_length(v)));
}

static const struct lrecord_description bit_vector_description[] = {
        {XD_LISP_OBJECT, offsetof(Lisp_Bit_Vector, next)},
        {XD_END}
};

DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION("bit-vector", bit_vector,
                                             mark_bit_vector, print_bit_vector,
                                             0, bit_vector_equal,
                                             bit_vector_hash,
                                             bit_vector_description,
                                             size_bit_vector, Lisp_Bit_Vector);
\f
DEFUN("identity", Fidentity, 1, 1, 0,   /*
Return the argument unchanged.
*/
      (arg))
{
        return arg;
}

extern long get_random(void);
extern void seed_random(long arg);

DEFUN("random", Frandom, 0, 1, 0,       /*
Return a pseudo-random number.
All integers representable in Lisp are equally likely.
On most systems, this is 31 bits' worth.

With positive integer argument LIMIT, return random number 
in interval [0,LIMIT). LIMIT can be a big integer, in which
case the range of possible values is extended.

With argument t, set the random number seed from the 
current time and pid.
*/
      (limit))
{
        EMACS_INT val;
        unsigned long denominator;

        if (EQ(limit, Qt))
                seed_random(getpid() + time(NULL));
        if (NATNUMP(limit) && !ZEROP(limit)) {
                /* Try to take our random number from the higher bits of VAL,
                   not the lower, since (says Gentzel) the low bits of `random'
                   are less random than the higher ones.  We do this by using the
                   quotient rather than the remainder.  At the high end of the RNG
                   it's possible to get a quotient larger than limit; discarding
                   these values eliminates the bias that would otherwise appear
                   when using a large limit.  */
                denominator = ((unsigned long)1 << INT_VALBITS) / XINT(limit);
                do
                        val = get_random() / denominator;
                while (val >= XINT(limit));
        } else if (ZEROP(limit)) {
                return wrong_type_argument(Qpositivep, limit);
#if defined HAVE_MPZ && defined WITH_GMP
        } else if (BIGZP(limit)) {
                bigz bz;
                Lisp_Object result;

                if (bigz_sign(XBIGZ_DATA(limit)) <= 0)
                        return wrong_type_argument(Qpositivep, limit);

                bigz_init(bz);

                bigz_random(bz, XBIGZ_DATA(limit));
                result = ent_mpz_downgrade_maybe(bz);

                bigz_fini(bz);
                return result;
#endif  /* HAVE_MPZ */
        } else
                val = get_random();

        return make_int(val);
}

#if defined(WITH_GMP) && defined(HAVE_MPZ)
DEFUN("randomb", Frandomb, 1, 1, 0,     /*
Return a uniform pseudo-random number in the range [0, 2^LIMIT).
*/
      (limit))
{
        bigz bz;
        unsigned long limui;
        Lisp_Object result;

        CHECK_INTEGER(limit);

        if (NILP(Fnonnegativep(limit)))
                return wrong_type_argument(Qnonnegativep, limit);
        else if (INTP(limit))
                limui = XINT(limit);
        else if (BIGZP(limit) && bigz_fits_ulong_p(XBIGZ_DATA(limit)))
                limui = bigz_to_ulong(XBIGZ_DATA(limit));
        else
                return wrong_type_argument(Qintegerp, limit);

        bigz_init(bz);

        mpz_urandomb(bz, random_state, limui);
        result = make_bigz_bz(bz);

        bigz_fini(bz);
        return result;
}
#endif  /* HAVE_MPZ */

\f
/* Random data-structure functions */

#ifdef LOSING_BYTECODE

/* #### Delete this shit */

/* Charcount is a misnomer here as we might be dealing with the
   length of a vector or list, but emphasizes that we're not dealing
   with Bytecounts in strings */
static Charcount length_with_bytecode_hack(Lisp_Object seq)
{
        if (!COMPILED_FUNCTIONP(seq))
                return XINT(Flength(seq));
        else {
                Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(seq);

                return (f->flags.interactivep ? COMPILED_INTERACTIVE :
                        f->flags.domainp ? COMPILED_DOMAIN :
                        COMPILED_DOC_STRING)
                    + 1;
        }
}

#endif                          /* LOSING_BYTECODE */

void check_losing_bytecode(const char *function, Lisp_Object seq)
{
        if (COMPILED_FUNCTIONP(seq))
                error_with_frob
                    (seq,
                     "As of 20.3, `%s' no longer works with compiled-function objects",
                     function);
}

DEFUN("length", Flength, 1, 1, 0,       /*
Return the length of vector, bit vector, list or string SEQUENCE.
*/
      (sequence))
{
#if 1
/* that's whither we have to get */
        if (LIKELY(!NILP(sequence))) {
                return make_int(seq_length((seq_t)sequence));
        } else {
                return Qzero;
        }
#elif 0
retry:
        if (LIKELY(STRINGP(sequence) ||
                   CONSP(sequence) ||
                   VECTORP(sequence) ||
                   DLLISTP(sequence) ||
                   BIT_VECTORP(sequence))) {
                return make_int(seq_length(sequence));
        } else if (NILP(sequence)) {
                return Qzero;
        } else {
                check_losing_bytecode("length", sequence);
                sequence = wrong_type_argument(Qsequencep, sequence);
                goto retry;
        }
#else
retry:
        if (STRINGP(sequence))
                return make_int(XSTRING_CHAR_LENGTH(sequence));
        else if (CONSP(sequence)) {
                return make_int(seq_length(sequence));
        } else if (VECTORP(sequence))
                return make_int(seq_length(sequence));
        else if (DLLISTP(sequence))
                return make_int(XDLLIST_SIZE(sequence));
        else if (NILP(sequence))
                return Qzero;
        else if (BIT_VECTORP(sequence))
                return make_int(bit_vector_length(XBIT_VECTOR(sequence)));
        else {
                check_losing_bytecode("length", sequence);
                sequence = wrong_type_argument(Qsequencep, sequence);
                goto retry;
        }
#endif
}

DEFUN("safe-length", Fsafe_length, 1, 1, 0,     /*
Return the length of a list, but avoid error or infinite loop.
This function never gets an error.  If LIST is not really a list,
it returns 0.  If LIST is circular, it returns a finite value
which is at least the number of distinct elements.
*/
      (list))
{
        Lisp_Object hare, tortoise;
        size_t len;

        for (hare = tortoise = list, len = 0;
             CONSP(hare) && (!EQ(hare, tortoise) || len == 0);
             hare = XCDR(hare), len++) {
                if (len & 1)
                        tortoise = XCDR(tortoise);
        }

        return make_int(len);
}

/*** string functions. ***/

DEFUN("string-equal", Fstring_equal, 2, 2, 0,   /*
Return t if two strings have identical contents.
Case is significant.  Text properties are ignored.
\(Under SXEmacs, `equal' also ignores text properties and extents in
strings, but this is not the case under FSF Emacs 19.  In FSF Emacs 20
`equal' is the same as in SXEmacs, in that respect.)
Symbols are also allowed; their print names are used instead.
*/
      (string1, string2))
{
        Bytecount len;
        Lisp_String *p1, *p2;

        if (SYMBOLP(string1))
                p1 = XSYMBOL(string1)->name;
        else {
                CHECK_STRING(string1);
                p1 = XSTRING(string1);
        }

        if (SYMBOLP(string2))
                p2 = XSYMBOL(string2)->name;
        else {
                CHECK_STRING(string2);
                p2 = XSTRING(string2);
        }

        return (((len = string_length(p1)) == string_length(p2)) &&
                !memcmp(string_data(p1), string_data(p2), len)) ? Qt : Qnil;
}

DEFUN("string-lessp", Fstring_lessp, 2, 2, 0,   /*
Return t if first arg string is less than second in lexicographic order.
If I18N2 support (but not Mule support) was compiled in, ordering is
determined by the locale. (Case is significant for the default C locale.)
In all other cases, comparison is simply done on a character-by-
character basis using the numeric value of a character. (Note that
this may not produce particularly meaningful results under Mule if
characters from different charsets are being compared.)

Symbols are also allowed; their print names are used instead.

The reason that the I18N2 locale-specific collation is not used under
Mule is that the locale model of internationalization does not handle
multiple charsets and thus has no hope of working properly under Mule.
What we really should do is create a collation table over all built-in
charsets.  This is extremely difficult to do from scratch, however.

Unicode is a good first step towards solving this problem.  In fact,
it is quite likely that a collation table exists (or will exist) for
Unicode.  When Unicode support is added to SXEmacs/Mule, this problem
may be solved.
*/
      (string1, string2))
{
        Lisp_String *p1, *p2;
        Charcount end, len2;
        int i;

        if (SYMBOLP(string1))
                p1 = XSYMBOL(string1)->name;
        else {
                CHECK_STRING(string1);
                p1 = XSTRING(string1);
        }

        if (SYMBOLP(string2))
                p2 = XSYMBOL(string2)->name;
        else {
                CHECK_STRING(string2);
                p2 = XSTRING(string2);
        }

        end = string_char_length(p1);
        len2 = string_char_length(p2);
        if (end > len2)
                end = len2;

#if defined (I18N2) && !defined (MULE)
        /* There is no hope of this working under Mule.  Even if we converted
           the data into an external format so that strcoll() processed it
           properly, it would still not work because strcoll() does not
           handle multiple locales.  This is the fundamental flaw in the
           locale model. */
        {
                Bytecount bcend = charcount_to_bytecount(string_data(p1), end);
                /* Compare strings using collation order of locale. */
                /* Need to be tricky to handle embedded nulls. */

                for (i = 0; i < bcend;
                     i += strlen((char *)string_data(p1) + i) + 1) {
                        int val = strcoll((char *)string_data(p1) + i,
                                          (char *)string_data(p2) + i);
                        if (val < 0)
                                return Qt;
                        if (val > 0)
                                return Qnil;
                }
        }
#else                           /* not I18N2, or MULE */
        {
                Bufbyte *ptr1 = string_data(p1);
                Bufbyte *ptr2 = string_data(p2);

                /* #### It is not really necessary to do this: We could compare
                   byte-by-byte and still get a reasonable comparison, since this
                   would compare characters with a charset in the same way.  With
                   a little rearrangement of the leading bytes, we could make most
                   inter-charset comparisons work out the same, too; even if some
                   don't, this is not a big deal because inter-charset comparisons
                   aren't really well-defined anyway. */
                for (i = 0; i < end; i++) {
                        if (charptr_emchar(ptr1) != charptr_emchar(ptr2))
                                return charptr_emchar(ptr1) <
                                    charptr_emchar(ptr2) ? Qt : Qnil;
                        INC_CHARPTR(ptr1);
                        INC_CHARPTR(ptr2);
                }
        }
#endif                          /* not I18N2, or MULE */
        /* Can't do i < len2 because then comparison between "foo" and "foo^@"
           won't work right in I18N2 case */
        return end < len2 ? Qt : Qnil;
}

DEFUN("string-greaterp", Fstring_greaterp, 2, 2, 0, /*
Return t if first arg string is greater than second in lexicographic order.
If I18N2 support (but not Mule support) was compiled in, ordering is
determined by the locale. (Case is significant for the default C locale.)
In all other cases, comparison is simply done on a character-by-
character basis using the numeric value of a character. (Note that
this may not produce particularly meaningful results under Mule if
characters from different charsets are being compared.)

Symbols are also allowed; their print names are used instead.

The reason that the I18N2 locale-specific collation is not used under
Mule is that the locale model of internationalization does not handle
multiple charsets and thus has no hope of working properly under Mule.
What we really should do is create a collation table over all built-in
charsets.  This is extremely difficult to do from scratch, however.

Unicode is a good first step towards solving this problem.  In fact,
it is quite likely that a collation table exists (or will exist) for
Unicode.  When Unicode support is added to SXEmacs/Mule, this problem
may be solved.
*/
      (string1, string2))
{
        return Fstring_lessp(string2, string1);
}

DEFUN("string-modified-tick", Fstring_modified_tick, 1, 1, 0,   /*
Return STRING's tick counter, incremented for each change to the string.
Each string has a tick counter which is incremented each time the contents
of the string are changed (e.g. with `aset').  It wraps around occasionally.
*/
      (string))
{
        Lisp_String *s;

        CHECK_STRING(string);
        s = XSTRING(string);
        if (CONSP(s->plist) && INTP(XCAR(s->plist)))
                return XCAR(s->plist);
        else
                return Qzero;
}

void bump_string_modiff(Lisp_Object str)
{
        Lisp_String *s = XSTRING(str);
        Lisp_Object *ptr = &s->plist;

#ifdef I18N3
        /* #### remove the `string-translatable' property from the string,
           if there is one. */
#endif
        /* skip over extent info if it's there */
        if (CONSP(*ptr) && EXTENT_INFOP(XCAR(*ptr)))
                ptr = &XCDR(*ptr);
        if (CONSP(*ptr) && INTP(XCAR(*ptr)))
                XSETINT(XCAR(*ptr), 1 + XINT(XCAR(*ptr)));
        else
                *ptr = Fcons(make_int(1), *ptr);
}
\f
enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector, c_dllist };
static Lisp_Object concat(int nargs, Lisp_Object * args,
                          enum concat_target_type target_type,
                          int last_special);

Lisp_Object concat2(Lisp_Object string1, Lisp_Object string2)
{
        Lisp_Object args[2];
        args[0] = string1;
        args[1] = string2;
        return concat(2, args, c_string, 0);
}

Lisp_Object
concat3(Lisp_Object string1, Lisp_Object string2, Lisp_Object string3)
{
        Lisp_Object args[3];
        args[0] = string1;
        args[1] = string2;
        args[2] = string3;
        return concat(3, args, c_string, 0);
}

Lisp_Object vconcat2(Lisp_Object vec1, Lisp_Object vec2)
{
        Lisp_Object args[2];
        args[0] = vec1;
        args[1] = vec2;
        return concat(2, args, c_vector, 0);
}

Lisp_Object vconcat3(Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3)
{
        Lisp_Object args[3];
        args[0] = vec1;
        args[1] = vec2;
        args[2] = vec3;
        return concat(3, args, c_vector, 0);
}

DEFUN("append", Fappend, 0, MANY, 0,    /*
Concatenate all the arguments and make the result a list.
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector, bit vector, or string.
The last argument is not copied, just used as the tail of the new list.
Also see: `nconc'.
*/
      (int nargs, Lisp_Object * args))
{
        return concat(nargs, args, c_cons, 1);
}

DEFUN("concat", Fconcat, 0, MANY, 0,    /*
Concatenate all the arguments and make the result a string.
The result is a string whose elements are the elements of all the arguments.
Each argument may be a string or a list or vector of characters.

As of XEmacs 21.0, this function does NOT accept individual integers
as arguments.  Old code that relies on, for example, (concat "foo" 50)
returning "foo50" will fail.  To fix such code, either apply
`int-to-string' to the integer argument, or use `format'.
*/
      (int nargs, Lisp_Object * args))
{
        return concat(nargs, args, c_string, 0);
}

DEFUN("vconcat", Fvconcat, 0, MANY, 0,  /*
Concatenate all the arguments and make the result a vector.
The result is a vector whose elements are the elements of all the arguments.
Each argument may be a list, vector, bit vector, or string.
*/
      (int nargs, Lisp_Object * args))
{
        return concat(nargs, args, c_vector, 0);
}

DEFUN("bvconcat", Fbvconcat, 0, MANY, 0,        /*
Concatenate all the arguments and make the result a bit vector.
The result is a bit vector whose elements are the elements of all the
arguments.  Each argument may be a list, vector, bit vector, or string.
*/
      (int nargs, Lisp_Object * args))
{
        return concat(nargs, args, c_bit_vector, 0);
}

/* Copy a (possibly dotted) list.  LIST must be a cons.
   Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
static Lisp_Object copy_list(Lisp_Object list)
{
        Lisp_Object list_copy = Fcons(XCAR(list), XCDR(list));
        Lisp_Object last = list_copy;
        Lisp_Object hare, tortoise;
        size_t len;

        for (tortoise = hare = XCDR(list), len = 1;
             CONSP(hare); hare = XCDR(hare), len++) {
                XCDR(last) = Fcons(XCAR(hare), XCDR(hare));
                last = XCDR(last);

                if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
                        continue;
                if (len & 1)
                        tortoise = XCDR(tortoise);
                if (EQ(tortoise, hare))
                        signal_circular_list_error(list);
        }

        return list_copy;
}

DEFUN("copy-list", Fcopy_list, 1, 1, 0, /*
Return a copy of list LIST, which may be a dotted list.
The elements of LIST are not copied; they are shared
with the original.
*/
      (list))
{
      again:
        if (NILP(list))
                return list;
        if (CONSP(list))
                return copy_list(list);

        list = wrong_type_argument(Qlistp, list);
        goto again;
}

DEFUN("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
Return a copy of list, dllist, vector, bit vector or string SEQUENCE.
The elements of a list or vector are not copied; they are shared
with the original. SEQUENCE may be a dotted list.
*/
      (sequence))
{
      again:
        if (NILP(sequence))
                return sequence;
        if (CONSP(sequence))
                return copy_list(sequence);
        if (DLLISTP(sequence))
                return Fcopy_dllist(sequence);
        if (STRINGP(sequence))
                return concat(1, &sequence, c_string, 0);
        if (VECTORP(sequence))
                return concat(1, &sequence, c_vector, 0);
        if (BIT_VECTORP(sequence))
                return concat(1, &sequence, c_bit_vector, 0);

        check_losing_bytecode("copy-sequence", sequence);
        sequence = wrong_type_argument(Qsequencep, sequence);
        goto again;
}

struct merge_string_extents_struct {
        Lisp_Object string;
        Bytecount entry_offset;
        Bytecount entry_length;
};

static Lisp_Object
concat(int nargs, Lisp_Object * args,
       enum concat_target_type target_type, int last_special)
{
        Lisp_Object val;
        Lisp_Object tail = Qnil;
        int toindex;
        int argnum;
        Lisp_Object last_tail;
        Lisp_Object prev;
        struct merge_string_extents_struct *args_mse = 0;
        Bufbyte *string_result = NULL;
        Bufbyte *string_result_ptr = NULL;
        struct gcpro gcpro1;
        int speccount = specpdl_depth();
        Charcount total_length;
        

        /* The modus operandi in Emacs is "caller gc-protects args".
           However, concat is called many times in Emacs on freshly
           created stuff.  So we help those callers out by protecting
           the args ourselves to save them a lot of temporary-variable
           grief. */

        GCPROn(args, nargs);

#ifdef I18N3
        /* #### if the result is a string and any of the strings have a string
           for the `string-translatable' property, then concat should also
           concat the args but use the `string-translatable' strings, and store
           the result in the returned string's `string-translatable' property. */
#endif
        if (target_type == c_string)
                XMALLOC_OR_ALLOCA(args_mse, nargs, struct merge_string_extents_struct);

        /* In append, the last arg isn't treated like the others */
        if (last_special && nargs > 0) {
                nargs--;
                last_tail = args[nargs];
        } else
                last_tail = Qnil;

        /* Check and coerce the arguments. */
        for (argnum = 0; argnum < nargs; argnum++) {
                Lisp_Object seq = args[argnum];
                if (LISTP(seq) || DLLISTP(seq)) ;
                else if (VECTORP(seq) || STRINGP(seq) || BIT_VECTORP(seq)) ;
#ifdef LOSING_BYTECODE
                else if (COMPILED_FUNCTIONP(seq))
                        /* Urk!  We allow this, for "compatibility"... */
                        ;
#endif
#if 0                           /* removed for XEmacs 21 */
                else if (INTP(seq))
                        /* This is too revolting to think about but maintains
                           compatibility with FSF (and lots and lots of old code). */
     &