procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge from emacs--devo--0

Browse source 
Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-283
This commit is contained in:
Miles Bader 2007-11-11 00:56:44 +00:00
commit f23d76bdef
403 changed files with 36975 additions and 16864 deletions
Download patch file Download diff file Expand all files Collapse all files

7
lisp/emacs-lisp/advice.el
View file

@ -2675,12 +2675,9 @@ For that it has to be fbound with a non-autoload definition."
(ad-with-auto-activation-disabled
(require 'bytecomp)
(let ((symbol (make-symbol "advice-compilation"))
(byte-compile-warnings
(if (listp byte-compile-warnings) byte-compile-warnings
byte-compile-warning-types)))
(byte-compile-warnings byte-compile-warnings))
(if (featurep 'cl)
(setq byte-compile-warnings
(remq 'cl-functions byte-compile-warnings)))
(byte-compile-disable-warning 'cl-functions))
(fset symbol (symbol-function function))
(byte-compile symbol)
(fset function (symbol-function symbol))))))

8
lisp/emacs-lisp/authors.el
View file

@ -475,8 +475,8 @@ with the file and the number of each action.
:wrote means the author wrote the file
:changed means he changed the file COUNT times."
(let* ((enable-local-variables t)
(enable-local-eval t)
(let* ((enable-local-variables :safe)
(enable-local-eval nil)
(existing-buffer (get-file-buffer log-file))
(buffer (find-file-noselect log-file))
author file pos)
@ -521,8 +521,8 @@ with the file and the number of each action.
"Scan Lisp file FILE for author information.
TABLE is a hash table to add author information to."
(let* ((existing-buffer (get-file-buffer file))
(enable-local-variables t)
(enable-local-eval t)
(enable-local-variables :safe)
(enable-local-eval nil)
(buffer (find-file-noselect file)))
(save-excursion
(set-buffer buffer)

4
lisp/emacs-lisp/byte-opt.el
View file

@ -1150,7 +1150,9 @@
;; can safely optimize away this test.
(if (member (cdr-safe form) '(((quote xemacs)) ((quote sxemacs))))
nil
form))
(if (member (cdr-safe form) '(((quote emacs))))
t
form)))
(put 'set 'byte-optimizer 'byte-optimize-set)
(defun byte-optimize-set (form)

173
lisp/emacs-lisp/bytecomp.el
View file

@ -362,7 +362,10 @@ Elements of the list may be:
interactive-only
commands that normally shouldn't be called from Lisp code.
make-local calls to make-variable-buffer-local that may be incorrect.
mapcar mapcar called for effect."
mapcar mapcar called for effect.
If the list begins with `not', then the remaining elements specify warnings to
suppress. For example, (not mapcar) will suppress warnings about mapcar."
:group 'bytecomp
:type `(choice (const :tag "All" t)
(set :menu-tag "Some"
@ -377,6 +380,8 @@ Elements of the list may be:
(defun byte-compile-warnings-safe-p (x)
(or (booleanp x)
(and (listp x)
(if (eq (car x) 'not) (setq x (cdr x))
t)
(equal (mapcar
(lambda (e)
(when (memq e '(free-vars unresolved
@ -388,6 +393,46 @@ Elements of the list may be:
x)
x))))
(defun byte-compile-warning-enabled-p (warning)
"Return non-nil if WARNING is enabled, according to `byte-compile-warnings'."
(or (eq byte-compile-warnings t)
(if (eq (car byte-compile-warnings) 'not)
(not (memq warning byte-compile-warnings))
(memq warning byte-compile-warnings))))
;;;###autoload
(defun byte-compile-disable-warning (warning)
"Change `byte-compile-warnings' to disable WARNING.
If `byte-compile-warnings' is t, set it to `(not WARNING)'.
Otherwise, if the first element is `not', add WARNING, else remove it.
Normally you should let-bind `byte-compile-warnings' before calling this,
else the global value will be modified."
(setq byte-compile-warnings
(cond ((eq byte-compile-warnings t)
(list 'not warning))
((eq (car byte-compile-warnings) 'not)
(if (memq warning byte-compile-warnings)
byte-compile-warnings
(append byte-compile-warnings (list warning))))
(t
(delq warning byte-compile-warnings)))))
;;;###autoload
(defun byte-compile-enable-warning (warning)
"Change `byte-compile-warnings' to enable WARNING.
If `byte-compile-warnings' is `t', do nothing. Otherwise, if the
first element is `not', remove WARNING, else add it.
Normally you should let-bind `byte-compile-warnings' before calling this,
else the global value will be modified."
(or (eq byte-compile-warnings t)
(setq byte-compile-warnings
(cond ((eq (car byte-compile-warnings) 'not)
(delq warning byte-compile-warnings))
((memq warning byte-compile-warnings)
byte-compile-warnings)
(t
(append byte-compile-warnings (list warning)))))))
(defvar byte-compile-interactive-only-functions
'(beginning-of-buffer end-of-buffer replace-string replace-regexp
insert-file insert-buffer insert-file-literally previous-line next-line)
@ -830,7 +875,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(let ((hist-orig load-history)
(hist-nil-orig current-load-list))
(prog1 (eval form)
(when (memq 'noruntime byte-compile-warnings)
(when (byte-compile-warning-enabled-p 'noruntime)
(let ((hist-new load-history)
(hist-nil-new current-load-list))
;; Go through load-history, look for newly loaded files
@ -858,7 +903,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(push s byte-compile-noruntime-functions))
(when (and (consp s) (eq t (car s)))
(push (cdr s) old-autoloads)))))))
(when (memq 'cl-functions byte-compile-warnings)
(when (byte-compile-warning-enabled-p 'cl-functions)
(let ((hist-new load-history))
;; Go through load-history, look for newly loaded files
;; and mark all the functions defined therein.
@ -876,8 +921,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(let ((tem current-load-list))
(while (not (eq tem hist-nil-orig))
(when (equal (car tem) '(require . cl))
(setq byte-compile-warnings
(remq 'cl-functions byte-compile-warnings)))
(byte-compile-disable-warning 'cl-functions))
(setq tem (cdr tem)))))))
;;; byte compiler messages
@ -1075,7 +1119,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(handler (nth 1 new))
(when (nth 2 new)))
(byte-compile-set-symbol-position (car form))
(if (memq 'obsolete byte-compile-warnings)
(if (byte-compile-warning-enabled-p 'obsolete)
(byte-compile-warn "`%s' is an obsolete function%s; %s" (car form)
(if when (concat " (as of Emacs " when ")") "")
(if (stringp (car new))
@ -1421,7 +1465,7 @@ extra args."
;; defined, issue a warning enumerating them.
;; `unresolved' in the list `byte-compile-warnings' disables this.
(defun byte-compile-warn-about-unresolved-functions ()
(when (memq 'unresolved byte-compile-warnings)
(when (byte-compile-warning-enabled-p 'unresolved)
(let ((byte-compile-current-form :end)
(noruntime nil)
(unresolved nil))
@ -1484,9 +1528,7 @@ symbol itself."
byte-compile-dynamic-docstrings)
;; (byte-compile-generate-emacs19-bytecodes
;; byte-compile-generate-emacs19-bytecodes)
(byte-compile-warnings (if (eq byte-compile-warnings t)
byte-compile-warning-types
byte-compile-warnings))
(byte-compile-warnings byte-compile-warnings)
)
body)))
@ -1829,9 +1871,7 @@ With argument, insert value in current buffer after the form."
(read-with-symbol-positions inbuffer)
(read-symbol-positions-list nil)
;; #### This is bound in b-c-close-variables.
;; (byte-compile-warnings (if (eq byte-compile-warnings t)
;; byte-compile-warning-types
;; byte-compile-warnings))
;; (byte-compile-warnings byte-compile-warnings)
)
(byte-compile-close-variables
(with-current-buffer
@ -2210,7 +2250,7 @@ list that represents a doc string reference.
;; Since there is no doc string, we can compile this as a normal form,
;; and not do a file-boundary.
(byte-compile-keep-pending form)
(when (memq 'free-vars byte-compile-warnings)
(when (byte-compile-warning-enabled-p 'free-vars)
(push (nth 1 form) byte-compile-bound-variables)
(if (eq (car form) 'defconst)
(push (nth 1 form) byte-compile-const-variables)))
@ -2220,12 +2260,19 @@ list that represents a doc string reference.
(byte-compile-top-level (nth 2 form) nil 'file))))
form))
(put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-define-abbrev-table)
(defun byte-compile-file-form-define-abbrev-table (form)
(when (and (byte-compile-warning-enabled-p 'free-vars)
(eq 'quote (car-safe (car-safe (cdr form)))))
(push (car-safe (cdr (cadr form))) byte-compile-bound-variables))
(byte-compile-keep-pending form))
(put 'custom-declare-variable 'byte-hunk-handler
'byte-compile-file-form-custom-declare-variable)
(defun byte-compile-file-form-custom-declare-variable (form)
(when (memq 'callargs byte-compile-warnings)
(when (byte-compile-warning-enabled-p 'callargs)
(byte-compile-nogroup-warn form))
(when (memq 'free-vars byte-compile-warnings)
(when (byte-compile-warning-enabled-p 'free-vars)
(push (nth 1 (nth 1 form)) byte-compile-bound-variables))
(let ((tail (nthcdr 4 form)))
(while tail
@ -2248,8 +2295,7 @@ list that represents a doc string reference.
(apply 'require args)
;; Detect (require 'cl) in a way that works even if cl is already loaded.
(if (member (car args) '("cl" cl))
(setq byte-compile-warnings
(remq 'cl-functions byte-compile-warnings))))
(byte-compile-disable-warning 'cl-functions)))
(byte-compile-keep-pending form 'byte-compile-normal-call))
(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
@ -2295,12 +2341,12 @@ list that represents a doc string reference.
(cons (list name nil nil) byte-compile-call-tree))))
(setq byte-compile-current-form name) ; for warnings
(if (memq 'redefine byte-compile-warnings)
(if (byte-compile-warning-enabled-p 'redefine)
(byte-compile-arglist-warn form macrop))
(if byte-compile-verbose
(message "Compiling %s... (%s)" (or filename "") (nth 1 form)))
(cond (that-one
(if (and (memq 'redefine byte-compile-warnings)
(if (and (byte-compile-warning-enabled-p 'redefine)
;; don't warn when compiling the stubs in byte-run...
(not (assq (nth 1 form)
byte-compile-initial-macro-environment)))
@ -2309,7 +2355,7 @@ list that represents a doc string reference.
(nth 1 form)))
(setcdr that-one nil))
(this-one
(when (and (memq 'redefine byte-compile-warnings)
(when (and (byte-compile-warning-enabled-p 'redefine)
;; hack: don't warn when compiling the magic internal
;; byte-compiler macros in byte-run.el...
(not (assq (nth 1 form)
@ -2320,7 +2366,7 @@ list that represents a doc string reference.
((and (fboundp name)
(eq (car-safe (symbol-function name))
(if macrop 'lambda 'macro)))
(when (memq 'redefine byte-compile-warnings)
(when (byte-compile-warning-enabled-p 'redefine)
(byte-compile-warn "%s `%s' being redefined as a %s"
(if macrop "function" "macro")
(nth 1 form)
@ -2560,7 +2606,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(byte-compile-check-lambda-list (nth 1 fun))
(let* ((arglist (nth 1 fun))
(byte-compile-bound-variables
(nconc (and (memq 'free-vars byte-compile-warnings)
(nconc (and (byte-compile-warning-enabled-p 'free-vars)
(delq '&rest (delq '&optional (copy-sequence arglist))))
byte-compile-bound-variables))
(body (cdr (cdr fun)))
@ -2800,7 +2846,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(handler (get fn 'byte-compile)))
(when (byte-compile-const-symbol-p fn)
(byte-compile-warn "`%s' called as a function" fn))
(and (memq 'interactive-only byte-compile-warnings)
(and (byte-compile-warning-enabled-p 'interactive-only)
(memq fn byte-compile-interactive-only-functions)
(byte-compile-warn "`%s' used from Lisp code\n\
That command is designed for interactive use only" fn))
@ -2815,12 +2861,12 @@ That command is designed for interactive use only" fn))
byte-compile-compatibility)
(get (get fn 'byte-opcode) 'emacs19-opcode))))
(funcall handler form)
(when (memq 'callargs byte-compile-warnings)
(when (byte-compile-warning-enabled-p 'callargs)
(if (memq fn '(custom-declare-group custom-declare-variable custom-declare-face))
(byte-compile-nogroup-warn form))
(byte-compile-callargs-warn form))
(byte-compile-normal-call form))
(if (memq 'cl-functions byte-compile-warnings)
(if (byte-compile-warning-enabled-p 'cl-functions)
(byte-compile-cl-warn form))))
((and (or (byte-code-function-p (car form))
(eq (car-safe (car form)) 'lambda))
@ -2837,7 +2883,7 @@ That command is designed for interactive use only" fn))
(if byte-compile-generate-call-tree
(byte-compile-annotate-call-tree form))
(when (and for-effect (eq (car form) 'mapcar)
(memq 'mapcar byte-compile-warnings))
(byte-compile-warning-enabled-p 'mapcar))
(byte-compile-set-symbol-position 'mapcar)
(byte-compile-warn
"`mapcar' called for effect; use `mapc' or `dolist' instead"))
@ -2857,7 +2903,7 @@ That command is designed for interactive use only" fn))
(if (symbolp var) "constant" "nonvariable")
(prin1-to-string var))
(if (and (get var 'byte-obsolete-variable)
(memq 'obsolete byte-compile-warnings)
(byte-compile-warning-enabled-p 'obsolete)
(not (eq var byte-compile-not-obsolete-var)))
(let* ((ob (get var 'byte-obsolete-variable))
(when (cdr ob)))
@ -2866,7 +2912,7 @@ That command is designed for interactive use only" fn))
(if (stringp (car ob))
(car ob)
(format "use `%s' instead." (car ob))))))
(if (memq 'free-vars byte-compile-warnings)
(if (byte-compile-warning-enabled-p 'free-vars)
(if (eq base-op 'byte-varbind)
(push var byte-compile-bound-variables)
(or (boundp var)
@ -3448,6 +3494,32 @@ That command is designed for interactive use only" fn))
(if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
,tag))
;; Return the list of items in CONDITION-PARAM that match PRED-LIST.
;; Only return items that are not in ONLY-IF-NOT-PRESENT.
(defun byte-compile-find-bound-condition (condition-param
pred-list
&optional only-if-not-present)
(let ((result nil)
(nth-one nil)
(cond-list
(if (memq (car-safe condition-param) pred-list)
;; The condition appears by itself.
(list condition-param)
;; If the condition is an `and', look for matches among the
;; `and' arguments.
(when (eq 'and (car-safe condition-param))
(cdr condition-param)))))
(dolist (crt cond-list)
(when (and (memq (car-safe crt) pred-list)
(eq 'quote (car-safe (setq nth-one (nth 1 crt))))
;; Ignore if the symbol is already on the unresolved
;; list.
(not (assq (nth 1 nth-one) ; the relevant symbol
only-if-not-present)))
(push (nth 1 (nth 1 crt)) result)))
result))
(defmacro byte-compile-maybe-guarded (condition &rest body)
"Execute forms in BODY, potentially guarded by CONDITION.
CONDITION is a variable whose value is a test in an `if' or `cond'.
@ -3459,35 +3531,34 @@ being undefined will be suppressed.
If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs),
that suppresses all warnings during execution of BODY."
(declare (indent 1) (debug t))
`(let* ((fbound
(if (eq 'fboundp (car-safe ,condition))
(and (eq 'quote (car-safe (nth 1 ,condition)))
;; Ignore if the symbol is already on the
;; unresolved list.
(not (assq (nth 1 (nth 1 ,condition)) ; the relevant symbol
byte-compile-unresolved-functions))
(nth 1 (nth 1 ,condition)))))
(bound (if (or (eq 'boundp (car-safe ,condition))
(eq 'default-boundp (car-safe ,condition)))
(and (eq 'quote (car-safe (nth 1 ,condition)))
(nth 1 (nth 1 ,condition)))))
`(let* ((fbound-list (byte-compile-find-bound-condition
,condition (list 'fboundp)
byte-compile-unresolved-functions))
(bound-list (byte-compile-find-bound-condition
,condition (list 'boundp 'default-boundp)))
;; Maybe add to the bound list.
(byte-compile-bound-variables
(if bound
(cons bound byte-compile-bound-variables)
(if bound-list
(append bound-list byte-compile-bound-variables)
byte-compile-bound-variables))
;; Suppress all warnings, for code not used in Emacs.
(byte-compile-warnings
(if (member ,condition '((featurep 'xemacs)
(not (featurep 'emacs))))
nil byte-compile-warnings)))
;; FIXME: by the time this is executed the `featurep'
;; emacs/xemacs tests have been optimized away, so this is
;; not doing anything useful here, is should probably be
;; moved to a different place.
;; (byte-compile-warnings
;; (if (member ,condition '((featurep 'xemacs)
;; (not (featurep 'emacs))))
;; nil byte-compile-warnings))
)
(unwind-protect
(progn ,@body)
;; Maybe remove the function symbol from the unresolved list.
(if fbound
(dolist (fbound fbound-list)
(when fbound
(setq byte-compile-unresolved-functions
(delq (assq fbound byte-compile-unresolved-functions)
byte-compile-unresolved-functions))))))
byte-compile-unresolved-functions)))))))
(defun byte-compile-if (form)
(byte-compile-form (car (cdr form)))
@ -3809,7 +3880,7 @@ that suppresses all warnings during execution of BODY."
(if (= 1 ncall) "" "s")
(if (< ncall 2) "requires" "accepts only")
"2-3")))
(when (memq 'free-vars byte-compile-warnings)
(when (byte-compile-warning-enabled-p 'free-vars)
(push var byte-compile-bound-variables)
(if (eq fun 'defconst)
(push var byte-compile-const-variables)))
@ -3901,7 +3972,7 @@ that suppresses all warnings during execution of BODY."
(byte-defop-compiler-1 make-variable-buffer-local byte-compile-make-variable-buffer-local)
(defun byte-compile-make-variable-buffer-local (form)
(if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote)
(memq 'make-local byte-compile-warnings))
(byte-compile-warning-enabled-p 'make-local))
(byte-compile-warn
"`make-variable-buffer-local' should be called at toplevel"))
(byte-compile-normal-call form))

4
lisp/emacs-lisp/cl-compat.el
View file

@ -186,5 +186,9 @@
(provide 'cl-compat)
;; Local variables:
;; byte-compile-warnings: (not cl-functions)
;; End:
;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163
;;; cl-compat.el ends here

118
lisp/emacs-lisp/cl-loaddefs.el
View file

@ -745,24 +745,24 @@ Not documented
;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not
;;;;;; substitute-if substitute delete-duplicates remove-duplicates
;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove*
;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "c972a97c053d4e001ac1d1012c315b28")
;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "77bee7df392948b6ab0699e391e8abc1")
;;; Generated autoloads from cl-seq.el
(autoload (quote reduce) "cl-seq" "\
(autoload 'reduce "cl-seq" "\
Reduce two-argument FUNCTION across SEQ.
Keywords supported: :start :end :from-end :initial-value :key
\(fn FUNCTION SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote fill) "cl-seq" "\
(autoload 'fill "cl-seq" "\
Fill the elements of SEQ with ITEM.
Keywords supported: :start :end
\(fn SEQ ITEM [KEYWORD VALUE]...)" nil nil)
(autoload (quote replace) "cl-seq" "\
(autoload 'replace "cl-seq" "\
Replace the elements of SEQ1 with the elements of SEQ2.
SEQ1 is destructively modified, then returned.
@ -770,7 +770,7 @@ Keywords supported: :start1 :end1 :start2 :end2
\(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote remove*) "cl-seq" "\
(autoload 'remove* "cl-seq" "\
Remove all occurrences of ITEM in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
@ -779,7 +779,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end
\(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote remove-if) "cl-seq" "\
(autoload 'remove-if "cl-seq" "\
Remove all items satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
@ -788,7 +788,7 @@ Keywords supported: :key :count :start :end :from-end
\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote remove-if-not) "cl-seq" "\
(autoload 'remove-if-not "cl-seq" "\
Remove all items not satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
@ -797,7 +797,7 @@ Keywords supported: :key :count :start :end :from-end
\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote delete*) "cl-seq" "\
(autoload 'delete* "cl-seq" "\
Remove all occurrences of ITEM in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -805,7 +805,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end
\(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote delete-if) "cl-seq" "\
(autoload 'delete-if "cl-seq" "\
Remove all items satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -813,7 +813,7 @@ Keywords supported: :key :count :start :end :from-end
\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote delete-if-not) "cl-seq" "\
(autoload 'delete-if-not "cl-seq" "\
Remove all items not satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -821,21 +821,21 @@ Keywords supported: :key :count :start :end :from-end
\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote remove-duplicates) "cl-seq" "\
(autoload 'remove-duplicates "cl-seq" "\
Return a copy of SEQ with all duplicate elements removed.
Keywords supported: :test :test-not :key :start :end :from-end
\(fn SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote delete-duplicates) "cl-seq" "\
(autoload 'delete-duplicates "cl-seq" "\
Remove all duplicate elements from SEQ (destructively).
Keywords supported: :test :test-not :key :start :end :from-end
\(fn SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote substitute) "cl-seq" "\
(autoload 'substitute "cl-seq" "\
Substitute NEW for OLD in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
@ -844,7 +844,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end
\(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote substitute-if) "cl-seq" "\
(autoload 'substitute-if "cl-seq" "\
Substitute NEW for all items satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
@ -853,7 +853,7 @@ Keywords supported: :key :count :start :end :from-end
\(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote substitute-if-not) "cl-seq" "\
(autoload 'substitute-if-not "cl-seq" "\
Substitute NEW for all items not satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
@ -862,7 +862,7 @@ Keywords supported: :key :count :start :end :from-end
\(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote nsubstitute) "cl-seq" "\
(autoload 'nsubstitute "cl-seq" "\
Substitute NEW for OLD in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -870,7 +870,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end
\(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote nsubstitute-if) "cl-seq" "\
(autoload 'nsubstitute-if "cl-seq" "\
Substitute NEW for all items satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -878,7 +878,7 @@ Keywords supported: :key :count :start :end :from-end
\(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote nsubstitute-if-not) "cl-seq" "\
(autoload 'nsubstitute-if-not "cl-seq" "\
Substitute NEW for all items not satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -886,7 +886,7 @@ Keywords supported: :key :count :start :end :from-end
\(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote find) "cl-seq" "\
(autoload 'find "cl-seq" "\
Find the first occurrence of ITEM in SEQ.
Return the matching ITEM, or nil if not found.
@ -894,7 +894,7 @@ Keywords supported: :test :test-not :key :start :end :from-end
\(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote find-if) "cl-seq" "\
(autoload 'find-if "cl-seq" "\
Find the first item satisfying PREDICATE in SEQ.
Return the matching item, or nil if not found.
@ -902,7 +902,7 @@ Keywords supported: :key :start :end :from-end
\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote find-if-not) "cl-seq" "\
(autoload 'find-if-not "cl-seq" "\
Find the first item not satisfying PREDICATE in SEQ.
Return the matching item, or nil if not found.
@ -910,7 +910,7 @@ Keywords supported: :key :start :end :from-end
\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote position) "cl-seq" "\
(autoload 'position "cl-seq" "\
Find the first occurrence of ITEM in SEQ.
Return the index of the matching item, or nil if not found.
@ -918,7 +918,7 @@ Keywords supported: :test :test-not :key :start :end :from-end
\(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote position-if) "cl-seq" "\
(autoload 'position-if "cl-seq" "\
Find the first item satisfying PREDICATE in SEQ.
Return the index of the matching item, or nil if not found.
@ -926,7 +926,7 @@ Keywords supported: :key :start :end :from-end
\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote position-if-not) "cl-seq" "\
(autoload 'position-if-not "cl-seq" "\
Find the first item not satisfying PREDICATE in SEQ.
Return the index of the matching item, or nil if not found.
@ -934,28 +934,28 @@ Keywords supported: :key :start :end :from-end
\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote count) "cl-seq" "\
(autoload 'count "cl-seq" "\
Count the number of occurrences of ITEM in SEQ.
Keywords supported: :test :test-not :key :start :end
\(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote count-if) "cl-seq" "\
(autoload 'count-if "cl-seq" "\
Count the number of items satisfying PREDICATE in SEQ.
Keywords supported: :key :start :end
\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote count-if-not) "cl-seq" "\
(autoload 'count-if-not "cl-seq" "\
Count the number of items not satisfying PREDICATE in SEQ.
Keywords supported: :key :start :end
\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil)
(autoload (quote mismatch) "cl-seq" "\
(autoload 'mismatch "cl-seq" "\
Compare SEQ1 with SEQ2, return index of first mismatching element.
Return nil if the sequences match. If one sequence is a prefix of the
other, the return value indicates the end of the shorter sequence.
@ -964,7 +964,7 @@ Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
\(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote search) "cl-seq" "\
(autoload 'search "cl-seq" "\
Search for SEQ1 as a subsequence of SEQ2.
Return the index of the leftmost element of the first match found;
return nil if there are no matches.
@ -973,7 +973,7 @@ Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
\(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote sort*) "cl-seq" "\
(autoload 'sort* "cl-seq" "\
Sort the argument SEQ according to PREDICATE.
This is a destructive function; it reuses the storage of SEQ if possible.
@ -981,7 +981,7 @@ Keywords supported: :key
\(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil)
(autoload (quote stable-sort) "cl-seq" "\
(autoload 'stable-sort "cl-seq" "\
Sort the argument SEQ stably according to PREDICATE.
This is a destructive function; it reuses the storage of SEQ if possible.
@ -989,7 +989,7 @@ Keywords supported: :key
\(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil)
(autoload (quote merge) "cl-seq" "\
(autoload 'merge "cl-seq" "\
Destructively merge the two sequences to produce a new sequence.
TYPE is the sequence type to return, SEQ1 and SEQ2 are the two argument
sequences, and PREDICATE is a `less-than' predicate on the elements.
@ -998,7 +998,7 @@ Keywords supported: :key
\(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)" nil nil)
(autoload (quote member*) "cl-seq" "\
(autoload 'member* "cl-seq" "\
Find the first occurrence of ITEM in LIST.
Return the sublist of LIST whose car is ITEM.
@ -1006,7 +1006,7 @@ Keywords supported: :test :test-not :key
\(fn ITEM LIST [KEYWORD VALUE]...)" nil nil)
(autoload (quote member-if) "cl-seq" "\
(autoload 'member-if "cl-seq" "\
Find the first item satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
@ -1014,7 +1014,7 @@ Keywords supported: :key
\(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil)
(autoload (quote member-if-not) "cl-seq" "\
(autoload 'member-if-not "cl-seq" "\
Find the first item not satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
@ -1022,54 +1022,54 @@ Keywords supported: :key
\(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil)
(autoload (quote cl-adjoin) "cl-seq" "\
(autoload 'cl-adjoin "cl-seq" "\
Not documented
\(fn CL-ITEM CL-LIST &rest CL-KEYS)" nil nil)
(autoload (quote assoc*) "cl-seq" "\
(autoload 'assoc* "cl-seq" "\
Find the first item whose car matches ITEM in LIST.
Keywords supported: :test :test-not :key
\(fn ITEM LIST [KEYWORD VALUE]...)" nil nil)
(autoload (quote assoc-if) "cl-seq" "\
(autoload 'assoc-if "cl-seq" "\
Find the first item whose car satisfies PREDICATE in LIST.
Keywords supported: :key
\(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil)
(autoload (quote assoc-if-not) "cl-seq" "\
(autoload 'assoc-if-not "cl-seq" "\
Find the first item whose car does not satisfy PREDICATE in LIST.
Keywords supported: :key
\(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil)
(autoload (quote rassoc*) "cl-seq" "\
(autoload 'rassoc* "cl-seq" "\
Find the first item whose cdr matches ITEM in LIST.
Keywords supported: :test :test-not :key
\(fn ITEM LIST [KEYWORD VALUE]...)" nil nil)
(autoload (quote rassoc-if) "cl-seq" "\
(autoload 'rassoc-if "cl-seq" "\
Find the first item whose cdr satisfies PREDICATE in LIST.
Keywords supported: :key
\(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil)
(autoload (quote rassoc-if-not) "cl-seq" "\
(autoload 'rassoc-if-not "cl-seq" "\
Find the first item whose cdr does not satisfy PREDICATE in LIST.
Keywords supported: :key
\(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil)
(autoload (quote union) "cl-seq" "\
(autoload 'union "cl-seq" "\
Combine LIST1 and LIST2 using a set-union operation.
The result list contains all items that appear in either LIST1 or LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
@ -1079,7 +1079,7 @@ Keywords supported: :test :test-not :key
\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote nunion) "cl-seq" "\
(autoload 'nunion "cl-seq" "\
Combine LIST1 and LIST2 using a set-union operation.
The result list contains all items that appear in either LIST1 or LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
@ -1089,7 +1089,7 @@ Keywords supported: :test :test-not :key
\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote intersection) "cl-seq" "\
(autoload 'intersection "cl-seq" "\
Combine LIST1 and LIST2 using a set-intersection operation.
The result list contains all items that appear in both LIST1 and LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
@ -1099,7 +1099,7 @@ Keywords supported: :test :test-not :key
\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote nintersection) "cl-seq" "\
(autoload 'nintersection "cl-seq" "\
Combine LIST1 and LIST2 using a set-intersection operation.
The result list contains all items that appear in both LIST1 and LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
@ -1109,7 +1109,7 @@ Keywords supported: :test :test-not :key
\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote set-difference) "cl-seq" "\
(autoload 'set-difference "cl-seq" "\
Combine LIST1 and LIST2 using a set-difference operation.
The result list contains all items that appear in LIST1 but not LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
@ -1119,7 +1119,7 @@ Keywords supported: :test :test-not :key
\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote nset-difference) "cl-seq" "\
(autoload 'nset-difference "cl-seq" "\
Combine LIST1 and LIST2 using a set-difference operation.
The result list contains all items that appear in LIST1 but not LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
@ -1129,7 +1129,7 @@ Keywords supported: :test :test-not :key
\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote set-exclusive-or) "cl-seq" "\
(autoload 'set-exclusive-or "cl-seq" "\
Combine LIST1 and LIST2 using a set-exclusive-or operation.
The result list contains all items that appear in exactly one of LIST1, LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
@ -1139,7 +1139,7 @@ Keywords supported: :test :test-not :key
\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote nset-exclusive-or) "cl-seq" "\
(autoload 'nset-exclusive-or "cl-seq" "\
Combine LIST1 and LIST2 using a set-exclusive-or operation.
The result list contains all items that appear in exactly one of LIST1, LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
@ -1149,7 +1149,7 @@ Keywords supported: :test :test-not :key
\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote subsetp) "cl-seq" "\
(autoload 'subsetp "cl-seq" "\
Return true if LIST1 is a subset of LIST2.
I.e., if every element of LIST1 also appears in LIST2.
@ -1157,7 +1157,7 @@ Keywords supported: :test :test-not :key
\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil)
(autoload (quote subst-if) "cl-seq" "\
(autoload 'subst-if "cl-seq" "\
Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
Return a copy of TREE with all matching elements replaced by NEW.
@ -1165,7 +1165,7 @@ Keywords supported: :key
\(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil)
(autoload (quote subst-if-not) "cl-seq" "\
(autoload 'subst-if-not "cl-seq" "\
Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
Return a copy of TREE with all non-matching elements replaced by NEW.
@ -1173,7 +1173,7 @@ Keywords supported: :key
\(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil)
(autoload (quote nsubst) "cl-seq" "\
(autoload 'nsubst "cl-seq" "\
Substitute NEW for OLD everywhere in TREE (destructively).
Any element of TREE which is `eql' to OLD is changed to NEW (via a call
to `setcar').
@ -1182,7 +1182,7 @@ Keywords supported: :test :test-not :key
\(fn NEW OLD TREE [KEYWORD VALUE]...)" nil nil)
(autoload (quote nsubst-if) "cl-seq" "\
(autoload 'nsubst-if "cl-seq" "\
Substitute NEW for elements matching PREDICATE in TREE (destructively).
Any element of TREE which matches is changed to NEW (via a call to `setcar').
@ -1190,7 +1190,7 @@ Keywords supported: :key
\(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil)
(autoload (quote nsubst-if-not) "cl-seq" "\
(autoload 'nsubst-if-not "cl-seq" "\
Substitute NEW for elements not matching PREDICATE in TREE (destructively).
Any element of TREE which matches is changed to NEW (via a call to `setcar').
@ -1198,7 +1198,7 @@ Keywords supported: :key
\(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil)
(autoload (quote sublis) "cl-seq" "\
(autoload 'sublis "cl-seq" "\
Perform substitutions indicated by ALIST in TREE (non-destructively).
Return a copy of TREE with all matching elements replaced.
@ -1206,7 +1206,7 @@ Keywords supported: :test :test-not :key
\(fn ALIST TREE [KEYWORD VALUE]...)" nil nil)
(autoload (quote nsublis) "cl-seq" "\
(autoload 'nsublis "cl-seq" "\
Perform substitutions indicated by ALIST in TREE (destructively).
Any matching element of TREE is changed via a call to `setcar'.
@ -1214,7 +1214,7 @@ Keywords supported: :test :test-not :key
\(fn ALIST TREE [KEYWORD VALUE]...)" nil nil)
(autoload (quote tree-equal) "cl-seq" "\
(autoload 'tree-equal "cl-seq" "\
Return t if trees TREE1 and TREE2 have `eql' leaves.
Atoms are compared by `eql'; cons cells are compared recursively.

13
lisp/emacs-lisp/cl-macs.el
View file

@ -1,4 +1,4 @@
;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*-
;;; cl-macs.el --- Common Lisp macros
;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007
;; Free Software Foundation, Inc.
@ -1554,15 +1554,11 @@ values. For compatibility, (values A B C) is a synonym for (list A B C).
byte-compile-delete-errors (nth 1 safety)))))
((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
(if (eq byte-compile-warnings t)
(setq byte-compile-warnings byte-compile-warning-types))
(while (setq spec (cdr spec))
(if (consp (car spec))
(if (eq (cadar spec) 0)
(setq byte-compile-warnings
(delq (caar spec) byte-compile-warnings))
(setq byte-compile-warnings
(adjoin (caar spec) byte-compile-warnings)))))))
(byte-compile-disable-warning (caar spec))
(byte-compile-enable-warning (caar spec)))))))
nil)
;;; Process any proclamations made before cl-macs was loaded.
@ -2728,7 +2724,8 @@ surrounded by (block NAME ...).
(run-hooks 'cl-macs-load-hook)
;; Local variables:
;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime)
;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; generated-autoload-file: "cl-loaddefs.el"
;; End:

4
lisp/emacs-lisp/cl-seq.el
View file

@ -1,4 +1,4 @@
;;; cl-seq.el --- Common Lisp features, part 3 -*-byte-compile-dynamic: t;-*-
;;; cl-seq.el --- Common Lisp features, part 3
;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007 Free Software Foundation, Inc.
@ -1020,6 +1020,8 @@ Atoms are compared by `eql'; cons cells are compared recursively.
(run-hooks 'cl-seq-load-hook)
;; Local variables:
;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; generated-autoload-file: "cl-loaddefs.el"
;; End:

15
lisp/emacs-lisp/cl.el
View file

@ -1,4 +1,4 @@
;;; cl.el --- Common Lisp extensions for Emacs -*-byte-compile-dynamic: t;-*-
;;; cl.el --- Common Lisp extensions for Emacs
;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007 Free Software Foundation, Inc.
@ -109,9 +109,11 @@ printer proceeds to the next function on the list.
This variable is not used at present, but it is defined in hopes that
a future Emacs interpreter will be able to use it.")
(add-hook 'cl-unload-hook 'cl-cannot-unload)
(defun cl-cannot-unload ()
(error "Cannot unload the feature `cl'"))
(defun cl-unload-function ()
"Stop unloading of the Common Lisp extensions."
(message "Cannot unload the feature `cl'")
;; stop standard unloading!
t)
;;; Generalized variables.
;; These macros are defined here so that they
@ -658,5 +660,10 @@ If ALIST is non-nil, the new pairs are prepended to it."
(run-hooks 'cl-load-hook)
;; Local variables:
;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; End:
;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851
;;; cl.el ends here

28
lisp/emacs-lisp/elp.el
View file

@ -147,16 +147,16 @@ Results are displayed with the `elp-results' command."
:group 'elp)
(defcustom elp-sort-by-function 'elp-sort-by-total-time
"*Non-nil specifies elp results sorting function.
"*Non-nil specifies ELP results sorting function.
These functions are currently available:
elp-sort-by-call-count -- sort by the highest call count
elp-sort-by-total-time -- sort by the highest total time
elp-sort-by-average-time -- sort by the highest average times
You can write you're own sort function. It should adhere to the
interface specified by the PRED argument for the `sort' defun. Each
\"element of LIST\" is really a 4 element vector where element 0 is
You can write your own sort function. It should adhere to the
interface specified by the PREDICATE argument for `sort'.
Each \"element of LIST\" is really a 4 element vector where element 0 is
the call count, element 1 is the total time spent in the function,
element 2 is the average time spent in the function, and element 3 is
the symbol's name string."
@ -164,7 +164,7 @@ the symbol's name string."
:group 'elp)
(defcustom elp-report-limit 1
"*Prevents some functions from being displayed in the results buffer.
"*Prevent some functions from being displayed in the results buffer.
If a number, no function that has been called fewer than that number
of times will be displayed in the output buffer. If nil, all
functions will be displayed."
@ -173,12 +173,12 @@ functions will be displayed."
:group 'elp)
(defcustom elp-use-standard-output nil
"*Non-nil says to output to `standard-output' instead of a buffer."
"*If non-nil, output to `standard-output' instead of a buffer."
:type 'boolean
:group 'elp)
(defcustom elp-recycle-buffers-p t
"*nil says to not recycle the `elp-results-buffer'.
"*If nil, don't recycle the `elp-results-buffer'.
In other words, a new unique buffer is create every time you run
\\[elp-results]."
:type 'boolean
@ -372,7 +372,7 @@ Use optional LIST if provided instead."
(mapcar 'elp-restore-function list)))
(defun elp-restore-all ()
"Restores the original definitions of all functions being profiled."
"Restore the original definitions of all functions being profiled."
(interactive)
(elp-restore-list elp-all-instrumented-list))
@ -412,7 +412,7 @@ Use optional LIST if provided instead."
(elp-instrument-function funsym)))
(defun elp-unset-master ()
"Unsets the master function."
"Unset the master function."
(interactive)
;; when there's no master function, recording is turned on by default.
(setq elp-master nil
@ -558,7 +558,7 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]."
(defun elp-results ()
"Display current profiling results.
If `elp-reset-after-results' is non-nil, then current profiling
information for all instrumented functions are reset after results are
information for all instrumented functions is reset after results are
displayed."
(interactive)
(let ((curbuf (current-buffer))
@ -626,9 +626,11 @@ displayed."
(and elp-reset-after-results
(elp-reset-all))))
(defun elp-unload-hook ()
(elp-restore-all))
(add-hook 'elp-unload-hook 'elp-unload-hook)
(defun elp-unload-function ()
"Unload the Emacs Lisp Profiler."
(elp-restore-all)
;; continue standard unloading
nil)
(provide 'elp)

20
lisp/emacs-lisp/find-func.el
View file

@ -192,11 +192,21 @@ TYPE should be nil to find a function, or `defvar' to find a variable."
(defun find-library (library)
"Find the elisp source of LIBRARY."
(interactive
(list
(completing-read "Library name: "
'locate-file-completion
(cons (or find-function-source-path load-path)
(find-library-suffixes)))))
(let* ((path (cons (or find-function-source-path load-path)
(find-library-suffixes)))
(def (if (eq (function-called-at-point) 'require)
(save-excursion
(backward-up-list)
(forward-char)
(backward-sexp -2)
(thing-at-point 'symbol))
(thing-at-point 'symbol))))
(when def
(setq def (and (locate-file-completion def path 'test) def)))
(list
(completing-read (if def (format "Library name (default %s): " def)
"Library name: ")
'locate-file-completion path nil nil nil def))))
(let ((buf (find-file-noselect (find-library-name library))))
(condition-case nil (switch-to-buffer buf) (error (pop-to-buffer buf)))))

242
lisp/emacs-lisp/lselect.el
View file

@ -1,242 +0,0 @@
;;; lselect.el --- Lucid interface to X Selections
;; Copyright (C) 1990, 1993, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: emulations
;; This won't completely work until we support or emulate Lucid-style extents.
;; Based on Lucid's selection code.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
;; The selection code requires us to use certain symbols whose names are
;; all upper-case; this may seem tasteless, but it makes there be a 1:1
;; correspondence between these symbols and X Atoms (which are upcased.)
;; This is Lucid/XEmacs stuff
(defvar mouse-highlight-priority)
(defvar x-lost-selection-functions)
(defvar zmacs-regions)
(defalias 'x-get-cutbuffer 'x-get-cut-buffer)
(defalias 'x-store-cutbuffer 'x-set-cut-buffer)
(or (facep 'primary-selection)
(make-face 'primary-selection))
(or (facep 'secondary-selection)
(make-face 'secondary-selection))
(defun x-get-secondary-selection ()
"Return text selected from some X window."
(x-get-selection-internal 'SECONDARY 'STRING))
(defvar primary-selection-extent nil
"The extent of the primary selection; don't use this.")
(defvar secondary-selection-extent nil
"The extent of the secondary selection; don't use this.")
(defun x-select-make-extent-for-selection (selection previous-extent face)
;; Given a selection, this makes an extent in the buffer which holds that
;; selection, for highlighting purposes. If the selection isn't associated
;; with a buffer, this does nothing.
(let ((buffer nil)
(valid (and (extentp previous-extent)
(extent-buffer previous-extent)
(buffer-name (extent-buffer previous-extent))))
start end)
(cond ((stringp selection)
;; if we're selecting a string, lose the previous extent used
;; to highlight the selection.
(setq valid nil))
((consp selection)
(setq start (min (car selection) (cdr selection))
end (max (car selection) (cdr selection))
valid (and valid
(eq (marker-buffer (car selection))
(extent-buffer previous-extent)))
buffer (marker-buffer (car selection))))
((extentp selection)
(setq start (extent-start-position selection)
end (extent-end-position selection)
valid (and valid
(eq (extent-buffer selection)
(extent-buffer previous-extent)))
buffer (extent-buffer selection)))
)
(if (and (not valid)
(extentp previous-extent)
(extent-buffer previous-extent)
(buffer-name (extent-buffer previous-extent)))
(delete-extent previous-extent))
(if (not buffer)
;; string case
nil
;; normal case
(if valid
(set-extent-endpoints previous-extent start end)
(setq previous-extent (make-extent start end buffer))
;; use same priority as mouse-highlighting so that conflicts between
;; the selection extent and a mouse-highlighted extent are resolved
;; by the usual size-and-endpoint-comparison method.
(set-extent-priority previous-extent mouse-highlight-priority)
(set-extent-face previous-extent face)))))
(defun x-own-selection (selection &optional type)
"Make a primary X Selection of the given argument.
The argument may be a string, a cons of two markers, or an extent.
In the latter cases the selection is considered to be the text
between the markers, or the between extents endpoints."
(interactive (if (not current-prefix-arg)
(list (read-string "Store text for pasting: "))
(list (cons ;; these need not be ordered.
(copy-marker (point-marker))
(copy-marker (mark-marker))))))
(or type (setq type 'PRIMARY))
(x-set-selection selection type)
(cond ((eq type 'PRIMARY)
(setq primary-selection-extent
(x-select-make-extent-for-selection
selection primary-selection-extent 'primary-selection)))
((eq type 'SECONDARY)
(setq secondary-selection-extent
(x-select-make-extent-for-selection
selection secondary-selection-extent 'secondary-selection))))
selection)
(defun x-own-secondary-selection (selection &optional type)
"Make a secondary X Selection of the given argument. The argument may be a
string or a cons of two markers (in which case the selection is considered to
be the text between those markers.)"
(interactive (if (not current-prefix-arg)
(list (read-string "Store text for pasting: "))
(list (cons ;; these need not be ordered.
(copy-marker (point-marker))
(copy-marker (mark-marker))))))
(x-own-selection selection 'SECONDARY))
(defun x-own-clipboard (string)
"Paste the given string to the X Clipboard."
(x-own-selection string 'CLIPBOARD))
(defun x-disown-selection (&optional secondary-p)
"Assuming we own the selection, disown it. With an argument, discard the
secondary selection instead of the primary selection."
(x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
(defun x-dehilight-selection (selection)
"for use as a value of `x-lost-selection-functions'."
(cond ((eq selection 'PRIMARY)
(if primary-selection-extent
(let ((inhibit-quit t))
(delete-extent primary-selection-extent)
(setq primary-selection-extent nil)))
(if zmacs-regions (zmacs-deactivate-region)))
((eq selection 'SECONDARY)
(if secondary-selection-extent
(let ((inhibit-quit t))
(delete-extent secondary-selection-extent)
(setq secondary-selection-extent nil)))))
nil)
(setq x-lost-selection-functions 'x-dehilight-selection)
(defun x-notice-selection-requests (selection type successful)
"for possible use as the value of `x-sent-selection-functions'."
(if (not successful)
(message "Selection request failed to convert %s to %s"
selection type)
(message "Sent selection %s as %s" selection type)))
(defun x-notice-selection-failures (selection type successful)
"for possible use as the value of `x-sent-selection-functions'."
(or successful
(message "Selection request failed to convert %s to %s"
selection type)))
;(setq x-sent-selection-functions 'x-notice-selection-requests)
;(setq x-sent-selection-functions 'x-notice-selection-failures)
;; Random utility functions
(defun x-kill-primary-selection ()
"If there is a selection, delete the text it covers, and copy it to
both the kill ring and the Clipboard."
(interactive)
(or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
(setq last-command nil)
(or primary-selection-extent
(error "the primary selection is not an extent?"))
(save-excursion
(set-buffer (extent-buffer primary-selection-extent))
(kill-region (extent-start-position primary-selection-extent)
(extent-end-position primary-selection-extent)))
(x-disown-selection nil))
(defun x-delete-primary-selection ()
"If there is a selection, delete the text it covers *without* copying it to
the kill ring or the Clipboard."
(interactive)
(or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
(setq last-command nil)
(or primary-selection-extent
(error "the primary selection is not an extent?"))
(save-excursion
(set-buffer (extent-buffer primary-selection-extent))
(delete-region (extent-start-position primary-selection-extent)
(extent-end-position primary-selection-extent)))
(x-disown-selection nil))
(defun x-copy-primary-selection ()
"If there is a selection, copy it to both the kill ring and the Clipboard."
(interactive)
(setq last-command nil)
(or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
(or primary-selection-extent
(error "the primary selection is not an extent?"))
(save-excursion
(set-buffer (extent-buffer primary-selection-extent))
(copy-region-as-kill (extent-start-position primary-selection-extent)
(extent-end-position primary-selection-extent))))
(defun x-yank-clipboard-selection ()
"If someone owns a Clipboard selection, insert it at point."
(interactive)
(setq last-command nil)
(let ((clip (x-get-clipboard)))
(or clip (error "there is no clipboard selection"))
(push-mark)
(insert clip)))
(provide 'lselect)
;; arch-tag: 92fa54d4-c5d1-4e9b-ad58-cf1e13930556
;;; lselect.el ends here

19
lisp/emacs-lisp/unsafep.el
View file

@ -116,9 +116,9 @@ in the parse.")
;;;###autoload
(defun unsafep (form &optional unsafep-vars)
"Return nil if evaluating FORM couldn't possibly do any harm;
otherwise result is a reason why FORM is unsafe. UNSAFEP-VARS is a list
of symbols with local bindings."
"Return nil if evaluating FORM couldn't possibly do any harm.
Otherwise result is a reason why FORM is unsafe.
UNSAFEP-VARS is a list of symbols with local bindings."
(catch 'unsafep
(if (or (eq safe-functions t) ;User turned off safety-checking
(atom form)) ;Atoms are never unsafe
@ -213,8 +213,8 @@ of symbols with local bindings."
(defun unsafep-function (fun)
"Return nil if FUN is a safe function.
\(either a safe lambda or a symbol that names a safe function). Otherwise
result is a reason code."
\(Either a safe lambda or a symbol that names a safe function).
Otherwise result is a reason code."
(cond
((eq (car-safe fun) 'lambda)
(unsafep fun unsafep-vars))
@ -226,8 +226,8 @@ result is a reason code."
`(function ,fun))))
(defun unsafep-progn (list)
"Return nil if all forms in LIST are safe, or the reason
for the first unsafe form."
"Return nil if all forms in LIST are safe.
Else, return the reason for the first unsafe form."
(catch 'unsafep-progn
(let (reason)
(dolist (x list)
@ -236,8 +236,9 @@ for the first unsafe form."
(defun unsafep-let (clause)
"Check the safety of a let binding.
CLAUSE is a let-binding, either SYM or (SYM) or (SYM VAL). Checks VAL
and throws a reason to `unsafep' if unsafe. Returns SYM."
CLAUSE is a let-binding, either SYM or (SYM) or (SYM VAL).
Check VAL and throw a reason to `unsafep' if unsafe.
Return SYM."
(let (reason sym)
(if (atom clause)
(setq sym clause)