Mercurial > hg > xemacs-beta
view src/select.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 | 8608eadee6ba |
children | a9094f28f9a9 |
line wrap: on
line source
/* Generic selection processing for XEmacs Copyright (C) 1999 Free Software Foundation, Inc. Copyright (C) 1999 Andy Piper. This file is part of XEmacs. XEmacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with XEmacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Synched up with: Not synched with FSF. */ #include <config.h> #include "lisp.h" #include "buffer.h" #include "device-impl.h" #include "extents.h" #include "console.h" #include "fontcolor.h" #include "frame.h" #include "opaque.h" #include "select.h" /* X Atoms */ Lisp_Object QPRIMARY, QSECONDARY, QSTRING, QINTEGER, QCLIPBOARD, QTIMESTAMP, QTEXT, QDELETE, QMULTIPLE, QINCR, QEMACS_TMP, QTARGETS, QATOM, QNULL, QATOM_PAIR, QCOMPOUND_TEXT; /* Windows clipboard formats */ Lisp_Object QCF_TEXT, QCF_BITMAP, QCF_METAFILEPICT, QCF_SYLK, QCF_DIF, QCF_TIFF, QCF_OEMTEXT, QCF_DIB, QCF_DIBV5, QCF_PALETTE, QCF_PENDATA, QCF_RIFF, QCF_WAVE, QCF_UNICODETEXT, QCF_ENHMETAFILE, QCF_HDROP, QCF_LOCALE, QCF_OWNERDISPLAY, QCF_DSPTEXT, QCF_DSPBITMAP, QCF_DSPMETAFILEPICT, QCF_DSPENHMETAFILE; /* Selection strategy symbols */ Lisp_Object Qreplace_all, Qreplace_existing; /* "Selection owner couldn't convert selection" */ Lisp_Object Qselection_conversion_error; /* A couple of Lisp functions */ Lisp_Object Qselect_convert_in, Qselect_convert_out, Qselect_coerce; /* These are alists whose CARs are selection-types (whose names are the same as the names of X Atoms or Windows clipboard formats) and whose CDRs are the names of Lisp functions to call to convert the given Emacs selection value to a string representing the given selection type. This is for elisp-level extension of the emacs selection handling. */ Lisp_Object Vselection_converter_out_alist; Lisp_Object Vselection_converter_in_alist; Lisp_Object Vselection_coercion_alist; Lisp_Object Vselection_appender_alist; Lisp_Object Vselection_buffer_killed_alist; Lisp_Object Vselection_coercible_types; Lisp_Object Vlost_selection_hooks; /* This is an association list whose elements are of the form ( selection-name selection-value selection-timestamp ) selection-name is a lisp symbol, whose name is the name of an X Atom. selection-value is a list of cons pairs that emacs owns for that selection. Each pair consists of (type . value), where type is nil or a selection data type, and value is any type of Lisp object. selection-timestamp is the time at which emacs began owning this selection, as a cons of two 16-bit numbers (making a 32 bit time). If there is an entry in this alist, then it can be assumed that emacs owns that selection. The only (eq) parts of this list that are visible from elisp are the selection-values. */ Lisp_Object Vselection_alist; /* Given a selection-name and desired type, this looks up our local copy of the selection value and converts it to the type. */ static Lisp_Object get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type) { Lisp_Object local_value = assq_no_quit (selection_symbol, Vselection_alist); if (!NILP (local_value)) { Lisp_Object value_list = XCAR (XCDR (local_value)); Lisp_Object value; /* First try to find an entry of the appropriate type */ value = assq_no_quit (target_type, value_list); if (!NILP (value)) return XCDR (value); } return Qnil; } /* #### Should perhaps handle `MULTIPLE'. The code below is now completely broken due to a re-organization of get_local_selection, but I've left it here should anyone show an interest - ajh */ #if 0 else if (CONSP (target_type) && XCAR (target_type) == QMULTIPLE) { Lisp_Object pairs = XCDR (target_type); int len = XVECTOR_LENGTH (pairs); int i; /* If the target is MULTIPLE, then target_type looks like (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ]) We modify the second element of each pair in the vector and return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ] */ for (i = 0; i < len; i++) { Lisp_Object pair = XVECTOR_DATA (pairs) [i]; XVECTOR_DATA (pair) [1] = x_get_local_selection (XVECTOR_DATA (pair) [0], XVECTOR_DATA (pair) [1]); } return pairs; } #endif DEFUN ("own-selection-internal", Fown_selection_internal, 2, 5, 0, /* Give the selection SELECTION-NAME the value SELECTION-VALUE. SELECTION-NAME is a symbol, typically PRIMARY, SECONDARY, or CLIPBOARD. SELECTION-VALUE is typically a string, or a cons of two markers, but may be anything that the functions on selection-converter-out-alist know about. Optional arg HOW-TO-ADD specifies how the selection will be combined with any existing selection(s) - see `own-selection' for more information. Optional arg DATA-TYPE is a window-system-specific type. Optional arg DEVICE specifies the device on which to assert the selection. It defaults to the selected device. */ (selection_name, selection_value, how_to_add, data_type, device)) { Lisp_Object selection_time, selection_data, prev_value = Qnil, value_list = Qnil; Lisp_Object prev_real_value = Qnil; struct gcpro gcpro1; int owned_p = 0; CHECK_SYMBOL (selection_name); if (NILP (selection_value)) invalid_argument ("`selection-value' may not be nil", Qunbound); if (NILP (device)) device = Fselected_device (Qnil); if (!EQ (how_to_add, Qappend) && !EQ (how_to_add, Qt) && !EQ (how_to_add, Qreplace_existing) && !EQ (how_to_add, Qreplace_all) && !NILP (how_to_add)) invalid_constant ("`how-to-add' must be nil, append, replace_all, " "replace_existing or t", how_to_add); #ifdef MULE if (NILP (data_type)) data_type = QCOMPOUND_TEXT; #else if (NILP (data_type)) data_type = QSTRING; #endif /* Examine the how-to-add argument */ if (EQ (how_to_add, Qreplace_all) || NILP (how_to_add)) { Lisp_Object local_selection_data = assq_no_quit (selection_name, Vselection_alist); if (!NILP (local_selection_data)) { owned_p = 1; Vselection_alist = delq_no_quit (local_selection_data, Vselection_alist); } } else { /* Look for a previous value */ prev_value = assq_no_quit (selection_name, Vselection_alist); if (!NILP (prev_value)) { owned_p = 1; value_list = XCAR (XCDR (prev_value)); } if (!NILP (value_list)) prev_real_value = assq_no_quit (data_type, value_list); } /* Append values if necessary */ if (!NILP (value_list) && (EQ (how_to_add, Qappend) || EQ (how_to_add, Qt))) { /* Did we have anything of this type previously? */ if (!NILP (prev_real_value)) { if ((NILP (data_type) && STRINGP (selection_value) && STRINGP (XCDR (prev_real_value))) || !NILP (data_type)) { Lisp_Object function = assq_no_quit (data_type, Vselection_appender_alist); if (NILP (function)) signal_error (Qinvalid_argument, "Cannot append selections of supplied types (no function)", data_type); function = XCDR (function); selection_value = call4 (function, selection_name, data_type, XCDR (prev_real_value), selection_value); if (NILP (selection_value)) signal_error (Qinvalid_argument, "Cannot append selections of supplied types (function returned nil)", data_type); } else signal_error_2 (Qinvalid_argument, "Cannot append selections of supplied types (data type nil and both values not strings)", XCDR (prev_real_value), selection_value); } selection_data = Fcons (data_type, selection_value); value_list = Fcons (selection_data, value_list); } if (!NILP (prev_real_value)) { Lisp_Object rest; /* We know it isn't the CAR, so it's easy. */ /* Delete the old type entry from the list */ for (rest = value_list; !NILP (rest); rest = Fcdr (rest)) if (EQ (prev_real_value, Fcar (XCDR (rest)))) { XCDR (rest) = Fcdr (XCDR (rest)); break; } } else { value_list = Fcons (Fcons (data_type, selection_value), value_list); } /* Complete the local cache update; note that we destructively modify the current list entry if there is one */ if (NILP (prev_value)) { selection_data = list3 (selection_name, value_list, Qnil); Vselection_alist = Fcons (selection_data, Vselection_alist); } else { selection_data = prev_value; Fsetcar (XCDR (selection_data), value_list); } GCPRO1 (selection_data); /* have to do device specific stuff last so that methods can access the selection_alist */ /* If you are re-implementing this for another redisplay type, either make certain that the selection time will fit within thirty-two bits, or redesign get-xemacs-selection-timestamp to return, say, a bignum, and convert the device-specific timestamp to a bignum before storing it in this list. The current practice is to blindly assume that the timestamp is thirty-two bits, which will work for extant architectures. */ if (HAS_DEVMETH_P (XDEVICE (device), own_selection)) selection_time = DEVMETH (XDEVICE (device), own_selection, (selection_name, selection_value, how_to_add, data_type, owned_p)); else selection_time = Qnil; Fsetcar (XCDR (XCDR (selection_data)), selection_time); UNGCPRO; return selection_value; } DEFUN ("register-selection-data-type", Fregister_selection_data_type, 1,2,0, /* Register a new selection data type DATA-TYPE, optionally on the specified DEVICE. Returns the device-specific data type identifier, or nil if the device does not support this feature or the registration fails. */ (data_type, device)) { /* Check arguments */ CHECK_STRING (data_type); if (NILP (device)) device = Fselected_device (Qnil); if (HAS_DEVMETH_P (XDEVICE (device), register_selection_data_type)) return DEVMETH (XDEVICE (device), register_selection_data_type, (data_type)); else return Qnil; } DEFUN ("selection-data-type-name", Fselection_data_type_name, 1, 2, 0, /* Retrieve the name of the specified selection data type DATA-TYPE, optionally on the specified DEVICE. Returns either a string or a symbol on success, and nil if the device does not support this feature or the type is not known. */ (data_type, device)) { if (NILP (device)) device = Fselected_device (Qnil); if (HAS_DEVMETH_P (XDEVICE (device), selection_data_type_name)) return DEVMETH (XDEVICE (device), selection_data_type_name, (data_type)); else return Qnil; } DEFUN ("available-selection-types", Favailable_selection_types, 1, 2, 0, /* Retrieve a list of currently available types of selection associated with the given SELECTION-NAME, optionally on the specified DEVICE. This list does not take into account any possible conversions that might take place, so it should be taken as a minimal estimate of what is available. */ (selection_name, device)) { Lisp_Object types = Qnil, rest; struct gcpro gcpro1; CHECK_SYMBOL (selection_name); if (NILP (device)) device = Fselected_device (Qnil); GCPRO1 (types); /* First check the device */ if (HAS_DEVMETH_P (XDEVICE (device), available_selection_types)) types = DEVMETH (XDEVICE (device), available_selection_types, (selection_name)); /* Now look in the list */ rest = assq_no_quit (selection_name, Vselection_alist); if (NILP (rest)) { UNGCPRO; return types; } /* Examine the types and cons them onto the front of the list */ for (rest = XCAR (XCDR (rest)); !NILP (rest); rest = XCDR (rest)) { Lisp_Object value = XCDR (XCAR (rest)); Lisp_Object type = XCAR (XCAR (rest)); types = Fcons (type, types); if ((STRINGP (value) || EXTENTP (value)) && (NILP (type) || EQ (type, QSTRING) || EQ (type, QTEXT) || EQ (type, QCOMPOUND_TEXT))) types = Fcons (QTEXT, Fcons (QCOMPOUND_TEXT, Fcons (QSTRING, types))); else if (INTP (value) && NILP (type)) types = Fcons (QINTEGER, types); else if (SYMBOLP (value) && NILP (type)) types = Fcons (QATOM, types); } UNGCPRO; return types; } /* remove a selection from our local copy */ void handle_selection_clear (Lisp_Object selection_symbol) { Lisp_Object local_selection_data = assq_no_quit (selection_symbol, Vselection_alist); /* Well, we already believe that we don't own it, so that's just fine. */ if (NILP (local_selection_data)) return; /* Otherwise, we're really honest and truly being told to drop it. */ Vselection_alist = delq_no_quit (local_selection_data, Vselection_alist); /* Let random lisp code notice that the selection has been stolen. */ { Lisp_Object rest; Lisp_Object val = Vlost_selection_hooks; if (!UNBOUNDP (val) && !NILP (val)) { if (CONSP (val) && !EQ (XCAR (val), Qlambda)) for (rest = val; !NILP (rest); rest = Fcdr (rest)) call1 (Fcar (rest), selection_symbol); else call1 (val, selection_symbol); } } } DEFUN ("disown-selection-internal", Fdisown_selection_internal, 1, 3, 0, /* If we own the named selection, then disown it (make there be no selection). */ (selection_name, selection_time, device)) { if (NILP (assq_no_quit (selection_name, Vselection_alist))) return Qnil; /* Don't disown the selection when we're not the owner. */ if (NILP (device)) device = Fselected_device (Qnil); MAYBE_DEVMETH (XDEVICE (device), disown_selection, (selection_name, selection_time)); handle_selection_clear (selection_name); return Qt; } DEFUN ("selection-owner-p", Fselection_owner_p, 0, 1, 0, /* Return t if the current emacs process owns SELECTION. SELECTION should be the name of the selection in question, typically one of the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience, the symbol nil is the same as PRIMARY, and t is the same as SECONDARY.) */ (selection)) { CHECK_SYMBOL (selection); if (EQ (selection, Qnil)) selection = QPRIMARY; else if (EQ (selection, Qt)) selection = QSECONDARY; return NILP (Fassq (selection, Vselection_alist)) ? Qnil : Qt; } DEFUN ("selection-exists-p", Fselection_exists_p, 0, 3, 0, /* Whether there is currently an owner for SELECTION. SELECTION should be the name of the selection in question, typically one of the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience, the symbol nil is the same as PRIMARY, and t is the same as SECONDARY.) Optionally, the window-system DATA-TYPE and the DEVICE may be specified. */ (selection, data_type, device)) { CHECK_SYMBOL (selection); if (NILP (data_type) && !NILP (Fselection_owner_p (selection))) return Qt; if (NILP (device)) device = Fselected_device (Qnil); return HAS_DEVMETH_P (XDEVICE (device), selection_exists_p) ? DEVMETH (XDEVICE (device), selection_exists_p, (selection, data_type)) : Qnil; } Lisp_Object get_selection_raw_time(Lisp_Object selection) { Lisp_Object local_value = assq_no_quit (selection, Vselection_alist); if (!NILP (local_value)) { return XCAR (XCDR (XCDR (local_value))); } return Qnil; } /* Get the timestamp of the given selection */ DEFUN ("get-xemacs-selection-timestamp", Fget_selection_timestamp, 1, 1, 0, /* Return timestamp for SELECTION, if it belongs to XEmacs and exists. The timestamp is a cons of two integers, the first being the higher-order sixteen bits of the device-specific thirty-two-bit quantity, the second being the lower-order sixteen bits of same. Expect to see this API change when and if redisplay on a window system with timestamps wider than 32bits happens. */ (selection)) { Lisp_Object val = get_selection_raw_time(selection); if (!NILP (val)) { return word_to_lisp(* (UINT_32_BIT *) XOPAQUE_DATA (val)); } return Qnil; } /* Request the selection value from the owner. If we are the owner, simply return our selection value. If we are not the owner, this will block until all of the data has arrived. */ DEFUN ("get-selection-internal", Fget_selection_internal, 2, 3, 0, /* Return text selected from some window-system window. SELECTION is a symbol, typically PRIMARY, SECONDARY, or CLIPBOARD. TARGET-TYPE is the type of data desired, typically STRING or COMPOUND_TEXT. Under Mule, if the resultant data comes back as 8-bit data in type TEXT or COMPOUND_TEXT, it will be decoded as Compound Text. */ (selection, target_type, device)) { /* This function can GC */ Lisp_Object val = Qnil; struct gcpro gcpro1, gcpro2; GCPRO2 (target_type, val); CHECK_SYMBOL (selection); if (NILP (device)) device = Fselected_device (Qnil); #ifdef MULE if (NILP (target_type)) target_type = QCOMPOUND_TEXT; #else if (NILP (target_type)) target_type = QSTRING; #endif #if 0 /* #### MULTIPLE doesn't work yet and probably never will */ if (CONSP (target_type) && XCAR (target_type) == QMULTIPLE) { CHECK_VECTOR (XCDR (target_type)); /* So we don't destructively modify this... */ target_type = copy_multiple_data (target_type); } #endif /* Used to check that target_type was a symbol. This is no longer necessarily the case, because the type might be registered with the device (in which case target_type would be a device-specific identifier - probably an integer) - ajh */ val = get_local_selection (selection, target_type); if (!NILP (val)) { /* If we get something from the local cache, we may need to convert it slightly - to do this, we call select-coerce */ val = call3 (Qselect_coerce, selection, target_type, val); } else if (HAS_DEVMETH_P (XDEVICE (device), get_foreign_selection)) { /* Nothing in the local cache; try the window system */ val = DEVMETH (XDEVICE (device), get_foreign_selection, (selection, target_type)); } if (NILP (val)) { /* Still nothing. Try coercion. */ /* Try looking in selection-coercible-types to see if any of them are present for this selection. We try them *in order*; the first for which a conversion succeeds gets returned. */ EXTERNAL_LIST_LOOP_2 (element, Vselection_coercible_types) { val = get_local_selection (selection, element); if (NILP (val)) continue; val = call3 (Qselect_coerce, selection, target_type, val); if (!NILP (val)) break; } } /* Used to call clean_local_selection here... but that really belonged in Lisp (so the equivalent is now built-in to the INTEGER conversion function select-convert-from-integer) - ajh */ UNGCPRO; return val; } /* These are convenient interfaces to the lisp code in select.el; this way we can rename them easily rather than having to hunt everywhere. Also, this gives us access to get_local_selection so that convert_out can retrieve the internal selection value automatically if passed a value of Qnil. */ Lisp_Object select_convert_in (Lisp_Object selection, Lisp_Object type, Lisp_Object value) { return call3 (Qselect_convert_in, selection, type, value); } Lisp_Object select_coerce (Lisp_Object selection, Lisp_Object type, Lisp_Object value) { return call3 (Qselect_coerce, selection, type, value); } Lisp_Object select_convert_out (Lisp_Object selection, Lisp_Object type, Lisp_Object value) { if (NILP (value)) value = get_local_selection (selection, type); if (NILP (value)) { /* Try looking in selection-coercible-types to see if any of them are present for this selection. We try them *in order*; the first for which a conversion succeeds gets returned. */ EXTERNAL_LIST_LOOP_2 (element, Vselection_coercible_types) { Lisp_Object ret; value = get_local_selection (selection, element); if (NILP (value)) continue; ret = call3 (Qselect_convert_out, selection, type, value); if (!NILP (ret)) return ret; } return Qnil; } return call3 (Qselect_convert_out, selection, type, value); } /* Gets called from kill-buffer; this lets us dispose of buffer-dependent selections (or alternatively make them independent of the buffer) when it gets vaped. */ void select_notify_buffer_kill (Lisp_Object buffer) { Lisp_Object rest; struct gcpro gcpro1, gcpro2, gcpro3; /* For each element of Vselection_alist */ for (rest = Vselection_alist; !NILP (rest);) { Lisp_Object selection, values, prev = Qnil; selection = XCAR (rest); for (values = XCAR (XCDR (selection)); !NILP (values); values = XCDR (values)) { Lisp_Object value, handler_fn; /* Extract the (type . value) pair. */ value = XCAR (values); /* Find the handler function (if any). */ handler_fn = Fcdr (Fassq (XCAR (value), Vselection_buffer_killed_alist)); if (!NILP (handler_fn)) { Lisp_Object newval; /* Protect ourselves, just in case some tomfool calls own-selection from with the buffer-killed handler, then causes a GC. Just as a note, *don't do this*. */ GCPRO3 (rest, values, value); newval = call4 (handler_fn, XCAR (selection), XCAR (value), XCDR (value), buffer); UNGCPRO; /* Set or delete the value (by destructively modifying the list). */ if (!NILP (newval)) { Fsetcdr (value, newval); prev = values; } else { if (NILP (prev)) Fsetcar (XCDR (selection), XCDR (values)); else Fsetcdr (prev, XCDR (values)); } } else prev = values; } /* If we have no values for this selection */ if (NILP (XCAR (XCDR (selection)))) { /* Move on to the next element *first* */ rest = XCDR (rest); /* Protect it and disown this selection */ GCPRO1 (rest); Fdisown_selection_internal (XCAR (selection), Qnil, Qnil); UNGCPRO; } else rest = XCDR (rest); } } void syms_of_select (void) { DEFSUBR (Fown_selection_internal); DEFSUBR (Fget_selection_internal); DEFSUBR (Fget_selection_timestamp); DEFSUBR (Fselection_exists_p); DEFSUBR (Fdisown_selection_internal); DEFSUBR (Fselection_owner_p); DEFSUBR (Favailable_selection_types); DEFSUBR (Fregister_selection_data_type); DEFSUBR (Fselection_data_type_name); /* Lisp Functions */ DEFSYMBOL (Qselect_convert_in); DEFSYMBOL (Qselect_convert_out); DEFSYMBOL (Qselect_coerce); /* X Atoms */ DEFSYMBOL (QPRIMARY); DEFSYMBOL (QSECONDARY); DEFSYMBOL (QSTRING); DEFSYMBOL (QINTEGER); DEFSYMBOL (QCLIPBOARD); DEFSYMBOL (QTIMESTAMP); DEFSYMBOL (QTEXT); DEFSYMBOL (QDELETE); DEFSYMBOL (QMULTIPLE); DEFSYMBOL (QINCR); defsymbol (&QEMACS_TMP, "_EMACS_TMP_"); DEFSYMBOL (QTARGETS); DEFSYMBOL (QATOM); defsymbol (&QATOM_PAIR, "ATOM_PAIR"); defsymbol (&QCOMPOUND_TEXT, "COMPOUND_TEXT"); DEFSYMBOL (QNULL); /* Windows formats - these all start with CF_ */ defsymbol (&QCF_TEXT, "CF_TEXT"); defsymbol (&QCF_BITMAP, "CF_BITMAP"); defsymbol (&QCF_METAFILEPICT, "CF_METAFILEPICT"); defsymbol (&QCF_SYLK, "CF_SYLK"); defsymbol (&QCF_DIF, "CF_DIF"); defsymbol (&QCF_TIFF, "CF_TIFF"); defsymbol (&QCF_OEMTEXT, "CF_OEMTEXT"); defsymbol (&QCF_DIB, "CF_DIB"); defsymbol (&QCF_DIBV5, "CF_DIBV5"); defsymbol (&QCF_PALETTE, "CF_PALETTE"); defsymbol (&QCF_PENDATA, "CF_PENDATA"); defsymbol (&QCF_RIFF, "CF_RIFF"); defsymbol (&QCF_WAVE, "CF_WAVE"); defsymbol (&QCF_UNICODETEXT, "CF_UNICODETEXT"); defsymbol (&QCF_ENHMETAFILE, "CF_ENHMETAFILE"); defsymbol (&QCF_HDROP, "CF_HDROP"); defsymbol (&QCF_LOCALE, "CF_LOCALE"); defsymbol (&QCF_OWNERDISPLAY, "CF_OWNERDISPLAY"); defsymbol (&QCF_DSPTEXT, "CF_DSPTEXT"); defsymbol (&QCF_DSPBITMAP, "CF_DSPBITMAP"); defsymbol (&QCF_DSPMETAFILEPICT, "CF_DSPMETAFILEPICT"); defsymbol (&QCF_DSPENHMETAFILE, "CF_DSPENHMETAFILE"); /* Selection strategies */ DEFSYMBOL (Qreplace_all); DEFSYMBOL (Qreplace_existing); DEFERROR_STANDARD (Qselection_conversion_error, Qconversion_error); } void vars_of_select (void) { Vselection_alist = Qnil; staticpro (&Vselection_alist); DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_out_alist /* An alist associating selection-types (such as STRING and TIMESTAMP) with functions. This is an alias for `selection-converter-out-alist', and should be considered obsolete. Use the new name instead. */ ); DEFVAR_LISP ("selection-converter-out-alist", &Vselection_converter_out_alist /* An alist associating selection-types (such as STRING and TIMESTAMP) with functions. These functions will be called with three args: the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD); a desired type to which the selection should be converted; and the local selection value (whatever had been passed to `own-selection'). The return type of these functions depends upon the device in question; for mswindows, a string should be returned containing data in the requested format, or nil to indicate that the conversion could not be done. Additionally, it is permissible to return a cons of the form (DATA-TYPE . STRING) suggesting a new data type to use instead. For X, the return value should be one of: -- nil (the conversion could not be done) -- a cons of a symbol and any of the following values; the symbol explicitly specifies the type that will be sent. -- a string (If the type is not specified, then if Mule support exists, the string will be converted to Compound Text and sent in the `COMPOUND_TEXT' format; otherwise (no Mule support), the string will be left as-is and sent in the `STRING' format. If the type is specified, the string will be left as-is (or converted to binary format under Mule). In all cases, 8-bit data it sent.) -- a character (With Mule support, will be converted to Compound Text whether or not a type is specified. If a type is not specified, a type of `STRING' or `COMPOUND_TEXT' will be sent, as for strings.) -- the symbol `NULL' (Indicates that there is no meaningful return value. Empty 32-bit data with a type of `NULL' will be sent.) -- a symbol (Will be converted into an atom. If the type is not specified, a type of `ATOM' will be sent.) -- an integer (Will be converted into a 16-bit or 32-bit integer depending on the value. If the type is not specified, a type of `INTEGER' will be sent.) -- a cons (HIGH . LOW) of integers (Will be converted into a 32-bit integer. If the type is not specified, a type of `INTEGER' will be sent.) -- a vector of symbols (Will be converted into a list of atoms. If the type is not specified, a type of `ATOM' will be sent.) -- a vector of integers (Will be converted into a list of 16-bit integers. If the type is not specified, a type of `INTEGER' will be sent.) -- a vector of integers and/or conses (HIGH . LOW) of integers (Will be converted into a list of 16-bit integers. If the type is not specified, a type of `INTEGER' will be sent.) */ ); Vselection_converter_out_alist = Qnil; DEFVAR_LISP ("selection-converter-in-alist", &Vselection_converter_in_alist /* An alist associating selection-types (such as STRING and TIMESTAMP) with functions. These functions will be called with three args: the name of the selection (typically PRIMARY, SECONDARY or CLIPBOARD); the type from which the selection should be converted; and the selection value. These functions should return a suitable representation of the value, or nil to indicate that the conversion was not possible. See also `selection-converter-out-alist'. */ ); Vselection_converter_in_alist = Qnil; DEFVAR_LISP ("selection-coercion-alist", &Vselection_coercion_alist /* An alist associating selection-types (such as STRING and TIMESTAMP) with functions. These functions will be called with three args; the name of the selection (typically PRIMARY, SECONDARY or CLIPBOARD); the type from which the selection should be converted, and the selection value. The value passed will be *exactly the same value* that was given to `own-selection'; it should be converted into something suitable for return to a program calling `get-selection' with the appropriate parameters. See also `selection-converter-in-alist' and `selection-converter-out-alist'. */); Vselection_coercion_alist = Qnil; DEFVAR_LISP ("selection-appender-alist", &Vselection_appender_alist /* An alist associating selection-types (such as STRING and TIMESTAMP) with functions. These functions will be called with four args; the name of the selection (typically PRIMARY, SECONDARY or CLIPBOARD); the type of the selection; and two selection values. The functions are expected to return a value representing the catenation of the two values, or nil to indicate that this was not possible. */ ); Vselection_appender_alist = Qnil; DEFVAR_LISP ("selection-buffer-killed-alist", &Vselection_buffer_killed_alist /* An alist associating selection-types (such as STRING and TIMESTAMP) with functions. These functions will be called whenever a buffer is killed, with four args: the name of the selection (typically PRIMARY, SECONDARY or CLIPBOARD); the type of the selection; the value of the selection; and the buffer that has just been killed. These functions should return a new selection value, or nil to indicate that the selection value should be deleted. */ ); Vselection_buffer_killed_alist = Qnil; DEFVAR_LISP ("selection-coercible-types", &Vselection_coercible_types /* A list of selection types that are coercible---that is, types that may be automatically converted to another type. Selection values with types in this list may be subject to conversion attempts to other types. */ ); Vselection_coercible_types = Qnil; DEFVAR_LISP ("lost-selection-hooks", &Vlost_selection_hooks /* A function or functions to be called after we have been notified that we have lost the selection. The function(s) will be called with one argument, a symbol naming the selection (typically PRIMARY, SECONDARY, or CLIPBOARD). */ ); Vlost_selection_hooks = Qunbound; }