Mercurial > hg > xemacs-beta
annotate src/specifier.c @ 5353:38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
lisp/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el:
* bytecomp.el (byte-compile-initial-macro-environment):
Shadow `block', `return-from' here, we implement them differently
when byte-compiling.
* bytecomp.el (byte-compile-active-blocks): New.
* bytecomp.el (byte-compile-block-1): New.
* bytecomp.el (byte-compile-return-from-1): New.
* bytecomp.el (return-from-1): New.
* bytecomp.el (block-1): New.
These are two aliases that exist to have their own associated
byte-compile functions, which functions implement `block' and
`return-from'.
* cl-extra.el (cl-macroexpand-all):
Fix a bug here when macros in the environment have been compiled.
* cl-macs.el (block):
* cl-macs.el (return):
* cl-macs.el (return-from):
Be more careful about lexical scope in these macros.
* cl.el:
* cl.el ('cl-block-wrapper): Removed.
* cl.el ('cl-block-throw): Removed.
These aren't needed in code generated by this XEmacs. They
shouldn't be needed in code generated by XEmacs 21.4, but if it
turns out the packages do need them, we can put them back.
2011-01-30 Mike Sperber <mike@xemacs.org>
* font-lock.el (font-lock-fontify-pending-extents): Don't fail if
`font-lock-mode' is unset, which can happen in the middle of
`revert-buffer'.
2011-01-23 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete):
* cl-macs.el (delq):
* cl-macs.el (remove):
* cl-macs.el (remq):
Don't use the compiler macro if these functions were given the
wrong number of arguments, as happens in lisp-tests.el.
* cl-seq.el (remove, remq): Removed.
I added these to subr.el, and forgot to remove them from here.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-setq, byte-compile-set):
Remove kludge allowing keywords' values to be set, all the code
that does that is gone.
* cl-compat.el (elt-satisfies-test-p):
* faces.el (set-face-parent):
* faces.el (face-doc-string):
* gtk-font-menu.el:
* gtk-font-menu.el (gtk-reset-device-font-menus):
* msw-font-menu.el:
* msw-font-menu.el (mswindows-reset-device-font-menus):
* package-get.el (package-get-installedp):
* select.el (select-convert-from-image-data):
* sound.el:
* sound.el (load-sound-file):
* x-font-menu.el (x-reset-device-font-menus-core):
Don't quote keywords, they're self-quoting, and the
win from backward-compatibility is sufficiently small now that the
style problem overrides it.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (block, return-from): Require that NAME be a symbol
in these macros, as always documented in the #'block docstring and
as required by Common Lisp.
* descr-text.el (unidata-initialize-unihan-database):
Correct the use of non-symbols in #'block and #'return-from in
this function.
2011-01-15 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (concatenate): Accept more complicated TYPEs in this
function, handing the sequences over to #'coerce if we don't
understand them here.
* cl-macs.el (inline): Don't proclaim #'concatenate as inline, its
compiler macro is more useful than doing that.
2011-01-11 Aidan Kehoe <kehoea@parhasard.net>
* subr.el (delete, delq, remove, remq): Move #'remove, #'remq
here, they don't belong in cl-seq.el; move #'delete, #'delq here
from fns.c, implement them in terms of #'delete*, allowing support
for sequences generally.
* update-elc.el (do-autoload-commands): Use #'delete*, not #'delq
here, now the latter's no longer dumped.
* cl-macs.el (delete, delq): Add compiler macros transforming
#'delete and #'delq to #'delete* calls.
2011-01-10 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box): Correct a misplaced parenthesis
here, thank you Mats Lidell in 87zkr9gqrh.fsf@mail.contactor.se !
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box):
* list-mode.el (display-completion-list):
These functions used to use cl-parsing-keywords; change them to
use defun* instead, fixing the build. (Not sure what led to me
not including this change in d1b17a33450b!)
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (define-star-compiler-macros):
Make sure the form has ITEM and LIST specified before attempting
to change to calls with explicit tests; necessary for some tests
in lisp-tests.el to compile correctly.
(stable-union, stable-intersection): Add compiler macros for these
functions, in the same way we do for most of the other functions
in cl-seq.el.
2011-01-01 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
(symbol-macrolet):
Define these macros with defmacro* instead of parsing the argument
list by hand, for the sake of style and readability; use backquote
where appropriate, instead of calling #'list and and friends, for
the same reason.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* x-misc.el (device-x-display):
Provide this function, documented in the Lispref for years, but
not existing previously. Thank you Julian Bradfield, thank you
Jeff Mincy.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl-seq.el:
Move the heavy lifting from this file to C. Dump the
cl-parsing-keywords macro, but don't use defun* for the functions
we define that do take keywords, dynamic scope lossage makes that
not practical.
* subr.el (sort, fillarray): Move these aliases here.
(map-plist): #'nsublis is now built-in, but at this point #'eql
isn't necessarily available as a test; use #'eq.
* obsolete.el (cl-delete-duplicates): Make this available for old
compiler macros and old code.
(memql): Document that this is equivalent to #'member*, and worse.
* cl.el (adjoin, subst): Removed. These are in C.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
this function (it's already in subr.el).
* iso8859-1.el (char-width):
On non-Mule, make this function equivalent to that produced by
(constantly 1), but preserve its docstring.
* subr.el (subst-char-in-string): Define this in terms of
#'substitute, #'nsubstitute.
(string-width): Define this using #'reduce and #'char-width.
(char-width): Give this a simpler definition, it makes far more
sense to check for mule at load time and redefine, as we do in
iso8859-1.el.
(store-substring): Implement this in terms of #'replace, now
#'replace is cheap.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* update-elc.el (lisp-files-needed-for-byte-compilation)
(lisp-files-needing-early-byte-compilation):
cl-macs belongs in the former, not the latter, it is as
fundamental as bytecomp.el.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl.el:
Provde the Common Lisp program-error, type-error as error
symbols. This doesn't nearly go far enough for anyone using the
Common Lisp errors.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete-duplicates):
If the form has an incorrect number of arguments, don't attempt a
compiler macroexpansion.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (cl-safe-expr-p):
Forms that start with the symbol lambda are also safe.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
For these functions' compiler macros, the optimisation is safe
even if the first and the last arguments have side effects, since
they're only used the once.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (inline-side-effect-free-compiler-macros):
Unroll a loop here at macro-expansion time, so these compiler
macros are compiled. Use #'eql instead of #'eq in a couple of
places for better style.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (notany, notevery): Avoid some dynamic scope
stupidity with local variable names in these functions, when they
weren't prefixed with cl-; go into some more detail in the doc
strings.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns): #'remove, #'remq are
free of side-effects.
(side-effect-and-error-free-fns):
Drop dot, dot-marker from the list.
2010-11-17 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (coerce):
In the argument list, name the first argument OBJECT, not X; the
former name was always used in the doc string and is clearer.
Handle vector type specifications which include the length of the
target sequence, error if there's a mismatch.
* cl-macs.el (cl-make-type-test): Handle type specifications
starting with the symbol 'eql.
2010-11-14 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (eql): Don't remove the byte-compile property of this
symbol. That was necessary to override a bug in bytecomp.el where
#'eql was confused with #'eq, which bug we no longer have.
If neither expression is constant, don't attempt to handle the
expression in this compiler macro, leave it to byte-compile-eql,
which produces better code anyway.
* bytecomp.el (eq): #'eql is not the function associated with the
byte-eq byte code.
(byte-compile-eql): Add an explicit compile method for this
function, for cases where the cl-macs compiler macro hasn't
reduced it to #'eq or #'equal.
2010-10-25 Aidan Kehoe <kehoea@parhasard.net>
Add compiler macros and compilation sanity-checking for various
functions that take keywords.
* byte-optimize.el (side-effect-free-fns): #'symbol-value is
side-effect free and not error free.
* bytecomp.el (byte-compile-normal-call): Check keyword argument
lists for sanity; store information about the positions where
keyword arguments start using the new byte-compile-keyword-start
property.
* cl-macs.el (cl-const-expr-val): Take a new optional argument,
cl-not-constant, defaulting to nil, in this function; return it if
the expression is not constant.
(cl-non-fixnum-number-p): Make this into a separate function, we
want to pass it to #'every.
(eql): Use it.
(define-star-compiler-macros): Use the same code to generate the
member*, assoc* and rassoc* compiler macros; special-case some
code in #'add-to-list in subr.el.
(remove, remq): Add compiler macros for these two functions, in
preparation for #'remove being in C.
(define-foo-if-compiler-macros): Transform (remove-if-not ...) calls to
(remove ... :if-not) at compile time, which will be a real win
once the latter is in C.
(define-substitute-if-compiler-macros)
(define-subst-if-compiler-macros): Similarly for these functions.
(delete-duplicates): Change this compiler macro to use
#'plists-equal; if we don't have information about the type of
SEQUENCE at compile time, don't bother attempting to inline the
call, the function will be in C soon enough.
(equalp): Remove an old commented-out compiler macro for this, if
we want to see it it's in version control.
(subst-char-in-string): Transform this to a call to nsubstitute or
nsubstitute, if that is appropriate.
* cl.el (ldiff): Don't call setf here, this makes for a load-time
dependency problem in cl-macs.el
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* term/vt100.el:
Refer to XEmacs, not GNU Emacs, in permissions.
* term/bg-mouse.el:
* term/sup-mouse.el:
Put copyright notice in canonical "Copyright DATE AUTHOR" form.
Refer to XEmacs, not GNU Emacs, in permissions.
* site-load.el:
Add permission boilerplate.
* mule/canna-leim.el:
* alist.el:
Refer to XEmacs, not APEL/this program, in permissions.
* mule/canna-leim.el:
Remove my copyright, I've assigned it to the FSF.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* gtk.el:
* gtk-widget-accessors.el:
* gtk-package.el:
* gtk-marshal.el:
* gtk-compose.el:
* gnome.el:
Add copyright notice based on internal evidence.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* easymenu.el: Add reference to COPYING to permission notice.
* gutter.el:
* gutter-items.el:
* menubar-items.el:
Fix typo "Xmacs" in permissions notice.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* auto-save.el:
* font.el:
* fontconfig.el:
* mule/kinsoku.el:
Add "part of XEmacs" text to permission notice.
2010-10-14 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns):
* cl-macs.el (remf, getf):
* cl-extra.el (tailp, cl-set-getf, cl-do-remf):
* cl.el (ldiff, endp):
Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp;
add circularity checking for the first two.
#'cl-set-getf and #'cl-do-remf were Lisp implementations of
#'plist-put and #'plist-remprop; change the names to aliases,
changes the macros that use them to using #'plist-put and
#'plist-remprop directly.
2010-10-12 Aidan Kehoe <kehoea@parhasard.net>
* abbrev.el (fundamental-mode-abbrev-table, global-abbrev-table):
Create both these abbrev tables using the usual
#'define-abbrev-table calls, rather than attempting to
special-case them.
* cl-extra.el: Force cl-macs to be loaded here, if cl-extra.el is
being loaded interpreted. Previously other, later files would
redundantly call (load "cl-macs") when interpreted, it's more
reasonable to do it here, once.
* cmdloop.el (read-quoted-char-radix): Use defcustom here, we
don't have any dump-order dependencies that would prevent that.
* custom.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling, rely on cl-extra.el in the
former case and the appropriate entry in bytecomp-load-hook in the
latter. Get rid of custom-declare-variable-list, we have no
dump-time dependencies that would require it.
* faces.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling.
* packages.el: Remove some inaccurate comments.
* post-gc.el (cleanup-simple-finalizers): Use #'delete-if-not
here, now the order of preloaded-file-list has been changed to
make it available.
* subr.el (custom-declare-variable-list): Remove. No need for it.
Also remove a stub define-abbrev-table from this file, given the
current order of preloaded-file-list there's no need for it.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-constp) Forms quoted with FUNCTION are
also constant.
(byte-compile-initial-macro-environment): In #'the, if FORM is
constant and does not match TYPE, warn at byte-compile time.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* backquote.el (bq-vector-contents, bq-list*): Remove; the former
is equivalent to (append VECTOR nil), the latter to (list* ...).
(bq-process-2): Use (append VECTOR nil) instead of using
#'bq-vector-contents to convert to a list.
(bq-process-1): Now we use list* instead of bq-list
* subr.el (list*): Moved from cl.el, since it is now required to
be available the first time a backquoted form is encountered.
* cl.el (list*): Move to subr.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* test-harness.el (Check-Message):
Add an omitted comma here, thank you the buildbot.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
(hash-table-key-value-alist, hash-table-key-value-plist):
Remove some useless #'nreverse calls in these files; our hash
tables have no order, it's not helpful to pretend they do.
* behavior.el (read-behavior):
Do the same in this file, in some code evidently copied from
hash-table.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* info.el (Info-insert-dir):
* format.el (format-deannotate-region):
* files.el (cd, save-buffers-kill-emacs):
Use #'some, #'every and related functions for applying boolean
operations to lists, instead of rolling our own ones that cons and
don't short-circuit.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
* cl-macs.el (the):
Rephrase the docstring, make its implementation when compiling
files a little nicer.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
(unidata-initialize-unihan-database, describe-char-unicode-data)
(describe-char-unicode-data):
Wrap calls to the database functions with (with-fboundp ...),
avoiding byte compile warnings on builds without support for the
database functions.
(describe-char): (reduce #'max ...), not (apply #'max ...), no
need to cons needlessly.
(describe-char): Remove a redundant lambda wrapping
#'extent-properties.
(describe-char-unicode-data): Call #'nsubst when replacing "" with
nil in the result of #'split-string, instead of consing inside
mapcar.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* x-faces.el (x-available-font-sizes):
* specifier.el (let-specifier):
* package-ui.el (pui-add-required-packages):
* msw-faces.el (mswindows-available-font-sizes):
* modeline.el (modeline-minor-mode-menu):
* minibuf.el (minibuf-directory-files):
Replace the O2N (delq nil (mapcar (lambda (W) (and X Y)) Z)) with
the ON (mapcan (lambda (W) (and X (list Y))) Z) in these files.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
When these functions are handed more than two arguments, and those
arguments have no side effects, transform to a series of two
argument calls, avoiding funcall in the byte-compiled code.
* mule/mule-cmds.el (finish-set-language-environment):
Take advantage of this change in a function called 256 times at
startup.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
(mapcar ...)) to (mapcan ...); warn about use of the first idiom.
* update-elc.el (do-autoload-commands):
* packages.el (packages-find-package-library-path):
* frame.el (frame-list):
* extents.el (extent-descendants):
* etags.el (buffer-tag-table-files):
* dumped-lisp.el (preloaded-file-list):
* device.el (device-list):
* bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
* bytecomp-runtime.el (eval-when-compile, eval-and-compile):
In passing, mention that these macros also evaluate the body when
interpreted.
tests/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test lexical scope for `block', `return-from'; add a
Known-Bug-Expect-Failure for a contorted example that fails when
byte-compiled.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 07 Feb 2011 12:01:24 +0000 |
| parents | d185fa593d5f |
| children | b9167d522a9a |
| rev | line source |
|---|---|
| 428 | 1 /* Specifier implementation |
| 2 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3 Copyright (C) 1995, 1996, 2002, 2005, 2010 Ben Wing. |
| 428 | 4 Copyright (C) 1995 Sun Microsystems, Inc. |
| 5 | |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: Not in FSF. */ | |
| 24 | |
| 25 /* Design by Ben Wing; | |
| 2953 | 26 Written by Ben Wing based on prototype for 19.12 by Chuck Thompson. |
| 27 Magic specifiers by Kirill Katsnelson. | |
| 428 | 28 */ |
| 29 | |
| 30 #include <config.h> | |
| 31 #include "lisp.h" | |
| 32 | |
| 33 #include "buffer.h" | |
| 800 | 34 #include "chartab.h" |
| 872 | 35 #include "device-impl.h" |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
36 #include "elhash.h" |
| 428 | 37 #include "frame.h" |
| 800 | 38 #include "glyphs.h" |
| 428 | 39 #include "opaque.h" |
| 800 | 40 #include "rangetab.h" |
| 428 | 41 #include "specifier.h" |
| 42 #include "window.h" | |
| 43 | |
| 44 Lisp_Object Qspecifierp; | |
| 442 | 45 Lisp_Object Qremove_tag_set_prepend, Qremove_tag_set_append; |
| 46 Lisp_Object Qremove_locale, Qremove_locale_type; | |
| 428 | 47 |
| 48 Lisp_Object Qconsole_type, Qdevice_class; | |
| 49 | |
| 50 static Lisp_Object Vuser_defined_tags; | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
51 /* This is a hash table mapping charsets to "tag lists". A tag list here |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
52 is an assoc list mapping charset tags to size-two vectors (one for the |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
53 initial stage, one for the final stage) containing t or nil, indicating |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
54 whether the charset tag matches the charset for the given stage. These |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
55 values are determined at the time a charset tag is defined by calling |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
56 the charset predicate on all the existing charsets, and at the time a |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
57 charset is defined by calling the predicate on all existing charset |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
58 tags. */ |
| 3659 | 59 static Lisp_Object Vcharset_tag_lists; |
| 428 | 60 |
| 61 typedef struct specifier_type_entry specifier_type_entry; | |
| 62 struct specifier_type_entry | |
| 63 { | |
| 64 Lisp_Object symbol; | |
| 65 struct specifier_methods *meths; | |
| 66 }; | |
| 67 | |
| 68 typedef struct | |
| 69 { | |
| 70 Dynarr_declare (specifier_type_entry); | |
| 71 } specifier_type_entry_dynarr; | |
| 72 | |
| 73 static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr; | |
| 74 | |
| 1204 | 75 static const struct memory_description ste_description_1[] = { |
| 440 | 76 { XD_LISP_OBJECT, offsetof (specifier_type_entry, symbol) }, |
| 2367 | 77 { XD_BLOCK_PTR, offsetof (specifier_type_entry, meths), 1, |
| 2551 | 78 { &specifier_methods_description } }, |
| 428 | 79 { XD_END } |
| 80 }; | |
| 81 | |
| 1204 | 82 static const struct sized_memory_description ste_description = { |
| 440 | 83 sizeof (specifier_type_entry), |
| 428 | 84 ste_description_1 |
| 85 }; | |
| 86 | |
| 1204 | 87 static const struct memory_description sted_description_1[] = { |
| 440 | 88 XD_DYNARR_DESC (specifier_type_entry_dynarr, &ste_description), |
| 428 | 89 { XD_END } |
| 90 }; | |
| 91 | |
| 1204 | 92 static const struct sized_memory_description sted_description = { |
| 440 | 93 sizeof (specifier_type_entry_dynarr), |
| 428 | 94 sted_description_1 |
| 95 }; | |
| 96 | |
| 97 static Lisp_Object Vspecifier_type_list; | |
| 98 | |
| 99 static Lisp_Object Vcached_specifiers; | |
| 100 /* Do NOT mark through this, or specifiers will never be GC'd. */ | |
| 101 static Lisp_Object Vall_specifiers; | |
| 102 | |
| 103 static Lisp_Object Vunlock_ghost_specifiers; | |
| 104 | |
| 105 /* #### The purpose of this is to check for inheritance loops | |
| 106 in specifiers that can inherit from other specifiers, but it's | |
| 107 not yet implemented. | |
| 108 | |
| 109 #### Look into this for 19.14. */ | |
| 110 /* static Lisp_Object_dynarr current_specifiers; */ | |
| 111 | |
| 112 static void recompute_cached_specifier_everywhere (Lisp_Object specifier); | |
| 113 | |
| 114 EXFUN (Fspecifier_specs, 4); | |
| 115 EXFUN (Fremove_specifier, 4); | |
| 116 | |
| 117 | |
| 118 /************************************************************************/ | |
| 119 /* Specifier object methods */ | |
| 120 /************************************************************************/ | |
| 121 | |
| 122 /* Remove dead objects from the specified assoc list. */ | |
| 123 | |
| 124 static Lisp_Object | |
| 125 cleanup_assoc_list (Lisp_Object list) | |
| 126 { | |
| 127 Lisp_Object loop, prev, retval; | |
| 128 | |
| 129 loop = retval = list; | |
| 130 prev = Qnil; | |
| 131 | |
| 132 while (!NILP (loop)) | |
| 133 { | |
| 134 Lisp_Object entry = XCAR (loop); | |
| 135 Lisp_Object key = XCAR (entry); | |
| 136 | |
| 137 /* remember, dead windows can become alive again. */ | |
| 138 if (!WINDOWP (key) && object_dead_p (key)) | |
| 139 { | |
| 140 if (NILP (prev)) | |
| 141 { | |
| 142 /* Removing the head. */ | |
| 143 retval = XCDR (retval); | |
| 144 } | |
| 145 else | |
| 146 { | |
| 147 Fsetcdr (prev, XCDR (loop)); | |
| 148 } | |
| 149 } | |
| 150 else | |
| 151 prev = loop; | |
| 152 | |
| 153 loop = XCDR (loop); | |
| 154 } | |
| 155 | |
| 156 return retval; | |
| 157 } | |
| 158 | |
| 159 /* Remove dead objects from the various lists so that they | |
| 160 don't keep getting marked as long as this specifier exists and | |
| 161 therefore wasting memory. */ | |
| 162 | |
| 163 void | |
| 164 cleanup_specifiers (void) | |
| 165 { | |
| 166 Lisp_Object rest; | |
| 167 | |
| 168 for (rest = Vall_specifiers; | |
| 169 !NILP (rest); | |
| 170 rest = XSPECIFIER (rest)->next_specifier) | |
| 171 { | |
| 440 | 172 Lisp_Specifier *sp = XSPECIFIER (rest); |
| 428 | 173 /* This effectively changes the specifier specs. |
| 174 However, there's no need to call | |
| 175 recompute_cached_specifier_everywhere() or the | |
| 176 after-change methods because the only specs we | |
| 177 are removing are for dead objects, and they can | |
| 178 never have any effect on the specifier values: | |
| 179 specifiers can only be instantiated over live | |
| 180 objects, and you can't derive a dead object | |
| 181 from a live one. */ | |
| 182 sp->device_specs = cleanup_assoc_list (sp->device_specs); | |
| 183 sp->frame_specs = cleanup_assoc_list (sp->frame_specs); | |
| 184 sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs); | |
| 185 /* windows are handled specially because dead windows | |
| 186 can be resurrected */ | |
| 187 } | |
| 188 } | |
| 189 | |
| 190 void | |
| 191 kill_specifier_buffer_locals (Lisp_Object buffer) | |
| 192 { | |
| 193 Lisp_Object rest; | |
| 194 | |
| 195 for (rest = Vall_specifiers; | |
| 196 !NILP (rest); | |
| 197 rest = XSPECIFIER (rest)->next_specifier) | |
| 198 { | |
| 440 | 199 Lisp_Specifier *sp = XSPECIFIER (rest); |
| 428 | 200 |
| 201 /* Make sure we're actually going to be changing something. | |
| 202 Fremove_specifier() always calls | |
| 203 recompute_cached_specifier_everywhere() (#### but should | |
| 204 be smarter about this). */ | |
| 205 if (!NILP (assq_no_quit (buffer, sp->buffer_specs))) | |
| 206 Fremove_specifier (rest, buffer, Qnil, Qnil); | |
| 207 } | |
| 208 } | |
| 209 | |
| 210 static Lisp_Object | |
| 211 mark_specifier (Lisp_Object obj) | |
| 212 { | |
| 440 | 213 Lisp_Specifier *specifier = XSPECIFIER (obj); |
| 428 | 214 |
| 215 mark_object (specifier->global_specs); | |
| 216 mark_object (specifier->device_specs); | |
| 217 mark_object (specifier->frame_specs); | |
| 218 mark_object (specifier->window_specs); | |
| 219 mark_object (specifier->buffer_specs); | |
| 220 mark_object (specifier->magic_parent); | |
| 221 mark_object (specifier->fallback); | |
| 222 if (!GHOST_SPECIFIER_P (XSPECIFIER (obj))) | |
| 223 MAYBE_SPECMETH (specifier, mark, (obj)); | |
| 224 return Qnil; | |
| 225 } | |
| 226 | |
| 227 /* The idea here is that the specifier specs point to locales | |
| 228 (windows, buffers, frames, and devices), and we want to make sure | |
| 229 that the specs disappear automatically when the associated locale | |
| 230 is no longer in use. For all but windows, "no longer in use" | |
| 231 corresponds exactly to when the object is deleted (non-deleted | |
| 232 objects are always held permanently in special lists, and deleted | |
| 233 objects are never on these lists and never reusable). To handle | |
| 234 this, we just have cleanup_specifiers() called periodically | |
| 235 (at the beginning of garbage collection); it removes all dead | |
| 236 objects. | |
| 237 | |
| 238 For windows, however, it's trickier because dead objects can be | |
| 239 converted to live ones again if the dead object is in a window | |
| 240 configuration. Therefore, for windows, "no longer in use" | |
| 241 corresponds to when the window object is garbage-collected. | |
| 242 We now use weak lists for this purpose. | |
| 243 | |
| 244 */ | |
| 245 | |
| 246 void | |
| 247 prune_specifiers (void) | |
| 248 { | |
| 249 Lisp_Object rest, prev = Qnil; | |
| 250 | |
| 251 for (rest = Vall_specifiers; | |
| 252 !NILP (rest); | |
| 253 rest = XSPECIFIER (rest)->next_specifier) | |
| 254 { | |
| 255 if (! marked_p (rest)) | |
| 256 { | |
| 440 | 257 Lisp_Specifier* sp = XSPECIFIER (rest); |
| 428 | 258 /* A bit of assertion that we're removing both parts of the |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
259 magic one altogether */ |
| 5198 | 260 assert (!MAGIC_SPECIFIER_P (sp) |
| 261 || (BODILY_SPECIFIER_P (sp) && marked_p (sp->fallback)) | |
| 262 || (GHOST_SPECIFIER_P (sp) && marked_p (sp->magic_parent))); | |
| 428 | 263 /* This specifier is garbage. Remove it from the list. */ |
| 264 if (NILP (prev)) | |
| 265 Vall_specifiers = sp->next_specifier; | |
| 266 else | |
| 267 XSPECIFIER (prev)->next_specifier = sp->next_specifier; | |
| 268 } | |
| 269 else | |
| 270 prev = rest; | |
| 271 } | |
| 272 } | |
| 273 | |
| 274 static void | |
| 2286 | 275 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, |
| 276 int UNUSED (escapeflag)) | |
| 428 | 277 { |
| 440 | 278 Lisp_Specifier *sp = XSPECIFIER (obj); |
| 428 | 279 int count = specpdl_depth (); |
| 280 Lisp_Object the_specs; | |
| 281 | |
| 282 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
283 printing_unreadable_object_fmt ("#<%s-specifier 0x%x>", |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
284 sp->methods->name, LISP_OBJECT_UID (obj)); |
| 428 | 285 |
| 800 | 286 write_fmt_string (printcharfun, "#<%s-specifier global=", sp->methods->name); |
| 872 | 287 #if 0 |
| 288 /* #### Not obvious this is useful, and overrides user settings; if we | |
| 289 resurrect this, create variables like `print-specifier-length' so it | |
| 290 can be controlled. */ | |
| 428 | 291 specbind (Qprint_string_length, make_int (100)); |
| 292 specbind (Qprint_length, make_int (5)); | |
| 872 | 293 #endif |
| 428 | 294 the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil); |
| 295 if (NILP (the_specs)) | |
| 296 /* there are no global specs */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
297 write_ascstring (printcharfun, "<unspecified>"); |
| 428 | 298 else |
| 299 print_internal (the_specs, printcharfun, 1); | |
| 300 if (!NILP (sp->fallback)) | |
| 301 { | |
| 800 | 302 write_fmt_string_lisp (printcharfun, " fallback=%S", 1, sp->fallback); |
| 428 | 303 } |
| 771 | 304 unbind_to (count); |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
305 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 306 } |
| 307 | |
| 3263 | 308 #ifndef NEW_GC |
| 428 | 309 static void |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
310 finalize_specifier (Lisp_Object obj) |
| 428 | 311 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
312 Lisp_Specifier *sp = XSPECIFIER (obj); |
| 5198 | 313 if (!GHOST_SPECIFIER_P (sp) && sp->caching) |
| 428 | 314 { |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
315 xfree (sp->caching); |
| 428 | 316 sp->caching = 0; |
| 317 } | |
| 318 } | |
| 3263 | 319 #endif /* not NEW_GC */ |
| 428 | 320 |
| 321 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
322 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
| 428 | 323 { |
| 440 | 324 Lisp_Specifier *s1 = XSPECIFIER (obj1); |
| 325 Lisp_Specifier *s2 = XSPECIFIER (obj2); | |
| 428 | 326 int retval; |
| 327 Lisp_Object old_inhibit_quit = Vinhibit_quit; | |
| 328 | |
| 329 /* This function can be called from within redisplay. | |
| 330 internal_equal can trigger a quit. That leads to Bad Things. */ | |
| 331 Vinhibit_quit = Qt; | |
| 332 | |
| 333 depth++; | |
| 334 retval = | |
| 335 (s1->methods == s2->methods && | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
336 internal_equal_0 (s1->global_specs, s2->global_specs, depth, foldcase) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
337 internal_equal_0 (s1->device_specs, s2->device_specs, depth, foldcase) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
338 internal_equal_0 (s1->frame_specs, s2->frame_specs, depth, foldcase) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
339 internal_equal_0 (s1->window_specs, s2->window_specs, depth, foldcase) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
340 internal_equal_0 (s1->buffer_specs, s2->buffer_specs, depth, foldcase) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
341 internal_equal_0 (s1->fallback, s2->fallback, depth, foldcase)); |
| 428 | 342 |
| 343 if (retval && HAS_SPECMETH_P (s1, equal)) | |
| 344 retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1)); | |
| 345 | |
| 346 Vinhibit_quit = old_inhibit_quit; | |
| 347 return retval; | |
| 348 } | |
| 349 | |
| 2515 | 350 static Hashcode |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5179
diff
changeset
|
351 specifier_hash (Lisp_Object obj, int depth, Boolint equalp) |
| 428 | 352 { |
| 440 | 353 Lisp_Specifier *s = XSPECIFIER (obj); |
| 428 | 354 |
| 355 /* specifier hashing is a bit problematic because there are so | |
| 356 many places where data can be stored. We pick what are perhaps | |
| 357 the most likely places where interesting stuff will be. */ | |
| 358 return HASH5 ((HAS_SPECMETH_P (s, hash) ? | |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5179
diff
changeset
|
359 SPECMETH (s, hash, (obj, depth, equalp)) : 0), |
| 2515 | 360 (Hashcode) s->methods, |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5179
diff
changeset
|
361 internal_hash (s->global_specs, depth + 1, equalp), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5179
diff
changeset
|
362 internal_hash (s->frame_specs, depth + 1, equalp), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5179
diff
changeset
|
363 internal_hash (s->buffer_specs, depth + 1, equalp)); |
| 428 | 364 } |
| 365 | |
| 665 | 366 inline static Bytecount |
| 367 aligned_sizeof_specifier (Bytecount specifier_type_specific_size) | |
| 456 | 368 { |
| 826 | 369 return MAX_ALIGN_SIZE (offsetof (Lisp_Specifier, data) |
| 370 + specifier_type_specific_size); | |
| 456 | 371 } |
| 372 | |
| 665 | 373 static Bytecount |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
374 sizeof_specifier (Lisp_Object obj) |
| 428 | 375 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
376 const Lisp_Specifier *p = XSPECIFIER (obj); |
| 456 | 377 return aligned_sizeof_specifier (GHOST_SPECIFIER_P (p) |
| 378 ? 0 | |
| 379 : p->methods->extra_data_size); | |
| 428 | 380 } |
| 381 | |
| 1204 | 382 static const struct memory_description specifier_methods_description_1[] = { |
| 440 | 383 { XD_LISP_OBJECT, offsetof (struct specifier_methods, predicate_symbol) }, |
| 428 | 384 { XD_END } |
| 385 }; | |
| 386 | |
| 1204 | 387 const struct sized_memory_description specifier_methods_description = { |
| 440 | 388 sizeof (struct specifier_methods), |
| 428 | 389 specifier_methods_description_1 |
| 390 }; | |
| 391 | |
| 1204 | 392 static const struct memory_description specifier_caching_description_1[] = { |
| 428 | 393 { XD_END } |
| 394 }; | |
| 395 | |
| 3092 | 396 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
397 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("specifier-caching", specifier_caching, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
398 0, specifier_caching_description_1, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
399 struct specifier_caching); |
| 3092 | 400 #else /* not NEW_GC */ |
| 1204 | 401 static const struct sized_memory_description specifier_caching_description = { |
| 440 | 402 sizeof (struct specifier_caching), |
| 428 | 403 specifier_caching_description_1 |
| 404 }; | |
| 3092 | 405 #endif /* not NEW_GC */ |
| 428 | 406 |
| 1204 | 407 static const struct sized_memory_description specifier_extra_description_map[] |
| 408 = { | |
| 409 { offsetof (Lisp_Specifier, methods) }, | |
| 410 { offsetof (struct specifier_methods, extra_description) }, | |
| 411 { -1 }, | |
| 412 }; | |
| 413 | |
| 414 const struct memory_description specifier_description[] = { | |
| 2367 | 415 { XD_BLOCK_PTR, offsetof (Lisp_Specifier, methods), 1, |
| 2551 | 416 { &specifier_methods_description } }, |
| 440 | 417 { XD_LO_LINK, offsetof (Lisp_Specifier, next_specifier) }, |
| 418 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) }, | |
| 419 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) }, | |
| 420 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) }, | |
| 421 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) }, | |
| 422 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) }, | |
| 3092 | 423 #ifdef NEW_GC |
| 424 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, caching) }, | |
| 425 #else /* not NEW_GC */ | |
| 2367 | 426 { XD_BLOCK_PTR, offsetof (Lisp_Specifier, caching), 1, |
| 2551 | 427 { &specifier_caching_description } }, |
| 3092 | 428 #endif /* not NEW_GC */ |
| 440 | 429 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) }, |
| 430 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) }, | |
| 2367 | 431 { XD_BLOCK_ARRAY, offsetof (Lisp_Specifier, data), 1, |
| 2551 | 432 { specifier_extra_description_map } }, |
| 428 | 433 { XD_END } |
| 434 }; | |
| 435 | |
| 1204 | 436 static const struct memory_description specifier_empty_extra_description_1[] = |
| 3659 | 437 { |
| 438 { XD_END } | |
| 439 }; | |
| 1204 | 440 |
| 441 const struct sized_memory_description specifier_empty_extra_description = { | |
| 442 0, specifier_empty_extra_description_1 | |
| 443 }; | |
| 444 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
445 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("specifier", specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
446 mark_specifier, print_specifier, |
|
5169
6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
447 IF_OLD_GC (finalize_specifier), |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
448 specifier_equal, specifier_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
449 specifier_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
450 sizeof_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
451 Lisp_Specifier); |
| 428 | 452 |
| 453 /************************************************************************/ | |
| 454 /* Creating specifiers */ | |
| 455 /************************************************************************/ | |
| 456 | |
| 457 static struct specifier_methods * | |
| 578 | 458 decode_specifier_type (Lisp_Object type, Error_Behavior errb) |
| 428 | 459 { |
| 460 int i; | |
| 461 | |
| 462 for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++) | |
| 463 { | |
| 464 if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol)) | |
| 465 return Dynarr_at (the_specifier_type_entry_dynarr, i).meths; | |
| 466 } | |
| 467 | |
| 563 | 468 maybe_invalid_argument ("Invalid specifier type", |
| 3659 | 469 type, Qspecifier, errb); |
| 428 | 470 |
| 471 return 0; | |
| 472 } | |
| 473 | |
| 474 static int | |
| 475 valid_specifier_type_p (Lisp_Object type) | |
| 476 { | |
| 477 return decode_specifier_type (type, ERROR_ME_NOT) != 0; | |
| 478 } | |
| 479 | |
| 480 DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /* | |
| 481 Given a SPECIFIER-TYPE, return non-nil if it is valid. | |
| 2953 | 482 Valid types are `generic', `integer', `boolean', `color', `font', `image', |
| 483 `face-boolean', and `toolbar'. | |
| 428 | 484 */ |
| 485 (specifier_type)) | |
| 486 { | |
| 487 return valid_specifier_type_p (specifier_type) ? Qt : Qnil; | |
| 488 } | |
| 489 | |
| 490 DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /* | |
| 491 Return a list of valid specifier types. | |
| 492 */ | |
| 493 ()) | |
| 494 { | |
| 495 return Fcopy_sequence (Vspecifier_type_list); | |
| 496 } | |
| 497 | |
| 498 void | |
| 499 add_entry_to_specifier_type_list (Lisp_Object symbol, | |
| 500 struct specifier_methods *meths) | |
| 501 { | |
| 502 struct specifier_type_entry entry; | |
| 503 | |
| 504 entry.symbol = symbol; | |
| 505 entry.meths = meths; | |
| 506 Dynarr_add (the_specifier_type_entry_dynarr, entry); | |
| 507 Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list); | |
| 508 } | |
| 509 | |
| 510 static Lisp_Object | |
| 511 make_specifier_internal (struct specifier_methods *spec_meths, | |
| 665 | 512 Bytecount data_size, int call_create_meth) |
| 428 | 513 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
514 Lisp_Object specifier = |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
515 ALLOC_SIZED_LISP_OBJECT (aligned_sizeof_specifier (data_size), specifier); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
516 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 517 |
| 518 sp->methods = spec_meths; | |
| 519 sp->global_specs = Qnil; | |
| 520 sp->device_specs = Qnil; | |
| 521 sp->frame_specs = Qnil; | |
| 522 sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC); | |
| 523 sp->buffer_specs = Qnil; | |
| 524 sp->fallback = Qnil; | |
| 525 sp->magic_parent = Qnil; | |
| 526 sp->caching = 0; | |
| 527 sp->next_specifier = Vall_specifiers; | |
| 528 | |
| 529 Vall_specifiers = specifier; | |
| 530 | |
| 531 if (call_create_meth) | |
| 532 { | |
| 533 struct gcpro gcpro1; | |
| 534 GCPRO1 (specifier); | |
| 535 MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier)); | |
| 536 UNGCPRO; | |
| 537 } | |
| 538 return specifier; | |
| 539 } | |
| 540 | |
| 541 static Lisp_Object | |
| 542 make_specifier (struct specifier_methods *meths) | |
| 543 { | |
| 544 return make_specifier_internal (meths, meths->extra_data_size, 1); | |
| 545 } | |
| 546 | |
| 547 Lisp_Object | |
| 548 make_magic_specifier (Lisp_Object type) | |
| 549 { | |
| 550 /* This function can GC */ | |
| 551 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 552 Lisp_Object bodily, ghost; | |
| 553 struct gcpro gcpro1; | |
| 554 | |
| 555 bodily = make_specifier (meths); | |
| 556 GCPRO1 (bodily); | |
| 557 ghost = make_specifier_internal (meths, 0, 0); | |
| 558 UNGCPRO; | |
| 559 | |
| 560 /* Connect guys together */ | |
| 5198 | 561 XSPECIFIER (bodily)->magic_parent = Qt; |
| 562 XSPECIFIER (bodily)->fallback = ghost; | |
| 563 XSPECIFIER (ghost)->magic_parent = bodily; | |
| 428 | 564 |
| 565 return bodily; | |
| 566 } | |
| 567 | |
| 568 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /* | |
| 569 Return a new specifier object of type TYPE. | |
| 570 | |
| 571 A specifier is an object that can be used to keep track of a property | |
| 572 whose value can be per-buffer, per-window, per-frame, or per-device, | |
| 442 | 573 and can further be restricted to a particular console-type or |
| 574 device-class. Specifiers are used, for example, for the various | |
| 575 built-in properties of a face; this allows a face to have different | |
| 576 values in different frames, buffers, etc. | |
| 577 | |
| 578 When speaking of the value of a specifier, it is important to | |
| 579 distinguish between the *setting* of a specifier, called an | |
| 580 \"instantiator\", and the *actual value*, called an \"instance\". You | |
| 581 put various possible instantiators (i.e. settings) into a specifier | |
| 582 and associate them with particular locales (buffer, window, frame, | |
| 583 device, global), and then the instance (i.e. actual value) is | |
| 584 retrieved in a specific domain (window, frame, device) by looking | |
| 585 through the possible instantiators (i.e. settings). This process is | |
| 586 called \"instantiation\". | |
| 444 | 587 |
| 442 | 588 To put settings into a specifier, use `set-specifier', or the |
| 589 lower-level functions `add-spec-to-specifier' and | |
| 590 `add-spec-list-to-specifier'. You can also temporarily bind a setting | |
| 591 to a specifier using `let-specifier'. To retrieve settings, use | |
| 592 `specifier-specs', or its lower-level counterpart | |
| 2953 | 593 `specifier-spec-list'. |
| 594 | |
| 595 To determine the actual value (i.e. the instance) in a particular domain, use | |
| 596 `specifier-instance'. To determine the corresponding setting that yielded | |
| 597 the value (i.e. the instantiator), use `specifier-instantiator'. | |
| 442 | 598 |
| 599 For more information, see `set-specifier', `specifier-instance', | |
| 428 | 600 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed |
| 442 | 601 description of specifiers, including how exactly the instantiation |
| 602 process works, see the chapter on specifiers in the XEmacs Lisp | |
| 603 Reference Manual. | |
| 428 | 604 |
| 605 TYPE specifies the particular type of specifier, and should be one of | |
| 2953 | 606 the symbols `generic', `integer', `natnum', `boolean', `color', `font', |
| 607 `image', `face-boolean', `display-table', `gutter', `gutter-size', | |
| 608 `gutter-visible' or `toolbar'. | |
| 442 | 609 |
| 610 For more information on particular types of specifiers, see the | |
| 611 functions `make-generic-specifier', `make-integer-specifier', | |
| 612 `make-natnum-specifier', `make-boolean-specifier', | |
| 613 `make-color-specifier', `make-font-specifier', `make-image-specifier', | |
| 614 `make-face-boolean-specifier', `make-gutter-size-specifier', | |
| 615 `make-gutter-visible-specifier', `default-toolbar', `default-gutter', | |
| 616 and `current-display-table'. | |
| 428 | 617 */ |
| 618 (type)) | |
| 619 { | |
| 620 /* This function can GC */ | |
| 442 | 621 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); |
| 428 | 622 |
| 623 return make_specifier (meths); | |
| 624 } | |
| 625 | |
| 626 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /* | |
| 627 Return t if OBJECT is a specifier. | |
| 628 | |
| 629 A specifier is an object that can be used to keep track of a property | |
| 630 whose value can be per-buffer, per-window, per-frame, or per-device, | |
| 631 and can further be restricted to a particular console-type or device-class. | |
| 632 See `make-specifier'. | |
| 633 */ | |
| 634 (object)) | |
| 635 { | |
| 636 return SPECIFIERP (object) ? Qt : Qnil; | |
| 637 } | |
| 638 | |
| 639 DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /* | |
| 640 Return the type of SPECIFIER. | |
| 641 */ | |
| 642 (specifier)) | |
| 643 { | |
| 644 CHECK_SPECIFIER (specifier); | |
| 645 return intern (XSPECIFIER (specifier)->methods->name); | |
| 646 } | |
| 647 | |
| 648 | |
| 649 /************************************************************************/ | |
| 650 /* Locales and domains */ | |
| 651 /************************************************************************/ | |
| 652 | |
| 653 DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /* | |
| 654 Return t if LOCALE is a valid specifier locale. | |
| 2953 | 655 Valid locales are devices, frames, windows, buffers, and `global'. |
| 428 | 656 \(nil is not valid.) |
| 657 */ | |
| 658 (locale)) | |
| 659 { | |
| 660 /* This cannot GC. */ | |
| 661 return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) || | |
| 662 (FRAMEP (locale) && FRAME_LIVE_P (XFRAME (locale))) || | |
| 663 (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) || | |
| 664 /* dead windows are allowed because they may become live | |
| 665 windows again when a window configuration is restored */ | |
| 666 WINDOWP (locale) || | |
| 667 EQ (locale, Qglobal)) | |
| 668 ? Qt : Qnil; | |
| 669 } | |
| 670 | |
| 671 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /* | |
| 672 Return t if DOMAIN is a valid specifier domain. | |
| 2953 | 673 A domain is used to instantiate a specifier (i.e. determine the specifier's |
| 442 | 674 value in that domain). Valid domains are image instances, windows, frames, |
| 675 and devices. \(nil is not valid.) image instances are pseudo-domains since | |
| 676 instantiation will actually occur in the window the image instance itself is | |
| 677 instantiated in. | |
| 428 | 678 */ |
| 3659 | 679 (domain)) |
| 428 | 680 { |
| 681 /* This cannot GC. */ | |
| 682 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) || | |
| 683 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) || | |
| 442 | 684 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))) || |
| 685 /* #### get image instances out of domains! */ | |
| 686 IMAGE_INSTANCEP (domain)) | |
| 428 | 687 ? Qt : Qnil; |
| 688 } | |
| 689 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
690 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, |
| 3659 | 691 1, 0, /* |
| 428 | 692 Given a specifier LOCALE-TYPE, return non-nil if it is valid. |
| 2953 | 693 Valid locale types are `global', `device', `frame', `window', and `buffer'. |
| 428 | 694 \(Note, however, that in functions that accept either a locale or a locale |
| 2953 | 695 type, `global' is considered an individual locale.) |
| 428 | 696 */ |
| 3659 | 697 (locale_type)) |
| 428 | 698 { |
| 699 /* This cannot GC. */ | |
| 700 return (EQ (locale_type, Qglobal) || | |
| 701 EQ (locale_type, Qdevice) || | |
| 702 EQ (locale_type, Qframe) || | |
| 703 EQ (locale_type, Qwindow) || | |
| 704 EQ (locale_type, Qbuffer)) ? Qt : Qnil; | |
| 705 } | |
| 706 | |
| 707 static void | |
| 708 check_valid_locale_or_locale_type (Lisp_Object locale) | |
| 709 { | |
| 710 /* This cannot GC. */ | |
| 711 if (EQ (locale, Qall) || | |
| 712 !NILP (Fvalid_specifier_locale_p (locale)) || | |
| 713 !NILP (Fvalid_specifier_locale_type_p (locale))) | |
| 714 return; | |
| 563 | 715 invalid_argument ("Invalid specifier locale or locale type", locale); |
| 428 | 716 } |
| 717 | |
| 718 DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale, | |
| 719 1, 1, 0, /* | |
| 720 Given a specifier LOCALE, return its type. | |
| 721 */ | |
| 722 (locale)) | |
| 723 { | |
| 724 /* This cannot GC. */ | |
| 725 if (NILP (Fvalid_specifier_locale_p (locale))) | |
| 563 | 726 invalid_argument ("Invalid specifier locale", |
| 3659 | 727 locale); |
| 428 | 728 if (DEVICEP (locale)) return Qdevice; |
| 729 if (FRAMEP (locale)) return Qframe; | |
| 730 if (WINDOWP (locale)) return Qwindow; | |
| 731 if (BUFFERP (locale)) return Qbuffer; | |
| 732 assert (EQ (locale, Qglobal)); | |
| 733 return Qglobal; | |
| 734 } | |
| 735 | |
| 736 static Lisp_Object | |
| 737 decode_locale (Lisp_Object locale) | |
| 738 { | |
| 739 /* This cannot GC. */ | |
| 740 if (NILP (locale)) | |
| 741 return Qglobal; | |
| 742 else if (!NILP (Fvalid_specifier_locale_p (locale))) | |
| 743 return locale; | |
| 744 else | |
| 563 | 745 invalid_argument ("Invalid specifier locale", |
| 3659 | 746 locale); |
| 428 | 747 |
| 748 return Qnil; | |
| 749 } | |
| 750 | |
| 751 static enum spec_locale_type | |
| 752 decode_locale_type (Lisp_Object locale_type) | |
| 753 { | |
| 754 /* This cannot GC. */ | |
| 755 if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL; | |
| 756 if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE; | |
| 757 if (EQ (locale_type, Qframe)) return LOCALE_FRAME; | |
| 758 if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW; | |
| 759 if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER; | |
| 760 | |
| 563 | 761 invalid_argument ("Invalid specifier locale type", |
| 3659 | 762 locale_type); |
| 1204 | 763 RETURN_NOT_REACHED (LOCALE_GLOBAL); |
| 428 | 764 } |
| 765 | |
| 766 Lisp_Object | |
| 767 decode_locale_list (Lisp_Object locale) | |
| 768 { | |
| 769 /* This cannot GC. */ | |
| 770 /* The return value of this function must be GCPRO'd. */ | |
| 771 if (NILP (locale)) | |
| 772 { | |
| 773 return list1 (Qall); | |
| 774 } | |
| 775 else if (CONSP (locale)) | |
| 776 { | |
| 777 EXTERNAL_LIST_LOOP_2 (elt, locale) | |
| 778 check_valid_locale_or_locale_type (elt); | |
| 779 return locale; | |
| 780 } | |
| 781 else | |
| 782 { | |
| 783 check_valid_locale_or_locale_type (locale); | |
| 784 return list1 (locale); | |
| 785 } | |
| 786 } | |
| 787 | |
| 788 static enum spec_locale_type | |
| 789 locale_type_from_locale (Lisp_Object locale) | |
| 790 { | |
| 791 return decode_locale_type (Fspecifier_locale_type_from_locale (locale)); | |
| 792 } | |
| 793 | |
| 794 static void | |
| 795 check_valid_domain (Lisp_Object domain) | |
| 796 { | |
| 797 if (NILP (Fvalid_specifier_domain_p (domain))) | |
| 563 | 798 invalid_argument ("Invalid specifier domain", |
| 3659 | 799 domain); |
| 428 | 800 } |
| 801 | |
| 442 | 802 Lisp_Object |
| 428 | 803 decode_domain (Lisp_Object domain) |
| 804 { | |
| 805 if (NILP (domain)) | |
| 806 return Fselected_window (Qnil); | |
| 807 check_valid_domain (domain); | |
| 808 return domain; | |
| 809 } | |
| 810 | |
| 811 | |
| 812 /************************************************************************/ | |
| 813 /* Tags */ | |
| 814 /************************************************************************/ | |
| 815 | |
| 816 DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /* | |
| 817 Return non-nil if TAG is a valid specifier tag. | |
| 818 See also `valid-specifier-tag-set-p'. | |
| 819 */ | |
| 820 (tag)) | |
| 821 { | |
| 822 return (valid_console_type_p (tag) || | |
| 823 valid_device_class_p (tag) || | |
| 824 !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil; | |
| 825 } | |
| 826 | |
| 827 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /* | |
| 828 Return non-nil if TAG-SET is a valid specifier tag set. | |
| 829 | |
| 3659 | 830 A specifier tag set is an entity that is attached to an instantiator and can |
| 831 be used to restrict the scope of that instantiator to a particular device | |
| 832 class, device type, or charset. It can also be used to mark instantiators | |
| 833 added by a particular package so that they can be later removed as a group. | |
| 428 | 834 |
| 835 A specifier tag set consists of a list of zero of more specifier tags, | |
| 836 each of which is a symbol that is recognized by XEmacs as a tag. | |
| 837 \(The valid device types and device classes are always tags, as are | |
| 838 any tags defined by `define-specifier-tag'.) It is called a "tag set" | |
| 839 \(as opposed to a list) because the order of the tags or the number of | |
| 840 times a particular tag occurs does not matter. | |
| 841 | |
| 3659 | 842 Each tag has two predicates associated with it, which specify, respectively, |
| 843 whether that tag applies to a particular device and whether it applies to a | |
| 844 particular character set. The predefined tags which are device types and | |
| 845 classes match devices of that type or class. User-defined tags can have any | |
| 846 device predicate, or none (meaning that all devices match). When attempting | |
| 847 to instantiate a specifier, a particular instantiator is only considered if | |
| 848 the device of the domain being instantiated over matches all tags in the tag | |
| 849 set attached to that instantiator. | |
| 850 | |
| 851 If a charset is to be considered--which is only the case for face | |
| 852 instantiators--this consideration may be done twice. The first iteration | |
| 853 pays attention to the character set predicates; if no instantiator can be | |
| 854 found in that case, the search is repeated ignoring the character set | |
| 855 predicates. | |
| 428 | 856 |
| 857 Most of the time, a tag set is not specified, and the instantiator | |
| 858 gets a null tag set, which matches all devices. | |
| 859 */ | |
| 3659 | 860 (tag_set)) |
| 428 | 861 { |
| 862 Lisp_Object rest; | |
| 863 | |
| 864 for (rest = tag_set; !NILP (rest); rest = XCDR (rest)) | |
| 865 { | |
| 866 if (!CONSP (rest)) | |
| 867 return Qnil; | |
| 868 if (NILP (Fvalid_specifier_tag_p (XCAR (rest)))) | |
| 869 return Qnil; | |
| 870 QUIT; | |
| 871 } | |
| 872 return Qt; | |
| 873 } | |
| 874 | |
| 875 Lisp_Object | |
| 876 decode_specifier_tag_set (Lisp_Object tag_set) | |
| 877 { | |
| 878 /* The return value of this function must be GCPRO'd. */ | |
| 879 if (!NILP (Fvalid_specifier_tag_p (tag_set))) | |
| 880 return list1 (tag_set); | |
| 881 if (NILP (Fvalid_specifier_tag_set_p (tag_set))) | |
| 563 | 882 invalid_argument ("Invalid specifier tag-set", |
| 3659 | 883 tag_set); |
| 428 | 884 return tag_set; |
| 885 } | |
| 886 | |
| 887 static Lisp_Object | |
| 888 canonicalize_tag_set (Lisp_Object tag_set) | |
| 889 { | |
| 890 int len = XINT (Flength (tag_set)); | |
| 891 Lisp_Object *tags, rest; | |
| 892 int i, j; | |
| 893 | |
| 894 /* We assume in this function that the tag_set has already been | |
| 895 validated, so there are no surprises. */ | |
| 896 | |
| 897 if (len == 0 || len == 1) | |
| 898 /* most common case */ | |
| 899 return tag_set; | |
| 900 | |
| 901 tags = alloca_array (Lisp_Object, len); | |
| 902 | |
| 903 i = 0; | |
| 904 LIST_LOOP (rest, tag_set) | |
| 905 tags[i++] = XCAR (rest); | |
| 906 | |
| 907 /* Sort the list of tags. We use a bubble sort here (copied from | |
| 908 extent_fragment_update()) -- reduces the function call overhead, | |
| 909 and is the fastest sort for small numbers of items. */ | |
| 910 | |
| 911 for (i = 1; i < len; i++) | |
| 912 { | |
| 913 j = i - 1; | |
| 914 while (j >= 0 && | |
| 793 | 915 qxestrcmp (XSTRING_DATA (XSYMBOL (tags[j])->name), |
| 916 XSTRING_DATA (XSYMBOL (tags[j+1])->name)) > 0) | |
| 428 | 917 { |
| 918 Lisp_Object tmp = tags[j]; | |
| 919 tags[j] = tags[j+1]; | |
| 920 tags[j+1] = tmp; | |
| 921 j--; | |
| 922 } | |
| 923 } | |
| 924 | |
| 925 /* Now eliminate duplicates. */ | |
| 926 | |
| 927 for (i = 1, j = 1; i < len; i++) | |
| 928 { | |
| 929 /* j holds the destination, i the source. */ | |
| 930 if (!EQ (tags[i], tags[i-1])) | |
| 931 tags[j++] = tags[i]; | |
| 932 } | |
| 933 | |
| 934 return Flist (j, tags); | |
| 935 } | |
| 936 | |
| 937 DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /* | |
| 938 Canonicalize the given tag set. | |
| 939 Two canonicalized tag sets can be compared with `equal' to see if they | |
| 940 represent the same tag set. (Specifically, canonicalizing involves | |
| 941 sorting by symbol name and removing duplicates.) | |
| 942 */ | |
| 943 (tag_set)) | |
| 944 { | |
| 945 if (NILP (Fvalid_specifier_tag_set_p (tag_set))) | |
| 563 | 946 invalid_argument ("Invalid tag set", tag_set); |
| 428 | 947 return canonicalize_tag_set (tag_set); |
| 948 } | |
| 949 | |
| 950 static int | |
| 951 device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set) | |
| 952 { | |
| 953 Lisp_Object devtype, devclass, rest; | |
| 954 struct device *d = XDEVICE (device); | |
| 955 | |
| 956 devtype = DEVICE_TYPE (d); | |
| 957 devclass = DEVICE_CLASS (d); | |
| 958 | |
| 959 LIST_LOOP (rest, tag_set) | |
| 960 { | |
| 961 Lisp_Object tag = XCAR (rest); | |
| 962 Lisp_Object assoc; | |
| 963 | |
| 964 if (EQ (tag, devtype) || EQ (tag, devclass)) | |
| 965 continue; | |
| 966 assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d)); | |
| 967 /* other built-in tags (device types/classes) are not in | |
| 968 the user-defined-tags list. */ | |
| 969 if (NILP (assoc) || NILP (XCDR (assoc))) | |
| 970 return 0; | |
| 971 } | |
| 972 | |
| 973 return 1; | |
| 974 } | |
| 975 | |
| 3659 | 976 static int |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
977 charset_matches_specifier_tag_set_p (Lisp_Object charset, Lisp_Object tag_set, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
978 enum font_specifier_matchspec_stages |
| 3659 | 979 stage) |
| 980 { | |
| 981 Lisp_Object rest; | |
| 982 int res = 0; | |
| 983 | |
| 5198 | 984 assert (stage < NUM_MATCHSPEC_STAGES); |
| 3659 | 985 |
| 986 LIST_LOOP (rest, tag_set) | |
| 987 { | |
| 988 Lisp_Object tag = XCAR (rest); | |
| 989 Lisp_Object assoc; | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
990 Lisp_Object tag_list = Fgethash (charset, Vcharset_tag_lists, Qnil); |
| 3659 | 991 |
| 3736 | 992 /* In the event that, during the creation of a charset, no specifier |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
993 tags exist for which CHARSET-PREDICATE has been specified, then |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
994 that charset's entry in Vcharset_tag_lists will be nil, and this |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
995 charset shouldn't match. */ |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
996 |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
997 if (NILP (tag_list)) |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
998 { |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
999 return 0; |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1000 } |
| 3659 | 1001 |
| 1002 /* Now, find out what the pre-calculated value is. */ | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1003 assoc = assq_no_quit (tag, tag_list); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1004 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1005 if (!(NILP (assoc))) |
| 3659 | 1006 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1007 assert (VECTORP (XCDR (assoc))); |
| 3659 | 1008 |
| 1009 /* In the event that a tag specifies a charset, then the specifier | |
| 1010 must match for (this stage and this charset) for all | |
| 1011 charset-specifying tags. */ | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1012 if (NILP (XVECTOR_DATA (XCDR (assoc))[stage])) |
| 3659 | 1013 { |
| 1014 /* It doesn't match for this tag, even though the tag | |
| 1015 specifies a charset. Return 0. */ | |
| 1016 return 0; | |
| 1017 } | |
| 1018 | |
| 1019 /* This tag specifies charset limitations, and this charset and | |
| 1020 stage match those charset limitations. | |
| 1021 | |
| 1022 In the event that a later tag specifies charset limitations | |
| 1023 that don't match, the return 0 above prevents us giving a | |
| 1024 positive match. */ | |
| 1025 res = 1; | |
| 1026 } | |
| 1027 } | |
| 1028 | |
| 1029 return res; | |
| 1030 } | |
| 1031 | |
| 1032 | |
| 442 | 1033 DEFUN ("device-matches-specifier-tag-set-p", |
| 1034 Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /* | |
| 428 | 1035 Return non-nil if DEVICE matches specifier tag set TAG-SET. |
| 1036 This means that DEVICE matches each tag in the tag set. (Every | |
| 1037 tag recognized by XEmacs has a predicate associated with it that | |
| 1038 specifies which devices match it.) | |
| 1039 */ | |
| 1040 (device, tag_set)) | |
| 1041 { | |
| 1042 CHECK_LIVE_DEVICE (device); | |
| 1043 | |
| 1044 if (NILP (Fvalid_specifier_tag_set_p (tag_set))) | |
| 563 | 1045 invalid_argument ("Invalid tag set", tag_set); |
| 428 | 1046 |
| 1047 return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil; | |
| 1048 } | |
| 1049 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1050 /* Call CHARSET_PREDICATE on CHARSET, evaluating it at both stages (initial |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1051 and final) and returning a size-two vector of the results. */ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1052 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1053 static Lisp_Object |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1054 call_charset_predicate (Lisp_Object charset_predicate, Lisp_Object charset) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1055 { |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1056 struct gcpro gcpro1; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1057 Lisp_Object charpres = make_vector (NUM_MATCHSPEC_STAGES, Qnil); |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5015
diff
changeset
|
1058 int max_args = XINT (Ffunction_max_args (charset_predicate)); |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1059 GCPRO1 (charpres); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1060 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1061 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1062 #define DEFINE_SPECIFIER_TAG_FROB(stage, enumstage) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1063 do { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1064 if (max_args > 1) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1065 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1066 XVECTOR_DATA (charpres)[enumstage] = \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1067 call2_trapping_problems \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1068 ("Error during specifier tag charset predicate," \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1069 " stage " #stage, charset_predicate, \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1070 charset, Q##stage, 0); \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1071 } \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1072 else \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1073 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1074 XVECTOR_DATA (charpres)[enumstage] = \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1075 call1_trapping_problems \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1076 ("Error during specifier tag charset predicate," \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1077 " stage " #stage, charset_predicate, \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1078 charset, 0); \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1079 } \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1080 \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1081 if (UNBOUNDP (XVECTOR_DATA (charpres)[enumstage])) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1082 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1083 XVECTOR_DATA (charpres)[enumstage] = Qnil; \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1084 } \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1085 else if (!NILP (XVECTOR_DATA (charpres)[enumstage])) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1086 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1087 /* Don't want refs to random other objects. */ \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1088 XVECTOR_DATA (charpres)[enumstage] = Qt; \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1089 } \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1090 } while (0) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1091 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1092 DEFINE_SPECIFIER_TAG_FROB (initial, STAGE_INITIAL); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1093 DEFINE_SPECIFIER_TAG_FROB (final, STAGE_FINAL); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1094 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1095 #undef DEFINE_SPECIFIER_TAG_FROB |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1096 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1097 UNGCPRO; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1098 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1099 return charpres; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1100 } |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1101 |
| 3659 | 1102 Lisp_Object |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1103 define_specifier_tag (Lisp_Object tag, Lisp_Object device_predicate, |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1104 Lisp_Object charset_predicate) |
| 428 | 1105 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1106 Lisp_Object assoc = assq_no_quit (tag, Vuser_defined_tags), |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1107 concons, devcons; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1108 int recompute_devices = 0, recompute_charsets = 0; |
| 3659 | 1109 |
| 428 | 1110 if (NILP (assoc)) |
| 1111 { | |
| 3659 | 1112 recompute_devices = recompute_charsets = 1; |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1113 Vuser_defined_tags = Fcons (list3 (tag, device_predicate, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1114 charset_predicate), |
| 3659 | 1115 Vuser_defined_tags); |
| 428 | 1116 DEVICE_LOOP_NO_BREAK (devcons, concons) |
| 1117 { | |
| 1118 struct device *d = XDEVICE (XCAR (devcons)); | |
| 1119 /* Initially set the value to t in case of error | |
| 3659 | 1120 in device_predicate */ |
| 428 | 1121 DEVICE_USER_DEFINED_TAGS (d) = |
| 1122 Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d)); | |
| 1123 } | |
| 1124 } | |
| 3659 | 1125 else if (!NILP (device_predicate) && !NILP (XCADR (assoc))) |
| 428 | 1126 { |
| 3659 | 1127 recompute_devices = 1; |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1128 XCDR (assoc) = list2 (device_predicate, charset_predicate); |
| 428 | 1129 } |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1130 else if (!NILP (charset_predicate) || !NILP (XCADDR (assoc))) |
| 3659 | 1131 { |
| 1132 /* If there exists a charset_predicate for the tag currently (even if | |
| 1133 the new charset_predicate is nil), or if we're adding one, we need | |
| 1134 to recompute. This contrasts with the device predicates, where we | |
| 1135 don't need to recompute if the old and new device predicates are | |
| 1136 both nil. */ | |
| 1137 | |
| 1138 recompute_charsets = 1; | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1139 XCDR (assoc) = list2 (device_predicate, charset_predicate); |
| 3659 | 1140 } |
| 1141 | |
| 1142 /* Recompute the tag values for all devices and charsets, if necessary. In | |
| 1143 the special case where both the old and new device_predicates are nil, | |
| 1144 we know that we don't have to do it for the device. (It's probably | |
| 1145 common for people to call (define-specifier-tag) more than once on the | |
| 1146 same tag, and the most common case is where DEVICE_PREDICATE is not | |
| 1147 specified.) */ | |
| 1148 | |
| 1149 if (recompute_devices) | |
| 428 | 1150 { |
| 1151 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 1152 { | |
| 1153 Lisp_Object device = XCAR (devcons); | |
| 1154 assoc = assq_no_quit (tag, | |
| 1155 DEVICE_USER_DEFINED_TAGS (XDEVICE (device))); | |
| 1156 assert (CONSP (assoc)); | |
| 3659 | 1157 if (NILP (device_predicate)) |
| 428 | 1158 XCDR (assoc) = Qt; |
| 1159 else | |
| 3659 | 1160 XCDR (assoc) = !NILP (call1 (device_predicate, device)) ? Qt |
| 1161 : Qnil; | |
| 428 | 1162 } |
| 1163 } | |
| 1164 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1165 if (recompute_charsets) |
| 3659 | 1166 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1167 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1168 LIST_LOOP_2 (charset_name, Fcharset_list ()) |
| 3659 | 1169 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1170 Lisp_Object charset = Fget_charset (charset_name); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1171 Lisp_Object tag_list = Fgethash (charset, Vcharset_tag_lists, Qnil); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1172 Lisp_Object charpres; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1173 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1174 if (NILP (charset_predicate)) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1175 continue; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1176 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1177 charpres = call_charset_predicate (charset_predicate, charset); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1178 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1179 assoc = assq_no_quit (tag, tag_list); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1180 if (!NILP (assoc)) |
| 3659 | 1181 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1182 assert (CONSP (assoc)); |
| 3659 | 1183 XCDR (assoc) = charpres; |
| 1184 } | |
| 1185 else | |
| 1186 { | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1187 Fputhash (charset, Fcons (Fcons (tag, charpres), tag_list), |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1188 Vcharset_tag_lists); |
| 3659 | 1189 } |
| 1190 } | |
| 1191 } | |
| 1192 return Qt; | |
| 1193 } | |
| 1194 | |
| 1195 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 3, 0, /* | |
| 1196 Define a new specifier tag. | |
| 1197 | |
| 1198 If DEVICE-PREDICATE is specified, it should be a function of one argument | |
| 1199 \(a device) that specifies whether the tag matches that particular device. | |
| 1200 If DEVICE-PREDICATE is omitted, the tag matches all devices. | |
| 1201 | |
| 1202 If CHARSET-PREDICATE is supplied, it should be a function taking a single | |
| 1203 Lisp character set argument. A tag's charset predicate is primarily used to | |
| 1204 determine what font to use for a given \(set of) charset\(s) when that tag | |
| 1205 is used in a set-face-font call; a non-nil return value indicates that the | |
| 1206 tag matches the charset. | |
| 1207 | |
| 1208 The font matching process also has a concept of stages; the defined stages | |
| 1209 are currently `initial' and `final', and there exist specifier tags with | |
| 1210 those names that correspond to those stages. On X11, 'initial is used when | |
| 1211 the font matching process is looking for fonts that match the desired | |
| 1212 registries of the charset--see the `charset-registries' function. If that | |
| 1213 match process fails, then the 'final tag becomes relevant; this means that a | |
| 1214 more general lookup is desired, and that a font doesn't necessarily have to | |
| 1215 match the desired XLFD for the face, just the charset repertoire for this | |
| 1216 charset. It also means that the charset registry and encoding used will be | |
| 1217 `iso10646-1', and the characters will be converted to display using that | |
| 1218 registry. | |
| 1219 | |
| 1220 If a tag set matches no character set; the two-stage match process will | |
| 1221 ignore the tag on its first pass, but if no match is found, it will respect | |
| 1222 it on the second pass, where character set information is ignored. | |
| 1223 | |
| 1224 You can redefine an existing user-defined specifier tag. However, you | |
| 1225 cannot redefine most of the built-in specifier tags \(the device types and | |
| 1226 classes, `initial', and `final') or the symbols nil, t, `all', or `global'. | |
| 1227 Note that if a device type is not supported in this XEmacs, it will not be | |
| 1228 available as a built-in specifier tag; this is probably something we should | |
| 1229 change. | |
| 1230 */ | |
| 1231 (tag, device_predicate, charset_predicate)) | |
| 1232 { | |
| 1233 CHECK_SYMBOL (tag); | |
| 1234 if (valid_device_class_p (tag) || | |
| 1235 valid_console_type_p (tag) || | |
| 1236 EQ (tag, Qinitial) || EQ (tag, Qfinal)) | |
| 1237 invalid_change ("Cannot redefine built-in specifier tags", tag); | |
| 1238 /* Try to prevent common instantiators and locales from being | |
| 1239 redefined, to reduce ambiguity */ | |
| 1240 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal)) | |
| 1241 invalid_change ("Cannot define nil, t, `all', or `global'", tag); | |
| 1242 | |
| 1243 if (!NILP (charset_predicate)) | |
| 1244 { | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1245 Lisp_Object min_args = Ffunction_min_args (charset_predicate); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1246 Lisp_Object max_args = Ffunction_max_args (charset_predicate); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1247 if (!(INTP (min_args) && XINT (min_args) == 1 && |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1248 INTP (max_args) && XINT (max_args) == 1)) |
| 3659 | 1249 { |
| 1250 /* We only allow the stage argument to be specifed from C. */ | |
| 1251 invalid_change ("Charset predicate must take one argument", | |
| 1252 tag); | |
| 1253 } | |
| 1254 } | |
| 1255 | |
| 5198 | 1256 return define_specifier_tag (tag, device_predicate, charset_predicate); |
| 428 | 1257 } |
| 1258 | |
| 1259 /* Called at device-creation time to initialize the user-defined | |
| 1260 tag values for the newly-created device. */ | |
| 1261 | |
| 1262 void | |
| 1263 setup_device_initial_specifier_tags (struct device *d) | |
| 1264 { | |
| 1265 Lisp_Object rest, rest2; | |
| 793 | 1266 Lisp_Object device = wrap_device (d); |
| 3836 | 1267 Lisp_Object device_predicate; |
| 3659 | 1268 int list_len; |
| 793 | 1269 |
| 428 | 1270 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags); |
| 1271 | |
| 1272 /* Now set up the initial values */ | |
| 1273 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d)) | |
| 1274 XCDR (XCAR (rest)) = Qt; | |
| 1275 | |
| 1276 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d); | |
| 1277 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2)) | |
| 1278 { | |
| 5198 | 1279 GET_LIST_LENGTH (XCAR(rest), list_len); |
| 1280 | |
| 1281 assert (3 == list_len); | |
| 1282 | |
| 1283 device_predicate = XCADR (XCAR (rest)); | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1284 |
| 3659 | 1285 if (NILP (device_predicate)) |
| 1286 { | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1287 XCDR (XCAR (rest2)) = Qt; |
| 3659 | 1288 } |
| 428 | 1289 else |
| 3659 | 1290 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1291 device_predicate = !NILP (call_critical_lisp_code |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1292 (d, device_predicate, device)) |
| 3659 | 1293 ? Qt : Qnil; |
| 3817 | 1294 XCDR (XCAR (rest2)) = device_predicate; |
| 3659 | 1295 } |
| 428 | 1296 } |
| 1297 } | |
| 1298 | |
| 3659 | 1299 void |
| 1300 setup_charset_initial_specifier_tags (Lisp_Object charset) | |
| 1301 { | |
| 1302 Lisp_Object rest, charset_predicate, tag, new_value; | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1303 Lisp_Object charset_tag_list = Qnil; |
| 3659 | 1304 |
| 1305 LIST_LOOP (rest, Vuser_defined_tags) | |
| 1306 { | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1307 tag = XCAR (XCAR (rest)); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1308 charset_predicate = XCADDR (XCAR (rest)); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1309 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1310 if (NILP (charset_predicate)) |
| 3659 | 1311 { |
| 1312 continue; | |
| 1313 } | |
| 1314 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1315 new_value = call_charset_predicate (charset_predicate, charset); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1316 charset_tag_list = Fcons (Fcons (tag, new_value), charset_tag_list); |
| 3659 | 1317 } |
| 1318 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1319 Fputhash (charset, charset_tag_list, Vcharset_tag_lists); |
| 3659 | 1320 } |
| 1321 | |
| 3673 | 1322 /* VM calls this, in vm-multiple-frames-possible-p, in the event that you're |
| 1323 considering taking it out. */ | |
| 3659 | 1324 |
| 442 | 1325 DEFUN ("device-matching-specifier-tag-list", |
| 1326 Fdevice_matching_specifier_tag_list, | |
| 428 | 1327 0, 1, 0, /* |
| 3673 | 1328 Return a list of all specifier tags matching DEVICE. |
| 1329 DEVICE defaults to the selected device if omitted. | |
| 1330 */ | |
| 428 | 1331 (device)) |
| 1332 { | |
| 1333 struct device *d = decode_device (device); | |
| 1334 Lisp_Object rest, list = Qnil; | |
| 1335 struct gcpro gcpro1; | |
| 1336 | |
| 1337 GCPRO1 (list); | |
| 1338 | |
| 1339 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d)) | |
| 1340 { | |
| 3836 | 1341 if (!NILP (XCDR (XCAR (rest)))) |
| 428 | 1342 list = Fcons (XCAR (XCAR (rest)), list); |
| 1343 } | |
| 1344 | |
| 1345 list = Fnreverse (list); | |
| 1346 list = Fcons (DEVICE_CLASS (d), list); | |
| 1347 list = Fcons (DEVICE_TYPE (d), list); | |
| 1348 | |
| 1349 RETURN_UNGCPRO (list); | |
| 1350 } | |
| 1351 | |
| 1352 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /* | |
| 1353 Return a list of all currently-defined specifier tags. | |
| 1354 This includes the built-in ones (the device types and classes). | |
| 1355 */ | |
| 1356 ()) | |
| 1357 { | |
| 1358 Lisp_Object list = Qnil, rest; | |
| 1359 struct gcpro gcpro1; | |
| 1360 | |
| 1361 GCPRO1 (list); | |
| 1362 | |
| 1363 LIST_LOOP (rest, Vuser_defined_tags) | |
| 1364 list = Fcons (XCAR (XCAR (rest)), list); | |
| 1365 | |
| 1366 list = Fnreverse (list); | |
| 1367 list = nconc2 (Fcopy_sequence (Vdevice_class_list), list); | |
| 1368 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list); | |
| 1369 | |
| 1370 RETURN_UNGCPRO (list); | |
| 1371 } | |
| 1372 | |
| 3659 | 1373 DEFUN ("specifier-tag-device-predicate", Fspecifier_tag_device_predicate, |
| 1374 1, 1, 0, /* | |
| 1375 Return the device predicate for the given specifier tag. | |
| 428 | 1376 */ |
| 1377 (tag)) | |
| 1378 { | |
| 1379 /* The return value of this function must be GCPRO'd. */ | |
| 1380 CHECK_SYMBOL (tag); | |
| 1381 | |
| 1382 if (NILP (Fvalid_specifier_tag_p (tag))) | |
| 563 | 1383 invalid_argument ("Invalid specifier tag", |
| 3659 | 1384 tag); |
| 428 | 1385 |
| 1386 /* Make up some predicates for the built-in types */ | |
| 1387 | |
| 1388 if (valid_console_type_p (tag)) | |
| 1389 return list3 (Qlambda, list1 (Qdevice), | |
| 1390 list3 (Qeq, list2 (Qquote, tag), | |
| 1391 list2 (Qconsole_type, Qdevice))); | |
| 1392 | |
| 1393 if (valid_device_class_p (tag)) | |
| 1394 return list3 (Qlambda, list1 (Qdevice), | |
| 1395 list3 (Qeq, list2 (Qquote, tag), | |
| 1396 list2 (Qdevice_class, Qdevice))); | |
| 1397 | |
| 3659 | 1398 return XCADR (assq_no_quit (tag, Vuser_defined_tags)); |
| 1399 } | |
| 1400 | |
| 1401 DEFUN ("specifier-tag-charset-predicate", Fspecifier_tag_charset_predicate, | |
| 1402 1, 1, 0, /* | |
| 3673 | 1403 Return the charset predicate for the given specifier tag. |
| 1404 */ | |
| 3659 | 1405 (tag)) |
| 1406 { | |
| 1407 /* The return value of this function must be GCPRO'd. */ | |
| 1408 CHECK_SYMBOL (tag); | |
| 1409 | |
| 1410 if (NILP (Fvalid_specifier_tag_p (tag))) | |
| 1411 invalid_argument ("Invalid specifier tag", | |
| 1412 tag); | |
| 1413 | |
| 1414 return XCADDR (assq_no_quit (tag, Vuser_defined_tags)); | |
| 428 | 1415 } |
| 1416 | |
| 1417 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B. | |
| 3659 | 1418 Otherwise, A must be `equal' to B. The sets must be canonicalized. */ |
| 428 | 1419 static int |
| 1420 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p) | |
| 1421 { | |
| 1422 if (!exact_p) | |
| 1423 { | |
| 1424 while (!NILP (a) && !NILP (b)) | |
| 1425 { | |
| 1426 if (EQ (XCAR (a), XCAR (b))) | |
| 1427 a = XCDR (a); | |
| 1428 b = XCDR (b); | |
| 1429 } | |
| 1430 | |
| 1431 return NILP (a); | |
| 1432 } | |
| 1433 else | |
| 1434 { | |
| 1435 while (!NILP (a) && !NILP (b)) | |
| 1436 { | |
| 1437 if (!EQ (XCAR (a), XCAR (b))) | |
| 1438 return 0; | |
| 1439 a = XCDR (a); | |
| 1440 b = XCDR (b); | |
| 1441 } | |
| 1442 | |
| 1443 return NILP (a) && NILP (b); | |
| 1444 } | |
| 1445 } | |
| 1446 | |
| 1447 | |
| 1448 /************************************************************************/ | |
| 1449 /* Spec-lists and inst-lists */ | |
| 1450 /************************************************************************/ | |
| 1451 | |
| 1452 static Lisp_Object | |
| 1453 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator) | |
| 1454 { | |
| 1455 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator); | |
| 1456 return Qt; | |
| 1457 } | |
| 1458 | |
| 1459 static Lisp_Object | |
| 1460 check_valid_instantiator (Lisp_Object instantiator, | |
| 1461 struct specifier_methods *meths, | |
| 578 | 1462 Error_Behavior errb) |
| 428 | 1463 { |
| 1464 if (meths->validate_method) | |
| 1465 { | |
| 1466 Lisp_Object retval; | |
| 1467 | |
| 1468 if (ERRB_EQ (errb, ERROR_ME)) | |
| 1469 { | |
| 1470 (meths->validate_method) (instantiator); | |
| 1471 retval = Qt; | |
| 1472 } | |
| 1473 else | |
| 1474 { | |
| 1475 Lisp_Object opaque = make_opaque_ptr ((void *) | |
| 1476 meths->validate_method); | |
| 1477 struct gcpro gcpro1; | |
| 1478 | |
| 1479 GCPRO1 (opaque); | |
| 1480 retval = call_with_suspended_errors | |
| 1481 ((lisp_fn_t) call_validate_method, | |
| 1482 Qnil, Qspecifier, errb, 2, opaque, instantiator); | |
| 1483 | |
| 1484 free_opaque_ptr (opaque); | |
| 1485 UNGCPRO; | |
| 1486 } | |
| 1487 | |
| 1488 return retval; | |
| 1489 } | |
| 1490 return Qt; | |
| 1491 } | |
| 1492 | |
| 1493 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /* | |
| 1494 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE. | |
| 1495 */ | |
| 1496 (instantiator, specifier_type)) | |
| 1497 { | |
| 1498 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 1499 ERROR_ME); | |
| 1500 | |
| 1501 return check_valid_instantiator (instantiator, meths, ERROR_ME); | |
| 1502 } | |
| 1503 | |
| 1504 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /* | |
| 1505 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE. | |
| 1506 */ | |
| 1507 (instantiator, specifier_type)) | |
| 1508 { | |
| 1509 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 1510 ERROR_ME); | |
| 1511 | |
| 1512 return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT); | |
| 1513 } | |
| 1514 | |
| 1515 static Lisp_Object | |
| 1516 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths, | |
| 578 | 1517 Error_Behavior errb) |
| 428 | 1518 { |
| 2159 | 1519 EXTERNAL_LIST_LOOP_2 (inst_pair, inst_list) |
| 428 | 1520 { |
| 2159 | 1521 Lisp_Object tag_set; |
| 1522 | |
| 1523 if (!CONSP (inst_pair)) | |
| 428 | 1524 { |
| 563 | 1525 maybe_sferror ( |
| 3659 | 1526 "Invalid instantiator pair", inst_pair, |
| 1527 Qspecifier, errb); | |
| 428 | 1528 return Qnil; |
| 1529 } | |
| 1530 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair)))) | |
| 1531 { | |
| 563 | 1532 maybe_invalid_argument ( |
| 3659 | 1533 "Invalid specifier tag", tag_set, |
| 1534 Qspecifier, errb); | |
| 428 | 1535 return Qnil; |
| 1536 } | |
| 1537 | |
| 1538 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb))) | |
| 1539 return Qnil; | |
| 1540 } | |
| 1541 | |
| 1542 return Qt; | |
| 1543 } | |
| 1544 | |
| 1545 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /* | |
| 1546 Signal an error if INST-LIST is invalid for specifier type TYPE. | |
| 1547 */ | |
| 1548 (inst_list, type)) | |
| 1549 { | |
| 1550 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1551 | |
| 1552 return check_valid_inst_list (inst_list, meths, ERROR_ME); | |
| 1553 } | |
| 1554 | |
| 1555 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /* | |
| 1556 Return non-nil if INST-LIST is valid for specifier type TYPE. | |
| 1557 */ | |
| 1558 (inst_list, type)) | |
| 1559 { | |
| 1560 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1561 | |
| 1562 return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT); | |
| 1563 } | |
| 1564 | |
| 1565 static Lisp_Object | |
| 1566 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths, | |
| 578 | 1567 Error_Behavior errb) |
| 428 | 1568 { |
| 2159 | 1569 EXTERNAL_LIST_LOOP_2 (spec, spec_list) |
| 428 | 1570 { |
| 2159 | 1571 Lisp_Object locale; |
| 1572 if (!CONSP (spec)) | |
| 428 | 1573 { |
| 563 | 1574 maybe_sferror ( |
| 3659 | 1575 "Invalid specification list", spec_list, |
| 1576 Qspecifier, errb); | |
| 428 | 1577 return Qnil; |
| 1578 } | |
| 1579 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec)))) | |
| 1580 { | |
| 563 | 1581 maybe_invalid_argument ( |
| 3659 | 1582 "Invalid specifier locale", locale, |
| 1583 Qspecifier, errb); | |
| 428 | 1584 return Qnil; |
| 1585 } | |
| 1586 | |
| 1587 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb))) | |
| 1588 return Qnil; | |
| 1589 } | |
| 1590 | |
| 1591 return Qt; | |
| 1592 } | |
| 1593 | |
| 1594 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /* | |
| 1595 Signal an error if SPEC-LIST is invalid for specifier type TYPE. | |
| 1596 */ | |
| 1597 (spec_list, type)) | |
| 1598 { | |
| 1599 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1600 | |
| 1601 return check_valid_spec_list (spec_list, meths, ERROR_ME); | |
| 1602 } | |
| 1603 | |
| 1604 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /* | |
| 1605 Return non-nil if SPEC-LIST is valid for specifier type TYPE. | |
| 1606 */ | |
| 1607 (spec_list, type)) | |
| 1608 { | |
| 1609 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1610 | |
| 1611 return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT); | |
| 1612 } | |
| 1613 | |
| 1614 enum spec_add_meth | |
| 1615 decode_how_to_add_specification (Lisp_Object how_to_add) | |
| 1616 { | |
| 1617 if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add)) | |
| 1618 return SPEC_REMOVE_TAG_SET_PREPEND; | |
| 1619 if (EQ (Qremove_tag_set_append, how_to_add)) | |
| 1620 return SPEC_REMOVE_TAG_SET_APPEND; | |
| 1621 if (EQ (Qappend, how_to_add)) | |
| 1622 return SPEC_APPEND; | |
| 1623 if (EQ (Qprepend, how_to_add)) | |
| 1624 return SPEC_PREPEND; | |
| 1625 if (EQ (Qremove_locale, how_to_add)) | |
| 1626 return SPEC_REMOVE_LOCALE; | |
| 1627 if (EQ (Qremove_locale_type, how_to_add)) | |
| 1628 return SPEC_REMOVE_LOCALE_TYPE; | |
| 1629 if (EQ (Qremove_all, how_to_add)) | |
| 1630 return SPEC_REMOVE_ALL; | |
| 1631 | |
| 563 | 1632 invalid_constant ("Invalid `how-to-add' flag", how_to_add); |
| 428 | 1633 |
| 1204 | 1634 RETURN_NOT_REACHED (SPEC_PREPEND); |
| 428 | 1635 } |
| 1636 | |
| 1637 /* Given a specifier object SPEC, return bodily specifier if SPEC is a | |
| 1638 ghost specifier, otherwise return the object itself | |
| 1639 */ | |
| 1640 static Lisp_Object | |
| 1641 bodily_specifier (Lisp_Object spec) | |
| 1642 { | |
| 1643 return (GHOST_SPECIFIER_P (XSPECIFIER (spec)) | |
| 5198 | 1644 ? XSPECIFIER (spec)->magic_parent : spec); |
| 428 | 1645 } |
| 1646 | |
| 1647 /* Signal error if (specifier SPEC is read-only. | |
| 1648 Read only are ghost specifiers unless Vunlock_ghost_specifiers is | |
| 1649 non-nil. All other specifiers are read-write. | |
| 1650 */ | |
| 1651 static void | |
| 1652 check_modifiable_specifier (Lisp_Object spec) | |
| 1653 { | |
| 1654 if (NILP (Vunlock_ghost_specifiers) | |
| 1655 && GHOST_SPECIFIER_P (XSPECIFIER (spec))) | |
| 563 | 1656 signal_error (Qsetting_constant, |
| 1657 "Attempt to modify read-only specifier", | |
| 1658 spec); | |
| 428 | 1659 } |
| 1660 | |
| 1661 int | |
| 1662 unlock_ghost_specifiers_protected (void) | |
| 1663 { | |
| 853 | 1664 return internal_bind_lisp_object (&Vunlock_ghost_specifiers, Qt); |
| 428 | 1665 } |
| 1666 | |
| 1667 /* This gets hit so much that the function call overhead had a | |
| 1668 measurable impact (according to Quantify). #### We should figure | |
| 1669 out the frequency with which this is called with the various types | |
| 1670 and reorder the check accordingly. */ | |
| 1671 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \ | |
| 3659 | 1672 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \ |
| 1673 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \ | |
| 1674 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \ | |
| 1675 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \ | |
| 1676 (XSPECIFIER (specifier)->window_specs)) : \ | |
| 1677 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \ | |
| 1678 0) | |
| 428 | 1679 |
| 1680 static Lisp_Object * | |
| 1681 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1682 enum spec_locale_type type) | |
| 1683 { | |
| 1684 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1685 Lisp_Object specification; | |
| 1686 | |
| 1687 if (type == LOCALE_GLOBAL) | |
| 1688 return spec_list; | |
| 1689 /* Calling assq_no_quit when it is just going to return nil anyhow | |
| 1690 is extremely expensive. So sayeth Quantify. */ | |
| 1691 if (!CONSP (*spec_list)) | |
| 1692 return 0; | |
| 1693 specification = assq_no_quit (locale, *spec_list); | |
| 1694 if (NILP (specification)) | |
| 1695 return 0; | |
| 1696 return &XCDR (specification); | |
| 1697 } | |
| 1698 | |
| 1699 /* For the given INST_LIST, return a new INST_LIST containing all elements | |
| 1700 where TAG-SET matches the element's tag set. EXACT_P indicates whether | |
| 1701 the match must be exact (as opposed to a subset). SHORT_P indicates | |
| 1702 that the short form (for `specifier-specs') should be returned if | |
| 1703 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no | |
| 1704 elements of the new list are shared with the initial list. | |
| 1705 */ | |
| 1706 | |
| 1707 static Lisp_Object | |
| 1708 specifier_process_inst_list (Lisp_Object inst_list, | |
| 1709 Lisp_Object tag_set, int exact_p, | |
| 1710 int short_p, int copy_tree_p) | |
| 1711 { | |
| 1712 Lisp_Object retval = Qnil; | |
| 1713 Lisp_Object rest; | |
| 1714 struct gcpro gcpro1; | |
| 1715 | |
| 1716 GCPRO1 (retval); | |
| 1717 LIST_LOOP (rest, inst_list) | |
| 1718 { | |
| 1719 Lisp_Object tagged_inst = XCAR (rest); | |
| 1720 Lisp_Object tagged_inst_tag = XCAR (tagged_inst); | |
| 1721 if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p)) | |
| 1722 { | |
| 1723 if (short_p && NILP (tagged_inst_tag)) | |
| 1724 retval = Fcons (copy_tree_p ? | |
| 1725 Fcopy_tree (XCDR (tagged_inst), Qt) : | |
| 1726 XCDR (tagged_inst), | |
| 1727 retval); | |
| 1728 else | |
| 1729 retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) : | |
| 1730 tagged_inst, retval); | |
| 1731 } | |
| 1732 } | |
| 1733 retval = Fnreverse (retval); | |
| 1734 UNGCPRO; | |
| 1735 /* If there is a single instantiator and the short form is | |
| 1736 requested, return just the instantiator (rather than a one-element | |
| 1737 list of it) unless it is nil (so that it can be distinguished from | |
| 1738 no instantiators at all). */ | |
| 1739 if (short_p && CONSP (retval) && !NILP (XCAR (retval)) && | |
| 1740 NILP (XCDR (retval))) | |
| 1741 return XCAR (retval); | |
| 1742 else | |
| 1743 return retval; | |
| 1744 } | |
| 1745 | |
| 1746 static Lisp_Object | |
| 1747 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1748 enum spec_locale_type type, | |
| 1749 Lisp_Object tag_set, int exact_p, | |
| 1750 int short_p, int copy_tree_p) | |
| 1751 { | |
| 1752 Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale, | |
| 1753 type); | |
| 1754 if (!inst_list || NILP (*inst_list)) | |
| 1755 { | |
| 2953 | 1756 /* nil for *inst_list should only occur in `global' */ |
| 428 | 1757 assert (!inst_list || EQ (locale, Qglobal)); |
| 1758 return Qnil; | |
| 1759 } | |
| 1760 | |
| 1761 return specifier_process_inst_list (*inst_list, tag_set, exact_p, | |
| 1762 short_p, copy_tree_p); | |
| 1763 } | |
| 1764 | |
| 1765 static Lisp_Object | |
| 1766 specifier_get_external_spec_list (Lisp_Object specifier, | |
| 1767 enum spec_locale_type type, | |
| 1768 Lisp_Object tag_set, int exact_p) | |
| 1769 { | |
| 1770 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1771 Lisp_Object retval = Qnil; | |
| 1772 Lisp_Object rest; | |
| 1773 struct gcpro gcpro1; | |
| 1774 | |
| 1775 assert (type != LOCALE_GLOBAL); | |
| 1776 /* We're about to let stuff go external; make sure there aren't | |
| 1777 any dead objects */ | |
| 1778 *spec_list = cleanup_assoc_list (*spec_list); | |
| 1779 | |
| 1780 GCPRO1 (retval); | |
| 1781 LIST_LOOP (rest, *spec_list) | |
| 1782 { | |
| 1783 Lisp_Object spec = XCAR (rest); | |
| 1784 Lisp_Object inst_list = | |
| 1785 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1); | |
| 1786 if (!NILP (inst_list)) | |
| 1787 retval = Fcons (Fcons (XCAR (spec), inst_list), retval); | |
| 1788 } | |
| 1789 RETURN_UNGCPRO (Fnreverse (retval)); | |
| 1790 } | |
| 1791 | |
| 1792 static Lisp_Object * | |
| 1793 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 1794 enum spec_locale_type type) | |
| 1795 { | |
| 1796 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1797 Lisp_Object new_spec = Fcons (locale, Qnil); | |
| 1798 assert (type != LOCALE_GLOBAL); | |
| 1799 *spec_list = Fcons (new_spec, *spec_list); | |
| 1800 return &XCDR (new_spec); | |
| 1801 } | |
| 1802 | |
| 1803 /* For the given INST_LIST, return a new list comprised of elements | |
| 1804 where TAG_SET does not match the element's tag set. This operation | |
| 1805 is destructive. */ | |
| 1806 | |
| 1807 static Lisp_Object | |
| 1808 specifier_process_remove_inst_list (Lisp_Object inst_list, | |
| 1809 Lisp_Object tag_set, int exact_p, | |
| 1810 int *was_removed) | |
| 1811 { | |
| 1812 Lisp_Object prev = Qnil, rest; | |
| 1813 | |
| 1814 *was_removed = 0; | |
| 1815 | |
| 1816 LIST_LOOP (rest, inst_list) | |
| 1817 { | |
| 1818 if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p)) | |
| 1819 { | |
| 1820 /* time to remove. */ | |
| 1821 *was_removed = 1; | |
| 1822 if (NILP (prev)) | |
| 1823 inst_list = XCDR (rest); | |
| 1824 else | |
| 1825 XCDR (prev) = XCDR (rest); | |
| 1826 } | |
| 1827 else | |
| 1828 prev = rest; | |
| 1829 } | |
| 1830 | |
| 1831 return inst_list; | |
| 1832 } | |
| 1833 | |
| 1834 static void | |
| 1835 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 1836 enum spec_locale_type type, | |
| 1837 Lisp_Object tag_set, int exact_p) | |
| 1838 { | |
| 1839 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1840 Lisp_Object assoc; | |
| 1841 int was_removed; | |
| 1842 | |
| 1843 if (type == LOCALE_GLOBAL) | |
| 1844 *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set, | |
| 1845 exact_p, &was_removed); | |
| 1846 else | |
| 1847 { | |
| 1848 assoc = assq_no_quit (locale, *spec_list); | |
| 1849 if (NILP (assoc)) | |
| 1850 /* this locale is not found. */ | |
| 1851 return; | |
| 1852 XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc), | |
| 1853 tag_set, exact_p, | |
| 1854 &was_removed); | |
| 1855 if (NILP (XCDR (assoc))) | |
| 1856 /* no inst-pairs left; remove this locale entirely. */ | |
| 1857 *spec_list = remassq_no_quit (locale, *spec_list); | |
| 1858 } | |
| 1859 | |
| 1860 if (was_removed) | |
| 1861 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change, | |
| 1862 (bodily_specifier (specifier), locale)); | |
| 1863 } | |
| 1864 | |
| 1865 static void | |
| 1866 specifier_remove_locale_type (Lisp_Object specifier, | |
| 1867 enum spec_locale_type type, | |
| 1868 Lisp_Object tag_set, int exact_p) | |
| 1869 { | |
| 1870 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1871 Lisp_Object prev = Qnil, rest; | |
| 1872 | |
| 1873 assert (type != LOCALE_GLOBAL); | |
| 1874 LIST_LOOP (rest, *spec_list) | |
| 1875 { | |
| 1876 int was_removed; | |
| 1877 int remove_spec = 0; | |
| 1878 Lisp_Object spec = XCAR (rest); | |
| 1879 | |
| 1880 /* There may be dead objects floating around */ | |
| 1881 /* remember, dead windows can become alive again. */ | |
| 1882 if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec))) | |
| 1883 { | |
| 1884 remove_spec = 1; | |
| 1885 was_removed = 0; | |
| 1886 } | |
| 1887 else | |
| 1888 { | |
| 1889 XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec), | |
| 1890 tag_set, exact_p, | |
| 1891 &was_removed); | |
| 1892 if (NILP (XCDR (spec))) | |
| 1893 remove_spec = 1; | |
| 1894 } | |
| 1895 | |
| 1896 if (remove_spec) | |
| 1897 { | |
| 1898 if (NILP (prev)) | |
| 1899 *spec_list = XCDR (rest); | |
| 1900 else | |
| 1901 XCDR (prev) = XCDR (rest); | |
| 1902 } | |
| 1903 else | |
| 1904 prev = rest; | |
| 1905 | |
| 1906 if (was_removed) | |
| 1907 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change, | |
| 1908 (bodily_specifier (specifier), XCAR (spec))); | |
| 1909 } | |
| 1910 } | |
| 1911 | |
| 1912 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH. | |
| 1913 Frob INST_LIST according to ADD_METH. No need to call an after-change | |
| 1914 function; the calling function will do this. Return either SPEC_PREPEND | |
| 1915 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */ | |
| 1916 | |
| 1917 static enum spec_add_meth | |
| 1918 handle_multiple_add_insts (Lisp_Object *inst_list, | |
| 1919 Lisp_Object new_list, | |
| 1920 enum spec_add_meth add_meth) | |
| 1921 { | |
| 1922 switch (add_meth) | |
| 1923 { | |
| 1924 case SPEC_REMOVE_TAG_SET_APPEND: | |
| 1925 add_meth = SPEC_APPEND; | |
| 1926 goto remove_tag_set; | |
| 1927 case SPEC_REMOVE_TAG_SET_PREPEND: | |
| 1928 add_meth = SPEC_PREPEND; | |
| 1929 remove_tag_set: | |
| 1930 { | |
| 1931 Lisp_Object rest; | |
| 1932 | |
| 1933 LIST_LOOP (rest, new_list) | |
| 1934 { | |
| 1935 Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest))); | |
| 1936 struct gcpro gcpro1; | |
| 1937 | |
| 1938 GCPRO1 (canontag); | |
| 1939 /* pull out all elements from the existing list with the | |
| 1940 same tag as any tags in NEW_LIST. */ | |
| 1941 *inst_list = remassoc_no_quit (canontag, *inst_list); | |
| 1942 UNGCPRO; | |
| 1943 } | |
| 1944 } | |
| 1945 return add_meth; | |
| 1946 case SPEC_REMOVE_LOCALE: | |
| 1947 *inst_list = Qnil; | |
| 1948 return SPEC_PREPEND; | |
| 1949 case SPEC_APPEND: | |
| 1950 return add_meth; | |
| 1951 default: | |
| 1952 return SPEC_PREPEND; | |
| 1953 } | |
| 1954 } | |
| 1955 | |
| 1956 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER, | |
| 1957 copy, canonicalize, and call the going_to_add methods as necessary | |
| 1958 to produce a new list that is the one that really will be added | |
| 1959 to the specifier. */ | |
| 1960 | |
| 1961 static Lisp_Object | |
| 1962 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1963 Lisp_Object inst_list) | |
| 1964 { | |
| 1965 /* The return value of this function must be GCPRO'd. */ | |
| 1966 Lisp_Object rest, list_to_build_up = Qnil; | |
| 440 | 1967 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 1968 struct gcpro gcpro1; |
| 1969 | |
| 1970 GCPRO1 (list_to_build_up); | |
| 1971 LIST_LOOP (rest, inst_list) | |
| 1972 { | |
| 1973 Lisp_Object tag_set = XCAR (XCAR (rest)); | |
| 1974 Lisp_Object sub_inst_list = Qnil; | |
| 434 | 1975 Lisp_Object instantiator; |
| 428 | 1976 struct gcpro ngcpro1, ngcpro2; |
| 1977 | |
| 434 | 1978 if (HAS_SPECMETH_P (sp, copy_instantiator)) |
| 1979 instantiator = SPECMETH (sp, copy_instantiator, | |
| 1980 (XCDR (XCAR (rest)))); | |
| 1981 else | |
| 1982 instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt); | |
| 1983 | |
| 428 | 1984 NGCPRO2 (instantiator, sub_inst_list); |
| 1985 /* call the will-add method; it may GC */ | |
| 1986 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ? | |
| 1987 SPECMETH (sp, going_to_add, | |
| 1988 (bodily_specifier (specifier), locale, | |
| 1989 tag_set, instantiator)) : | |
| 1990 Qt; | |
| 1991 if (EQ (sub_inst_list, Qt)) | |
| 1992 /* no change here. */ | |
| 1993 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set), | |
| 1994 instantiator)); | |
| 1995 else | |
| 1996 { | |
| 1997 /* now canonicalize all the tag sets in the new objects */ | |
| 1998 Lisp_Object rest2; | |
| 1999 LIST_LOOP (rest2, sub_inst_list) | |
| 2000 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2))); | |
| 2001 } | |
| 2002 | |
| 2003 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up); | |
| 2004 NUNGCPRO; | |
| 2005 } | |
| 2006 | |
| 2007 RETURN_UNGCPRO (Fnreverse (list_to_build_up)); | |
| 2008 } | |
| 2009 | |
| 2010 /* Add a specification (locale and instantiator list) to a specifier. | |
| 2011 ADD_METH specifies what to do with existing specifications in the | |
| 2012 specifier, and is an enum that corresponds to the values in | |
| 2013 `add-spec-to-specifier'. The calling routine is responsible for | |
| 2014 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST | |
| 2015 do not need to be canonicalized. */ | |
| 2016 | |
| 3659 | 2017 /* #### I really need to rethink the after-change |
| 2018 functions to make them easier to use and more efficient. */ | |
| 428 | 2019 |
| 2020 static void | |
| 2021 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 2022 Lisp_Object inst_list, enum spec_add_meth add_meth) | |
| 2023 { | |
| 440 | 2024 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2025 enum spec_locale_type type = locale_type_from_locale (locale); |
| 2026 Lisp_Object *orig_inst_list, tem; | |
| 2027 Lisp_Object list_to_build_up = Qnil; | |
| 2028 struct gcpro gcpro1; | |
| 2029 | |
| 1015 | 2030 if (NILP (inst_list)) |
| 2031 return; | |
| 2032 | |
| 428 | 2033 GCPRO1 (list_to_build_up); |
| 2034 list_to_build_up = build_up_processed_list (specifier, locale, inst_list); | |
| 2035 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the | |
| 2036 add-meth types that affect locales other than this one. */ | |
| 2037 if (add_meth == SPEC_REMOVE_LOCALE_TYPE) | |
| 2038 specifier_remove_locale_type (specifier, type, Qnil, 0); | |
| 2039 else if (add_meth == SPEC_REMOVE_ALL) | |
| 2040 { | |
| 2041 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0); | |
| 2042 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0); | |
| 2043 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0); | |
| 2044 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0); | |
| 2045 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0); | |
| 2046 } | |
| 2047 | |
| 2048 orig_inst_list = specifier_get_inst_list (specifier, locale, type); | |
| 2049 if (!orig_inst_list) | |
| 2050 orig_inst_list = specifier_new_spec (specifier, locale, type); | |
| 2051 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up, | |
| 2052 add_meth); | |
| 2053 | |
| 2054 if (add_meth == SPEC_PREPEND) | |
| 2055 tem = nconc2 (list_to_build_up, *orig_inst_list); | |
| 2056 else if (add_meth == SPEC_APPEND) | |
| 2057 tem = nconc2 (*orig_inst_list, list_to_build_up); | |
| 2058 else | |
| 442 | 2059 { |
| 2500 | 2060 ABORT (); |
| 442 | 2061 tem = Qnil; |
| 2062 } | |
| 428 | 2063 |
| 2064 *orig_inst_list = tem; | |
| 2065 | |
| 2066 UNGCPRO; | |
| 2067 | |
| 2068 /* call the after-change method */ | |
| 2069 MAYBE_SPECMETH (sp, after_change, | |
| 2070 (bodily_specifier (specifier), locale)); | |
| 2071 } | |
| 2072 | |
| 2073 static void | |
| 2074 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest, | |
| 2075 Lisp_Object locale, enum spec_locale_type type, | |
| 2076 Lisp_Object tag_set, int exact_p, | |
| 2077 enum spec_add_meth add_meth) | |
| 2078 { | |
| 2079 Lisp_Object inst_list = | |
| 2080 specifier_get_external_inst_list (specifier, locale, type, tag_set, | |
| 2081 exact_p, 0, 0); | |
| 2082 specifier_add_spec (dest, locale, inst_list, add_meth); | |
| 2083 } | |
| 2084 | |
| 2085 static void | |
| 2086 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest, | |
| 2087 enum spec_locale_type type, | |
| 2088 Lisp_Object tag_set, int exact_p, | |
| 2089 enum spec_add_meth add_meth) | |
| 2090 { | |
| 2091 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 2092 Lisp_Object rest; | |
| 2093 | |
| 2094 /* This algorithm is O(n^2) in running time. | |
| 2095 It's certainly possible to implement an O(n log n) algorithm, | |
| 2096 but I doubt there's any need to. */ | |
| 2097 | |
| 2098 LIST_LOOP (rest, *src_list) | |
| 2099 { | |
| 2100 Lisp_Object spec = XCAR (rest); | |
| 2101 /* There may be dead objects floating around */ | |
| 2102 /* remember, dead windows can become alive again. */ | |
| 2103 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec))) | |
| 2104 specifier_add_spec | |
| 2105 (dest, XCAR (spec), | |
| 2106 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0), | |
| 2107 add_meth); | |
| 2108 } | |
| 2109 } | |
| 2110 | |
| 2111 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE. | |
| 2112 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of | |
| 2113 | |
| 3659 | 2114 -- nil (same as `all') |
| 2115 -- a single locale, locale type, or `all' | |
| 2116 -- a list of locales, locale types, and/or `all' | |
| 2953 | 2117 |
| 2118 MAPFUN is called for each locale and locale type given; for `all', | |
| 2119 it is called for the locale `global' and for the four possible | |
| 428 | 2120 locale types. In each invocation, either LOCALE will be a locale |
| 2121 and LOCALE_TYPE will be the locale type of this locale, | |
| 2122 or LOCALE will be nil and LOCALE_TYPE will be a locale type. | |
| 2123 If MAPFUN ever returns non-zero, the mapping is halted and the | |
| 2124 value returned is returned from map_specifier(). Otherwise, the | |
| 2125 mapping proceeds to the end and map_specifier() returns 0. | |
| 3659 | 2126 */ |
| 428 | 2127 |
| 2128 static int | |
| 2129 map_specifier (Lisp_Object specifier, Lisp_Object locale, | |
| 2130 int (*mapfun) (Lisp_Object specifier, | |
| 2131 Lisp_Object locale, | |
| 2132 enum spec_locale_type locale_type, | |
| 2133 Lisp_Object tag_set, | |
| 2134 int exact_p, | |
| 2135 void *closure), | |
| 2136 Lisp_Object tag_set, Lisp_Object exact_p, | |
| 2137 void *closure) | |
| 2138 { | |
| 2139 int retval = 0; | |
| 2140 Lisp_Object rest; | |
| 2141 struct gcpro gcpro1, gcpro2; | |
| 2142 | |
| 2143 GCPRO2 (tag_set, locale); | |
| 2144 locale = decode_locale_list (locale); | |
| 2145 tag_set = decode_specifier_tag_set (tag_set); | |
| 2146 tag_set = canonicalize_tag_set (tag_set); | |
| 2147 | |
| 2148 LIST_LOOP (rest, locale) | |
| 2149 { | |
| 2150 Lisp_Object theloc = XCAR (rest); | |
| 2151 if (!NILP (Fvalid_specifier_locale_p (theloc))) | |
| 2152 { | |
| 2153 retval = (*mapfun) (specifier, theloc, | |
| 2154 locale_type_from_locale (theloc), | |
| 2155 tag_set, !NILP (exact_p), closure); | |
| 2156 if (retval) | |
| 2157 break; | |
| 2158 } | |
| 2159 else if (!NILP (Fvalid_specifier_locale_type_p (theloc))) | |
| 2160 { | |
| 2161 retval = (*mapfun) (specifier, Qnil, | |
| 2162 decode_locale_type (theloc), tag_set, | |
| 2163 !NILP (exact_p), closure); | |
| 2164 if (retval) | |
| 2165 break; | |
| 2166 } | |
| 2167 else | |
| 2168 { | |
| 2169 assert (EQ (theloc, Qall)); | |
| 2170 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set, | |
| 2171 !NILP (exact_p), closure); | |
| 2172 if (retval) | |
| 2173 break; | |
| 2174 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set, | |
| 2175 !NILP (exact_p), closure); | |
| 2176 if (retval) | |
| 2177 break; | |
| 2178 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set, | |
| 2179 !NILP (exact_p), closure); | |
| 2180 if (retval) | |
| 2181 break; | |
| 2182 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set, | |
| 2183 !NILP (exact_p), closure); | |
| 2184 if (retval) | |
| 2185 break; | |
| 2186 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set, | |
| 2187 !NILP (exact_p), closure); | |
| 2188 if (retval) | |
| 2189 break; | |
| 2190 } | |
| 2191 } | |
| 2192 | |
| 2193 UNGCPRO; | |
| 2194 return retval; | |
| 2195 } | |
| 2196 | |
| 2197 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /* | |
| 2198 Add a specification to SPECIFIER. | |
| 2199 The specification maps from LOCALE (which should be a window, buffer, | |
| 2953 | 2200 frame, device, or `global', and defaults to `global') to INSTANTIATOR, |
| 428 | 2201 whose allowed values depend on the type of the specifier. Optional |
| 2202 argument TAG-SET limits the instantiator to apply only to the specified | |
| 2203 tag set, which should be a list of tags all of which must match the | |
| 2204 device being instantiated over (tags are a device type, a device class, | |
| 2205 or tags defined with `define-specifier-tag'). Specifying a single | |
| 2206 symbol for TAG-SET is equivalent to specifying a one-element list | |
| 2207 containing that symbol. Optional argument HOW-TO-ADD specifies what to | |
| 2208 do if there are already specifications in the specifier. | |
| 2209 It should be one of | |
| 2210 | |
| 2953 | 2211 `prepend' Put at the beginning of the current list of |
| 428 | 2212 instantiators for LOCALE. |
| 2953 | 2213 `append' Add to the end of the current list of |
| 428 | 2214 instantiators for LOCALE. |
| 2953 | 2215 `remove-tag-set-prepend' (this is the default) |
| 428 | 2216 Remove any existing instantiators whose tag set is |
| 2217 the same as TAG-SET; then put the new instantiator | |
| 2218 at the beginning of the current list. ("Same tag | |
| 2219 set" means that they contain the same elements. | |
| 2220 The order may be different.) | |
| 2953 | 2221 `remove-tag-set-append' |
| 428 | 2222 Remove any existing instantiators whose tag set is |
| 2223 the same as TAG-SET; then put the new instantiator | |
| 2224 at the end of the current list. | |
| 2953 | 2225 `remove-locale' Remove all previous instantiators for this locale |
| 428 | 2226 before adding the new spec. |
| 2953 | 2227 `remove-locale-type' Remove all specifications for all locales of the |
| 428 | 2228 same type as LOCALE (this includes LOCALE itself) |
| 2229 before adding the new spec. | |
| 2953 | 2230 `remove-all' Remove all specifications from the specifier |
| 428 | 2231 before adding the new spec. |
| 2232 | |
| 2233 You can retrieve the specifications for a particular locale or locale type | |
| 2234 with the function `specifier-spec-list' or `specifier-specs'. | |
| 2235 */ | |
| 2236 (specifier, instantiator, locale, tag_set, how_to_add)) | |
| 2237 { | |
| 2238 enum spec_add_meth add_meth; | |
| 2239 Lisp_Object inst_list; | |
| 2240 struct gcpro gcpro1; | |
| 2241 | |
| 2242 CHECK_SPECIFIER (specifier); | |
| 2243 check_modifiable_specifier (specifier); | |
| 2244 | |
| 2245 locale = decode_locale (locale); | |
| 2246 check_valid_instantiator (instantiator, | |
| 2247 decode_specifier_type | |
| 2248 (Fspecifier_type (specifier), ERROR_ME), | |
| 2249 ERROR_ME); | |
| 2250 /* tag_set might be newly-created material, but it's part of inst_list | |
| 2251 so is properly GC-protected. */ | |
| 2252 tag_set = decode_specifier_tag_set (tag_set); | |
| 2253 add_meth = decode_how_to_add_specification (how_to_add); | |
| 2254 | |
| 2255 inst_list = list1 (Fcons (tag_set, instantiator)); | |
| 2256 GCPRO1 (inst_list); | |
| 2257 specifier_add_spec (specifier, locale, inst_list, add_meth); | |
| 2258 recompute_cached_specifier_everywhere (specifier); | |
| 2259 RETURN_UNGCPRO (Qnil); | |
| 2260 } | |
| 2261 | |
| 2262 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /* | |
| 444 | 2263 Add SPEC-LIST (a list of specifications) to SPECIFIER. |
| 2264 The format of SPEC-LIST is | |
| 428 | 2265 |
| 2266 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...) | |
| 2267 | |
| 2268 where | |
| 2953 | 2269 LOCALE := a window, a buffer, a frame, a device, or `global' |
| 428 | 2270 TAG-SET := an unordered list of zero or more TAGS, each of which |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2271 is a symbol |
| 428 | 2272 TAG := a device class (see `valid-device-class-p'), a device type |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2273 (see `valid-console-type-p'), or a tag defined with |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2274 `define-specifier-tag' |
| 428 | 2275 INSTANTIATOR := format determined by the type of specifier |
| 2276 | |
| 2277 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'. | |
| 2278 A list of inst-pairs is called an `inst-list'. | |
| 2279 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'. | |
| 2280 A spec-list, then, can be viewed as a list of specifications. | |
| 2281 | |
| 2282 HOW-TO-ADD specifies how to combine the new specifications with | |
| 2283 the existing ones, and has the same semantics as for | |
| 2284 `add-spec-to-specifier'. | |
| 2285 | |
| 2286 In many circumstances, the higher-level function `set-specifier' is | |
| 2287 more convenient and should be used instead. | |
| 2288 */ | |
| 2289 (specifier, spec_list, how_to_add)) | |
| 2290 { | |
| 2291 enum spec_add_meth add_meth; | |
| 2292 Lisp_Object rest; | |
| 2293 | |
| 2294 CHECK_SPECIFIER (specifier); | |
| 2295 check_modifiable_specifier (specifier); | |
| 2296 | |
| 2297 check_valid_spec_list (spec_list, | |
| 2298 decode_specifier_type | |
| 2299 (Fspecifier_type (specifier), ERROR_ME), | |
| 2300 ERROR_ME); | |
| 2301 add_meth = decode_how_to_add_specification (how_to_add); | |
| 2302 | |
| 2303 LIST_LOOP (rest, spec_list) | |
| 2304 { | |
| 2305 /* Placating the GCC god. */ | |
| 2306 Lisp_Object specification = XCAR (rest); | |
| 2307 Lisp_Object locale = XCAR (specification); | |
| 2308 Lisp_Object inst_list = XCDR (specification); | |
| 2309 | |
| 2310 specifier_add_spec (specifier, locale, inst_list, add_meth); | |
| 2311 } | |
| 2312 recompute_cached_specifier_everywhere (specifier); | |
| 2313 return Qnil; | |
| 2314 } | |
| 2315 | |
| 2316 void | |
| 2317 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator, | |
| 2318 Lisp_Object locale, Lisp_Object tag_set, | |
| 2319 Lisp_Object how_to_add) | |
| 2320 { | |
| 2321 int depth = unlock_ghost_specifiers_protected (); | |
| 5198 | 2322 Fadd_spec_to_specifier (XSPECIFIER (specifier)->fallback, |
| 428 | 2323 instantiator, locale, tag_set, how_to_add); |
| 771 | 2324 unbind_to (depth); |
| 428 | 2325 } |
| 2326 | |
| 2327 struct specifier_spec_list_closure | |
| 2328 { | |
| 2329 Lisp_Object head, tail; | |
| 2330 }; | |
| 2331 | |
| 2332 static int | |
| 2333 specifier_spec_list_mapfun (Lisp_Object specifier, | |
| 2334 Lisp_Object locale, | |
| 2335 enum spec_locale_type locale_type, | |
| 2336 Lisp_Object tag_set, | |
| 2337 int exact_p, | |
| 2338 void *closure) | |
| 2339 { | |
| 2340 struct specifier_spec_list_closure *cl = | |
| 2341 (struct specifier_spec_list_closure *) closure; | |
| 2342 Lisp_Object partial; | |
| 2343 | |
| 2344 if (NILP (locale)) | |
| 2345 partial = specifier_get_external_spec_list (specifier, | |
| 2346 locale_type, | |
| 2347 tag_set, exact_p); | |
| 2348 else | |
| 2349 { | |
| 2350 partial = specifier_get_external_inst_list (specifier, locale, | |
| 2351 locale_type, tag_set, | |
| 2352 exact_p, 0, 1); | |
| 2353 if (!NILP (partial)) | |
| 2354 partial = list1 (Fcons (locale, partial)); | |
| 2355 } | |
| 2356 if (NILP (partial)) | |
| 2357 return 0; | |
| 2358 | |
| 2359 /* tack on the new list */ | |
| 2360 if (NILP (cl->tail)) | |
| 2361 cl->head = cl->tail = partial; | |
| 2362 else | |
| 2363 XCDR (cl->tail) = partial; | |
| 2364 /* find the new tail */ | |
| 2365 while (CONSP (XCDR (cl->tail))) | |
| 2366 cl->tail = XCDR (cl->tail); | |
| 2367 return 0; | |
| 2368 } | |
| 2369 | |
| 2370 /* For the given SPECIFIER create and return a list of all specs | |
| 2371 contained within it, subject to LOCALE. If LOCALE is a locale, only | |
| 2372 specs in that locale will be returned. If LOCALE is a locale type, | |
| 2373 all specs in all locales of that type will be returned. If LOCALE is | |
| 2374 nil, all specs will be returned. This always copies lists and never | |
| 2375 returns the actual lists, because we do not want someone manipulating | |
| 2376 the actual objects. This may cause a slight loss of potential | |
| 2377 functionality but if we were to allow it then a user could manage to | |
| 2378 violate our assertion that the specs contained in the actual | |
| 2379 specifier lists are all valid. */ | |
| 2380 | |
| 2381 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /* | |
| 2382 Return the spec-list of specifications for SPECIFIER in LOCALE. | |
| 2383 | |
| 2384 If LOCALE is a particular locale (a buffer, window, frame, device, | |
| 2953 | 2385 or `global'), a spec-list consisting of the specification for that |
| 428 | 2386 locale will be returned. |
| 2387 | |
| 2953 | 2388 If LOCALE is a locale type (i.e. `buffer', `window', `frame', or `device'), |
| 428 | 2389 a spec-list of the specifications for all locales of that type will be |
| 2390 returned. | |
| 2391 | |
| 2953 | 2392 If LOCALE is nil or `all', a spec-list of all specifications in SPECIFIER |
| 428 | 2393 will be returned. |
| 2394 | |
| 2953 | 2395 LOCALE can also be a list of locales, locale types, and/or `all'; the |
| 428 | 2396 result is as if `specifier-spec-list' were called on each element of the |
| 2397 list and the results concatenated together. | |
| 2398 | |
| 2399 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2400 subset of (or possibly equal to) the instantiator's tag set are returned. | |
| 2401 \(The default value of nil is a subset of all tag sets, so in this case | |
| 2402 no instantiators will be screened out.) If EXACT-P is non-nil, however, | |
| 2403 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2404 to be returned. | |
| 2405 */ | |
| 3659 | 2406 (specifier, locale, tag_set, exact_p)) |
| 428 | 2407 { |
| 2408 struct specifier_spec_list_closure cl; | |
| 2409 struct gcpro gcpro1, gcpro2; | |
| 2410 | |
| 2411 CHECK_SPECIFIER (specifier); | |
| 2412 cl.head = cl.tail = Qnil; | |
| 2413 GCPRO2 (cl.head, cl.tail); | |
| 2414 map_specifier (specifier, locale, specifier_spec_list_mapfun, | |
| 2415 tag_set, exact_p, &cl); | |
| 2416 UNGCPRO; | |
| 2417 return cl.head; | |
| 2418 } | |
| 2419 | |
| 2420 | |
| 2421 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /* | |
| 2422 Return the specification(s) for SPECIFIER in LOCALE. | |
| 2423 | |
| 2424 If LOCALE is a single locale or is a list of one element containing a | |
| 2425 single locale, then a "short form" of the instantiators for that locale | |
| 2426 will be returned. Otherwise, this function is identical to | |
| 2427 `specifier-spec-list'. | |
| 2428 | |
| 2429 The "short form" is designed for readability and not for ease of use | |
| 2430 in Lisp programs, and is as follows: | |
| 2431 | |
| 2432 1. If there is only one instantiator, then an inst-pair (i.e. cons of | |
| 2433 tag and instantiator) will be returned; otherwise a list of | |
| 2434 inst-pairs will be returned. | |
| 2953 | 2435 2. For each inst-pair returned, if the instantiator's tag is `any', |
| 428 | 2436 the tag will be removed and the instantiator itself will be returned |
| 2437 instead of the inst-pair. | |
| 2438 3. If there is only one instantiator, its value is nil, and its tag is | |
| 2953 | 2439 `any', a one-element list containing nil will be returned rather |
| 428 | 2440 than just nil, to distinguish this case from there being no |
| 2441 instantiators at all. | |
| 2442 */ | |
| 2443 (specifier, locale, tag_set, exact_p)) | |
| 2444 { | |
| 2445 if (!NILP (Fvalid_specifier_locale_p (locale)) || | |
| 2446 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) && | |
| 2447 NILP (XCDR (locale)))) | |
| 2448 { | |
| 2449 struct gcpro gcpro1; | |
| 2450 | |
| 2451 CHECK_SPECIFIER (specifier); | |
| 2452 if (CONSP (locale)) | |
| 2453 locale = XCAR (locale); | |
| 2454 GCPRO1 (tag_set); | |
| 2455 tag_set = decode_specifier_tag_set (tag_set); | |
| 2456 tag_set = canonicalize_tag_set (tag_set); | |
| 2457 RETURN_UNGCPRO | |
| 2458 (specifier_get_external_inst_list (specifier, locale, | |
| 2459 locale_type_from_locale (locale), | |
| 2460 tag_set, !NILP (exact_p), 1, 1)); | |
| 2461 } | |
| 2462 else | |
| 2463 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p); | |
| 2464 } | |
| 2465 | |
| 2466 static int | |
| 2467 remove_specifier_mapfun (Lisp_Object specifier, | |
| 2468 Lisp_Object locale, | |
| 2469 enum spec_locale_type locale_type, | |
| 2470 Lisp_Object tag_set, | |
| 2471 int exact_p, | |
| 2286 | 2472 void *UNUSED (closure)) |
| 428 | 2473 { |
| 2474 if (NILP (locale)) | |
| 2475 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p); | |
| 2476 else | |
| 2477 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p); | |
| 2478 return 0; | |
| 2479 } | |
| 2480 | |
| 2481 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /* | |
| 2482 Remove specification(s) for SPECIFIER. | |
| 2483 | |
| 2484 If LOCALE is a particular locale (a window, buffer, frame, device, | |
| 2953 | 2485 or `global'), the specification for that locale will be removed. |
| 2486 | |
| 2487 If instead, LOCALE is a locale type (i.e. `window', `buffer', `frame', | |
| 2488 or `device'), the specifications for all locales of that type will be | |
| 428 | 2489 removed. |
| 2490 | |
| 2953 | 2491 If LOCALE is nil or `all', all specifications will be removed. |
| 2492 | |
| 2493 LOCALE can also be a list of locales, locale types, and/or `all'; this | |
| 428 | 2494 is equivalent to calling `remove-specifier' for each of the elements |
| 2495 in the list. | |
| 2496 | |
| 2497 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2498 subset of (or possibly equal to) the instantiator's tag set are removed. | |
| 2499 The default value of nil is a subset of all tag sets, so in this case | |
| 2500 no instantiators will be screened out. If EXACT-P is non-nil, however, | |
| 2501 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2502 to be removed. | |
| 2503 */ | |
| 2504 (specifier, locale, tag_set, exact_p)) | |
| 2505 { | |
| 2506 CHECK_SPECIFIER (specifier); | |
| 2507 check_modifiable_specifier (specifier); | |
| 2508 | |
| 2509 map_specifier (specifier, locale, remove_specifier_mapfun, | |
| 2510 tag_set, exact_p, 0); | |
| 2511 recompute_cached_specifier_everywhere (specifier); | |
| 2512 return Qnil; | |
| 2513 } | |
| 2514 | |
| 2515 void | |
| 2516 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale, | |
| 2517 Lisp_Object tag_set, Lisp_Object exact_p) | |
| 2518 { | |
| 2519 int depth = unlock_ghost_specifiers_protected (); | |
| 5198 | 2520 Fremove_specifier (XSPECIFIER (specifier)->fallback, |
| 428 | 2521 locale, tag_set, exact_p); |
| 771 | 2522 unbind_to (depth); |
| 428 | 2523 } |
| 2524 | |
| 2525 struct copy_specifier_closure | |
| 2526 { | |
| 2527 Lisp_Object dest; | |
| 2528 enum spec_add_meth add_meth; | |
| 2529 int add_meth_is_nil; | |
| 2530 }; | |
| 2531 | |
| 2532 static int | |
| 2533 copy_specifier_mapfun (Lisp_Object specifier, | |
| 2534 Lisp_Object locale, | |
| 2535 enum spec_locale_type locale_type, | |
| 2536 Lisp_Object tag_set, | |
| 2537 int exact_p, | |
| 2538 void *closure) | |
| 2539 { | |
| 2540 struct copy_specifier_closure *cl = | |
| 2541 (struct copy_specifier_closure *) closure; | |
| 2542 | |
| 2543 if (NILP (locale)) | |
| 2544 specifier_copy_locale_type (specifier, cl->dest, locale_type, | |
| 2545 tag_set, exact_p, | |
| 2546 cl->add_meth_is_nil ? | |
| 2547 SPEC_REMOVE_LOCALE_TYPE : | |
| 2548 cl->add_meth); | |
| 2549 else | |
| 2550 specifier_copy_spec (specifier, cl->dest, locale, locale_type, | |
| 2551 tag_set, exact_p, | |
| 2552 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE : | |
| 2553 cl->add_meth); | |
| 2554 return 0; | |
| 2555 } | |
| 2556 | |
| 2557 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /* | |
| 2558 Copy SPECIFIER to DEST, or create a new one if DEST is nil. | |
| 2559 | |
| 2560 If DEST is nil or omitted, a new specifier will be created and the | |
| 2561 specifications copied into it. Otherwise, the specifications will be | |
| 2562 copied into the existing specifier in DEST. | |
| 2563 | |
| 2953 | 2564 If LOCALE is nil or `all', all specifications will be copied. If LOCALE |
| 428 | 2565 is a particular locale, the specification for that particular locale will |
| 2566 be copied. If LOCALE is a locale type, the specifications for all locales | |
| 2567 of that type will be copied. LOCALE can also be a list of locales, | |
| 2953 | 2568 locale types, and/or `all'; this is equivalent to calling `copy-specifier' |
| 428 | 2569 for each of the elements of the list. See `specifier-spec-list' for more |
| 2570 information about LOCALE. | |
| 2571 | |
| 2572 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2573 subset of (or possibly equal to) the instantiator's tag set are copied. | |
| 2574 The default value of nil is a subset of all tag sets, so in this case | |
| 2575 no instantiators will be screened out. If EXACT-P is non-nil, however, | |
| 2576 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2577 to be copied. | |
| 2578 | |
| 2579 Optional argument HOW-TO-ADD specifies what to do with existing | |
| 2580 specifications in DEST. If nil, then whichever locales or locale types | |
| 2581 are copied will first be completely erased in DEST. Otherwise, it is | |
| 2582 the same as in `add-spec-to-specifier'. | |
| 2583 */ | |
| 2584 (specifier, dest, locale, tag_set, exact_p, how_to_add)) | |
| 2585 { | |
| 2586 struct gcpro gcpro1; | |
| 2587 struct copy_specifier_closure cl; | |
| 2588 | |
| 2589 CHECK_SPECIFIER (specifier); | |
| 2590 if (NILP (how_to_add)) | |
| 2591 cl.add_meth_is_nil = 1; | |
| 2592 else | |
| 2593 cl.add_meth_is_nil = 0; | |
| 2594 cl.add_meth = decode_how_to_add_specification (how_to_add); | |
| 2595 if (NILP (dest)) | |
| 2596 { | |
| 2597 /* #### What about copying the extra data? */ | |
| 2598 dest = make_specifier (XSPECIFIER (specifier)->methods); | |
| 2599 } | |
| 2600 else | |
| 2601 { | |
| 2602 CHECK_SPECIFIER (dest); | |
| 2603 check_modifiable_specifier (dest); | |
| 2604 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods) | |
| 3659 | 2605 invalid_argument ("Specifiers not of same type", Qunbound); |
| 428 | 2606 } |
| 2607 | |
| 2608 cl.dest = dest; | |
| 2609 GCPRO1 (dest); | |
| 2610 map_specifier (specifier, locale, copy_specifier_mapfun, | |
| 2611 tag_set, exact_p, &cl); | |
| 2612 UNGCPRO; | |
| 2613 recompute_cached_specifier_everywhere (dest); | |
| 2614 return dest; | |
| 2615 } | |
| 2616 | |
| 2617 | |
| 2618 /************************************************************************/ | |
| 2953 | 2619 /* Instantiation */ |
| 428 | 2620 /************************************************************************/ |
| 2621 | |
| 2622 static Lisp_Object | |
| 2623 call_validate_matchspec_method (Lisp_Object boxed_method, | |
| 2624 Lisp_Object matchspec) | |
| 2625 { | |
| 2626 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec); | |
| 2627 return Qt; | |
| 2628 } | |
| 2629 | |
| 2630 static Lisp_Object | |
| 2631 check_valid_specifier_matchspec (Lisp_Object matchspec, | |
| 2632 struct specifier_methods *meths, | |
| 578 | 2633 Error_Behavior errb) |
| 428 | 2634 { |
| 2635 if (meths->validate_matchspec_method) | |
| 2636 { | |
| 2637 Lisp_Object retval; | |
| 2638 | |
| 2639 if (ERRB_EQ (errb, ERROR_ME)) | |
| 2640 { | |
| 2641 (meths->validate_matchspec_method) (matchspec); | |
| 2642 retval = Qt; | |
| 2643 } | |
| 2644 else | |
| 2645 { | |
| 2646 Lisp_Object opaque = | |
| 2647 make_opaque_ptr ((void *) meths->validate_matchspec_method); | |
| 2648 struct gcpro gcpro1; | |
| 2649 | |
| 2650 GCPRO1 (opaque); | |
| 2651 retval = call_with_suspended_errors | |
| 2652 ((lisp_fn_t) call_validate_matchspec_method, | |
| 2653 Qnil, Qspecifier, errb, 2, opaque, matchspec); | |
| 2654 | |
| 2655 free_opaque_ptr (opaque); | |
| 2656 UNGCPRO; | |
| 2657 } | |
| 2658 | |
| 2659 return retval; | |
| 2660 } | |
| 2661 else | |
| 2662 { | |
| 563 | 2663 maybe_sferror |
| 428 | 2664 ("Matchspecs not allowed for this specifier type", |
| 2665 intern (meths->name), Qspecifier, errb); | |
| 2666 return Qnil; | |
| 2667 } | |
| 2668 } | |
| 2669 | |
| 442 | 2670 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, |
| 2671 2, 0, /* | |
| 428 | 2672 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE. |
| 2673 See `specifier-matching-instance' for a description of matchspecs. | |
| 2674 */ | |
| 2675 (matchspec, specifier_type)) | |
| 2676 { | |
| 2677 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 2678 ERROR_ME); | |
| 2679 | |
| 2680 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME); | |
| 2681 } | |
| 2682 | |
| 2683 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /* | |
| 2684 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE. | |
| 2685 See `specifier-matching-instance' for a description of matchspecs. | |
| 2686 */ | |
| 2687 (matchspec, specifier_type)) | |
| 2688 { | |
| 2689 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 2690 ERROR_ME); | |
| 2691 | |
| 2692 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT); | |
| 2693 } | |
| 2694 | |
| 2695 /* This function is purposely not callable from Lisp. If a Lisp | |
| 2696 caller wants to set a fallback, they should just set the | |
| 2697 global value. */ | |
| 2698 | |
| 2699 void | |
| 2700 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback) | |
| 2701 { | |
| 440 | 2702 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2703 assert (SPECIFIERP (fallback) || |
| 2704 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier)))); | |
| 2705 if (SPECIFIERP (fallback)) | |
| 2706 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback))); | |
| 2707 if (BODILY_SPECIFIER_P (sp)) | |
| 5198 | 2708 GHOST_SPECIFIER (sp)->fallback = fallback; |
| 428 | 2709 else |
| 2710 sp->fallback = fallback; | |
| 2711 /* call the after-change method */ | |
| 2712 MAYBE_SPECMETH (sp, after_change, | |
| 2713 (bodily_specifier (specifier), Qfallback)); | |
| 2714 recompute_cached_specifier_everywhere (specifier); | |
| 2715 } | |
| 2716 | |
| 2717 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /* | |
| 2718 Return the fallback value for SPECIFIER. | |
| 2719 Fallback values are provided by the C code for certain built-in | |
| 2953 | 2720 specifiers to make sure that instantiation won't fail even if all |
| 428 | 2721 specs are removed from the specifier, or to implement simple |
| 2722 inheritance behavior (e.g. this method is used to ensure that | |
| 2953 | 2723 faces other than `default' inherit their attributes from `default'). |
| 428 | 2724 By design, you cannot change the fallback value, and specifiers |
| 2725 created with `make-specifier' will never have a fallback (although | |
| 2726 a similar, Lisp-accessible capability may be provided in the future | |
| 2727 to allow for inheritance). | |
| 2728 | |
| 2953 | 2729 The fallback value will be an inst-list that is instantiated like |
| 428 | 2730 any other inst-list, a specifier of the same type as SPECIFIER |
| 2731 \(results in inheritance), or nil for no fallback. | |
| 2732 | |
| 2953 | 2733 When you instantiate a specifier, you can explicitly request that the |
| 428 | 2734 fallback not be consulted. (The C code does this, for example, when |
| 2735 merging faces.) See `specifier-instance'. | |
| 2736 */ | |
| 2737 (specifier)) | |
| 2738 { | |
| 2739 CHECK_SPECIFIER (specifier); | |
| 2740 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt); | |
| 2741 } | |
| 2742 | |
| 2743 static Lisp_Object | |
| 2744 specifier_instance_from_inst_list (Lisp_Object specifier, | |
| 2745 Lisp_Object matchspec, | |
| 2746 Lisp_Object domain, | |
| 2747 Lisp_Object inst_list, | |
| 578 | 2748 Error_Behavior errb, int no_quit, |
| 2953 | 2749 Lisp_Object depth, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2750 Lisp_Object *instantiator, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2751 int no_fallback) |
| 428 | 2752 { |
| 2753 /* This function can GC */ | |
| 440 | 2754 Lisp_Specifier *sp; |
| 3659 | 2755 Lisp_Object device, charset = Qnil, rest; |
| 2756 int count = specpdl_depth (), respected_charsets = 0; | |
| 428 | 2757 struct gcpro gcpro1, gcpro2; |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2758 enum font_specifier_matchspec_stages stage = STAGE_INITIAL; |
| 428 | 2759 |
| 2760 GCPRO2 (specifier, inst_list); | |
| 2761 | |
| 2762 sp = XSPECIFIER (specifier); | |
| 442 | 2763 device = DOMAIN_DEVICE (domain); |
| 428 | 2764 |
| 2765 if (no_quit) | |
| 3659 | 2766 /* The instantiate method is allowed to call eval. Since it |
| 2767 is quite common for this function to get called from somewhere in | |
| 2768 redisplay we need to make sure that quits are ignored. Otherwise | |
| 2769 Fsignal will abort. */ | |
| 428 | 2770 specbind (Qinhibit_quit, Qt); |
| 2771 | |
| 3659 | 2772 #ifdef MULE |
| 4828 | 2773 /* #### FIXME Does this font-specific stuff need to be here and not in |
| 2774 the font-specifier-specific code? --ben */ | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2775 if (CONSP (matchspec) && (CHARSETP (Ffind_charset (XCAR (matchspec))))) |
| 3659 | 2776 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2777 charset = Ffind_charset (XCAR (matchspec)); |
| 3659 | 2778 |
| 2779 #ifdef DEBUG_XEMACS | |
| 2780 /* This is mostly to have somewhere to set debug breakpoints. */ | |
| 4853 | 2781 if (!EQ (charset, Vcharset_ascii)) |
| 3659 | 2782 { |
| 4853 | 2783 (void) 0; |
| 3659 | 2784 } |
| 2785 #endif /* DEBUG_XEMACS */ | |
| 2786 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2787 if (!NILP (XCDR (matchspec))) |
| 3659 | 2788 { |
| 2789 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2790 #define FROB(new_stage, enumstage) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2791 if (EQ (Q##new_stage, XCDR (matchspec))) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2792 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2793 stage = enumstage; \ |
| 3659 | 2794 } |
| 2795 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2796 FROB (initial, STAGE_INITIAL) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2797 else FROB (final, STAGE_FINAL) |
| 5198 | 2798 else assert (0); |
| 3659 | 2799 #undef FROB |
| 2800 | |
| 2801 } | |
| 2802 } | |
| 2803 #endif /* MULE */ | |
| 2804 | |
| 5198 | 2805 LIST_LOOP (rest, inst_list) |
| 3659 | 2806 { |
| 2807 Lisp_Object tagged_inst = XCAR (rest); | |
| 2808 Lisp_Object tag_set = XCAR (tagged_inst); | |
| 2809 Lisp_Object val, the_instantiator; | |
| 2810 | |
| 2811 if (!device_matches_specifier_tag_set_p (device, tag_set)) | |
| 2812 { | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2813 continue; |
| 3659 | 2814 } |
| 2815 | |
| 2816 val = XCDR (tagged_inst); | |
| 2817 the_instantiator = val; | |
| 2818 | |
| 5198 | 2819 if (!NILP (charset) && |
| 3659 | 2820 !(charset_matches_specifier_tag_set_p (charset, tag_set, stage))) |
| 2821 { | |
| 2822 ++respected_charsets; | |
| 2823 continue; | |
| 2824 } | |
| 2825 | |
| 2826 if (HAS_SPECMETH_P (sp, instantiate)) | |
| 2827 val = call_with_suspended_errors | |
| 2828 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), | |
|
5296
d185fa593d5f
Specify ERROR_ME_WARN explicitly in specifier_instance_from_inst_list().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5202
diff
changeset
|
2829 Qunbound, Qspecifier, ERROR_ME_WARN, 5, specifier, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2830 matchspec, domain, val, depth, no_fallback); |
| 3659 | 2831 |
| 2832 if (!UNBOUNDP (val)) | |
| 2833 { | |
| 2834 unbind_to (count); | |
| 2835 UNGCPRO; | |
| 2836 if (instantiator) | |
| 2837 *instantiator = the_instantiator; | |
| 2838 return val; | |
| 2839 } | |
| 2840 } | |
| 2841 | |
| 2842 /* We've checked all the tag sets, and checking the charset part of the | |
| 2843 specifier never returned 0 (preventing the attempted instantiation), so | |
| 2844 there's no need to loop for the second time to avoid checking the | |
| 2845 charsets. */ | |
| 2846 if (!respected_charsets) | |
| 2847 { | |
| 2848 unbind_to (count); | |
| 2849 UNGCPRO; | |
| 2850 return Qunbound; | |
| 2851 } | |
| 2852 | |
| 2853 /* Right, didn't instantiate a specifier last time, perhaps because we | |
| 2854 paid attention to the charset-specific aspects of the specifier. Try | |
| 2855 again without checking the charset information. | |
| 2856 | |
| 2857 We can't emulate the approach for devices, defaulting to matching all | |
| 2858 character sets for a given specifier, because $random font instantiator | |
| 2859 cannot usefully show all character sets, and indeed having it try is a | |
| 2860 failure on our part. */ | |
| 428 | 2861 LIST_LOOP (rest, inst_list) |
| 2862 { | |
| 2863 Lisp_Object tagged_inst = XCAR (rest); | |
| 2864 Lisp_Object tag_set = XCAR (tagged_inst); | |
| 3659 | 2865 Lisp_Object val, the_instantiator; |
| 2866 | |
| 2867 if (!device_matches_specifier_tag_set_p (device, tag_set)) | |
| 428 | 2868 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2869 continue; |
| 3659 | 2870 } |
| 2871 | |
| 2872 val = XCDR (tagged_inst); | |
| 2873 the_instantiator = val; | |
| 2874 | |
| 2875 if (HAS_SPECMETH_P (sp, instantiate)) | |
| 2876 val = call_with_suspended_errors | |
| 2877 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), | |
| 2878 Qunbound, Qspecifier, errb, 5, specifier, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2879 matchspec, domain, val, depth, no_fallback); |
| 3659 | 2880 |
| 2881 if (!UNBOUNDP (val)) | |
| 2882 { | |
| 2883 unbind_to (count); | |
| 2884 UNGCPRO; | |
| 2885 if (instantiator) | |
| 2886 *instantiator = the_instantiator; | |
| 2887 return val; | |
| 428 | 2888 } |
| 2889 } | |
| 2890 | |
| 771 | 2891 unbind_to (count); |
| 428 | 2892 UNGCPRO; |
| 2893 return Qunbound; | |
| 2894 } | |
| 2895 | |
| 2896 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that | |
| 2897 specifier. Try to find one by checking the specifier types from most | |
| 4437 | 2898 specific (window) to most general (global). If we find an instance, |
| 428 | 2899 return it. Otherwise return Qunbound. */ |
| 2900 | |
| 2901 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \ | |
| 3659 | 2902 Lisp_Object *CIE_inst_list = \ |
| 2903 specifier_get_inst_list (specifier, key, type); \ | |
| 2904 if (CIE_inst_list) \ | |
| 2905 { \ | |
| 2906 Lisp_Object CIE_val = \ | |
| 2907 specifier_instance_from_inst_list (specifier, matchspec, \ | |
| 2908 domain, *CIE_inst_list, \ | |
| 2909 errb, no_quit, depth, \ | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2910 instantiator, no_fallback); \ |
| 3659 | 2911 if (!UNBOUNDP (CIE_val)) \ |
| 2912 return CIE_val; \ | |
| 2913 } \ | |
| 2914 } while (0) | |
| 428 | 2915 |
| 2916 /* We accept any window, frame or device domain and do our checking | |
| 2917 starting from as specific a locale type as we can determine from the | |
| 2918 domain we are passed and going on up through as many other locale types | |
| 2919 as we can determine. In practice, when called from redisplay the | |
| 2920 arg will usually be a window and occasionally a frame. If | |
| 2921 triggered by a user call, who knows what it will usually be. */ | |
| 2953 | 2922 |
| 2923 static Lisp_Object | |
| 2924 specifier_instance_1 (Lisp_Object specifier, Lisp_Object matchspec, | |
| 2925 Lisp_Object domain, Error_Behavior errb, int no_quit, | |
| 2926 int no_fallback, Lisp_Object depth, | |
| 2927 Lisp_Object *instantiator) | |
| 428 | 2928 { |
| 2929 Lisp_Object buffer = Qnil; | |
| 2930 Lisp_Object window = Qnil; | |
| 2931 Lisp_Object frame = Qnil; | |
| 2932 Lisp_Object device = Qnil; | |
| 444 | 2933 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2934 |
| 2953 | 2935 if (instantiator) |
| 2936 *instantiator = Qunbound; | |
| 2937 | |
| 428 | 2938 /* Attempt to determine buffer, window, frame, and device from the |
| 2939 domain. */ | |
| 442 | 2940 /* #### get image instances out of domains! */ |
| 2941 if (IMAGE_INSTANCEP (domain)) | |
| 2942 window = DOMAIN_WINDOW (domain); | |
| 2943 else if (WINDOWP (domain)) | |
| 428 | 2944 window = domain; |
| 2945 else if (FRAMEP (domain)) | |
| 2946 frame = domain; | |
| 2947 else if (DEVICEP (domain)) | |
| 2948 device = domain; | |
| 2949 else | |
| 442 | 2950 /* dmoore writes: [dammit, this should just signal an error or something |
| 2951 shouldn't it?] | |
| 2952 | |
| 2953 No. Errors are handled in Lisp primitives implementation. | |
| 428 | 2954 Invalid domain is a design error here - kkm. */ |
| 2500 | 2955 ABORT (); |
| 428 | 2956 |
| 2957 if (NILP (buffer) && !NILP (window)) | |
| 444 | 2958 buffer = WINDOW_BUFFER (XWINDOW (window)); |
| 428 | 2959 if (NILP (frame) && !NILP (window)) |
| 2960 frame = XWINDOW (window)->frame; | |
| 2961 if (NILP (device)) | |
| 2962 /* frame had better exist; if device is undeterminable, something | |
| 2963 really went wrong. */ | |
| 444 | 2964 device = FRAME_DEVICE (XFRAME (frame)); |
| 428 | 2965 |
| 2966 /* device had better be determined by now; abort if not. */ | |
| 2286 | 2967 (void) DEVICE_CLASS (XDEVICE (device)); |
| 428 | 2968 |
| 2969 depth = make_int (1 + XINT (depth)); | |
| 2970 if (XINT (depth) > 20) | |
| 2971 { | |
| 563 | 2972 maybe_signal_error (Qstack_overflow, |
| 2973 "Apparent loop in specifier inheritance", | |
| 2974 Qunbound, Qspecifier, errb); | |
| 428 | 2975 /* The specification is fucked; at least try the fallback |
| 2976 (which better not be fucked, because it's not changeable | |
| 2977 from Lisp). */ | |
| 2978 depth = Qzero; | |
| 2979 goto do_fallback; | |
| 2980 } | |
| 2981 | |
| 434 | 2982 retry: |
| 428 | 2983 /* First see if we can generate one from the window specifiers. */ |
| 2984 if (!NILP (window)) | |
| 2985 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW); | |
| 2986 | |
| 2987 /* Next see if we can generate one from the buffer specifiers. */ | |
| 2988 if (!NILP (buffer)) | |
| 2989 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER); | |
| 2990 | |
| 2991 /* Next see if we can generate one from the frame specifiers. */ | |
| 2992 if (!NILP (frame)) | |
| 2993 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME); | |
| 2994 | |
| 2995 /* If we still haven't succeeded try with the device specifiers. */ | |
| 2996 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE); | |
| 2997 | |
| 2998 /* Last and least try the global specifiers. */ | |
| 2999 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL); | |
| 3000 | |
| 434 | 3001 do_fallback: |
| 428 | 3002 /* We're out of specifiers and we still haven't generated an |
| 3003 instance. At least try the fallback ... If this fails, | |
| 3004 then we just return Qunbound. */ | |
| 3005 | |
| 3006 if (no_fallback || NILP (sp->fallback)) | |
| 3007 /* I said, I don't want the fallbacks. */ | |
| 3008 return Qunbound; | |
| 3009 | |
| 3010 if (SPECIFIERP (sp->fallback)) | |
| 3011 { | |
| 3012 /* If you introduced loops in the default specifier chain, | |
| 3013 then you're fucked, so you better not do this. */ | |
| 3014 specifier = sp->fallback; | |
| 3015 sp = XSPECIFIER (specifier); | |
| 3016 goto retry; | |
| 3017 } | |
| 3018 | |
| 3019 assert (CONSP (sp->fallback)); | |
| 3020 return specifier_instance_from_inst_list (specifier, matchspec, domain, | |
| 3021 sp->fallback, errb, no_quit, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3022 depth, instantiator, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3023 no_fallback); |
| 428 | 3024 } |
| 3025 #undef CHECK_INSTANCE_ENTRY | |
| 3026 | |
| 3027 Lisp_Object | |
| 2953 | 3028 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec, |
| 3029 Lisp_Object domain, Error_Behavior errb, int no_quit, | |
| 3030 int no_fallback, Lisp_Object depth) | |
| 3031 { | |
| 3032 return specifier_instance_1 (specifier, matchspec, domain, errb, | |
| 3033 no_quit, no_fallback, depth, NULL); | |
| 3034 } | |
| 3035 | |
| 3036 Lisp_Object | |
| 428 | 3037 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec, |
| 578 | 3038 Lisp_Object domain, Error_Behavior errb, |
| 428 | 3039 int no_fallback, Lisp_Object depth) |
| 3040 { | |
| 2953 | 3041 return specifier_instance_1 (specifier, matchspec, domain, errb, |
| 3042 1, no_fallback, depth, NULL); | |
| 3043 } | |
| 3044 | |
| 3045 static Lisp_Object | |
| 3046 specifier_matching_foo (Lisp_Object specifier, | |
| 3047 Lisp_Object matchspec, | |
| 3048 Lisp_Object domain, | |
| 3049 Lisp_Object default_, | |
| 3050 Lisp_Object no_fallback, | |
| 3051 int want_instantiator) | |
| 3052 { | |
| 3053 Lisp_Object instance, instantiator; | |
| 3054 | |
| 3055 CHECK_SPECIFIER (specifier); | |
| 3056 if (!UNBOUNDP (matchspec)) | |
| 3057 check_valid_specifier_matchspec (matchspec, | |
| 3058 XSPECIFIER (specifier)->methods, | |
| 3059 ERROR_ME); | |
| 3060 domain = decode_domain (domain); | |
| 3061 | |
| 3062 instance = specifier_instance_1 (specifier, matchspec, domain, ERROR_ME, | |
| 3063 0, !NILP (no_fallback), Qzero, | |
| 3064 &instantiator); | |
| 3065 return UNBOUNDP (instance) ? default_ : want_instantiator ? instantiator : | |
| 3066 instance; | |
| 428 | 3067 } |
| 3068 | |
| 3069 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /* | |
| 3070 Instantiate SPECIFIER (return its value) in DOMAIN. | |
| 3071 If no instance can be generated for this domain, return DEFAULT. | |
| 3072 | |
| 2953 | 3073 DOMAIN is nearly always a window (defaulting to the selected window if |
| 3074 omitted), but can be a window, frame, or device. Other values that are legal | |
| 428 | 3075 as a locale (e.g. a buffer) are not valid as a domain because they do not |
| 3076 provide enough information to identify a particular device (see | |
| 2953 | 3077 `valid-specifier-domain-p'). Window domains are used internally in nearly |
| 3078 all circumstances when computing specifier instances of display properties. | |
| 3079 Frame domains are used in a few circumstances (such as when computing the | |
| 3080 geometry of a frame based on properties such as the toolbar widths), and | |
| 3081 device domains are rarely if ever used internally. | |
| 3082 | |
| 3083 This function looks through the specifications in SPECIFIER that correspond | |
| 3084 to DOMAIN, from most specific (specifications for DOMAIN itself) to most | |
| 3085 general (global specifications), for matching instantiators, and attempts | |
| 3086 to compute an instance value for each instantiator found. The first | |
| 3087 successfully computed value is returned. The corresponding instantiator | |
| 3088 can be returned using `specifier-instantiator'. | |
| 3089 | |
| 3090 A specifier is a generalized object for controlling the value of a property -- | |
| 3091 typically, but not necessarily, a display-related property -- that can vary | |
| 3092 over particular buffers, frames, device types, etc. | |
| 3093 | |
| 3094 A fundamental distinction must be made between the specification of a | |
| 3095 property's value, and the resulting value itself. This distinction is | |
| 3096 clearest in the case of an image -- the specification describes the source | |
| 3097 of the image (for example, a file of JPEG data), and the resulting value | |
| 3098 encapsulates a window-system object describing the image as displayed on a | |
| 3099 particular device (for example, a particular X display). The specification | |
| 3100 might also be an instruction of the form "use the background pixmap of the | |
| 3101 `modeline' face". A similar mapping exists between color strings and | |
| 3102 color-instance objects, and font strings and font-instance objects. In | |
| 3103 some cases, the specification and the resulting value are of the same type, | |
| 3104 but the distinction is still logically made. | |
| 3105 | |
| 3106 The specification of a value is called an instantiator, and the resulting | |
| 3107 value the instance. | |
| 428 | 3108 |
| 3109 "Instantiating" a specifier in a particular domain means determining | |
| 3110 the specifier's "value" in that domain. This is accomplished by | |
| 3111 searching through the specifications in the specifier that correspond | |
| 3112 to all locales that can be derived from the given domain, from specific | |
| 3113 to general. In most cases, the domain is an Emacs window. In that case | |
| 3114 specifications are searched for as follows: | |
| 3115 | |
| 3116 1. A specification whose locale is the window itself; | |
| 3117 2. A specification whose locale is the window's buffer; | |
| 3118 3. A specification whose locale is the window's frame; | |
| 3119 4. A specification whose locale is the window's frame's device; | |
| 2953 | 3120 5. A specification whose locale is `global'. |
| 428 | 3121 |
| 3122 If all of those fail, then the C-code-provided fallback value for | |
| 3123 this specifier is consulted (see `specifier-fallback'). If it is | |
| 3124 an inst-list, then this function attempts to instantiate that list | |
| 3125 just as when a specification is located in the first five steps above. | |
| 3126 If the fallback is a specifier, `specifier-instance' is called | |
| 3127 recursively on this specifier and the return value used. Note, | |
| 3128 however, that if the optional argument NO-FALLBACK is non-nil, | |
| 3129 the fallback value will not be consulted. | |
| 3130 | |
| 3131 Note that there may be more than one specification matching a particular | |
| 3132 locale; all such specifications are considered before looking for any | |
| 3133 specifications for more general locales. Any particular specification | |
| 3134 that is found may be rejected because its tag set does not match the | |
| 3135 device being instantiated over, or because the specification is not | |
| 3136 valid for the device of the given domain (e.g. the font or color name | |
| 3137 does not exist for this particular X server). | |
| 3138 | |
| 793 | 3139 NOTE: When errors occur in the process of trying a particular instantiator, |
| 3140 and the instantiator is thus skipped, warnings will be issued at level | |
| 3141 `debug'. Normally, such warnings are ignored entirely, but you can change | |
| 3142 this by setting `log-warning-minimum-level'. This is useful if you're | |
| 3143 trying to debug why particular instantiators are not being processed. | |
| 3144 | |
| 428 | 3145 The returned value is dependent on the type of specifier. For example, |
| 3146 for a font specifier (as returned by the `face-font' function), the returned | |
| 3147 value will be a font-instance object. For glyphs, the returned value | |
| 2953 | 3148 will be an image-instance object. |
| 428 | 3149 |
| 3150 See also `specifier-matching-instance'. | |
| 3151 */ | |
| 3152 (specifier, domain, default_, no_fallback)) | |
| 3153 { | |
| 2953 | 3154 return specifier_matching_foo (specifier, Qunbound, domain, default_, |
| 3155 no_fallback, 0); | |
| 3156 } | |
| 3157 | |
| 3158 DEFUN ("specifier-instantiator", Fspecifier_instantiator, 1, 4, 0, /* | |
| 3159 Return instantiator that would be used to instantiate SPECIFIER in DOMAIN. | |
| 3160 If no instance can be generated for this domain, return DEFAULT. | |
| 3161 | |
| 3162 DOMAIN should be a window, frame, or device. Other values that are legal | |
| 3163 as a locale (e.g. a buffer) are not valid as a domain because they do not | |
| 3164 provide enough information to identify a particular device (see | |
| 3165 `valid-specifier-domain-p'). DOMAIN defaults to the selected window | |
| 3166 if omitted. | |
| 3167 | |
| 3168 See `specifier-instance' for more information about the instantiation process. | |
| 3169 */ | |
| 3170 (specifier, domain, default_, no_fallback)) | |
| 3171 { | |
| 3172 return specifier_matching_foo (specifier, Qunbound, domain, default_, | |
| 3173 no_fallback, 1); | |
| 428 | 3174 } |
| 3175 | |
| 3176 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /* | |
| 3177 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC. | |
| 3178 If no instance can be generated for this domain, return DEFAULT. | |
| 3179 | |
| 3180 This function is identical to `specifier-instance' except that a | |
| 3181 specification will only be considered if it matches MATCHSPEC. | |
| 3182 The definition of "match", and allowed values for MATCHSPEC, are | |
| 3183 dependent on the particular type of specifier. Here are some examples: | |
| 3184 | |
| 3185 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a | |
| 3186 character, and the specification (a chartable) must give a value for | |
| 3187 that character in order to be considered. This allows you to specify, | |
| 3188 e.g., a buffer-local display table that only gives values for particular | |
| 3189 characters. All other characters are handled as if the buffer-local | |
| 3190 display table is not there. (Chartable specifiers are not yet | |
| 3191 implemented.) | |
| 3192 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3193 -- For font specifiers, MATCHSPEC should be a cons (CHARSET . STAGE). |
| 3674 | 3194 The defined stages are currently `initial' and `final'. On X11, 'initial |
| 3195 is used when the font matching process is looking for fonts that match | |
| 3196 the desired registries of the charset--see the `charset-registries' | |
| 3197 function. If that match process fails, then the 'final stage comes into | |
| 3198 play; this means that a more general lookup is desired, and that a font | |
| 3199 doesn't necessarily have to match the desired XLFD for the face, just the | |
| 3200 charset repertoire for this charset. It also means that the charset | |
| 3201 registry and encoding used will be `iso10646-1', and the characters will | |
| 3202 be converted to display using that registry. | |
| 3203 | |
| 3204 See `define-specifier-tag' for details on how to create a tag that | |
| 3205 specifies a given character set and stage combination. You can supply | |
| 3206 such a tag to `set-face-font' in order to set a face's font for that | |
| 3207 character set and stage combination. | |
| 428 | 3208 */ |
| 3209 (specifier, matchspec, domain, default_, no_fallback)) | |
| 3210 { | |
| 2953 | 3211 return specifier_matching_foo (specifier, matchspec, domain, default_, |
| 3212 no_fallback, 0); | |
| 3213 } | |
| 3214 | |
| 3215 DEFUN ("specifier-matching-instantiator", Fspecifier_matching_instantiator, | |
| 3216 2, 5, 0, /* | |
| 3217 Return instantiator for instance of SPECIFIER in DOMAIN that matches MATCHSPEC. | |
| 3218 If no instance can be generated for this domain, return DEFAULT. | |
| 3219 | |
| 3220 This function is identical to `specifier-matching-instance' but returns | |
| 3221 the instantiator used to generate the instance, rather than the actual | |
| 3222 instance. | |
| 3223 */ | |
| 3224 (specifier, matchspec, domain, default_, no_fallback)) | |
| 3225 { | |
| 3226 return specifier_matching_foo (specifier, matchspec, domain, default_, | |
| 3227 no_fallback, 1); | |
| 3228 } | |
| 3229 | |
| 3230 static Lisp_Object | |
| 3231 specifier_matching_foo_from_inst_list (Lisp_Object specifier, | |
| 3232 Lisp_Object matchspec, | |
| 3233 Lisp_Object domain, | |
| 3234 Lisp_Object inst_list, | |
| 3235 Lisp_Object default_, | |
| 3236 int want_instantiator) | |
| 3237 { | |
| 3238 Lisp_Object val = Qunbound; | |
| 3239 Lisp_Specifier *sp = XSPECIFIER (specifier); | |
| 3240 struct gcpro gcpro1; | |
| 3241 Lisp_Object built_up_list = Qnil; | |
| 3242 Lisp_Object instantiator; | |
| 428 | 3243 |
| 3244 CHECK_SPECIFIER (specifier); | |
| 2953 | 3245 if (!UNBOUNDP (matchspec)) |
| 3246 check_valid_specifier_matchspec (matchspec, | |
| 3247 XSPECIFIER (specifier)->methods, | |
| 3248 ERROR_ME); | |
| 3249 check_valid_domain (domain); | |
| 3250 check_valid_inst_list (inst_list, sp->methods, ERROR_ME); | |
| 3251 GCPRO1 (built_up_list); | |
| 3252 built_up_list = build_up_processed_list (specifier, domain, inst_list); | |
| 3253 if (!NILP (built_up_list)) | |
| 3254 val = specifier_instance_from_inst_list (specifier, matchspec, domain, | |
| 3255 built_up_list, ERROR_ME, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3256 0, Qzero, &instantiator, 0); |
| 2953 | 3257 UNGCPRO; |
| 3258 return UNBOUNDP (val) ? default_ : want_instantiator ? instantiator : val; | |
| 3259 | |
| 428 | 3260 } |
| 3261 | |
| 3262 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list, | |
| 3263 3, 4, 0, /* | |
| 3264 Attempt to convert a particular inst-list into an instance. | |
| 3265 This attempts to instantiate INST-LIST in the given DOMAIN, | |
| 3266 as if INST-LIST existed in a specification in SPECIFIER. If | |
| 3267 the instantiation fails, DEFAULT is returned. In most circumstances, | |
| 3268 you should not use this function; use `specifier-instance' instead. | |
| 3269 */ | |
| 3270 (specifier, domain, inst_list, default_)) | |
| 3271 { | |
| 2953 | 3272 return specifier_matching_foo_from_inst_list (specifier, Qunbound, |
| 3273 domain, inst_list, default_, | |
| 3274 0); | |
| 3275 } | |
| 3276 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3277 DEFUN ("specifier-instantiator-from-inst-list", |
| 3659 | 3278 Fspecifier_instantiator_from_inst_list, 3, 4, 0, /* |
| 2953 | 3279 Attempt to convert an inst-list into an instance; return instantiator. |
| 3280 This is identical to `specifier-instance-from-inst-list' but returns | |
| 3281 the instantiator used to generate the instance, rather than the instance | |
| 3282 itself. | |
| 3283 */ | |
| 3284 (specifier, domain, inst_list, default_)) | |
| 3285 { | |
| 3286 return specifier_matching_foo_from_inst_list (specifier, Qunbound, | |
| 3287 domain, inst_list, default_, | |
| 3288 1); | |
| 428 | 3289 } |
| 3290 | |
| 442 | 3291 DEFUN ("specifier-matching-instance-from-inst-list", |
| 3292 Fspecifier_matching_instance_from_inst_list, | |
| 428 | 3293 4, 5, 0, /* |
| 3294 Attempt to convert a particular inst-list into an instance. | |
| 3295 This attempts to instantiate INST-LIST in the given DOMAIN | |
| 3296 \(as if INST-LIST existed in a specification in SPECIFIER), | |
| 3297 matching the specifications against MATCHSPEC. | |
| 3298 | |
| 3299 This function is analogous to `specifier-instance-from-inst-list' | |
| 3300 but allows for specification-matching as in `specifier-matching-instance'. | |
| 3301 See that function for a description of exactly how the matching process | |
| 3302 works. | |
| 3303 */ | |
| 3304 (specifier, matchspec, domain, inst_list, default_)) | |
| 3305 { | |
| 2953 | 3306 return specifier_matching_foo_from_inst_list (specifier, matchspec, |
| 3307 domain, inst_list, default_, | |
| 3308 0); | |
| 3309 } | |
| 3310 | |
| 3311 DEFUN ("specifier-matching-instantiator-from-inst-list", | |
| 3312 Fspecifier_matching_instantiator_from_inst_list, | |
| 3313 4, 5, 0, /* | |
| 3314 Attempt to convert an inst-list into an instance; return instantiator. | |
| 3315 This is identical to `specifier-matching-instance-from-inst-list' but returns | |
| 3316 the instantiator used to generate the instance, rather than the instance | |
| 3317 itself. | |
| 3318 */ | |
| 3319 (specifier, matchspec, domain, inst_list, default_)) | |
| 3320 { | |
| 3321 return specifier_matching_foo_from_inst_list (specifier, matchspec, | |
| 3322 domain, inst_list, default_, | |
| 3323 1); | |
| 428 | 3324 } |
| 3325 | |
| 3326 | |
| 3327 /************************************************************************/ | |
| 3328 /* Caching in the struct window or frame */ | |
| 3329 /************************************************************************/ | |
| 3330 | |
| 853 | 3331 /* Cause the current value of SPECIFIER in the domain of each frame and/or |
| 3332 window to be cached in the struct frame at STRUCT_FRAME_OFFSET and the | |
| 3333 struct window at STRUCT_WINDOW_OFFSET. When the value changes in a | |
| 3334 particular window, VALUE_CHANGED_IN_WINDOW is called. When the value | |
| 3335 changes in a particular frame, VALUE_CHANGED_IN_FRAME is called. | |
| 3336 | |
| 3337 Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate | |
| 3338 no caching in that sort of object. However, if they're not 0, you | |
| 3339 must supply a corresponding value-changed function. (This is the case | |
| 3340 so that you are forced to consider the ramifications of a value change. | |
| 3341 You nearly always need to do something, e.g. set a dirty flag.) | |
| 3342 | |
| 3343 If you create a built-in specifier, you should do the following: | |
| 3344 | |
| 3345 - Make sure the file you create the specifier in has a | |
| 3659 | 3346 specifier_vars_of_foo() function. If not, create it, declare it in |
| 3347 symsinit.h, and make sure it's called in the appropriate place in | |
| 3348 emacs.c. | |
| 853 | 3349 - In specifier_vars_of_foo(), do a DEFVAR_SPECIFIER(), followed by |
| 3659 | 3350 initializing the specifier using Fmake_specifier(), followed by |
| 3351 set_specifier_fallback(), followed (optionally) by | |
| 3352 set_specifier_caching(). | |
| 853 | 3353 - If you used set_specifier_caching(), make sure to create the |
| 3659 | 3354 appropriate value-changed functions. Also make sure to add the |
| 3355 appropriate slots where the values are cached to frameslots.h and | |
| 3356 winslots.h. | |
| 853 | 3357 |
| 3358 Do a grep for menubar_visible_p for an example. | |
| 3359 */ | |
| 428 | 3360 |
| 3361 /* #### It would be nice if the specifier caching automatically knew | |
| 3362 about specifier fallbacks, so we didn't have to do it ourselves. */ | |
| 3363 | |
| 3364 void | |
| 3365 set_specifier_caching (Lisp_Object specifier, int struct_window_offset, | |
| 3366 void (*value_changed_in_window) | |
| 3367 (Lisp_Object specifier, struct window *w, | |
| 3368 Lisp_Object oldval), | |
| 3369 int struct_frame_offset, | |
| 3370 void (*value_changed_in_frame) | |
| 3371 (Lisp_Object specifier, struct frame *f, | |
| 444 | 3372 Lisp_Object oldval), |
| 3373 int always_recompute) | |
| 428 | 3374 { |
| 440 | 3375 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 3376 assert (!GHOST_SPECIFIER_P (sp)); |
| 3377 | |
| 3378 if (!sp->caching) | |
| 3092 | 3379 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
3380 sp->caching = XSPECIFIER_CACHING (ALLOC_NORMAL_LISP_OBJECT (specifier_caching)); |
| 3092 | 3381 #else /* not NEW_GC */ |
| 3659 | 3382 sp->caching = xnew_and_zero (struct specifier_caching); |
| 3092 | 3383 #endif /* not NEW_GC */ |
| 428 | 3384 sp->caching->offset_into_struct_window = struct_window_offset; |
| 3385 sp->caching->value_changed_in_window = value_changed_in_window; | |
| 3386 sp->caching->offset_into_struct_frame = struct_frame_offset; | |
| 3387 sp->caching->value_changed_in_frame = value_changed_in_frame; | |
| 853 | 3388 if (struct_window_offset) |
| 3389 assert (value_changed_in_window); | |
| 3390 if (struct_frame_offset) | |
| 3391 assert (value_changed_in_frame); | |
| 444 | 3392 sp->caching->always_recompute = always_recompute; |
| 428 | 3393 Vcached_specifiers = Fcons (specifier, Vcached_specifiers); |
| 3394 if (BODILY_SPECIFIER_P (sp)) | |
| 5198 | 3395 GHOST_SPECIFIER (sp)->caching = sp->caching; |
| 428 | 3396 recompute_cached_specifier_everywhere (specifier); |
| 3397 } | |
| 3398 | |
| 3399 static void | |
| 3400 recompute_one_cached_specifier_in_window (Lisp_Object specifier, | |
| 3401 struct window *w) | |
| 3402 { | |
| 3403 Lisp_Object window; | |
| 444 | 3404 Lisp_Object newval, *location, oldval; |
| 428 | 3405 |
| 3406 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier))); | |
| 3407 | |
| 793 | 3408 window = wrap_window (w); |
| 428 | 3409 |
| 3410 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN, | |
| 3411 0, 0, Qzero); | |
| 3412 /* If newval ended up Qunbound, then the calling functions | |
| 3413 better be able to deal. If not, set a default so this | |
| 3414 never happens or correct it in the value_changed_in_window | |
| 3415 method. */ | |
| 3416 location = (Lisp_Object *) | |
| 3417 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window); | |
| 442 | 3418 /* #### What's the point of this check, other than to optimize image |
| 3419 instance instantiation? Unless you specify a caching instantiate | |
| 3420 method the instantiation that specifier_instance will do will | |
| 3421 always create a new copy. Thus EQ will always fail. Unfortunately | |
| 3422 calling equal is no good either as this doesn't take into account | |
| 3423 things attached to the specifier - for instance strings on | |
| 3424 extents. --andyp */ | |
| 444 | 3425 if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute) |
| 428 | 3426 { |
| 444 | 3427 oldval = *location; |
| 428 | 3428 *location = newval; |
| 3429 (XSPECIFIER (specifier)->caching->value_changed_in_window) | |
| 3430 (specifier, w, oldval); | |
| 3431 } | |
| 3432 } | |
| 3433 | |
| 3434 static void | |
| 3435 recompute_one_cached_specifier_in_frame (Lisp_Object specifier, | |
| 3436 struct frame *f) | |
| 3437 { | |
| 3438 Lisp_Object frame; | |
| 444 | 3439 Lisp_Object newval, *location, oldval; |
| 428 | 3440 |
| 3441 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier))); | |
| 3442 | |
| 793 | 3443 frame = wrap_frame (f); |
| 428 | 3444 |
| 3445 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN, | |
| 3446 0, 0, Qzero); | |
| 3447 /* If newval ended up Qunbound, then the calling functions | |
| 3448 better be able to deal. If not, set a default so this | |
| 3449 never happens or correct it in the value_changed_in_frame | |
| 3450 method. */ | |
| 3451 location = (Lisp_Object *) | |
| 3452 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame); | |
| 444 | 3453 if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute) |
| 428 | 3454 { |
| 444 | 3455 oldval = *location; |
| 428 | 3456 *location = newval; |
| 3457 (XSPECIFIER (specifier)->caching->value_changed_in_frame) | |
| 3458 (specifier, f, oldval); | |
| 3459 } | |
| 3460 } | |
| 3461 | |
| 3462 void | |
| 3463 recompute_all_cached_specifiers_in_window (struct window *w) | |
| 3464 { | |
| 3465 Lisp_Object rest; | |
| 3466 | |
| 3467 LIST_LOOP (rest, Vcached_specifiers) | |
| 3468 { | |
| 3469 Lisp_Object specifier = XCAR (rest); | |
| 3470 if (XSPECIFIER (specifier)->caching->offset_into_struct_window) | |
| 3471 recompute_one_cached_specifier_in_window (specifier, w); | |
| 3472 } | |
| 3473 } | |
| 3474 | |
| 3475 void | |
| 3476 recompute_all_cached_specifiers_in_frame (struct frame *f) | |
| 3477 { | |
| 3478 Lisp_Object rest; | |
| 3479 | |
| 3480 LIST_LOOP (rest, Vcached_specifiers) | |
| 3481 { | |
| 3482 Lisp_Object specifier = XCAR (rest); | |
| 3483 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame) | |
| 3484 recompute_one_cached_specifier_in_frame (specifier, f); | |
| 3485 } | |
| 3486 } | |
| 3487 | |
| 3488 static int | |
| 3489 recompute_cached_specifier_everywhere_mapfun (struct window *w, | |
| 3490 void *closure) | |
| 3491 { | |
| 3492 Lisp_Object specifier = Qnil; | |
| 3493 | |
| 5013 | 3494 specifier = GET_LISP_FROM_VOID (closure); |
| 428 | 3495 recompute_one_cached_specifier_in_window (specifier, w); |
| 3496 return 0; | |
| 3497 } | |
| 3498 | |
| 3499 static void | |
| 3500 recompute_cached_specifier_everywhere (Lisp_Object specifier) | |
| 3501 { | |
| 3502 Lisp_Object frmcons, devcons, concons; | |
| 3503 | |
| 3504 specifier = bodily_specifier (specifier); | |
| 3505 | |
| 3506 if (!XSPECIFIER (specifier)->caching) | |
| 3507 return; | |
| 3508 | |
| 3509 if (XSPECIFIER (specifier)->caching->offset_into_struct_window) | |
| 3510 { | |
| 3511 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 3512 map_windows (XFRAME (XCAR (frmcons)), | |
| 3513 recompute_cached_specifier_everywhere_mapfun, | |
| 5013 | 3514 STORE_LISP_IN_VOID (specifier)); |
| 428 | 3515 } |
| 3516 | |
| 3517 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame) | |
| 3518 { | |
| 3519 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 3520 recompute_one_cached_specifier_in_frame (specifier, | |
| 3521 XFRAME (XCAR (frmcons))); | |
| 3522 } | |
| 3523 } | |
| 3524 | |
| 3525 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /* | |
| 3526 Force recomputation of any caches associated with SPECIFIER. | |
| 3527 Note that this automatically happens whenever you change a specification | |
| 3528 in SPECIFIER; you do not have to call this function then. | |
| 3529 One example of where this function is useful is when you have a | |
| 3530 toolbar button whose `active-p' field is an expression to be | |
| 3531 evaluated. Calling `set-specifier-dirty-flag' on the | |
| 3532 toolbar specifier will force the `active-p' fields to be | |
| 3533 recomputed. | |
| 3534 */ | |
| 3535 (specifier)) | |
| 3536 { | |
| 3537 CHECK_SPECIFIER (specifier); | |
| 3538 recompute_cached_specifier_everywhere (specifier); | |
| 3539 return Qnil; | |
| 3540 } | |
| 3541 | |
| 3542 | |
| 3543 /************************************************************************/ | |
| 3544 /* Generic specifier type */ | |
| 3545 /************************************************************************/ | |
| 3546 | |
| 3547 DEFINE_SPECIFIER_TYPE (generic); | |
| 3548 | |
| 3549 #if 0 | |
| 3550 | |
| 3551 /* This is the string that used to be in `generic-specifier-p'. | |
| 3552 The idea is good, but it doesn't quite work in the form it's | |
| 3553 in. (One major problem is that validating an instantiator | |
| 3554 is supposed to require only that the specifier type is passed, | |
| 3555 while with this approach the actual specifier is needed.) | |
| 3556 | |
| 3557 What really needs to be done is to write a function | |
| 3558 `make-specifier-type' that creates new specifier types. | |
| 442 | 3559 |
| 3560 #### [I'll look into this for 19.14.] Well, sometime. (Currently | |
| 3561 May 2000, 21.2 is in development. 19.14 was released in June 1996.) */ | |
| 428 | 3562 |
| 3563 "A generic specifier is a generalized kind of specifier with user-defined\n" | |
| 3564 "semantics. The instantiator can be any kind of Lisp object, and the\n" | |
| 3565 "instance computed from it is likewise any kind of Lisp object. The\n" | |
| 3566 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n" | |
| 3567 "works. All methods are optional, and reasonable default methods will be\n" | |
| 2953 | 3568 "provided. Currently there are two defined methods: `instantiate' and\n" |
| 3569 "`validate'.\n" | |
| 428 | 3570 "\n" |
| 2953 | 3571 "`instantiate' specifies how to do the instantiation; if omitted, the\n" |
| 428 | 3572 "instantiator itself is simply returned as the instance. The method\n" |
| 3573 "should be a function that accepts three parameters (a specifier, the\n" | |
| 3574 "instantiator that matched the domain being instantiated over, and that\n" | |
| 3575 "domain), and should return a one-element list containing the instance,\n" | |
| 3576 "or nil if no instance exists. Note that the domain passed to this function\n" | |
| 3577 "is the domain being instantiated over, which may not be the same as the\n" | |
| 3578 "locale contained in the specification corresponding to the instantiator\n" | |
| 3579 "(for example, the domain being instantiated over could be a window, but\n" | |
| 3580 "the locale corresponding to the passed instantiator could be the window's\n" | |
| 3581 "buffer or frame).\n" | |
| 3582 "\n" | |
| 2953 | 3583 "`validate' specifies whether a given instantiator is valid; if omitted,\n" |
| 428 | 3584 "all instantiators are considered valid. It should be a function of\n" |
| 3585 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n" | |
| 3586 "flag is false, the function must simply return t or nil indicating\n" | |
| 3587 "whether the instantiator is valid. If this flag is true, the function\n" | |
| 3588 "is free to signal an error if it encounters an invalid instantiator\n" | |
| 3589 "(this can be useful for issuing a specific error about exactly why the\n" | |
| 3590 "instantiator is valid). It can also return nil to indicate an invalid\n" | |
| 3591 "instantiator; in this case, a general error will be signalled." | |
| 3592 | |
| 3593 #endif /* 0 */ | |
| 3594 | |
| 3595 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /* | |
| 3596 Return non-nil if OBJECT is a generic specifier. | |
| 3597 | |
| 442 | 3598 See `make-generic-specifier' for a description of possible generic |
| 3599 instantiators. | |
| 428 | 3600 */ |
| 3601 (object)) | |
| 3602 { | |
| 3603 return GENERIC_SPECIFIERP (object) ? Qt : Qnil; | |
| 3604 } | |
| 3605 | |
| 3606 | |
| 3607 /************************************************************************/ | |
| 3608 /* Integer specifier type */ | |
| 3609 /************************************************************************/ | |
| 3610 | |
| 3611 DEFINE_SPECIFIER_TYPE (integer); | |
| 3612 | |
| 3613 static void | |
| 3614 integer_validate (Lisp_Object instantiator) | |
| 3615 { | |
| 3616 CHECK_INT (instantiator); | |
| 3617 } | |
| 3618 | |
| 3619 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /* | |
| 3620 Return non-nil if OBJECT is an integer specifier. | |
| 442 | 3621 |
| 3622 See `make-integer-specifier' for a description of possible integer | |
| 3623 instantiators. | |
| 428 | 3624 */ |
| 3625 (object)) | |
| 3626 { | |
| 3627 return INTEGER_SPECIFIERP (object) ? Qt : Qnil; | |
| 3628 } | |
| 3629 | |
| 3630 /************************************************************************/ | |
| 3631 /* Non-negative-integer specifier type */ | |
| 3632 /************************************************************************/ | |
| 3633 | |
| 3634 DEFINE_SPECIFIER_TYPE (natnum); | |
| 3635 | |
| 3636 static void | |
| 3637 natnum_validate (Lisp_Object instantiator) | |
| 3638 { | |
| 3639 CHECK_NATNUM (instantiator); | |
| 3640 } | |
| 3641 | |
| 3642 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /* | |
| 3643 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier. | |
| 442 | 3644 |
| 3645 See `make-natnum-specifier' for a description of possible natnum | |
| 3646 instantiators. | |
| 428 | 3647 */ |
| 3648 (object)) | |
| 3649 { | |
| 3650 return NATNUM_SPECIFIERP (object) ? Qt : Qnil; | |
| 3651 } | |
| 3652 | |
| 3653 /************************************************************************/ | |
| 3654 /* Boolean specifier type */ | |
| 3655 /************************************************************************/ | |
| 3656 | |
| 3657 DEFINE_SPECIFIER_TYPE (boolean); | |
| 3658 | |
| 3659 static void | |
| 3660 boolean_validate (Lisp_Object instantiator) | |
| 3661 { | |
| 3662 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil)) | |
| 563 | 3663 invalid_constant ("Must be t or nil", instantiator); |
| 428 | 3664 } |
| 3665 | |
| 3666 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /* | |
| 3667 Return non-nil if OBJECT is a boolean specifier. | |
| 442 | 3668 |
| 3669 See `make-boolean-specifier' for a description of possible boolean | |
| 3670 instantiators. | |
| 428 | 3671 */ |
| 3672 (object)) | |
| 3673 { | |
| 3674 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil; | |
| 3675 } | |
| 3676 | |
| 3677 /************************************************************************/ | |
| 3678 /* Display table specifier type */ | |
| 3679 /************************************************************************/ | |
| 3680 | |
| 3681 DEFINE_SPECIFIER_TYPE (display_table); | |
| 3682 | |
| 3659 | 3683 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \ |
| 3684 (VECTORP (instantiator) \ | |
| 3685 || (CHAR_TABLEP (instantiator) \ | |
| 3686 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \ | |
| 442 | 3687 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \ |
| 428 | 3688 || RANGE_TABLEP (instantiator)) |
| 3689 | |
| 3690 static void | |
| 3691 display_table_validate (Lisp_Object instantiator) | |
| 3692 { | |
| 3693 if (NILP (instantiator)) | |
| 3694 /* OK */ | |
| 3695 ; | |
| 3696 else if (CONSP (instantiator)) | |
| 3697 { | |
| 2367 | 3698 EXTERNAL_LIST_LOOP_2 (car, instantiator) |
| 428 | 3699 { |
| 3700 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car)) | |
| 3701 goto lose; | |
| 3702 } | |
| 3703 } | |
| 3704 else | |
| 3705 { | |
| 3706 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator)) | |
| 3707 { | |
| 3708 lose: | |
| 442 | 3709 dead_wrong_type_argument |
| 3710 (display_table_specifier_methods->predicate_symbol, | |
| 3659 | 3711 instantiator); |
| 428 | 3712 } |
| 3713 } | |
| 3714 } | |
| 3715 | |
| 3716 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /* | |
| 3717 Return non-nil if OBJECT is a display-table specifier. | |
| 442 | 3718 |
| 3719 See `current-display-table' for a description of possible display-table | |
| 3720 instantiators. | |
| 428 | 3721 */ |
| 3722 (object)) | |
| 3723 { | |
| 3724 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil; | |
| 3725 } | |
| 3726 | |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3727 |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3728 |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3729 #ifdef MEMORY_USAGE_STATS |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3730 |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3731 struct specifier_stats |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3732 { |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3733 struct usage_stats u; |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3734 /* Ancillary Lisp */ |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3735 Bytecount global, device, frame, window, buffer, fallback; |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3736 Bytecount magic_parent; |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3737 }; |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3738 |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3739 static void |
|
5202
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3740 specifier_memory_usage (Lisp_Object UNUSED (specifier), |
|
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3741 struct generic_usage_stats * UNUSED (gustats)) |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3742 { |
|
5202
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3743 #if 0 |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3744 struct specifier_stats *stats = (struct specifier_stats *) gustats; |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3745 Lisp_Specifier *spec = XSPECIFIER (specifier); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3746 |
|
5202
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3747 /* #### FIXME -- sometimes it appears that the specs, or at least global |
|
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3748 specs, can have circularities in the tree structure. This makes |
|
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3749 everything much slower and in fact can result in a hang with 100% CPU. |
|
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3750 Need to investigate properly and figure out what's going on here, |
|
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3751 since the specs are copied when stored in and so supposedly, circular |
|
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3752 structures shouldn't exist. */ |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3753 stats->global = tree_memory_usage (spec->global_specs, 1); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3754 stats->device = tree_memory_usage (spec->device_specs, 1); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3755 stats->frame = tree_memory_usage (spec->frame_specs, 1); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3756 stats->window = tree_memory_usage (spec->window_specs, 1); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3757 stats->buffer = tree_memory_usage (spec->buffer_specs, 1); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3758 stats->fallback = tree_memory_usage (spec->fallback, 1); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3759 if (SPECIFIERP (spec->magic_parent)) |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3760 stats->magic_parent = lisp_object_memory_usage (spec->magic_parent); |
|
5202
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3761 #endif |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3762 } |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3763 |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3764 #endif /* MEMORY_USAGE_STATS */ |
| 428 | 3765 |
| 3766 /************************************************************************/ | |
| 3767 /* Initialization */ | |
| 3768 /************************************************************************/ | |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3769 |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3770 void |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3771 specifier_objects_create (void) |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3772 { |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3773 #ifdef MEMORY_USAGE_STATS |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3774 OBJECT_HAS_METHOD (specifier, memory_usage); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3775 #endif |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3776 } |
| 428 | 3777 |
| 3778 void | |
| 3779 syms_of_specifier (void) | |
| 3780 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3781 INIT_LISP_OBJECT (specifier); |
| 3092 | 3782 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3783 INIT_LISP_OBJECT (specifier_caching); |
| 3092 | 3784 #endif /* NEW_GC */ |
| 442 | 3785 |
| 3786 DEFSYMBOL (Qspecifierp); | |
| 3787 | |
| 3788 DEFSYMBOL (Qconsole_type); | |
| 3789 DEFSYMBOL (Qdevice_class); | |
| 3790 | |
| 3791 /* specifier types defined in general.c. */ | |
| 428 | 3792 |
| 3793 DEFSUBR (Fvalid_specifier_type_p); | |
| 3794 DEFSUBR (Fspecifier_type_list); | |
| 3795 DEFSUBR (Fmake_specifier); | |
| 3796 DEFSUBR (Fspecifierp); | |
| 3797 DEFSUBR (Fspecifier_type); | |
| 3798 | |
| 3799 DEFSUBR (Fvalid_specifier_locale_p); | |
| 3800 DEFSUBR (Fvalid_specifier_domain_p); | |
| 3801 DEFSUBR (Fvalid_specifier_locale_type_p); | |
| 3802 DEFSUBR (Fspecifier_locale_type_from_locale); | |
| 3803 | |
| 3804 DEFSUBR (Fvalid_specifier_tag_p); | |
| 3805 DEFSUBR (Fvalid_specifier_tag_set_p); | |
| 3806 DEFSUBR (Fcanonicalize_tag_set); | |
| 3807 DEFSUBR (Fdevice_matches_specifier_tag_set_p); | |
| 3808 DEFSUBR (Fdefine_specifier_tag); | |
| 3809 DEFSUBR (Fdevice_matching_specifier_tag_list); | |
| 3673 | 3810 |
| 428 | 3811 DEFSUBR (Fspecifier_tag_list); |
| 3659 | 3812 DEFSUBR (Fspecifier_tag_device_predicate); |
| 3813 DEFSUBR (Fspecifier_tag_charset_predicate); | |
| 428 | 3814 |
| 3815 DEFSUBR (Fcheck_valid_instantiator); | |
| 3816 DEFSUBR (Fvalid_instantiator_p); | |
| 3817 DEFSUBR (Fcheck_valid_inst_list); | |
| 3818 DEFSUBR (Fvalid_inst_list_p); | |
| 3819 DEFSUBR (Fcheck_valid_spec_list); | |
| 3820 DEFSUBR (Fvalid_spec_list_p); | |
| 3821 DEFSUBR (Fadd_spec_to_specifier); | |
| 3822 DEFSUBR (Fadd_spec_list_to_specifier); | |
| 3823 DEFSUBR (Fspecifier_spec_list); | |
| 3824 DEFSUBR (Fspecifier_specs); | |
| 3825 DEFSUBR (Fremove_specifier); | |
| 3826 DEFSUBR (Fcopy_specifier); | |
| 3827 | |
| 3828 DEFSUBR (Fcheck_valid_specifier_matchspec); | |
| 3829 DEFSUBR (Fvalid_specifier_matchspec_p); | |
| 3830 DEFSUBR (Fspecifier_fallback); | |
| 3831 DEFSUBR (Fspecifier_instance); | |
| 2953 | 3832 DEFSUBR (Fspecifier_instantiator); |
| 428 | 3833 DEFSUBR (Fspecifier_matching_instance); |
| 2953 | 3834 DEFSUBR (Fspecifier_matching_instantiator); |
| 428 | 3835 DEFSUBR (Fspecifier_instance_from_inst_list); |
| 2953 | 3836 DEFSUBR (Fspecifier_instantiator_from_inst_list); |
| 428 | 3837 DEFSUBR (Fspecifier_matching_instance_from_inst_list); |
| 2953 | 3838 DEFSUBR (Fspecifier_matching_instantiator_from_inst_list); |
| 428 | 3839 DEFSUBR (Fset_specifier_dirty_flag); |
| 3840 | |
| 3841 DEFSUBR (Fgeneric_specifier_p); | |
| 3842 DEFSUBR (Finteger_specifier_p); | |
| 3843 DEFSUBR (Fnatnum_specifier_p); | |
| 3844 DEFSUBR (Fboolean_specifier_p); | |
| 3845 DEFSUBR (Fdisplay_table_specifier_p); | |
| 3846 | |
| 3847 /* Symbols pertaining to specifier creation. Specifiers are created | |
| 3848 in the syms_of() functions. */ | |
| 3849 | |
| 3850 /* locales are defined in general.c. */ | |
| 3851 | |
| 442 | 3852 /* some how-to-add flags in general.c. */ |
| 3853 DEFSYMBOL (Qremove_tag_set_prepend); | |
| 3854 DEFSYMBOL (Qremove_tag_set_append); | |
| 3855 DEFSYMBOL (Qremove_locale); | |
| 3856 DEFSYMBOL (Qremove_locale_type); | |
| 428 | 3857 } |
| 3858 | |
| 3859 void | |
| 3860 specifier_type_create (void) | |
| 3861 { | |
| 3862 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry); | |
| 2367 | 3863 dump_add_root_block_ptr (&the_specifier_type_entry_dynarr, &sted_description); |
| 428 | 3864 |
| 3865 Vspecifier_type_list = Qnil; | |
| 3866 staticpro (&Vspecifier_type_list); | |
| 3867 | |
| 3868 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p"); | |
| 3869 | |
| 3870 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p"); | |
| 3871 | |
| 3872 SPECIFIER_HAS_METHOD (integer, validate); | |
| 3873 | |
| 3874 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p"); | |
| 3875 | |
| 3876 SPECIFIER_HAS_METHOD (natnum, validate); | |
| 3877 | |
| 3878 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p"); | |
| 3879 | |
| 3880 SPECIFIER_HAS_METHOD (boolean, validate); | |
| 3881 | |
| 442 | 3882 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", |
| 3883 "display-table-p"); | |
| 428 | 3884 |
| 3885 SPECIFIER_HAS_METHOD (display_table, validate); | |
| 3886 } | |
| 3887 | |
| 3888 void | |
| 3889 reinit_specifier_type_create (void) | |
| 3890 { | |
| 3891 REINITIALIZE_SPECIFIER_TYPE (generic); | |
| 3892 REINITIALIZE_SPECIFIER_TYPE (integer); | |
| 3893 REINITIALIZE_SPECIFIER_TYPE (natnum); | |
| 3894 REINITIALIZE_SPECIFIER_TYPE (boolean); | |
| 3895 REINITIALIZE_SPECIFIER_TYPE (display_table); | |
| 3896 } | |
| 3897 | |
| 3898 void | |
| 3899 vars_of_specifier (void) | |
| 3900 { | |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3901 #ifdef MEMORY_USAGE_STATS |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3902 OBJECT_HAS_PROPERTY (specifier, memusage_stats_list, |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3903 listu (Qt, Qglobal, Qdevice, Qframe, Qwindow, Qbuffer, |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3904 Qfallback, intern ("magic-parent"), |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3905 Qunbound)); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3906 #endif /* MEMORY_USAGE_STATS */ |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3907 |
| 428 | 3908 Vcached_specifiers = Qnil; |
| 3909 staticpro (&Vcached_specifiers); | |
| 3910 | |
| 3911 /* Do NOT mark through this, or specifiers will never be GC'd. | |
| 3912 This is the same deal as for weak hash tables. */ | |
| 3913 Vall_specifiers = Qnil; | |
| 452 | 3914 dump_add_weak_object_chain (&Vall_specifiers); |
| 428 | 3915 |
| 3916 Vuser_defined_tags = Qnil; | |
| 3917 staticpro (&Vuser_defined_tags); | |
| 3918 | |
| 3919 Vunlock_ghost_specifiers = Qnil; | |
| 3920 staticpro (&Vunlock_ghost_specifiers); | |
| 3659 | 3921 |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3922 Vcharset_tag_lists = |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5179
diff
changeset
|
3923 make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, Qeq); |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3924 staticpro (&Vcharset_tag_lists); |
| 428 | 3925 } |