[sxemacs] / src / ui / specifier.c

/* Specifier implementation
   Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
   Copyright (C) 1995, 1996 Ben Wing.
   Copyright (C) 1995 Sun Microsystems, Inc.

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: Not in FSF. */

/* Design by Ben Wing;
   Original version by Chuck Thompson;
   rewritten by Ben Wing;
   Magic specifiers by Kirill Katsnelson;
*/

#include <config.h>
#include "lisp.h"

#include "buffer.h"
#include "device.h"
#include "frame.h"
#include "opaque.h"
#include "specifier.h"
#include "window.h"
#include "chartab.h"
#include "rangetab.h"

Lisp_Object Qspecifierp;
Lisp_Object Qremove_tag_set_prepend, Qremove_tag_set_append;
Lisp_Object Qremove_locale, Qremove_locale_type;

Lisp_Object Qconsole_type, Qdevice_class;

Lisp_Object Qspecifier_syntax_error;
Lisp_Object Qspecifier_argument_error;
Lisp_Object Qspecifier_change_error;

static Lisp_Object Vuser_defined_tags;

typedef struct specifier_type_entry specifier_type_entry;
struct specifier_type_entry {
        Lisp_Object symbol;
        struct specifier_methods *meths;
};

typedef struct {
        Dynarr_declare(specifier_type_entry);
} specifier_type_entry_dynarr;

static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;

static const struct lrecord_description ste_description_1[] = {
        {XD_LISP_OBJECT, offsetof(specifier_type_entry, symbol)},
        {XD_STRUCT_PTR, offsetof(specifier_type_entry, meths), 1,
         &specifier_methods_description},
        {XD_END}
};

static const struct struct_description ste_description = {
        sizeof(specifier_type_entry),
        ste_description_1
};

static const struct lrecord_description sted_description_1[] = {
        XD_DYNARR_DESC(specifier_type_entry_dynarr, &ste_description),
        {XD_END}
};

static const struct struct_description sted_description = {
        sizeof(specifier_type_entry_dynarr),
        sted_description_1
};

static Lisp_Object Vspecifier_type_list;

static Lisp_Object Vcached_specifiers;
/* Do NOT mark through this, or specifiers will never be GC'd. */
static Lisp_Object Vall_specifiers;

static Lisp_Object Vunlock_ghost_specifiers;

/* #### The purpose of this is to check for inheritance loops
   in specifiers that can inherit from other specifiers, but it's
   not yet implemented.

   #### Look into this for 19.14. */
/* static Lisp_Object_dynarr current_specifiers; */

static void recompute_cached_specifier_everywhere(Lisp_Object specifier);

EXFUN(Fspecifier_specs, 4);
EXFUN(Fremove_specifier, 4);
\f
/************************************************************************/
/*                       Specifier object methods                       */
/************************************************************************/

/* Remove dead objects from the specified assoc list. */

static Lisp_Object cleanup_assoc_list(Lisp_Object list)
{
        Lisp_Object loop, prev, retval;

        loop = retval = list;
        prev = Qnil;

        while (!NILP(loop)) {
                Lisp_Object entry = XCAR(loop);
                Lisp_Object key = XCAR(entry);

                /* remember, dead windows can become alive again. */
                if (!WINDOWP(key) && object_dead_p(key)) {
                        if (NILP(prev)) {
                                /* Removing the head. */
                                retval = XCDR(retval);
                        } else {
                                Fsetcdr(prev, XCDR(loop));
                        }
                } else
                        prev = loop;

                loop = XCDR(loop);
        }

        return retval;
}

/* Remove dead objects from the various lists so that they
   don't keep getting marked as long as this specifier exists and
   therefore wasting memory. */

void cleanup_specifiers(void)
{
        Lisp_Object rest;

        for (rest = Vall_specifiers;
             !NILP(rest); rest = XSPECIFIER(rest)->next_specifier) {
                Lisp_Specifier *sp = XSPECIFIER(rest);
                /* This effectively changes the specifier specs.
                   However, there's no need to call
                   recompute_cached_specifier_everywhere() or the
                   after-change methods because the only specs we
                   are removing are for dead objects, and they can
                   never have any effect on the specifier values:
                   specifiers can only be instantiated over live
                   objects, and you can't derive a dead object
                   from a live one. */
                sp->device_specs = cleanup_assoc_list(sp->device_specs);
                sp->frame_specs = cleanup_assoc_list(sp->frame_specs);
                sp->buffer_specs = cleanup_assoc_list(sp->buffer_specs);
                /* windows are handled specially because dead windows
                   can be resurrected */
        }
}

void kill_specifier_buffer_locals(Lisp_Object buffer)
{
        Lisp_Object rest;

        for (rest = Vall_specifiers;
             !NILP(rest); rest = XSPECIFIER(rest)->next_specifier) {
                Lisp_Specifier *sp = XSPECIFIER(rest);

                /* Make sure we're actually going to be changing something.
                   Fremove_specifier() always calls
                   recompute_cached_specifier_everywhere() (#### but should
                   be smarter about this). */
                if (!NILP(assq_no_quit(buffer, sp->buffer_specs)))
                        Fremove_specifier(rest, buffer, Qnil, Qnil);
        }
}

static Lisp_Object mark_specifier(Lisp_Object obj)
{
        Lisp_Specifier *specifier = XSPECIFIER(obj);

        mark_object(specifier->global_specs);
        mark_object(specifier->device_specs);
        mark_object(specifier->frame_specs);
        mark_object(specifier->window_specs);
        mark_object(specifier->buffer_specs);
        mark_object(specifier->magic_parent);
        mark_object(specifier->fallback);
        if (!GHOST_SPECIFIER_P(XSPECIFIER(obj)))
                MAYBE_SPECMETH(specifier, mark, (obj));
        return Qnil;
}

/* The idea here is that the specifier specs point to locales
   (windows, buffers, frames, and devices), and we want to make sure
   that the specs disappear automatically when the associated locale
   is no longer in use.  For all but windows, "no longer in use"
   corresponds exactly to when the object is deleted (non-deleted
   objects are always held permanently in special lists, and deleted
   objects are never on these lists and never reusable).  To handle
   this, we just have cleanup_specifiers() called periodically
   (at the beginning of garbage collection); it removes all dead
   objects.

   For windows, however, it's trickier because dead objects can be
   converted to live ones again if the dead object is in a window
   configuration.  Therefore, for windows, "no longer in use"
   corresponds to when the window object is garbage-collected.
   We now use weak lists for this purpose.

*/

void prune_specifiers(void)
{
        Lisp_Object rest, prev = Qnil;

        for (rest = Vall_specifiers;
             !NILP(rest); rest = XSPECIFIER(rest)->next_specifier) {
                if (!marked_p(rest)) {
                        Lisp_Specifier *sp = XSPECIFIER(rest);
                        /* A bit of assertion that we're removing both parts of the
                           magic one altogether */
#if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
#  define MARKED_P(a) marked_p(a)
#else
#  define MARKED_P(a) 1
#endif
                        assert(!MAGIC_SPECIFIER_P(sp)
                               || ( BODILY_SPECIFIER_P(sp) && 
                                    MARKED_P(sp->fallback) )
                               || ( GHOST_SPECIFIER_P(sp) && 
                                    MARKED_P(sp->magic_parent)));
#undef MARKED_P
                        /* This specifier is garbage.  Remove it from the list. */
                        if (NILP(prev))
                                Vall_specifiers = sp->next_specifier;
                        else
                                XSPECIFIER(prev)->next_specifier =
                                    sp->next_specifier;
                } else
                        prev = rest;
        }
}

static void
print_specifier(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
        Lisp_Specifier *sp = XSPECIFIER(obj);
        int count = specpdl_depth();
        Lisp_Object the_specs;

        if (print_readably)
                error("printing unreadable object #<%s-specifier 0x%x>",
                      sp->methods->name, sp->header.uid);

        write_fmt_string(printcharfun, "#<%s-specifier global=", sp->methods->name);
        specbind(Qprint_string_length, make_int(100));
        specbind(Qprint_length, make_int(5));
        the_specs = Fspecifier_specs(obj, Qglobal, Qnil, Qnil);
        if (NILP(the_specs))
                /* there are no global specs */
                write_c_string("<unspecified>", printcharfun);
        else
                print_internal(the_specs, printcharfun, 1);
        if (!NILP(sp->fallback)) {
                write_c_string(" fallback=", printcharfun);
                print_internal(sp->fallback, printcharfun, escapeflag);
        }
        unbind_to(count, Qnil);
        write_fmt_str(printcharfun," 0x%x>", sp->header.uid);
}

static void finalize_specifier(void *header, int for_disksave)
{
        Lisp_Specifier *sp = (Lisp_Specifier *) header;
        /* don't be snafued by the disksave finalization. */
        if (!for_disksave && !GHOST_SPECIFIER_P(sp) && sp->caching) {
                xfree(sp->caching);
                sp->caching = 0;
        }
}

static int specifier_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
{
        Lisp_Specifier *s1 = XSPECIFIER(obj1);
        Lisp_Specifier *s2 = XSPECIFIER(obj2);
        int retval;
        Lisp_Object old_inhibit_quit = Vinhibit_quit;

        /* This function can be called from within redisplay.
           internal_equal can trigger a quit.  That leads to Bad Things. */
        Vinhibit_quit = Qt;

        depth++;
        retval =
            (s1->methods == s2->methods &&
             internal_equal(s1->global_specs, s2->global_specs, depth) &&
             internal_equal(s1->device_specs, s2->device_specs, depth) &&
             internal_equal(s1->frame_specs, s2->frame_specs, depth) &&
             internal_equal(s1->window_specs, s2->window_specs, depth) &&
             internal_equal(s1->buffer_specs, s2->buffer_specs, depth) &&
             internal_equal(s1->fallback, s2->fallback, depth));

        if (retval && HAS_SPECMETH_P(s1, equal))
                retval = SPECMETH(s1, equal, (obj1, obj2, depth - 1));

        Vinhibit_quit = old_inhibit_quit;
        return retval;
}

static unsigned long specifier_hash(Lisp_Object obj, int depth)
{
        Lisp_Specifier *s = XSPECIFIER(obj);

        /* specifier hashing is a bit problematic because there are so
           many places where data can be stored.  We pick what are perhaps
           the most likely places where interesting stuff will be. */
        return HASH5((HAS_SPECMETH_P(s, hash) ?
                      SPECMETH(s, hash, (obj, depth)) : 0),
                     (unsigned long)s->methods,
                     internal_hash(s->global_specs, depth + 1),
                     internal_hash(s->frame_specs, depth + 1),
                     internal_hash(s->buffer_specs, depth + 1));
}

inline static size_t
aligned_sizeof_specifier(size_t specifier_type_specific_size)
{
        return ALIGN_SIZE(offsetof(Lisp_Specifier, data)
                          + specifier_type_specific_size, ALIGNOF(max_align_t));
}

static size_t sizeof_specifier(const void *header)
{
        const Lisp_Specifier *p = (const Lisp_Specifier *)header;
        return aligned_sizeof_specifier(GHOST_SPECIFIER_P(p)
                                        ? 0 : p->methods->extra_data_size);
}

static const struct lrecord_description specifier_methods_description_1[] = {
        {XD_LISP_OBJECT, offsetof(struct specifier_methods, predicate_symbol)},
        {XD_END}
};

const struct struct_description specifier_methods_description = {
        sizeof(struct specifier_methods),
        specifier_methods_description_1
};

static const struct lrecord_description specifier_caching_description_1[] = {
        {XD_END}
};

static const struct struct_description specifier_caching_description = {
        sizeof(struct specifier_caching),
        specifier_caching_description_1
};

static const struct lrecord_description specifier_description[] = {
        {XD_STRUCT_PTR, offsetof(Lisp_Specifier, methods), 1,
         &specifier_methods_description},
        {XD_LO_LINK, offsetof(Lisp_Specifier, next_specifier)},
        {XD_LISP_OBJECT, offsetof(Lisp_Specifier, global_specs)},
        {XD_LISP_OBJECT, offsetof(Lisp_Specifier, device_specs)},
        {XD_LISP_OBJECT, offsetof(Lisp_Specifier, frame_specs)},
        {XD_LISP_OBJECT, offsetof(Lisp_Specifier, window_specs)},
        {XD_LISP_OBJECT, offsetof(Lisp_Specifier, buffer_specs)},
        {XD_STRUCT_PTR, offsetof(Lisp_Specifier, caching), 1,
         &specifier_caching_description},
        {XD_LISP_OBJECT, offsetof(Lisp_Specifier, magic_parent)},
        {XD_LISP_OBJECT, offsetof(Lisp_Specifier, fallback)},
        {XD_SPECIFIER_END}
};

const struct lrecord_description specifier_empty_extra_description[] = {
        {XD_END}
};

DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("specifier", specifier,
                                       mark_specifier, print_specifier,
                                       finalize_specifier,
                                       specifier_equal, specifier_hash,
                                       specifier_description,
                                       sizeof_specifier, Lisp_Specifier);
\f
/************************************************************************/
/*                       Creating specifiers                            */
/************************************************************************/

static struct specifier_methods *decode_specifier_type(Lisp_Object type,
                                                       Error_behavior errb)
{
        int i;

        for (i = 0; i < Dynarr_length(the_specifier_type_entry_dynarr); i++) {
                if (EQ
                    (type,
                     Dynarr_at(the_specifier_type_entry_dynarr, i).symbol))
                        return Dynarr_at(the_specifier_type_entry_dynarr,
                                         i).meths;
        }

        maybe_signal_type_error(Qspecifier_argument_error,
                                "Invalid specifier type", type, Qspecifier,
                                errb);

        return 0;
}

static int valid_specifier_type_p(Lisp_Object type)
{
        return decode_specifier_type(type, ERROR_ME_NOT) != 0;
}

DEFUN("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0,       /*
Given a SPECIFIER-TYPE, return non-nil if it is valid.
Valid types are 'generic, 'integer, 'boolean, 'color, 'font, 'image,
'face-boolean, and 'toolbar.
*/
      (specifier_type))
{
        return valid_specifier_type_p(specifier_type) ? Qt : Qnil;
}

DEFUN("specifier-type-list", Fspecifier_type_list, 0, 0, 0,     /*
Return a list of valid specifier types.
*/
      ())
{
        return Fcopy_sequence(Vspecifier_type_list);
}

void
add_entry_to_specifier_type_list(Lisp_Object symbol,
                                 struct specifier_methods *meths)
{
        struct specifier_type_entry entry;

        entry.symbol = symbol;
        entry.meths = meths;
        Dynarr_add(the_specifier_type_entry_dynarr, entry);
        Vspecifier_type_list = Fcons(symbol, Vspecifier_type_list);
}

static Lisp_Object
make_specifier_internal(struct specifier_methods *spec_meths,
                        size_t data_size, int call_create_meth)
{
        Lisp_Object specifier;
        Lisp_Specifier *sp = (Lisp_Specifier *)
            alloc_lcrecord(aligned_sizeof_specifier(data_size),
                           &lrecord_specifier);

        sp->methods = spec_meths;
        sp->global_specs = Qnil;
        sp->device_specs = Qnil;
        sp->frame_specs = Qnil;
        sp->window_specs = make_weak_list(WEAK_LIST_KEY_ASSOC);
        sp->buffer_specs = Qnil;
        sp->fallback = Qnil;
        sp->magic_parent = Qnil;
        sp->caching = 0;
        sp->next_specifier = Vall_specifiers;

        XSETSPECIFIER(specifier, sp);
        Vall_specifiers = specifier;

        if (call_create_meth) {
                struct gcpro gcpro1;
                GCPRO1(specifier);
                MAYBE_SPECMETH(XSPECIFIER(specifier), create, (specifier));
                UNGCPRO;
        }
        return specifier;
}

static Lisp_Object make_specifier(struct specifier_methods *meths)
{
        return make_specifier_internal(meths, meths->extra_data_size, 1);
}

Lisp_Object make_magic_specifier(Lisp_Object type)
{
        /* This function can GC */
        struct specifier_methods *meths = decode_specifier_type(type, ERROR_ME);
        Lisp_Object bodily, ghost;
        struct gcpro gcpro1;

        bodily = make_specifier(meths);
        GCPRO1(bodily);
        ghost = make_specifier_internal(meths, 0, 0);
        UNGCPRO;

        /* Connect guys together */
        XSPECIFIER(bodily)->magic_parent = Qt;
        XSPECIFIER(bodily)->fallback = ghost;
        XSPECIFIER(ghost)->magic_parent = bodily;

        return bodily;
}

DEFUN("make-specifier", Fmake_specifier, 1, 1, 0,       /*
Return a new specifier object of type TYPE.

A specifier is an object that can be used to keep track of a property
whose value can be per-buffer, per-window, per-frame, or per-device,
and can further be restricted to a particular console-type or
device-class.  Specifiers are used, for example, for the various
built-in properties of a face; this allows a face to have different
values in different frames, buffers, etc.

When speaking of the value of a specifier, it is important to
distinguish between the *setting* of a specifier, called an
\"instantiator\", and the *actual value*, called an \"instance\".  You
put various possible instantiators (i.e. settings) into a specifier
and associate them with particular locales (buffer, window, frame,
device, global), and then the instance (i.e. actual value) is
retrieved in a specific domain (window, frame, device) by looking
through the possible instantiators (i.e. settings).  This process is
called \"instantiation\".

To put settings into a specifier, use `set-specifier', or the
lower-level functions `add-spec-to-specifier' and
`add-spec-list-to-specifier'.  You can also temporarily bind a setting
to a specifier using `let-specifier'.  To retrieve settings, use
`specifier-specs', or its lower-level counterpart
`specifier-spec-list'.  To determine the actual value, use
`specifier-instance'.

For more information, see `set-specifier', `specifier-instance',
`specifier-specs', and `add-spec-to-specifier'; or, for a detailed
description of specifiers, including how exactly the instantiation
process works, see the chapter on specifiers in the SXEmacs Lisp
Reference Manual.

TYPE specifies the particular type of specifier, and should be one of
the symbols 'generic, 'integer, 'natnum, 'boolean, 'color, 'font,
'image, 'face-boolean, 'display-table, 'gutter, 'gutter-size,
'gutter-visible or 'toolbar.

For more information on particular types of specifiers, see the