mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-21 21:20:44 -08:00
upstream, doesn build yet
This commit is contained in:
Joakim Verona
commit
13d6898b06
275 changed files with 11295 additions and 8105 deletions
|
|
@ -176,6 +176,7 @@ files.")
|
|||
("Torbjörn Einarsson" "Torbj.*rn Einarsson")
|
||||
("Toru Tomabechi" "Toru Tomabechi,")
|
||||
("Tsugutomo Enami" "enami tsugutomo")
|
||||
("Ulrich Müller" "Ulrich Mueller")
|
||||
("Vincent Del Vecchio" "Vince Del Vecchio")
|
||||
("William M. Perry" "Bill Perry")
|
||||
("Wlodzimierz Bzyl" "W.*dek Bzyl")
|
||||
|
|
@ -398,7 +399,7 @@ Changes to files in this list are not listed.")
|
|||
("Lawrence R. Dodd" :cowrote "dired-x.el")
|
||||
;; No longer distributed.
|
||||
;;; ("Viktor Dukhovni" :wrote "unexsunos4.c")
|
||||
("Paul Eggert" :wrote "rcs2log" "vcdiff")
|
||||
("Paul Eggert" :wrote "rcs2log") ; "vcdiff"
|
||||
("Fred Fish" :changed "unexcoff.c")
|
||||
;; No longer distributed.
|
||||
;;; ("Tim Fleehart" :wrote "makefile.nt")
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
|
||||
(require 'lisp-mode) ;for `doc-string-elt' properties.
|
||||
(require 'help-fns) ;for help-add-fundoc-usage.
|
||||
(eval-when-compile (require 'cl))
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
(defvar generated-autoload-file nil
|
||||
"File into which to write autoload definitions.
|
||||
|
|
@ -151,17 +151,18 @@ expression, in which case we want to handle forms differently."
|
|||
easy-mmode-define-global-mode define-global-minor-mode
|
||||
define-globalized-minor-mode
|
||||
easy-mmode-define-minor-mode define-minor-mode
|
||||
defun* defmacro* define-overloadable-function))
|
||||
cl-defun defun* cl-defmacro defmacro*
|
||||
define-overloadable-function))
|
||||
(let* ((macrop (memq car '(defmacro defmacro*)))
|
||||
(name (nth 1 form))
|
||||
(args (case car
|
||||
(args (cl-case car
|
||||
((defun defmacro defun* defmacro*
|
||||
define-overloadable-function) (nth 2 form))
|
||||
((define-skeleton) '(&optional str arg))
|
||||
((define-generic-mode define-derived-mode
|
||||
define-compilation-mode) nil)
|
||||
(t)))
|
||||
(body (nthcdr (get car 'doc-string-elt) form))
|
||||
(body (nthcdr (or (get car 'doc-string-elt) 3) form))
|
||||
(doc (if (stringp (car body)) (pop body))))
|
||||
;; Add the usage form at the end where describe-function-1
|
||||
;; can recover it.
|
||||
|
|
@ -546,7 +547,7 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
|
|||
(save-excursion
|
||||
;; Insert the section-header line which lists the file name
|
||||
;; and which functions are in it, etc.
|
||||
(assert (= ostart output-start))
|
||||
(cl-assert (= ostart output-start))
|
||||
(goto-char output-start)
|
||||
(let ((relfile (file-relative-name absfile)))
|
||||
(autoload-insert-section-header
|
||||
|
|
|
|||
|
|
@ -183,7 +183,8 @@
|
|||
;;; Code:
|
||||
|
||||
(require 'bytecomp)
|
||||
(eval-when-compile (require 'cl))
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
(require 'macroexp)
|
||||
|
||||
(defun byte-compile-log-lap-1 (format &rest args)
|
||||
;; Newer byte codes for stack-ref make the slot 0 non-nil again.
|
||||
|
|
@ -434,11 +435,9 @@
|
|||
clause))
|
||||
(cdr form))))
|
||||
((eq fn 'progn)
|
||||
;; as an extra added bonus, this simplifies (progn <x>) --> <x>
|
||||
;; As an extra added bonus, this simplifies (progn <x>) --> <x>.
|
||||
(if (cdr (cdr form))
|
||||
(progn
|
||||
(setq tmp (byte-optimize-body (cdr form) for-effect))
|
||||
(if (cdr tmp) (cons 'progn tmp) (car tmp)))
|
||||
(macroexp-progn (byte-optimize-body (cdr form) for-effect))
|
||||
(byte-optimize-form (nth 1 form) for-effect)))
|
||||
((eq fn 'prog1)
|
||||
(if (cdr (cdr form))
|
||||
|
|
@ -577,10 +576,10 @@
|
|||
(cons fn args)))))))
|
||||
|
||||
(defun byte-optimize-all-constp (list)
|
||||
"Non-nil if all elements of LIST satisfy `byte-compile-constp'."
|
||||
"Non-nil if all elements of LIST satisfy `macroexp-const-p"
|
||||
(let ((constant t))
|
||||
(while (and list constant)
|
||||
(unless (byte-compile-constp (car list))
|
||||
(unless (macroexp-const-p (car list))
|
||||
(setq constant nil))
|
||||
(setq list (cdr list)))
|
||||
constant))
|
||||
|
|
@ -643,7 +642,7 @@
|
|||
(while (eq (car-safe form) 'progn)
|
||||
(setq form (car (last (cdr form)))))
|
||||
(cond ((consp form)
|
||||
(case (car form)
|
||||
(cl-case (car form)
|
||||
(quote (cadr form))
|
||||
;; Can't use recursion in a defsubst.
|
||||
;; (progn (byte-compile-trueconstp (car (last (cdr form)))))
|
||||
|
|
@ -657,7 +656,7 @@
|
|||
(while (eq (car-safe form) 'progn)
|
||||
(setq form (car (last (cdr form)))))
|
||||
(cond ((consp form)
|
||||
(case (car form)
|
||||
(cl-case (car form)
|
||||
(quote (null (cadr form)))
|
||||
;; Can't use recursion in a defsubst.
|
||||
;; (progn (byte-compile-nilconstp (car (last (cdr form)))))
|
||||
|
|
@ -870,8 +869,8 @@
|
|||
|
||||
|
||||
(defun byte-optimize-binary-predicate (form)
|
||||
(if (byte-compile-constp (nth 1 form))
|
||||
(if (byte-compile-constp (nth 2 form))
|
||||
(if (macroexp-const-p (nth 1 form))
|
||||
(if (macroexp-const-p (nth 2 form))
|
||||
(condition-case ()
|
||||
(list 'quote (eval form))
|
||||
(error form))
|
||||
|
|
@ -883,7 +882,7 @@
|
|||
(let ((ok t)
|
||||
(rest (cdr form)))
|
||||
(while (and rest ok)
|
||||
(setq ok (byte-compile-constp (car rest))
|
||||
(setq ok (macroexp-const-p (car rest))
|
||||
rest (cdr rest)))
|
||||
(if ok
|
||||
(condition-case ()
|
||||
|
|
@ -949,7 +948,7 @@
|
|||
(defun byte-optimize-quote (form)
|
||||
(if (or (consp (nth 1 form))
|
||||
(and (symbolp (nth 1 form))
|
||||
(not (byte-compile-const-symbol-p form))))
|
||||
(not (macroexp--const-symbol-p form))))
|
||||
form
|
||||
(nth 1 form)))
|
||||
|
||||
|
|
@ -1159,16 +1158,6 @@
|
|||
;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte,
|
||||
;; string-make-multibyte for constant args.
|
||||
|
||||
(put 'featurep 'byte-optimizer 'byte-optimize-featurep)
|
||||
(defun byte-optimize-featurep (form)
|
||||
;; Emacs-21's byte-code doesn't run under XEmacs or SXEmacs anyway, so we
|
||||
;; can safely optimize away this test.
|
||||
(if (member (cdr-safe form) '(((quote xemacs)) ((quote sxemacs))))
|
||||
nil
|
||||
(if (member (cdr-safe form) '(((quote emacs))))
|
||||
t
|
||||
form)))
|
||||
|
||||
(put 'set 'byte-optimizer 'byte-optimize-set)
|
||||
(defun byte-optimize-set (form)
|
||||
(let ((var (car-safe (cdr-safe form))))
|
||||
|
|
@ -1377,7 +1366,7 @@
|
|||
;; This uses dynamic-scope magic.
|
||||
offset (disassemble-offset bytes))
|
||||
(let ((opcode (aref byte-code-vector bytedecomp-op)))
|
||||
(assert opcode)
|
||||
(cl-assert opcode)
|
||||
(setq bytedecomp-op opcode))
|
||||
(cond ((memq bytedecomp-op byte-goto-ops)
|
||||
;; It's a pc.
|
||||
|
|
@ -1586,13 +1575,13 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
|||
(not (eq (car lap0) 'byte-constant)))
|
||||
nil
|
||||
(setq keep-going t)
|
||||
(if (memq (car lap0) '(byte-constant byte-dup))
|
||||
(progn
|
||||
(setq tmp (if (or (not tmp)
|
||||
(byte-compile-const-symbol-p
|
||||
(car (cdr lap0))))
|
||||
(cdr lap0)
|
||||
(byte-compile-get-constant t)))
|
||||
(if (memq (car lap0) '(byte-constant byte-dup))
|
||||
(progn
|
||||
(setq tmp (if (or (not tmp)
|
||||
(macroexp--const-symbol-p
|
||||
(car (cdr lap0))))
|
||||
(cdr lap0)
|
||||
(byte-compile-get-constant t)))
|
||||
(byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
|
||||
lap0 lap1 lap2 lap0 lap1
|
||||
(cons (car lap0) tmp))
|
||||
|
|
@ -1620,7 +1609,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
|||
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
|
||||
(setq keep-going t
|
||||
rest (cdr rest))
|
||||
(if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1)))
|
||||
(if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
|
||||
(setq lap (delq lap0 (delq lap2 lap))))
|
||||
;;
|
||||
;; not goto-X-if-nil --> goto-X-if-non-nil
|
||||
|
|
|
|||
|
|
@ -70,30 +70,37 @@ The return value of this function is not used."
|
|||
;; loaded by loadup.el that uses declarations in macros.
|
||||
|
||||
(defvar defun-declarations-alist
|
||||
;; FIXME: Should we also add an `obsolete' property?
|
||||
(list
|
||||
;; Too bad we can't use backquote yet at this stage of the bootstrap.
|
||||
;; We can only use backquotes inside the lambdas and not for those
|
||||
;; properties that are used by functions loaded before backquote.el.
|
||||
(list 'advertised-calling-convention
|
||||
#'(lambda (f arglist when)
|
||||
#'(lambda (f _args arglist when)
|
||||
(list 'set-advertised-calling-convention
|
||||
(list 'quote f) (list 'quote arglist) (list 'quote when))))
|
||||
(list 'obsolete
|
||||
#'(lambda (f _args new-name when)
|
||||
`(make-obsolete ',f ',new-name ,when)))
|
||||
(list 'compiler-macro
|
||||
#'(lambda (f _args compiler-function)
|
||||
`(put ',f 'compiler-macro #',compiler-function)))
|
||||
(list 'doc-string
|
||||
#'(lambda (f pos)
|
||||
#'(lambda (f _args pos)
|
||||
(list 'put (list 'quote f) ''doc-string-elt (list 'quote pos))))
|
||||
(list 'indent
|
||||
#'(lambda (f val)
|
||||
#'(lambda (f _args val)
|
||||
(list 'put (list 'quote f)
|
||||
''lisp-indent-function (list 'quote val)))))
|
||||
"List associating function properties to their macro expansion.
|
||||
Each element of the list takes the form (PROP FUN) where FUN is
|
||||
a function. For each (PROP . VALUES) in a function's declaration,
|
||||
the FUN corresponding to PROP is called with the function name
|
||||
and the VALUES and should return the code to use to set this property.")
|
||||
the FUN corresponding to PROP is called with the function name,
|
||||
the function's arglist, and the VALUES and should return the code to use
|
||||
to set this property.")
|
||||
|
||||
(defvar macro-declarations-alist
|
||||
(cons
|
||||
(list 'debug
|
||||
#'(lambda (name spec)
|
||||
#'(lambda (name _args spec)
|
||||
(list 'progn :autoload-end
|
||||
(list 'put (list 'quote name)
|
||||
''edebug-form-spec (list 'quote spec)))))
|
||||
|
|
@ -135,7 +142,7 @@ interpreted according to `macro-declarations-alist'."
|
|||
(mapcar
|
||||
#'(lambda (x)
|
||||
(let ((f (cdr (assq (car x) macro-declarations-alist))))
|
||||
(if f (apply (car f) name (cdr x))
|
||||
(if f (apply (car f) name arglist (cdr x))
|
||||
(message "Warning: Unknown macro property %S in %S"
|
||||
(car x) name))))
|
||||
(cdr decl))))
|
||||
|
|
@ -171,7 +178,7 @@ interpreted according to `defun-declarations-alist'.
|
|||
#'(lambda (x)
|
||||
(let ((f (cdr (assq (car x) defun-declarations-alist))))
|
||||
(cond
|
||||
(f (apply (car f) name (cdr x)))
|
||||
(f (apply (car f) name arglist (cdr x)))
|
||||
;; Yuck!!
|
||||
((and (featurep 'cl)
|
||||
(memq (car x) ;C.f. cl-do-proclaim.
|
||||
|
|
|
|||
|
|
@ -120,7 +120,7 @@
|
|||
(require 'backquote)
|
||||
(require 'macroexp)
|
||||
(require 'cconv)
|
||||
(eval-when-compile (require 'cl))
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
(or (fboundp 'defsubst)
|
||||
;; This really ought to be loaded already!
|
||||
|
|
@ -738,7 +738,7 @@ BYTES and PC are updated after evaluating all the arguments."
|
|||
(bytes-var (car (last args 2)))
|
||||
(pc-var (car (last args))))
|
||||
`(setq ,bytes-var ,(if (null (cdr byte-exprs))
|
||||
`(progn (assert (<= 0 ,(car byte-exprs)))
|
||||
`(progn (cl-assert (<= 0 ,(car byte-exprs)))
|
||||
(cons ,@byte-exprs ,bytes-var))
|
||||
`(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
|
||||
,pc-var (+ ,(length byte-exprs) ,pc-var))))
|
||||
|
|
@ -1399,18 +1399,18 @@ extra args."
|
|||
;; These aren't all aliases of subrs, so not trivial to
|
||||
;; avoid hardwiring the list.
|
||||
(not (memq func
|
||||
'(cl-block-wrapper cl-block-throw
|
||||
'(cl--block-wrapper cl--block-throw
|
||||
multiple-value-call nth-value
|
||||
copy-seq first second rest endp cl-member
|
||||
;; These are included in generated code
|
||||
;; that can't be called except at compile time
|
||||
;; or unless cl is loaded anyway.
|
||||
cl-defsubst-expand cl-struct-setf-expander
|
||||
cl--defsubst-expand cl-struct-setf-expander
|
||||
;; These would sometimes be warned about
|
||||
;; but such warnings are never useful,
|
||||
;; so don't warn about them.
|
||||
macroexpand cl-macroexpand-all
|
||||
cl-compiling-file))))
|
||||
cl--compiling-file))))
|
||||
(byte-compile-warn "function `%s' from cl package called at runtime"
|
||||
func)))
|
||||
form)
|
||||
|
|
@ -1464,29 +1464,6 @@ extra args."
|
|||
nil)
|
||||
|
||||
|
||||
(defsubst byte-compile-const-symbol-p (symbol &optional any-value)
|
||||
"Non-nil if SYMBOL is constant.
|
||||
If ANY-VALUE is nil, only return non-nil if the value of the symbol is the
|
||||
symbol itself."
|
||||
(or (memq symbol '(nil t))
|
||||
(keywordp symbol)
|
||||
(if any-value
|
||||
(or (memq symbol byte-compile-const-variables)
|
||||
;; FIXME: We should provide a less intrusive way to find out
|
||||
;; if a variable is "constant".
|
||||
(and (boundp symbol)
|
||||
(condition-case nil
|
||||
(progn (set symbol (symbol-value symbol)) nil)
|
||||
(setting-constant t)))))))
|
||||
|
||||
(defmacro byte-compile-constp (form)
|
||||
"Return non-nil if FORM is a constant."
|
||||
`(cond ((consp ,form) (or (eq (car ,form) 'quote)
|
||||
(and (eq (car ,form) 'function)
|
||||
(symbolp (cadr ,form)))))
|
||||
((not (symbolp ,form)))
|
||||
((byte-compile-const-symbol-p ,form))))
|
||||
|
||||
;; Dynamically bound in byte-compile-from-buffer.
|
||||
;; NB also used in cl.el and cl-macs.el.
|
||||
(defvar byte-compile--outbuffer)
|
||||
|
|
@ -1614,7 +1591,7 @@ that already has a `.elc' file."
|
|||
(not (auto-save-file-name-p source))
|
||||
(not (string-equal dir-locals-file
|
||||
(file-name-nondirectory source))))
|
||||
(progn (case (byte-recompile-file source force arg)
|
||||
(progn (cl-case (byte-recompile-file source force arg)
|
||||
(no-byte-compile (setq skip-count (1+ skip-count)))
|
||||
((t) (setq file-count (1+ file-count)))
|
||||
((nil) (setq fail-count (1+ fail-count))))
|
||||
|
|
@ -1748,12 +1725,12 @@ The value is non-nil if there were no errors, nil if errors."
|
|||
(set-buffer-multibyte nil))
|
||||
;; Run hooks including the uncompression hook.
|
||||
;; If they change the file name, then change it for the output also.
|
||||
(letf ((buffer-file-name filename)
|
||||
((default-value 'major-mode) 'emacs-lisp-mode)
|
||||
;; Ignore unsafe local variables.
|
||||
;; We only care about a few of them for our purposes.
|
||||
(enable-local-variables :safe)
|
||||
(enable-local-eval nil))
|
||||
(cl-letf ((buffer-file-name filename)
|
||||
((default-value 'major-mode) 'emacs-lisp-mode)
|
||||
;; Ignore unsafe local variables.
|
||||
;; We only care about a few of them for our purposes.
|
||||
(enable-local-variables :safe)
|
||||
(enable-local-eval nil))
|
||||
;; Arg of t means don't alter enable-local-variables.
|
||||
(normal-mode t)
|
||||
;; There may be a file local variable setting (bug#10419).
|
||||
|
|
@ -1965,7 +1942,7 @@ and will be removed soon. See (elisp)Backquote in the manual."))
|
|||
;; Because the header must fit in a fixed width, we cannot
|
||||
;; insert arbitrary-length file names (Bug#11585).
|
||||
" (error \"`%s' was compiled for "
|
||||
(format "Emacs %s or later\" load-file-name))\n\n" minimum-version))
|
||||
(format "Emacs %s or later\" #$))\n\n" minimum-version))
|
||||
;; Now compensate for any change in size, to make sure all
|
||||
;; positions in the file remain valid.
|
||||
(setq delta (- (point-max) old-header-end))
|
||||
|
|
@ -2023,7 +2000,7 @@ Call from the source buffer."
|
|||
|
||||
(defun byte-compile-output-file-form (form)
|
||||
;; Write the given form to the output buffer, being careful of docstrings
|
||||
;; in defun, defmacro, defvar, defvaralias, defconst, autoload and
|
||||
;; in defvar, defvaralias, defconst, autoload and
|
||||
;; custom-declare-variable because make-docfile is so amazingly stupid.
|
||||
;; defalias calls are output directly by byte-compile-file-form-defmumble;
|
||||
;; it does not pay to first build the defalias in defmumble and then parse
|
||||
|
|
@ -2035,7 +2012,7 @@ Call from the source buffer."
|
|||
(print-gensym t)
|
||||
(print-circle ; Handle circular data structures.
|
||||
(not byte-compile-disable-print-circle)))
|
||||
(if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst
|
||||
(if (and (memq (car-safe form) '(defvar defvaralias defconst
|
||||
autoload custom-declare-variable))
|
||||
(stringp (nth 3 form)))
|
||||
(byte-compile-output-docform nil nil '("\n(" 3 ")") form nil
|
||||
|
|
@ -2089,7 +2066,16 @@ list that represents a doc string reference.
|
|||
(insert (car info))
|
||||
(let ((print-continuous-numbering t)
|
||||
print-number-table
|
||||
(index 0))
|
||||
(index 0)
|
||||
;; FIXME: The bindings below are only needed for when we're
|
||||
;; called from ...-defmumble.
|
||||
(print-escape-newlines t)
|
||||
(print-length nil)
|
||||
(print-level nil)
|
||||
(print-quoted t)
|
||||
(print-gensym t)
|
||||
(print-circle ; Handle circular data structures.
|
||||
(not byte-compile-disable-print-circle)))
|
||||
(prin1 (car form) byte-compile--outbuffer)
|
||||
(while (setq form (cdr form))
|
||||
(setq index (1+ index))
|
||||
|
|
@ -2195,7 +2181,7 @@ list that represents a doc string reference.
|
|||
(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
|
||||
(defun byte-compile-file-form-autoload (form)
|
||||
(and (let ((form form))
|
||||
(while (if (setq form (cdr form)) (byte-compile-constp (car form))))
|
||||
(while (if (setq form (cdr form)) (macroexp-const-p (car form))))
|
||||
(null form)) ;Constants only
|
||||
(eval (nth 5 form)) ;Macro
|
||||
(eval form)) ;Define the autoload.
|
||||
|
|
@ -2501,7 +2487,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
|
|||
(when (symbolp arg)
|
||||
(byte-compile-set-symbol-position arg))
|
||||
(cond ((or (not (symbolp arg))
|
||||
(byte-compile-const-symbol-p arg t))
|
||||
(macroexp--const-symbol-p arg t))
|
||||
(error "Invalid lambda variable %s" arg))
|
||||
((eq arg '&rest)
|
||||
(unless (cdr list)
|
||||
|
|
@ -2625,7 +2611,7 @@ for symbols generated by the byte compiler itself."
|
|||
(byte-compile-make-lambda-lexenv fun))
|
||||
reserved-csts)))
|
||||
;; Build the actual byte-coded function.
|
||||
(assert (eq 'byte-code (car-safe compiled)))
|
||||
(cl-assert (eq 'byte-code (car-safe compiled)))
|
||||
(apply #'make-byte-code
|
||||
(if lexical-binding
|
||||
(byte-compile-make-args-desc arglist)
|
||||
|
|
@ -2668,7 +2654,7 @@ for symbols generated by the byte compiler itself."
|
|||
(while (and rest (< i limit))
|
||||
(cond
|
||||
((numberp (car rest))
|
||||
(assert (< (car rest) byte-compile-reserved-constants)))
|
||||
(cl-assert (< (car rest) byte-compile-reserved-constants)))
|
||||
((setq tmp (assq (car (car rest)) ret))
|
||||
(setcdr (car rest) (cdr tmp)))
|
||||
(t
|
||||
|
|
@ -2770,7 +2756,7 @@ for symbols generated by the byte compiler itself."
|
|||
(if (if (eq (car (car rest)) 'byte-constant)
|
||||
(or (consp tmp)
|
||||
(and (symbolp tmp)
|
||||
(not (byte-compile-const-symbol-p tmp)))))
|
||||
(not (macroexp--const-symbol-p tmp)))))
|
||||
(if maycall
|
||||
(setq body (cons (list 'quote tmp) body)))
|
||||
(setq body (cons tmp body))))
|
||||
|
|
@ -2815,7 +2801,7 @@ for symbols generated by the byte compiler itself."
|
|||
(push (cons fn
|
||||
(if (and (consp args) (listp (car args)))
|
||||
(list 'declared (car args))
|
||||
t)) ; arglist not specified
|
||||
t)) ; Arglist not specified.
|
||||
byte-compile-function-environment)
|
||||
;; We are stating that it _will_ be defined at runtime.
|
||||
(setq byte-compile-noruntime-functions
|
||||
|
|
@ -2841,7 +2827,7 @@ for symbols generated by the byte compiler itself."
|
|||
(let ((byte-compile--for-effect for-effect))
|
||||
(cond
|
||||
((not (consp form))
|
||||
(cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form))
|
||||
(cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))
|
||||
(when (symbolp form)
|
||||
(byte-compile-set-symbol-position form))
|
||||
(byte-compile-constant form))
|
||||
|
|
@ -2854,7 +2840,7 @@ for symbols generated by the byte compiler itself."
|
|||
((symbolp (car form))
|
||||
(let* ((fn (car form))
|
||||
(handler (get fn 'byte-compile)))
|
||||
(when (byte-compile-const-symbol-p fn)
|
||||
(when (macroexp--const-symbol-p fn)
|
||||
(byte-compile-warn "`%s' called as a function" fn))
|
||||
(and (byte-compile-warning-enabled-p 'interactive-only)
|
||||
(memq fn byte-compile-interactive-only-functions)
|
||||
|
|
@ -2865,14 +2851,12 @@ That command is designed for interactive use only" fn))
|
|||
(byte-compile-log-warning
|
||||
(format "Forgot to expand macro %s" (car form)) nil :error))
|
||||
(if (and handler
|
||||
;; Make sure that function exists. This is important
|
||||
;; for CL compiler macros since the symbol may be
|
||||
;; `cl-byte-compile-compiler-macro' but if CL isn't
|
||||
;; loaded, this function doesn't exist.
|
||||
(and (not (eq handler
|
||||
;; Already handled by macroexpand-all.
|
||||
'cl-byte-compile-compiler-macro))
|
||||
(functionp handler)))
|
||||
;; Make sure that function exists.
|
||||
(and (functionp handler)
|
||||
;; Ignore obsolete byte-compile function used by former
|
||||
;; CL code to handle compiler macros (we do it
|
||||
;; differently now).
|
||||
(not (eq handler 'cl-byte-compile-compiler-macro))))
|
||||
(funcall handler form)
|
||||
(byte-compile-normal-call form))
|
||||
(if (byte-compile-warning-enabled-p 'cl-functions)
|
||||
|
|
@ -2949,9 +2933,9 @@ That command is designed for interactive use only" fn))
|
|||
(mapc 'byte-compile-form (cdr form))
|
||||
(unless fmax2
|
||||
;; Old-style byte-code.
|
||||
(assert (listp fargs))
|
||||
(cl-assert (listp fargs))
|
||||
(while fargs
|
||||
(case (car fargs)
|
||||
(cl-case (car fargs)
|
||||
(&optional (setq fargs (cdr fargs)))
|
||||
(&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1))
|
||||
(push (cadr fargs) dynbinds)
|
||||
|
|
@ -2970,7 +2954,7 @@ That command is designed for interactive use only" fn))
|
|||
(t
|
||||
;; Turn &rest args into a list.
|
||||
(let ((n (- alen (/ (1- fmax2) 2))))
|
||||
(assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n)
|
||||
(cl-assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n)
|
||||
(if (< n 5)
|
||||
(byte-compile-out
|
||||
(aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n))
|
||||
|
|
@ -2983,14 +2967,14 @@ That command is designed for interactive use only" fn))
|
|||
;; Unbind dynamic variables.
|
||||
(when dynbinds
|
||||
(byte-compile-out 'byte-unbind (length dynbinds)))
|
||||
(assert (eq byte-compile-depth (1+ start-depth))
|
||||
(cl-assert (eq byte-compile-depth (1+ start-depth))
|
||||
nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth)))
|
||||
|
||||
(defun byte-compile-check-variable (var access-type)
|
||||
"Do various error checks before a use of the variable VAR."
|
||||
(when (symbolp var)
|
||||
(byte-compile-set-symbol-position var))
|
||||
(cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var))
|
||||
(cond ((or (not (symbolp var)) (macroexp--const-symbol-p var))
|
||||
(when (byte-compile-warning-enabled-p 'constants)
|
||||
(byte-compile-warn (if (eq access-type 'let-bind)
|
||||
"attempt to let-bind %s `%s`"
|
||||
|
|
@ -3001,7 +2985,7 @@ That command is designed for interactive use only" fn))
|
|||
(and od
|
||||
(not (memq var byte-compile-not-obsolete-vars))
|
||||
(not (memq var byte-compile-global-not-obsolete-vars))
|
||||
(or (case (nth 1 od)
|
||||
(or (cl-case (nth 1 od)
|
||||
(set (not (eq access-type 'reference)))
|
||||
(get (eq access-type 'reference))
|
||||
(t t)))))
|
||||
|
|
@ -3328,8 +3312,8 @@ discarding."
|
|||
(body (nthcdr 3 form))
|
||||
(fun
|
||||
(byte-compile-lambda `(lambda ,vars . ,body) nil (length env))))
|
||||
(assert (> (length env) 0)) ;Otherwise, we don't need a closure.
|
||||
(assert (byte-code-function-p fun))
|
||||
(cl-assert (> (length env) 0)) ;Otherwise, we don't need a closure.
|
||||
(cl-assert (byte-code-function-p fun))
|
||||
(byte-compile-form `(make-byte-code
|
||||
',(aref fun 0) ',(aref fun 1)
|
||||
(vconcat (vector . ,env) ',(aref fun 2))
|
||||
|
|
@ -3561,7 +3545,7 @@ discarding."
|
|||
(byte-compile-form (cons 'progn (nreverse setters))))
|
||||
(let ((var (car form)))
|
||||
(and (or (not (symbolp var))
|
||||
(byte-compile-const-symbol-p var t))
|
||||
(macroexp--const-symbol-p var t))
|
||||
(byte-compile-warning-enabled-p 'constants)
|
||||
(byte-compile-warn
|
||||
"variable assignment to %s `%s'"
|
||||
|
|
@ -3907,8 +3891,8 @@ binding slots have been popped."
|
|||
(if lexical-binding
|
||||
;; Unbind both lexical and dynamic variables.
|
||||
(progn
|
||||
(assert (or (eq byte-compile-depth init-stack-depth)
|
||||
(eq byte-compile-depth (1+ init-stack-depth))))
|
||||
(cl-assert (or (eq byte-compile-depth init-stack-depth)
|
||||
(eq byte-compile-depth (1+ init-stack-depth))))
|
||||
(byte-compile-unbind clauses init-lexenv (> byte-compile-depth
|
||||
init-stack-depth)))
|
||||
;; Unbind dynamic variables.
|
||||
|
|
@ -4110,8 +4094,8 @@ binding slots have been popped."
|
|||
|
||||
(defun byte-compile-autoload (form)
|
||||
(byte-compile-set-symbol-position 'autoload)
|
||||
(and (byte-compile-constp (nth 1 form))
|
||||
(byte-compile-constp (nth 5 form))
|
||||
(and (macroexp-const-p (nth 1 form))
|
||||
(macroexp-const-p (nth 5 form))
|
||||
(eval (nth 5 form)) ; macro-p
|
||||
(not (fboundp (eval (nth 1 form))))
|
||||
(byte-compile-warn
|
||||
|
|
@ -4328,7 +4312,7 @@ invoked interactively."
|
|||
(if byte-compile-call-tree-sort
|
||||
(setq byte-compile-call-tree
|
||||
(sort byte-compile-call-tree
|
||||
(case byte-compile-call-tree-sort
|
||||
(cl-case byte-compile-call-tree-sort
|
||||
(callers
|
||||
(lambda (x y) (< (length (nth 1 x))
|
||||
(length (nth 1 y)))))
|
||||
|
|
@ -4555,6 +4539,16 @@ and corresponding effects."
|
|||
(setq command-line-args-left (cdr command-line-args-left)))
|
||||
(kill-emacs 0))
|
||||
|
||||
;;; Core compiler macros.
|
||||
|
||||
(put 'featurep 'compiler-macro
|
||||
(lambda (form feature &rest _ignore)
|
||||
;; Emacs-21's byte-code doesn't run under XEmacs or SXEmacs anyway, so
|
||||
;; we can safely optimize away this test.
|
||||
(if (member feature '('xemacs 'sxemacs 'emacs))
|
||||
(eval form)
|
||||
form)))
|
||||
|
||||
(provide 'byte-compile)
|
||||
(provide 'bytecomp)
|
||||
|
||||
|
|
|
|||
|
|
@ -110,7 +110,7 @@
|
|||
;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder)))
|
||||
;; binders)))
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
(defconst cconv-liftwhen 6
|
||||
"Try to do lambda lifting if the number of arguments + free variables
|
||||
|
|
@ -173,7 +173,7 @@ Returns a form where all lambdas don't have any free variables."
|
|||
;; Here we assume that X appears at most once in M.
|
||||
(let* ((b (assq x m))
|
||||
(res (if b (remq b m) m)))
|
||||
(assert (null (assq x res))) ;; Check the assumption was warranted.
|
||||
(cl-assert (null (assq x res))) ;; Check the assumption was warranted.
|
||||
res))
|
||||
|
||||
(defun cconv--map-diff-set (m s)
|
||||
|
|
@ -185,7 +185,7 @@ Returns a form where all lambdas don't have any free variables."
|
|||
(nreverse res)))
|
||||
|
||||
(defun cconv--convert-function (args body env parentform)
|
||||
(assert (equal body (caar cconv-freevars-alist)))
|
||||
(cl-assert (equal body (caar cconv-freevars-alist)))
|
||||
(let* ((fvs (cdr (pop cconv-freevars-alist)))
|
||||
(body-new '())
|
||||
(letbind '())
|
||||
|
|
@ -251,11 +251,11 @@ ENV is a list where each entry takes the shape either:
|
|||
EXTEND is a list of variables which might need to be accessed even from places
|
||||
where they are shadowed, because some part of ENV causes them to be used at
|
||||
places where they originally did not directly appear."
|
||||
(assert (not (delq nil (mapcar (lambda (mapping)
|
||||
(if (eq (cadr mapping) 'apply-partially)
|
||||
(cconv--set-diff (cdr (cddr mapping))
|
||||
extend)))
|
||||
env))))
|
||||
(cl-assert (not (delq nil (mapcar (lambda (mapping)
|
||||
(if (eq (cadr mapping) 'apply-partially)
|
||||
(cconv--set-diff (cdr (cddr mapping))
|
||||
extend)))
|
||||
env))))
|
||||
|
||||
;; What's the difference between fvrs and envs?
|
||||
;; Suppose that we have the code
|
||||
|
|
@ -287,10 +287,10 @@ places where they originally did not directly appear."
|
|||
;; Check if var is a candidate for lambda lifting.
|
||||
((and (member (cons binder form) cconv-lambda-candidates)
|
||||
(progn
|
||||
(assert (and (eq (car value) 'function)
|
||||
(eq (car (cadr value)) 'lambda)))
|
||||
(assert (equal (cddr (cadr value))
|
||||
(caar cconv-freevars-alist)))
|
||||
(cl-assert (and (eq (car value) 'function)
|
||||
(eq (car (cadr value)) 'lambda)))
|
||||
(cl-assert (equal (cddr (cadr value))
|
||||
(caar cconv-freevars-alist)))
|
||||
;; Peek at the freevars to decide whether to λ-lift.
|
||||
(let* ((fvs (cdr (car cconv-freevars-alist)))
|
||||
(fun (cadr value))
|
||||
|
|
@ -307,7 +307,7 @@ places where they originally did not directly appear."
|
|||
(funcbody-env ()))
|
||||
(push `(,var . (apply-partially ,var . ,fvs)) new-env)
|
||||
(dolist (fv fvs)
|
||||
(pushnew fv new-extend)
|
||||
(cl-pushnew fv new-extend)
|
||||
(if (and (eq 'car (car-safe (cdr (assq fv env))))
|
||||
(not (memq fv funargs)))
|
||||
(push `(,fv . (car ,fv)) funcbody-env)))
|
||||
|
|
@ -345,14 +345,14 @@ places where they originally did not directly appear."
|
|||
(mapcar (lambda (mapping)
|
||||
(if (not (eq (cadr mapping) 'apply-partially))
|
||||
mapping
|
||||
(assert (eq (car mapping) (nth 2 mapping)))
|
||||
(list* (car mapping)
|
||||
'apply-partially
|
||||
(car mapping)
|
||||
(mapcar (lambda (arg)
|
||||
(if (eq var arg)
|
||||
closedsym arg))
|
||||
(nthcdr 3 mapping)))))
|
||||
(cl-assert (eq (car mapping) (nth 2 mapping)))
|
||||
(cl-list* (car mapping)
|
||||
'apply-partially
|
||||
(car mapping)
|
||||
(mapcar (lambda (arg)
|
||||
(if (eq var arg)
|
||||
closedsym arg))
|
||||
(nthcdr 3 mapping)))))
|
||||
new-env))
|
||||
(setq new-extend (remq var new-extend))
|
||||
(push closedsym new-extend)
|
||||
|
|
@ -455,7 +455,7 @@ places where they originally did not directly appear."
|
|||
(let ((mapping (cdr (assq fun env))))
|
||||
(pcase mapping
|
||||
(`(apply-partially ,_ . ,(and fvs `(,_ . ,_)))
|
||||
(assert (eq (cadr mapping) fun))
|
||||
(cl-assert (eq (cadr mapping) fun))
|
||||
`(,callsym ,fun
|
||||
,@(mapcar (lambda (fv)
|
||||
(let ((exp (or (cdr (assq fv env)) fv)))
|
||||
|
|
@ -551,7 +551,7 @@ FORM is the parent form that binds this var."
|
|||
;; Transfer uses collected in `envcopy' (via `newenv') back to `env';
|
||||
;; and compute free variables.
|
||||
(while env
|
||||
(assert (and envcopy (eq (caar env) (caar envcopy))))
|
||||
(cl-assert (and envcopy (eq (caar env) (caar envcopy))))
|
||||
(let ((free nil)
|
||||
(x (cdr (car env)))
|
||||
(y (cdr (car envcopy))))
|
||||
|
|
@ -559,8 +559,8 @@ FORM is the parent form that binds this var."
|
|||
(when (car y) (setcar x t) (setq free t))
|
||||
(setq x (cdr x) y (cdr y)))
|
||||
(when free
|
||||
(push (caar env) (cdr freevars))
|
||||
(setf (nth 3 (car env)) t))
|
||||
(cl-push (caar env) (cdr freevars))
|
||||
(cl-setf (nth 3 (car env)) t))
|
||||
(setq env (cdr env) envcopy (cdr envcopy))))))
|
||||
|
||||
(defun cconv-analyse-form (form env)
|
||||
|
|
@ -610,7 +610,7 @@ and updates the data stored in ENV."
|
|||
;; it is a mutated variable.
|
||||
(while forms
|
||||
(let ((v (assq (car forms) env))) ; v = non nil if visible
|
||||
(when v (setf (nth 2 v) t)))
|
||||
(when v (cl-setf (nth 2 v) t)))
|
||||
(cconv-analyse-form (cadr forms) env)
|
||||
(setq forms (cddr forms))))
|
||||
|
||||
|
|
@ -656,7 +656,7 @@ and updates the data stored in ENV."
|
|||
;; lambda candidate list.
|
||||
(let ((fdata (and (symbolp fun) (assq fun env))))
|
||||
(if fdata
|
||||
(setf (nth 4 fdata) t)
|
||||
(cl-setf (nth 4 fdata) t)
|
||||
(cconv-analyse-form fun env)))
|
||||
(dolist (form args) (cconv-analyse-form form env)))
|
||||
|
||||
|
|
@ -676,7 +676,7 @@ and updates the data stored in ENV."
|
|||
((pred symbolp)
|
||||
(let ((dv (assq form env))) ; dv = declared and visible
|
||||
(when dv
|
||||
(setf (nth 1 dv) t))))))
|
||||
(cl-setf (nth 1 dv) t))))))
|
||||
|
||||
(provide 'cconv)
|
||||
;;; cconv.el ends here
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;; cl-extra.el --- Common Lisp features, part 2
|
||||
;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 1993, 2000-2012 Free Software Foundation, Inc.
|
||||
|
||||
|
|
@ -37,12 +37,12 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl)
|
||||
(require 'cl-lib)
|
||||
|
||||
;;; Type coercion.
|
||||
|
||||
;;;###autoload
|
||||
(defun coerce (x type)
|
||||
(defun cl-coerce (x type)
|
||||
"Coerce OBJECT to type TYPE.
|
||||
TYPE is a Common Lisp type specifier.
|
||||
\n(fn OBJECT TYPE)"
|
||||
|
|
@ -51,16 +51,16 @@ TYPE is a Common Lisp type specifier.
|
|||
((eq type 'string) (if (stringp x) x (concat x)))
|
||||
((eq type 'array) (if (arrayp x) x (vconcat x)))
|
||||
((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
|
||||
((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type))
|
||||
((and (eq type 'character) (symbolp x)) (cl-coerce (symbol-name x) type))
|
||||
((eq type 'float) (float x))
|
||||
((typep x type) x)
|
||||
((cl-typep x type) x)
|
||||
(t (error "Can't coerce %s to type %s" x type))))
|
||||
|
||||
|
||||
;;; Predicates.
|
||||
|
||||
;;;###autoload
|
||||
(defun equalp (x y)
|
||||
(defun cl-equalp (x y)
|
||||
"Return t if two Lisp objects have similar structures and contents.
|
||||
This is like `equal', except that it accepts numerically equal
|
||||
numbers of different types (float vs. integer), and also compares
|
||||
|
|
@ -73,14 +73,14 @@ strings case-insensitively."
|
|||
((numberp x)
|
||||
(and (numberp y) (= x y)))
|
||||
((consp x)
|
||||
(while (and (consp x) (consp y) (equalp (car x) (car y)))
|
||||
(while (and (consp x) (consp y) (cl-equalp (car x) (car y)))
|
||||
(setq x (cdr x) y (cdr y)))
|
||||
(and (not (consp x)) (equalp x y)))
|
||||
(and (not (consp x)) (cl-equalp x y)))
|
||||
((vectorp x)
|
||||
(and (vectorp y) (= (length x) (length y))
|
||||
(let ((i (length x)))
|
||||
(while (and (>= (setq i (1- i)) 0)
|
||||
(equalp (aref x i) (aref y i))))
|
||||
(cl-equalp (aref x i) (aref y i))))
|
||||
(< i 0))))
|
||||
(t (equal x y))))
|
||||
|
||||
|
|
@ -88,7 +88,7 @@ strings case-insensitively."
|
|||
;;; Control structures.
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-mapcar-many (cl-func cl-seqs)
|
||||
(defun cl--mapcar-many (cl-func cl-seqs)
|
||||
(if (cdr (cdr cl-seqs))
|
||||
(let* ((cl-res nil)
|
||||
(cl-n (apply 'min (mapcar 'length cl-seqs)))
|
||||
|
|
@ -115,21 +115,21 @@ strings case-insensitively."
|
|||
(cl-i -1))
|
||||
(while (< (setq cl-i (1+ cl-i)) cl-n)
|
||||
(push (funcall cl-func
|
||||
(if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
|
||||
(if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))
|
||||
cl-res)))
|
||||
(if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
|
||||
(if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))
|
||||
cl-res)))
|
||||
(nreverse cl-res))))
|
||||
|
||||
;;;###autoload
|
||||
(defun map (cl-type cl-func cl-seq &rest cl-rest)
|
||||
(defun cl-map (cl-type cl-func cl-seq &rest cl-rest)
|
||||
"Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
|
||||
TYPE is the sequence type to return.
|
||||
\n(fn TYPE FUNCTION SEQUENCE...)"
|
||||
(let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest)))
|
||||
(and cl-type (coerce cl-res cl-type))))
|
||||
(let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest)))
|
||||
(and cl-type (cl-coerce cl-res cl-type))))
|
||||
|
||||
;;;###autoload
|
||||
(defun maplist (cl-func cl-list &rest cl-rest)
|
||||
(defun cl-maplist (cl-func cl-list &rest cl-rest)
|
||||
"Map FUNCTION to each sublist of LIST or LISTs.
|
||||
Like `mapcar', except applies to lists and their cdr's rather than to
|
||||
the elements themselves.
|
||||
|
|
@ -153,40 +153,40 @@ the elements themselves.
|
|||
"Like `mapcar', but does not accumulate values returned by the function.
|
||||
\n(fn FUNCTION SEQUENCE...)"
|
||||
(if cl-rest
|
||||
(progn (apply 'map nil cl-func cl-seq cl-rest)
|
||||
(progn (apply 'cl-map nil cl-func cl-seq cl-rest)
|
||||
cl-seq)
|
||||
(mapc cl-func cl-seq)))
|
||||
|
||||
;;;###autoload
|
||||
(defun mapl (cl-func cl-list &rest cl-rest)
|
||||
"Like `maplist', but does not accumulate values returned by the function.
|
||||
(defun cl-mapl (cl-func cl-list &rest cl-rest)
|
||||
"Like `cl-maplist', but does not accumulate values returned by the function.
|
||||
\n(fn FUNCTION LIST...)"
|
||||
(if cl-rest
|
||||
(apply 'maplist cl-func cl-list cl-rest)
|
||||
(apply 'cl-maplist cl-func cl-list cl-rest)
|
||||
(let ((cl-p cl-list))
|
||||
(while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
|
||||
cl-list)
|
||||
|
||||
;;;###autoload
|
||||
(defun mapcan (cl-func cl-seq &rest cl-rest)
|
||||
(defun cl-mapcan (cl-func cl-seq &rest cl-rest)
|
||||
"Like `mapcar', but nconc's together the values returned by the function.
|
||||
\n(fn FUNCTION SEQUENCE...)"
|
||||
(apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest)))
|
||||
(apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest)))
|
||||
|
||||
;;;###autoload
|
||||
(defun mapcon (cl-func cl-list &rest cl-rest)
|
||||
"Like `maplist', but nconc's together the values returned by the function.
|
||||
(defun cl-mapcon (cl-func cl-list &rest cl-rest)
|
||||
"Like `cl-maplist', but nconc's together the values returned by the function.
|
||||
\n(fn FUNCTION LIST...)"
|
||||
(apply 'nconc (apply 'maplist cl-func cl-list cl-rest)))
|
||||
(apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest)))
|
||||
|
||||
;;;###autoload
|
||||
(defun some (cl-pred cl-seq &rest cl-rest)
|
||||
(defun cl-some (cl-pred cl-seq &rest cl-rest)
|
||||
"Return true if PREDICATE is true of any element of SEQ or SEQs.
|
||||
If so, return the true (non-nil) value returned by PREDICATE.
|
||||
\n(fn PREDICATE SEQ...)"
|
||||
(if (or cl-rest (nlistp cl-seq))
|
||||
(catch 'cl-some
|
||||
(apply 'map nil
|
||||
(apply 'cl-map nil
|
||||
(function (lambda (&rest cl-x)
|
||||
(let ((cl-res (apply cl-pred cl-x)))
|
||||
(if cl-res (throw 'cl-some cl-res)))))
|
||||
|
|
@ -196,12 +196,12 @@ If so, return the true (non-nil) value returned by PREDICATE.
|
|||
cl-x)))
|
||||
|
||||
;;;###autoload
|
||||
(defun every (cl-pred cl-seq &rest cl-rest)
|
||||
(defun cl-every (cl-pred cl-seq &rest cl-rest)
|
||||
"Return true if PREDICATE is true of every element of SEQ or SEQs.
|
||||
\n(fn PREDICATE SEQ...)"
|
||||
(if (or cl-rest (nlistp cl-seq))
|
||||
(catch 'cl-every
|
||||
(apply 'map nil
|
||||
(apply 'cl-map nil
|
||||
(function (lambda (&rest cl-x)
|
||||
(or (apply cl-pred cl-x) (throw 'cl-every nil))))
|
||||
cl-seq cl-rest) t)
|
||||
|
|
@ -210,23 +210,19 @@ If so, return the true (non-nil) value returned by PREDICATE.
|
|||
(null cl-seq)))
|
||||
|
||||
;;;###autoload
|
||||
(defun notany (cl-pred cl-seq &rest cl-rest)
|
||||
(defun cl-notany (cl-pred cl-seq &rest cl-rest)
|
||||
"Return true if PREDICATE is false of every element of SEQ or SEQs.
|
||||
\n(fn PREDICATE SEQ...)"
|
||||
(not (apply 'some cl-pred cl-seq cl-rest)))
|
||||
(not (apply 'cl-some cl-pred cl-seq cl-rest)))
|
||||
|
||||
;;;###autoload
|
||||
(defun notevery (cl-pred cl-seq &rest cl-rest)
|
||||
(defun cl-notevery (cl-pred cl-seq &rest cl-rest)
|
||||
"Return true if PREDICATE is false of some element of SEQ or SEQs.
|
||||
\n(fn PREDICATE SEQ...)"
|
||||
(not (apply 'every cl-pred cl-seq cl-rest)))
|
||||
|
||||
;;; Support for `loop'.
|
||||
;;;###autoload
|
||||
(defalias 'cl-map-keymap 'map-keymap)
|
||||
(not (apply 'cl-every cl-pred cl-seq cl-rest)))
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
|
||||
(defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
|
||||
(or cl-base
|
||||
(setq cl-base (copy-sequence [0])))
|
||||
(map-keymap
|
||||
|
|
@ -234,14 +230,14 @@ If so, return the true (non-nil) value returned by PREDICATE.
|
|||
(lambda (cl-key cl-bind)
|
||||
(aset cl-base (1- (length cl-base)) cl-key)
|
||||
(if (keymapp cl-bind)
|
||||
(cl-map-keymap-recursively
|
||||
(cl--map-keymap-recursively
|
||||
cl-func-rec cl-bind
|
||||
(vconcat cl-base (list 0)))
|
||||
(funcall cl-func-rec cl-base cl-bind))))
|
||||
cl-map))
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
|
||||
(defun cl--map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
|
||||
(or cl-what (setq cl-what (current-buffer)))
|
||||
(if (bufferp cl-what)
|
||||
(let (cl-mark cl-mark2 (cl-next t) cl-next2)
|
||||
|
|
@ -269,7 +265,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
|
|||
(setq cl-start cl-next)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
|
||||
(defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
|
||||
(or cl-buffer (setq cl-buffer (current-buffer)))
|
||||
(if (fboundp 'overlay-lists)
|
||||
|
||||
|
|
@ -309,38 +305,38 @@ If so, return the true (non-nil) value returned by PREDICATE.
|
|||
(setq cl-ovl (cdr cl-ovl))))
|
||||
(set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))
|
||||
|
||||
;;; Support for `setf'.
|
||||
;;; Support for `cl-setf'.
|
||||
;;;###autoload
|
||||
(defun cl-set-frame-visible-p (frame val)
|
||||
(defun cl--set-frame-visible-p (frame val)
|
||||
(cond ((null val) (make-frame-invisible frame))
|
||||
((eq val 'icon) (iconify-frame frame))
|
||||
(t (make-frame-visible frame)))
|
||||
val)
|
||||
|
||||
;;; Support for `progv'.
|
||||
(defvar cl-progv-save)
|
||||
;;; Support for `cl-progv'.
|
||||
(defvar cl--progv-save)
|
||||
;;;###autoload
|
||||
(defun cl-progv-before (syms values)
|
||||
(defun cl--progv-before (syms values)
|
||||
(while syms
|
||||
(push (if (boundp (car syms))
|
||||
(cons (car syms) (symbol-value (car syms)))
|
||||
(car syms)) cl-progv-save)
|
||||
(car syms)) cl--progv-save)
|
||||
(if values
|
||||
(set (pop syms) (pop values))
|
||||
(makunbound (pop syms)))))
|
||||
|
||||
(defun cl-progv-after ()
|
||||
(while cl-progv-save
|
||||
(if (consp (car cl-progv-save))
|
||||
(set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
|
||||
(makunbound (car cl-progv-save)))
|
||||
(pop cl-progv-save)))
|
||||
(defun cl--progv-after ()
|
||||
(while cl--progv-save
|
||||
(if (consp (car cl--progv-save))
|
||||
(set (car (car cl--progv-save)) (cdr (car cl--progv-save)))
|
||||
(makunbound (car cl--progv-save)))
|
||||
(pop cl--progv-save)))
|
||||
|
||||
|
||||
;;; Numbers.
|
||||
|
||||
;;;###autoload
|
||||
(defun gcd (&rest args)
|
||||
(defun cl-gcd (&rest args)
|
||||
"Return the greatest common divisor of the arguments."
|
||||
(let ((a (abs (or (pop args) 0))))
|
||||
(while args
|
||||
|
|
@ -349,18 +345,18 @@ If so, return the true (non-nil) value returned by PREDICATE.
|
|||
a))
|
||||
|
||||
;;;###autoload
|
||||
(defun lcm (&rest args)
|
||||
(defun cl-lcm (&rest args)
|
||||
"Return the least common multiple of the arguments."
|
||||
(if (memq 0 args)
|
||||
0
|
||||
(let ((a (abs (or (pop args) 1))))
|
||||
(while args
|
||||
(let ((b (abs (pop args))))
|
||||
(setq a (* (/ a (gcd a b)) b))))
|
||||
(setq a (* (/ a (cl-gcd a b)) b))))
|
||||
a)))
|
||||
|
||||
;;;###autoload
|
||||
(defun isqrt (x)
|
||||
(defun cl-isqrt (x)
|
||||
"Return the integer square root of the argument."
|
||||
(if (and (integerp x) (> x 0))
|
||||
(let ((g (cond ((<= x 100) 10) ((<= x 10000) 100)
|
||||
|
|
@ -372,35 +368,35 @@ If so, return the true (non-nil) value returned by PREDICATE.
|
|||
(if (eq x 0) 0 (signal 'arith-error nil))))
|
||||
|
||||
;;;###autoload
|
||||
(defun floor* (x &optional y)
|
||||
(defun cl-floor (x &optional y)
|
||||
"Return a list of the floor of X and the fractional part of X.
|
||||
With two arguments, return floor and remainder of their quotient."
|
||||
(let ((q (floor x y)))
|
||||
(list q (- x (if y (* y q) q)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun ceiling* (x &optional y)
|
||||
(defun cl-ceiling (x &optional y)
|
||||
"Return a list of the ceiling of X and the fractional part of X.
|
||||
With two arguments, return ceiling and remainder of their quotient."
|
||||
(let ((res (floor* x y)))
|
||||
(let ((res (cl-floor x y)))
|
||||
(if (= (car (cdr res)) 0) res
|
||||
(list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun truncate* (x &optional y)
|
||||
(defun cl-truncate (x &optional y)
|
||||
"Return a list of the integer part of X and the fractional part of X.
|
||||
With two arguments, return truncation and remainder of their quotient."
|
||||
(if (eq (>= x 0) (or (null y) (>= y 0)))
|
||||
(floor* x y) (ceiling* x y)))
|
||||
(cl-floor x y) (cl-ceiling x y)))
|
||||
|
||||
;;;###autoload
|
||||
(defun round* (x &optional y)
|
||||
(defun cl-round (x &optional y)
|
||||
"Return a list of X rounded to the nearest integer and the remainder.
|
||||
With two arguments, return rounding and remainder of their quotient."
|
||||
(if y
|
||||
(if (and (integerp x) (integerp y))
|
||||
(let* ((hy (/ y 2))
|
||||
(res (floor* (+ x hy) y)))
|
||||
(res (cl-floor (+ x hy) y)))
|
||||
(if (and (= (car (cdr res)) 0)
|
||||
(= (+ hy hy) y)
|
||||
(/= (% (car res) 2) 0))
|
||||
|
|
@ -413,17 +409,17 @@ With two arguments, return rounding and remainder of their quotient."
|
|||
(list q (- x q))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun mod* (x y)
|
||||
(defun cl-mod (x y)
|
||||
"The remainder of X divided by Y, with the same sign as Y."
|
||||
(nth 1 (floor* x y)))
|
||||
(nth 1 (cl-floor x y)))
|
||||
|
||||
;;;###autoload
|
||||
(defun rem* (x y)
|
||||
(defun cl-rem (x y)
|
||||
"The remainder of X divided by Y, with the same sign as X."
|
||||
(nth 1 (truncate* x y)))
|
||||
(nth 1 (cl-truncate x y)))
|
||||
|
||||
;;;###autoload
|
||||
(defun signum (x)
|
||||
(defun cl-signum (x)
|
||||
"Return 1 if X is positive, -1 if negative, 0 if zero."
|
||||
(cond ((> x 0) 1) ((< x 0) -1) (t 0)))
|
||||
|
||||
|
|
@ -431,7 +427,7 @@ With two arguments, return rounding and remainder of their quotient."
|
|||
;; Random numbers.
|
||||
|
||||
;;;###autoload
|
||||
(defun random* (lim &optional state)
|
||||
(defun cl-random (lim &optional state)
|
||||
"Return a random nonnegative number less than LIM, an integer or float.
|
||||
Optional second arg STATE is a random-state object."
|
||||
(or state (setq state cl--random-state))
|
||||
|
|
@ -443,29 +439,29 @@ Optional second arg STATE is a random-state object."
|
|||
(aset vec 0 j)
|
||||
(while (> (setq i (% (+ i 21) 55)) 0)
|
||||
(aset vec i (setq j (prog1 k (setq k (- j k))))))
|
||||
(while (< (setq i (1+ i)) 200) (random* 2 state))))
|
||||
(while (< (setq i (1+ i)) 200) (cl-random 2 state))))
|
||||
(let* ((i (aset state 1 (% (1+ (aref state 1)) 55)))
|
||||
(j (aset state 2 (% (1+ (aref state 2)) 55)))
|
||||
(n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
|
||||
(if (integerp lim)
|
||||
(if (<= lim 512) (% n lim)
|
||||
(if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state))))
|
||||
(if (> lim 8388607) (setq n (+ (lsh n 9) (cl-random 512 state))))
|
||||
(let ((mask 1023))
|
||||
(while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
|
||||
(if (< (setq n (logand n mask)) lim) n (random* lim state))))
|
||||
(if (< (setq n (logand n mask)) lim) n (cl-random lim state))))
|
||||
(* (/ n '8388608e0) lim)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun make-random-state (&optional state)
|
||||
(defun cl-make-random-state (&optional state)
|
||||
"Return a copy of random-state STATE, or of the internal state if omitted.
|
||||
If STATE is t, return a new state object seeded from the time of day."
|
||||
(cond ((null state) (make-random-state cl--random-state))
|
||||
((vectorp state) (cl-copy-tree state t))
|
||||
(cond ((null state) (cl-make-random-state cl--random-state))
|
||||
((vectorp state) (copy-tree state t))
|
||||
((integerp state) (vector 'cl-random-state-tag -1 30 state))
|
||||
(t (make-random-state (cl-random-time)))))
|
||||
(t (cl-make-random-state (cl-random-time)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun random-state-p (object)
|
||||
(defun cl-random-state-p (object)
|
||||
"Return t if OBJECT is a random-state object."
|
||||
(and (vectorp object) (= (length object) 4)
|
||||
(eq (aref object 0) 'cl-random-state-tag)))
|
||||
|
|
@ -473,8 +469,8 @@ If STATE is t, return a new state object seeded from the time of day."
|
|||
|
||||
;; Implementation limits.
|
||||
|
||||
(defun cl-finite-do (func a b)
|
||||
(condition-case err
|
||||
(defun cl--finite-do (func a b)
|
||||
(condition-case _
|
||||
(let ((res (funcall func a b))) ; check for IEEE infinity
|
||||
(and (numberp res) (/= res (/ res 2)) res))
|
||||
(arith-error nil)))
|
||||
|
|
@ -482,48 +478,48 @@ If STATE is t, return a new state object seeded from the time of day."
|
|||
;;;###autoload
|
||||
(defun cl-float-limits ()
|
||||
"Initialize the Common Lisp floating-point parameters.
|
||||
This sets the values of: `most-positive-float', `most-negative-float',
|
||||
`least-positive-float', `least-negative-float', `float-epsilon',
|
||||
`float-negative-epsilon', `least-positive-normalized-float', and
|
||||
`least-negative-normalized-float'."
|
||||
(or most-positive-float (not (numberp '2e1))
|
||||
This sets the values of: `cl-most-positive-float', `cl-most-negative-float',
|
||||
`cl-least-positive-float', `cl-least-negative-float', `cl-float-epsilon',
|
||||
`cl-float-negative-epsilon', `cl-least-positive-normalized-float', and
|
||||
`cl-least-negative-normalized-float'."
|
||||
(or cl-most-positive-float (not (numberp '2e1))
|
||||
(let ((x '2e0) y z)
|
||||
;; Find maximum exponent (first two loops are optimizations)
|
||||
(while (cl-finite-do '* x x) (setq x (* x x)))
|
||||
(while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
|
||||
(while (cl-finite-do '+ x x) (setq x (+ x x)))
|
||||
(while (cl--finite-do '* x x) (setq x (* x x)))
|
||||
(while (cl--finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
|
||||
(while (cl--finite-do '+ x x) (setq x (+ x x)))
|
||||
(setq z x y (/ x 2))
|
||||
;; Now fill in 1's in the mantissa.
|
||||
(while (and (cl-finite-do '+ x y) (/= (+ x y) x))
|
||||
;; Now cl-fill in 1's in the mantissa.
|
||||
(while (and (cl--finite-do '+ x y) (/= (+ x y) x))
|
||||
(setq x (+ x y) y (/ y 2)))
|
||||
(setq most-positive-float x
|
||||
most-negative-float (- x))
|
||||
(setq cl-most-positive-float x
|
||||
cl-most-negative-float (- x))
|
||||
;; Divide down until mantissa starts rounding.
|
||||
(setq x (/ x z) y (/ 16 z) x (* x y))
|
||||
(while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
|
||||
(while (condition-case _ (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
|
||||
(arith-error nil))
|
||||
(setq x (/ x 2) y (/ y 2)))
|
||||
(setq least-positive-normalized-float y
|
||||
least-negative-normalized-float (- y))
|
||||
(setq cl-least-positive-normalized-float y
|
||||
cl-least-negative-normalized-float (- y))
|
||||
;; Divide down until value underflows to zero.
|
||||
(setq x (/ 1 z) y x)
|
||||
(while (condition-case err (> (/ x 2) 0) (arith-error nil))
|
||||
(while (condition-case _ (> (/ x 2) 0) (arith-error nil))
|
||||
(setq x (/ x 2)))
|
||||
(setq least-positive-float x
|
||||
least-negative-float (- x))
|
||||
(setq cl-least-positive-float x
|
||||
cl-least-negative-float (- x))
|
||||
(setq x '1e0)
|
||||
(while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
|
||||
(setq float-epsilon (* x 2))
|
||||
(setq cl-float-epsilon (* x 2))
|
||||
(setq x '1e0)
|
||||
(while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
|
||||
(setq float-negative-epsilon (* x 2))))
|
||||
(setq cl-float-negative-epsilon (* x 2))))
|
||||
nil)
|
||||
|
||||
|
||||
;;; Sequence functions.
|
||||
|
||||
;;;###autoload
|
||||
(defun subseq (seq start &optional end)
|
||||
(defun cl-subseq (seq start &optional end)
|
||||
"Return the subsequence of SEQ from START to END.
|
||||
If END is omitted, it defaults to the length of the sequence.
|
||||
If START or END is negative, it counts from the end."
|
||||
|
|
@ -549,7 +545,7 @@ If START or END is negative, it counts from the end."
|
|||
res))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun concatenate (type &rest seqs)
|
||||
(defun cl-concatenate (type &rest seqs)
|
||||
"Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
|
||||
\n(fn TYPE SEQUENCE...)"
|
||||
(cond ((eq type 'vector) (apply 'vconcat seqs))
|
||||
|
|
@ -561,17 +557,17 @@ If START or END is negative, it counts from the end."
|
|||
;;; List functions.
|
||||
|
||||
;;;###autoload
|
||||
(defun revappend (x y)
|
||||
(defun cl-revappend (x y)
|
||||
"Equivalent to (append (reverse X) Y)."
|
||||
(nconc (reverse x) y))
|
||||
|
||||
;;;###autoload
|
||||
(defun nreconc (x y)
|
||||
(defun cl-nreconc (x y)
|
||||
"Equivalent to (nconc (nreverse X) Y)."
|
||||
(nconc (nreverse x) y))
|
||||
|
||||
;;;###autoload
|
||||
(defun list-length (x)
|
||||
(defun cl-list-length (x)
|
||||
"Return the length of list X. Return nil if list is circular."
|
||||
(let ((n 0) (fast x) (slow x))
|
||||
(while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
|
||||
|
|
@ -579,37 +575,36 @@ If START or END is negative, it counts from the end."
|
|||
(if fast (if (cdr fast) nil (1+ n)) n)))
|
||||
|
||||
;;;###autoload
|
||||
(defun tailp (sublist list)
|
||||
(defun cl-tailp (sublist list)
|
||||
"Return true if SUBLIST is a tail of LIST."
|
||||
(while (and (consp list) (not (eq sublist list)))
|
||||
(setq list (cdr list)))
|
||||
(if (numberp sublist) (equal sublist list) (eq sublist list)))
|
||||
|
||||
(defalias 'cl-copy-tree 'copy-tree)
|
||||
|
||||
|
||||
;;; Property lists.
|
||||
|
||||
;;;###autoload
|
||||
(defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el
|
||||
(defun cl-get (sym tag &optional def)
|
||||
"Return the value of SYMBOL's PROPNAME property, or DEFAULT if none.
|
||||
\n(fn SYMBOL PROPNAME &optional DEFAULT)"
|
||||
(declare (compiler-macro cl--compiler-macro-get))
|
||||
(or (get sym tag)
|
||||
(and def
|
||||
(let ((plist (symbol-plist sym)))
|
||||
(while (and plist (not (eq (car plist) tag)))
|
||||
(setq plist (cdr (cdr plist))))
|
||||
(if plist (car (cdr plist)) def)))))
|
||||
(autoload 'cl--compiler-macro-get "cl-macs")
|
||||
|
||||
;;;###autoload
|
||||
(defun getf (plist tag &optional def)
|
||||
(defun cl-getf (plist tag &optional def)
|
||||
"Search PROPLIST for property PROPNAME; return its value or DEFAULT.
|
||||
PROPLIST is a list of the sort returned by `symbol-plist'.
|
||||
\n(fn PROPLIST PROPNAME &optional DEFAULT)"
|
||||
(setplist '--cl-getf-symbol-- plist)
|
||||
(or (get '--cl-getf-symbol-- tag)
|
||||
;; Originally we called get* here,
|
||||
;; but that fails, because get* has a compiler macro
|
||||
;; Originally we called cl-get here,
|
||||
;; but that fails, because cl-get has a compiler macro
|
||||
;; definition that uses getf!
|
||||
(when def
|
||||
(while (and plist (not (eq (car plist) tag)))
|
||||
|
|
@ -617,13 +612,13 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
|
|||
(if plist (car (cdr plist)) def))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-set-getf (plist tag val)
|
||||
(defun cl--set-getf (plist tag val)
|
||||
(let ((p plist))
|
||||
(while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
|
||||
(if p (progn (setcar (cdr p) val) plist) (list* tag val plist))))
|
||||
(if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-do-remf (plist tag)
|
||||
(defun cl--do-remf (plist tag)
|
||||
(let ((p (cdr plist)))
|
||||
(while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
|
||||
(and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
|
||||
|
|
@ -635,41 +630,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
|
|||
(let ((plist (symbol-plist sym)))
|
||||
(if (and plist (eq tag (car plist)))
|
||||
(progn (setplist sym (cdr (cdr plist))) t)
|
||||
(cl-do-remf plist tag))))
|
||||
;;;###autoload
|
||||
(defalias 'remprop 'cl-remprop)
|
||||
|
||||
|
||||
|
||||
;;; Hash tables.
|
||||
;; This is just kept for compatibility with code byte-compiled by Emacs-20.
|
||||
|
||||
;; No idea if this might still be needed.
|
||||
(defun cl-not-hash-table (x &optional y &rest z)
|
||||
(signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
|
||||
|
||||
(defvar cl-builtin-gethash (symbol-function 'gethash))
|
||||
(defvar cl-builtin-remhash (symbol-function 'remhash))
|
||||
(defvar cl-builtin-clrhash (symbol-function 'clrhash))
|
||||
(defvar cl-builtin-maphash (symbol-function 'maphash))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'cl-gethash 'gethash)
|
||||
;;;###autoload
|
||||
(defalias 'cl-puthash 'puthash)
|
||||
;;;###autoload
|
||||
(defalias 'cl-remhash 'remhash)
|
||||
;;;###autoload
|
||||
(defalias 'cl-clrhash 'clrhash)
|
||||
;;;###autoload
|
||||
(defalias 'cl-maphash 'maphash)
|
||||
;; These three actually didn't exist in Emacs-20.
|
||||
;;;###autoload
|
||||
(defalias 'cl-make-hash-table 'make-hash-table)
|
||||
;;;###autoload
|
||||
(defalias 'cl-hash-table-p 'hash-table-p)
|
||||
;;;###autoload
|
||||
(defalias 'cl-hash-table-count 'hash-table-count)
|
||||
(cl--do-remf plist tag))))
|
||||
|
||||
;;; Some debugging aids.
|
||||
|
||||
|
|
@ -685,15 +646,15 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
|
|||
(forward-sexp)
|
||||
(delete-char 1))
|
||||
(goto-char (1+ pt))
|
||||
(cl-do-prettyprint)))
|
||||
(cl--do-prettyprint)))
|
||||
|
||||
(defun cl-do-prettyprint ()
|
||||
(defun cl--do-prettyprint ()
|
||||
(skip-chars-forward " ")
|
||||
(if (looking-at "(")
|
||||
(let ((skip (or (looking-at "((") (looking-at "(prog")
|
||||
(looking-at "(unwind-protect ")
|
||||
(looking-at "(function (")
|
||||
(looking-at "(cl-block-wrapper ")))
|
||||
(looking-at "(cl--block-wrapper ")))
|
||||
(two (or (looking-at "(defun ") (looking-at "(defmacro ")))
|
||||
(let (or (looking-at "(let\\*? ") (looking-at "(while ")))
|
||||
(set (looking-at "(p?set[qf] ")))
|
||||
|
|
@ -703,104 +664,24 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
|
|||
(and (>= (current-column) 78) (progn (backward-sexp) t))))
|
||||
(let ((nl t))
|
||||
(forward-char 1)
|
||||
(cl-do-prettyprint)
|
||||
(or skip (looking-at ")") (cl-do-prettyprint))
|
||||
(or (not two) (looking-at ")") (cl-do-prettyprint))
|
||||
(cl--do-prettyprint)
|
||||
(or skip (looking-at ")") (cl--do-prettyprint))
|
||||
(or (not two) (looking-at ")") (cl--do-prettyprint))
|
||||
(while (not (looking-at ")"))
|
||||
(if set (setq nl (not nl)))
|
||||
(if nl (insert "\n"))
|
||||
(lisp-indent-line)
|
||||
(cl-do-prettyprint))
|
||||
(cl--do-prettyprint))
|
||||
(forward-char 1))))
|
||||
(forward-sexp)))
|
||||
|
||||
(defvar cl-macroexpand-cmacs nil)
|
||||
(defvar cl-closure-vars nil)
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-macroexpand-all (form &optional env)
|
||||
"Expand all macro calls through a Lisp FORM.
|
||||
This also does some trivial optimizations to make the form prettier."
|
||||
(while (or (not (eq form (setq form (macroexpand form env))))
|
||||
(and cl-macroexpand-cmacs
|
||||
(not (eq form (setq form (compiler-macroexpand form)))))))
|
||||
(cond ((not (consp form)) form)
|
||||
((memq (car form) '(let let*))
|
||||
(if (null (nth 1 form))
|
||||
(cl-macroexpand-all (cons 'progn (cddr form)) env)
|
||||
(let ((letf nil) (res nil) (lets (cadr form)))
|
||||
(while lets
|
||||
(push (if (consp (car lets))
|
||||
(let ((exp (cl-macroexpand-all (caar lets) env)))
|
||||
(or (symbolp exp) (setq letf t))
|
||||
(cons exp (cl-macroexpand-body (cdar lets) env)))
|
||||
(let ((exp (cl-macroexpand-all (car lets) env)))
|
||||
(if (symbolp exp) exp
|
||||
(setq letf t) (list exp nil)))) res)
|
||||
(setq lets (cdr lets)))
|
||||
(list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form))
|
||||
(nreverse res) (cl-macroexpand-body (cddr form) env)))))
|
||||
((eq (car form) 'cond)
|
||||
(cons (car form)
|
||||
(mapcar (function (lambda (x) (cl-macroexpand-body x env)))
|
||||
(cdr form))))
|
||||
((eq (car form) 'condition-case)
|
||||
(list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
|
||||
(mapcar (function
|
||||
(lambda (x)
|
||||
(cons (car x) (cl-macroexpand-body (cdr x) env))))
|
||||
(cdddr form))))
|
||||
((memq (car form) '(quote function))
|
||||
(if (eq (car-safe (nth 1 form)) 'lambda)
|
||||
(let ((body (cl-macroexpand-body (cddadr form) env)))
|
||||
(if (and cl-closure-vars (eq (car form) 'function)
|
||||
(cl-expr-contains-any body cl-closure-vars))
|
||||
(let* ((new (mapcar 'gensym cl-closure-vars))
|
||||
(sub (pairlis cl-closure-vars new)) (decls nil))
|
||||
(while (or (stringp (car body))
|
||||
(eq (car-safe (car body)) 'interactive))
|
||||
(push (list 'quote (pop body)) decls))
|
||||
(put (car (last cl-closure-vars)) 'used t)
|
||||
`(list 'lambda '(&rest --cl-rest--)
|
||||
,@(sublis sub (nreverse decls))
|
||||
(list 'apply
|
||||
(list 'quote
|
||||
#'(lambda ,(append new (cadadr form))
|
||||
,@(sublis sub body)))
|
||||
,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
|
||||
cl-closure-vars)
|
||||
'((quote --cl-rest--))))))
|
||||
(list (car form) (list* 'lambda (cadadr form) body))))
|
||||
(let ((found (assq (cadr form) env)))
|
||||
(if (and found (ignore-errors
|
||||
(eq (cadr (caddr found)) 'cl-labels-args)))
|
||||
(cl-macroexpand-all (cadr (caddr (cadddr found))) env)
|
||||
form))))
|
||||
((memq (car form) '(defun defmacro))
|
||||
(list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
|
||||
((and (eq (car form) 'progn) (not (cddr form)))
|
||||
(cl-macroexpand-all (nth 1 form) env))
|
||||
((eq (car form) 'setq)
|
||||
(let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
|
||||
(while (and p (symbolp (car p))) (setq p (cddr p)))
|
||||
(if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
|
||||
((consp (car form))
|
||||
(cl-macroexpand-all (list* 'funcall
|
||||
(list 'function (car form))
|
||||
(cdr form))
|
||||
env))
|
||||
(t (cons (car form) (cl-macroexpand-body (cdr form) env)))))
|
||||
|
||||
(defun cl-macroexpand-body (body &optional env)
|
||||
(mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-prettyexpand (form &optional full)
|
||||
(message "Expanding...")
|
||||
(let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
|
||||
(let ((cl--compiling-file full)
|
||||
(byte-compile-macro-environment nil))
|
||||
(setq form (cl-macroexpand-all form
|
||||
(and (not full) '((block) (eval-when)))))
|
||||
(setq form (macroexpand-all form
|
||||
(and (not full) '((cl-block) (cl-eval-when)))))
|
||||
(message "Formatting...")
|
||||
(prog1 (cl-prettyprint form)
|
||||
(message ""))))
|
||||
|
|
|
|||
662
lisp/emacs-lisp/cl-lib.el
Normal file
662
lisp/emacs-lisp/cl-lib.el
Normal file
|
|
@ -0,0 +1,662 @@
|
|||
;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Dave Gillespie <daveg@synaptics.com>
|
||||
;; Version: 2.02
|
||||
;; Keywords: extensions
|
||||
|
||||
;; 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 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; These are extensions to Emacs Lisp that provide a degree of
|
||||
;; Common Lisp compatibility, beyond what is already built-in
|
||||
;; in Emacs Lisp.
|
||||
;;
|
||||
;; This package was written by Dave Gillespie; it is a complete
|
||||
;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
|
||||
;;
|
||||
;; Bug reports, comments, and suggestions are welcome!
|
||||
|
||||
;; This file contains the portions of the Common Lisp extensions
|
||||
;; package which should always be present.
|
||||
|
||||
|
||||
;;; Future notes:
|
||||
|
||||
;; Once Emacs 19 becomes standard, many things in this package which are
|
||||
;; messy for reasons of compatibility can be greatly simplified. For now,
|
||||
;; I prefer to maintain one unified version.
|
||||
|
||||
|
||||
;;; Change Log:
|
||||
|
||||
;; Version 2.02 (30 Jul 93):
|
||||
;; * Added "cl-compat.el" file, extra compatibility with old package.
|
||||
;; * Added `lexical-let' and `lexical-let*'.
|
||||
;; * Added `define-modify-macro', `callf', and `callf2'.
|
||||
;; * Added `ignore-errors'.
|
||||
;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero.
|
||||
;; * Merged `*gentemp-counter*' into `*gensym-counter*'.
|
||||
;; * Extended `subseq' to allow negative START and END like `substring'.
|
||||
;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses.
|
||||
;; * Added `concat', `vconcat' loop clauses.
|
||||
;; * Cleaned up a number of compiler warnings.
|
||||
|
||||
;; Version 2.01 (7 Jul 93):
|
||||
;; * Added support for FSF version of Emacs 19.
|
||||
;; * Added `add-hook' for Emacs 18 users.
|
||||
;; * Added `defsubst*' and `symbol-macrolet'.
|
||||
;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'.
|
||||
;; * Added `map', `concatenate', `reduce', `merge'.
|
||||
;; * Added `revappend', `nreconc', `tailp', `tree-equal'.
|
||||
;; * Added `assert', `check-type', `typecase', `typep', and `deftype'.
|
||||
;; * Added destructuring and `&environment' support to `defmacro*'.
|
||||
;; * Added destructuring to `loop', and added the following clauses:
|
||||
;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'.
|
||||
;; * Renamed `delete' to `delete*' and `remove' to `remove*'.
|
||||
;; * Completed support for all keywords in `remove*', `substitute', etc.
|
||||
;; * Added `most-positive-float' and company.
|
||||
;; * Fixed hash tables to work with latest Lucid Emacs.
|
||||
;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'.
|
||||
;; * Syntax for `warn' declarations has changed.
|
||||
;; * Improved implementation of `random*'.
|
||||
;; * Moved most sequence functions to a new file, cl-seq.el.
|
||||
;; * Moved `eval-when' into cl-macs.el.
|
||||
;; * Moved `pushnew' and `adjoin' to cl.el for most common cases.
|
||||
;; * Moved `provide' forms down to ends of files.
|
||||
;; * Changed expansion of `pop' to something that compiles to better code.
|
||||
;; * Changed so that no patch is required for Emacs 19 byte compiler.
|
||||
;; * Made more things dependent on `optimize' declarations.
|
||||
;; * Added a partial implementation of struct print functions.
|
||||
;; * Miscellaneous minor changes.
|
||||
|
||||
;; Version 2.00:
|
||||
;; * First public release of this package.
|
||||
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar cl-optimize-speed 1)
|
||||
(defvar cl-optimize-safety 1)
|
||||
|
||||
;;;###autoload
|
||||
(define-obsolete-variable-alias
|
||||
;; This alias is needed for compatibility with .elc files that use defstruct
|
||||
;; and were compiled with Emacs<24.2.
|
||||
'custom-print-functions 'cl-custom-print-functions "24.2")
|
||||
|
||||
;;;###autoload
|
||||
(defvar cl-custom-print-functions nil
|
||||
"This is a list of functions that format user objects for printing.
|
||||
Each function is called in turn with three arguments: the object, the
|
||||
stream, and the print level (currently ignored). If it is able to
|
||||
print the object it returns true; otherwise it returns nil and the
|
||||
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.")
|
||||
|
||||
(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
|
||||
;; can safely be used in .emacs files.
|
||||
|
||||
(defmacro cl-incf (place &optional x)
|
||||
"Increment PLACE by X (1 by default).
|
||||
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
|
||||
The return value is the incremented value of PLACE."
|
||||
(declare (debug (place &optional form)))
|
||||
(if (symbolp place)
|
||||
(list 'setq place (if x (list '+ place x) (list '1+ place)))
|
||||
(list 'cl-callf '+ place (or x 1))))
|
||||
|
||||
(defmacro cl-decf (place &optional x)
|
||||
"Decrement PLACE by X (1 by default).
|
||||
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
|
||||
The return value is the decremented value of PLACE."
|
||||
(declare (debug cl-incf))
|
||||
(if (symbolp place)
|
||||
(list 'setq place (if x (list '- place x) (list '1- place)))
|
||||
(list 'cl-callf '- place (or x 1))))
|
||||
|
||||
;; Autoloaded, but we haven't loaded cl-loaddefs yet.
|
||||
(declare-function cl-do-pop "cl-macs" (place))
|
||||
|
||||
(defmacro cl-pop (place)
|
||||
"Remove and return the head of the list stored in PLACE.
|
||||
Analogous to (prog1 (car PLACE) (cl-setf PLACE (cdr PLACE))), though more
|
||||
careful about evaluating each argument only once and in the right order.
|
||||
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'."
|
||||
(declare (debug (place)))
|
||||
(if (symbolp place)
|
||||
(list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))
|
||||
(cl-do-pop place)))
|
||||
|
||||
(defmacro cl-push (x place)
|
||||
"Insert X at the head of the list stored in PLACE.
|
||||
Analogous to (cl-setf PLACE (cons X PLACE)), though more careful about
|
||||
evaluating each argument only once and in the right order. PLACE may
|
||||
be a symbol, or any generalized variable allowed by `cl-setf'."
|
||||
(declare (debug (form place)))
|
||||
(if (symbolp place) (list 'setq place (list 'cons x place))
|
||||
(list 'cl-callf2 'cons x place)))
|
||||
|
||||
(defmacro cl-pushnew (x place &rest keys)
|
||||
"(cl-pushnew X PLACE): insert X at the head of the list if not already there.
|
||||
Like (cl-push X PLACE), except that the list is unmodified if X is `eql' to
|
||||
an element already on the list.
|
||||
\nKeywords supported: :test :test-not :key
|
||||
\n(fn X PLACE [KEYWORD VALUE]...)"
|
||||
(declare (debug
|
||||
(form place &rest
|
||||
&or [[&or ":test" ":test-not" ":key"] function-form]
|
||||
[keywordp form])))
|
||||
(if (symbolp place)
|
||||
(if (null keys)
|
||||
`(let ((x ,x))
|
||||
(if (memql x ,place)
|
||||
;; This symbol may later on expand to actual code which then
|
||||
;; trigger warnings like "value unused" since cl-pushnew's return
|
||||
;; value is rarely used. It should not matter that other
|
||||
;; warnings may be silenced, since `place' is used earlier and
|
||||
;; should have triggered them already.
|
||||
(with-no-warnings ,place)
|
||||
(setq ,place (cons x ,place))))
|
||||
(list 'setq place (cl-list* 'cl-adjoin x place keys)))
|
||||
(cl-list* 'cl-callf2 'cl-adjoin x place keys)))
|
||||
|
||||
(defun cl--set-elt (seq n val)
|
||||
(if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
|
||||
|
||||
(defsubst cl--set-nthcdr (n list x)
|
||||
(if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
|
||||
|
||||
(defun cl--set-buffer-substring (start end val)
|
||||
(save-excursion (delete-region start end)
|
||||
(goto-char start)
|
||||
(insert val)
|
||||
val))
|
||||
|
||||
(defun cl--set-substring (str start end val)
|
||||
(if end (if (< end 0) (cl-incf end (length str)))
|
||||
(setq end (length str)))
|
||||
(if (< start 0) (cl-incf start (length str)))
|
||||
(concat (and (> start 0) (substring str 0 start))
|
||||
val
|
||||
(and (< end (length str)) (substring str end))))
|
||||
|
||||
|
||||
;;; Blocks and exits.
|
||||
|
||||
(defalias 'cl--block-wrapper 'identity)
|
||||
(defalias 'cl--block-throw 'throw)
|
||||
|
||||
|
||||
;;; Multiple values.
|
||||
;; True multiple values are not supported, or even
|
||||
;; simulated. Instead, cl-multiple-value-bind and friends simply expect
|
||||
;; the target form to return the values as a list.
|
||||
|
||||
(defun cl--defalias (cl-f el-f &optional doc)
|
||||
(defalias cl-f el-f doc)
|
||||
(put cl-f 'byte-optimizer 'byte-compile-inline-expand))
|
||||
|
||||
(cl--defalias 'cl-values #'list
|
||||
"Return multiple values, Common Lisp style.
|
||||
The arguments of `cl-values' are the values
|
||||
that the containing function should return.
|
||||
|
||||
\(fn &rest VALUES)")
|
||||
|
||||
(cl--defalias 'cl-values-list #'identity
|
||||
"Return multiple values, Common Lisp style, taken from a list.
|
||||
LIST specifies the list of values
|
||||
that the containing function should return.
|
||||
|
||||
\(fn LIST)")
|
||||
|
||||
(defsubst cl-multiple-value-list (expression)
|
||||
"Return a list of the multiple values produced by EXPRESSION.
|
||||
This handles multiple values in Common Lisp style, but it does not
|
||||
work right when EXPRESSION calls an ordinary Emacs Lisp function
|
||||
that returns just one value."
|
||||
expression)
|
||||
|
||||
(defsubst cl-multiple-value-apply (function expression)
|
||||
"Evaluate EXPRESSION to get multiple values and apply FUNCTION to them.
|
||||
This handles multiple values in Common Lisp style, but it does not work
|
||||
right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
|
||||
one value."
|
||||
(apply function expression))
|
||||
|
||||
(defalias 'cl-multiple-value-call 'apply
|
||||
"Apply FUNCTION to ARGUMENTS, taking multiple values into account.
|
||||
This implementation only handles the case where there is only one argument.")
|
||||
|
||||
(defsubst cl-nth-value (n expression)
|
||||
"Evaluate EXPRESSION to get multiple values and return the Nth one.
|
||||
This handles multiple values in Common Lisp style, but it does not work
|
||||
right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
|
||||
one value."
|
||||
(nth n expression))
|
||||
|
||||
;;; Declarations.
|
||||
|
||||
(defvar cl--compiling-file nil)
|
||||
(defun cl--compiling-file ()
|
||||
(or cl--compiling-file
|
||||
(and (boundp 'byte-compile--outbuffer)
|
||||
(bufferp (symbol-value 'byte-compile--outbuffer))
|
||||
(equal (buffer-name (symbol-value 'byte-compile--outbuffer))
|
||||
" *Compiler Output*"))))
|
||||
|
||||
(defvar cl-proclaims-deferred nil)
|
||||
|
||||
(defun cl-proclaim (spec)
|
||||
(if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t)
|
||||
(push spec cl-proclaims-deferred))
|
||||
nil)
|
||||
|
||||
(defmacro cl-declaim (&rest specs)
|
||||
(let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x))))
|
||||
specs)))
|
||||
(if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body)
|
||||
(cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when
|
||||
|
||||
|
||||
;;; Symbols.
|
||||
|
||||
(defun cl-random-time ()
|
||||
(let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
|
||||
(while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
|
||||
v))
|
||||
|
||||
(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100))
|
||||
|
||||
|
||||
;;; Numbers.
|
||||
|
||||
(defun cl-floatp-safe (object)
|
||||
"Return t if OBJECT is a floating point number.
|
||||
On Emacs versions that lack floating-point support, this function
|
||||
always returns nil."
|
||||
(and (numberp object) (not (integerp object))))
|
||||
|
||||
(defsubst cl-plusp (number)
|
||||
"Return t if NUMBER is positive."
|
||||
(> number 0))
|
||||
|
||||
(defsubst cl-minusp (number)
|
||||
"Return t if NUMBER is negative."
|
||||
(< number 0))
|
||||
|
||||
(defun cl-oddp (integer)
|
||||
"Return t if INTEGER is odd."
|
||||
(eq (logand integer 1) 1))
|
||||
|
||||
(defun cl-evenp (integer)
|
||||
"Return t if INTEGER is even."
|
||||
(eq (logand integer 1) 0))
|
||||
|
||||
(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time)))
|
||||
|
||||
(defconst cl-most-positive-float nil
|
||||
"The largest value that a Lisp float can hold.
|
||||
If your system supports infinities, this is the largest finite value.
|
||||
For IEEE machines, this is approximately 1.79e+308.
|
||||
Call `cl-float-limits' to set this.")
|
||||
|
||||
(defconst cl-most-negative-float nil
|
||||
"The largest negative value that a Lisp float can hold.
|
||||
This is simply -`cl-most-positive-float'.
|
||||
Call `cl-float-limits' to set this.")
|
||||
|
||||
(defconst cl-least-positive-float nil
|
||||
"The smallest value greater than zero that a Lisp float can hold.
|
||||
For IEEE machines, it is about 4.94e-324 if denormals are supported,
|
||||
or 2.22e-308 if they are not.
|
||||
Call `cl-float-limits' to set this.")
|
||||
|
||||
(defconst cl-least-negative-float nil
|
||||
"The smallest value less than zero that a Lisp float can hold.
|
||||
This is simply -`cl-least-positive-float'.
|
||||
Call `cl-float-limits' to set this.")
|
||||
|
||||
(defconst cl-least-positive-normalized-float nil
|
||||
"The smallest normalized Lisp float greater than zero.
|
||||
This is the smallest value for which IEEE denormalization does not lose
|
||||
precision. For IEEE machines, this value is about 2.22e-308.
|
||||
For machines that do not support the concept of denormalization
|
||||
and gradual underflow, this constant equals `cl-least-positive-float'.
|
||||
Call `cl-float-limits' to set this.")
|
||||
|
||||
(defconst cl-least-negative-normalized-float nil
|
||||
"The smallest normalized Lisp float less than zero.
|
||||
This is simply -`cl-least-positive-normalized-float'.
|
||||
Call `cl-float-limits' to set this.")
|
||||
|
||||
(defconst cl-float-epsilon nil
|
||||
"The smallest positive float that adds to 1.0 to give a distinct value.
|
||||
Adding a number less than this to 1.0 returns 1.0 due to roundoff.
|
||||
For IEEE machines, epsilon is about 2.22e-16.
|
||||
Call `cl-float-limits' to set this.")
|
||||
|
||||
(defconst cl-float-negative-epsilon nil
|
||||
"The smallest positive float that subtracts from 1.0 to give a distinct value.
|
||||
For IEEE machines, it is about 1.11e-16.
|
||||
Call `cl-float-limits' to set this.")
|
||||
|
||||
|
||||
;;; Sequence functions.
|
||||
|
||||
(cl--defalias 'cl-copy-seq 'copy-sequence)
|
||||
|
||||
(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs))
|
||||
|
||||
(defun cl-mapcar (cl-func cl-x &rest cl-rest)
|
||||
"Apply FUNCTION to each element of SEQ, and make a list of the results.
|
||||
If there are several SEQs, FUNCTION is called with that many arguments,
|
||||
and mapping stops as soon as the shortest list runs out. With just one
|
||||
SEQ, this is like `mapcar'. With several, it is like the Common Lisp
|
||||
`mapcar' function extended to arbitrary sequence types.
|
||||
\n(fn FUNCTION SEQ...)"
|
||||
(if cl-rest
|
||||
(if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest)))
|
||||
(cl--mapcar-many cl-func (cons cl-x cl-rest))
|
||||
(let ((cl-res nil) (cl-y (car cl-rest)))
|
||||
(while (and cl-x cl-y)
|
||||
(push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res))
|
||||
(nreverse cl-res)))
|
||||
(mapcar cl-func cl-x)))
|
||||
|
||||
(cl--defalias 'cl-svref 'aref)
|
||||
|
||||
;;; List functions.
|
||||
|
||||
(cl--defalias 'cl-first 'car)
|
||||
(cl--defalias 'cl-second 'cadr)
|
||||
(cl--defalias 'cl-rest 'cdr)
|
||||
(cl--defalias 'cl-endp 'null)
|
||||
|
||||
(cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.")
|
||||
(cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.")
|
||||
|
||||
(defsubst cl-fifth (x)
|
||||
"Return the fifth element of the list X."
|
||||
(nth 4 x))
|
||||
|
||||
(defsubst cl-sixth (x)
|
||||
"Return the sixth element of the list X."
|
||||
(nth 5 x))
|
||||
|
||||
(defsubst cl-seventh (x)
|
||||
"Return the seventh element of the list X."
|
||||
(nth 6 x))
|
||||
|
||||
(defsubst cl-eighth (x)
|
||||
"Return the eighth element of the list X."
|
||||
(nth 7 x))
|
||||
|
||||
(defsubst cl-ninth (x)
|
||||
"Return the ninth element of the list X."
|
||||
(nth 8 x))
|
||||
|
||||
(defsubst cl-tenth (x)
|
||||
"Return the tenth element of the list X."
|
||||
(nth 9 x))
|
||||
|
||||
(defun cl-caaar (x)
|
||||
"Return the `car' of the `car' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (car (car x))))
|
||||
|
||||
(defun cl-caadr (x)
|
||||
"Return the `car' of the `car' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (car (cdr x))))
|
||||
|
||||
(defun cl-cadar (x)
|
||||
"Return the `car' of the `cdr' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (cdr (car x))))
|
||||
|
||||
(defun cl-caddr (x)
|
||||
"Return the `car' of the `cdr' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (cdr (cdr x))))
|
||||
|
||||
(defun cl-cdaar (x)
|
||||
"Return the `cdr' of the `car' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (car (car x))))
|
||||
|
||||
(defun cl-cdadr (x)
|
||||
"Return the `cdr' of the `car' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (car (cdr x))))
|
||||
|
||||
(defun cl-cddar (x)
|
||||
"Return the `cdr' of the `cdr' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (cdr (car x))))
|
||||
|
||||
(defun cl-cdddr (x)
|
||||
"Return the `cdr' of the `cdr' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (cdr (cdr x))))
|
||||
|
||||
(defun cl-caaaar (x)
|
||||
"Return the `car' of the `car' of the `car' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (car (car (car x)))))
|
||||
|
||||
(defun cl-caaadr (x)
|
||||
"Return the `car' of the `car' of the `car' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (car (car (cdr x)))))
|
||||
|
||||
(defun cl-caadar (x)
|
||||
"Return the `car' of the `car' of the `cdr' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (car (cdr (car x)))))
|
||||
|
||||
(defun cl-caaddr (x)
|
||||
"Return the `car' of the `car' of the `cdr' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (car (cdr (cdr x)))))
|
||||
|
||||
(defun cl-cadaar (x)
|
||||
"Return the `car' of the `cdr' of the `car' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (cdr (car (car x)))))
|
||||
|
||||
(defun cl-cadadr (x)
|
||||
"Return the `car' of the `cdr' of the `car' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (cdr (car (cdr x)))))
|
||||
|
||||
(defun cl-caddar (x)
|
||||
"Return the `car' of the `cdr' of the `cdr' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (cdr (cdr (car x)))))
|
||||
|
||||
(defun cl-cadddr (x)
|
||||
"Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(car (cdr (cdr (cdr x)))))
|
||||
|
||||
(defun cl-cdaaar (x)
|
||||
"Return the `cdr' of the `car' of the `car' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (car (car (car x)))))
|
||||
|
||||
(defun cl-cdaadr (x)
|
||||
"Return the `cdr' of the `car' of the `car' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (car (car (cdr x)))))
|
||||
|
||||
(defun cl-cdadar (x)
|
||||
"Return the `cdr' of the `car' of the `cdr' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (car (cdr (car x)))))
|
||||
|
||||
(defun cl-cdaddr (x)
|
||||
"Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (car (cdr (cdr x)))))
|
||||
|
||||
(defun cl-cddaar (x)
|
||||
"Return the `cdr' of the `cdr' of the `car' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (cdr (car (car x)))))
|
||||
|
||||
(defun cl-cddadr (x)
|
||||
"Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (cdr (car (cdr x)))))
|
||||
|
||||
(defun cl-cdddar (x)
|
||||
"Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (cdr (cdr (car x)))))
|
||||
|
||||
(defun cl-cddddr (x)
|
||||
"Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
|
||||
(declare (compiler-macro cl--compiler-macro-cXXr))
|
||||
(cdr (cdr (cdr (cdr x)))))
|
||||
|
||||
;;(defun last* (x &optional n)
|
||||
;; "Returns the last link in the list LIST.
|
||||
;;With optional argument N, returns Nth-to-last link (default 1)."
|
||||
;; (if n
|
||||
;; (let ((m 0) (p x))
|
||||
;; (while (consp p) (cl-incf m) (pop p))
|
||||
;; (if (<= n 0) p
|
||||
;; (if (< n m) (nthcdr (- m n) x) x)))
|
||||
;; (while (consp (cdr x)) (pop x))
|
||||
;; x))
|
||||
|
||||
(defun cl-list* (arg &rest rest)
|
||||
"Return a new list with specified ARGs as elements, consed to last ARG.
|
||||
Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
|
||||
`(cons A (cons B (cons C D)))'.
|
||||
\n(fn ARG...)"
|
||||
(declare (compiler-macro cl--compiler-macro-list*))
|
||||
(cond ((not rest) arg)
|
||||
((not (cdr rest)) (cons arg (car rest)))
|
||||
(t (let* ((n (length rest))
|
||||
(copy (copy-sequence rest))
|
||||
(last (nthcdr (- n 2) copy)))
|
||||
(setcdr last (car (cdr last)))
|
||||
(cons arg copy)))))
|
||||
|
||||
(defun cl-ldiff (list sublist)
|
||||
"Return a copy of LIST with the tail SUBLIST removed."
|
||||
(let ((res nil))
|
||||
(while (and (consp list) (not (eq list sublist)))
|
||||
(push (pop list) res))
|
||||
(nreverse res)))
|
||||
|
||||
(defun cl-copy-list (list)
|
||||
"Return a copy of LIST, which may be a dotted list.
|
||||
The elements of LIST are not copied, just the list structure itself."
|
||||
(if (consp list)
|
||||
(let ((res nil))
|
||||
(while (consp list) (push (pop list) res))
|
||||
(prog1 (nreverse res) (setcdr res list)))
|
||||
(car list)))
|
||||
|
||||
;; Autoloaded, but we have not loaded cl-loaddefs yet.
|
||||
(declare-function cl-floor "cl-extra" (x &optional y))
|
||||
(declare-function cl-ceiling "cl-extra" (x &optional y))
|
||||
(declare-function cl-truncate "cl-extra" (x &optional y))
|
||||
(declare-function cl-round "cl-extra" (x &optional y))
|
||||
(declare-function cl-mod "cl-extra" (x y))
|
||||
|
||||
(defun cl-adjoin (cl-item cl-list &rest cl-keys)
|
||||
"Return ITEM consed onto the front of LIST only if it's not already there.
|
||||
Otherwise, return LIST unmodified.
|
||||
\nKeywords supported: :test :test-not :key
|
||||
\n(fn ITEM LIST [KEYWORD VALUE]...)"
|
||||
(declare (compiler-macro cl--compiler-macro-adjoin))
|
||||
(cond ((or (equal cl-keys '(:test eq))
|
||||
(and (null cl-keys) (not (numberp cl-item))))
|
||||
(if (memq cl-item cl-list) cl-list (cons cl-item cl-list)))
|
||||
((or (equal cl-keys '(:test equal)) (null cl-keys))
|
||||
(if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
|
||||
(t (apply 'cl--adjoin cl-item cl-list cl-keys))))
|
||||
|
||||
(defun cl-subst (cl-new cl-old cl-tree &rest cl-keys)
|
||||
"Substitute NEW for OLD everywhere in TREE (non-destructively).
|
||||
Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
|
||||
\nKeywords supported: :test :test-not :key
|
||||
\n(fn NEW OLD TREE [KEYWORD VALUE]...)"
|
||||
(if (or cl-keys (and (numberp cl-old) (not (integerp cl-old))))
|
||||
(apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
|
||||
(cl--do-subst cl-new cl-old cl-tree)))
|
||||
|
||||
(defun cl--do-subst (cl-new cl-old cl-tree)
|
||||
(cond ((eq cl-tree cl-old) cl-new)
|
||||
((consp cl-tree)
|
||||
(let ((a (cl--do-subst cl-new cl-old (car cl-tree)))
|
||||
(d (cl--do-subst cl-new cl-old (cdr cl-tree))))
|
||||
(if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
|
||||
cl-tree (cons a d))))
|
||||
(t cl-tree)))
|
||||
|
||||
(defun cl-acons (key value alist)
|
||||
"Add KEY and VALUE to ALIST.
|
||||
Return a new list with (cons KEY VALUE) as car and ALIST as cdr."
|
||||
(cons (cons key value) alist))
|
||||
|
||||
(defun cl-pairlis (keys values &optional alist)
|
||||
"Make an alist from KEYS and VALUES.
|
||||
Return a new alist composed by associating KEYS to corresponding VALUES;
|
||||
the process stops as soon as KEYS or VALUES run out.
|
||||
If ALIST is non-nil, the new pairs are prepended to it."
|
||||
(nconc (cl-mapcar 'cons keys values) alist))
|
||||
|
||||
|
||||
;;; Miscellaneous.
|
||||
|
||||
;;;###autoload
|
||||
(progn
|
||||
;; Autoload, so autoload.el and font-lock can use it even when CL
|
||||
;; is not loaded.
|
||||
(put 'cl-defun 'doc-string-elt 3)
|
||||
(put 'cl-defmacro 'doc-string-elt 3)
|
||||
(put 'cl-defsubst 'doc-string-elt 3)
|
||||
(put 'cl-defstruct 'doc-string-elt 2))
|
||||
|
||||
(load "cl-loaddefs" nil 'quiet)
|
||||
|
||||
(provide 'cl-lib)
|
||||
|
||||
(run-hooks 'cl-load-hook)
|
||||
|
||||
;; Local variables:
|
||||
;; byte-compile-dynamic: t
|
||||
;; byte-compile-warnings: (not cl-functions)
|
||||
;; End:
|
||||
|
||||
;;; cl-lib.el ends here
|
||||
File diff suppressed because it is too large
Load diff
File diff suppressed because it is too large
Load diff
File diff suppressed because it is too large
Load diff
File diff suppressed because it is too large
Load diff
|
|
@ -1,683 +0,0 @@
|
|||
;;; cust-print.el --- handles print-level and print-circle
|
||||
|
||||
;; Copyright (C) 1992, 2001-2012 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Daniel LaLiberte <liberte@holonexus.org>
|
||||
;; Adapted-By: ESR
|
||||
;; Keywords: extensions
|
||||
|
||||
;; LCD Archive Entry:
|
||||
;; cust-print|Daniel LaLiberte|liberte@holonexus.org
|
||||
;; |Handle print-level, print-circle and more.
|
||||
|
||||
;; 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 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This package provides a general print handler for prin1 and princ
|
||||
;; that supports print-level and print-circle, and by the way,
|
||||
;; print-length since the standard routines are being replaced. Also,
|
||||
;; to print custom types constructed from lists and vectors, use
|
||||
;; custom-print-list and custom-print-vector. See the documentation
|
||||
;; strings of these variables for more details.
|
||||
|
||||
;; If the results of your expressions contain circular references to
|
||||
;; other parts of the same structure, the standard Emacs print
|
||||
;; subroutines may fail to print with an untrappable error,
|
||||
;; "Apparently circular structure being printed". If you only use cdr
|
||||
;; circular lists (where cdrs of lists point back; what is the right
|
||||
;; term here?), you can limit the length of printing with
|
||||
;; print-length. But car circular lists and circular vectors generate
|
||||
;; the above mentioned error in Emacs version 18. Version
|
||||
;; 19 supports print-level, but it is often useful to get a better
|
||||
;; print representation of circular and shared structures; the print-circle
|
||||
;; option may be used to print more concise representations.
|
||||
|
||||
;; There are three main ways to use this package. First, you may
|
||||
;; replace prin1, princ, and some subroutines that use them by calling
|
||||
;; install-custom-print so that any use of these functions in
|
||||
;; Lisp code will be affected; you can later reset with
|
||||
;; uninstall-custom-print. Second, you may temporarily install
|
||||
;; these functions with the macro with-custom-print. Third, you
|
||||
;; could call the custom routines directly, thus only affecting the
|
||||
;; printing that requires them.
|
||||
|
||||
;; Note that subroutines which call print subroutines directly will
|
||||
;; not use the custom print functions. In particular, the evaluation
|
||||
;; functions like eval-region call the print subroutines directly.
|
||||
;; Therefore, if you evaluate (aref circ-list 0), where circ-list is a
|
||||
;; circular list rather than an array, aref calls error directly which
|
||||
;; will jump to the top level instead of printing the circular list.
|
||||
|
||||
;; Uninterned symbols are recognized when print-circle is non-nil,
|
||||
;; but they are not printed specially here. Use the cl-packages package
|
||||
;; to print according to print-gensym.
|
||||
|
||||
;; Obviously the right way to implement this custom-print facility is
|
||||
;; in C or with hooks into the standard printer. Please volunteer
|
||||
;; since I don't have the time or need. More CL-like printing
|
||||
;; capabilities could be added in the future.
|
||||
|
||||
;; Implementation design: we want to use the same list and vector
|
||||
;; processing algorithm for all versions of prin1 and princ, since how
|
||||
;; the processing is done depends on print-length, print-level, and
|
||||
;; print-circle. For circle printing, a preprocessing step is
|
||||
;; required before the final printing. Thanks to Jamie Zawinski
|
||||
;; for motivation and algorithms.
|
||||
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defgroup cust-print nil
|
||||
"Handles print-level and print-circle."
|
||||
:prefix "print-"
|
||||
:group 'lisp
|
||||
:group 'extensions)
|
||||
|
||||
;; If using cl-packages:
|
||||
|
||||
'(defpackage "cust-print"
|
||||
(:nicknames "CP" "custom-print")
|
||||
(:use "el")
|
||||
(:export
|
||||
print-level
|
||||
print-circle
|
||||
|
||||
custom-print-install
|
||||
custom-print-uninstall
|
||||
custom-print-installed-p
|
||||
with-custom-print
|
||||
|
||||
custom-prin1
|
||||
custom-princ
|
||||
custom-prin1-to-string
|
||||
custom-print
|
||||
custom-format
|
||||
custom-message
|
||||
custom-error
|
||||
|
||||
custom-printers
|
||||
add-custom-printer
|
||||
))
|
||||
|
||||
'(in-package cust-print)
|
||||
|
||||
;; Emacs 18 doesn't have defalias.
|
||||
;; Provide def for byte compiler.
|
||||
(eval-and-compile
|
||||
(or (fboundp 'defalias) (fset 'defalias 'fset)))
|
||||
|
||||
|
||||
;; Variables:
|
||||
;;=========================================================
|
||||
|
||||
;;(defvar print-length nil
|
||||
;; "*Controls how many elements of a list, at each level, are printed.
|
||||
;;This is defined by emacs.")
|
||||
|
||||
(defcustom print-level nil
|
||||
"Controls how many levels deep a nested data object will print.
|
||||
|
||||
If nil, printing proceeds recursively and may lead to
|
||||
max-lisp-eval-depth being exceeded or an error may occur:
|
||||
`Apparently circular structure being printed.'
|
||||
Also see `print-length' and `print-circle'.
|
||||
|
||||
If non-nil, components at levels equal to or greater than `print-level'
|
||||
are printed simply as `#'. The object to be printed is at level 0,
|
||||
and if the object is a list or vector, its top-level components are at
|
||||
level 1."
|
||||
:type '(choice (const nil) integer)
|
||||
:group 'cust-print)
|
||||
|
||||
|
||||
(defcustom print-circle nil
|
||||
"Controls the printing of recursive structures.
|
||||
|
||||
If nil, printing proceeds recursively and may lead to
|
||||
`max-lisp-eval-depth' being exceeded or an error may occur:
|
||||
\"Apparently circular structure being printed.\" Also see
|
||||
`print-length' and `print-level'.
|
||||
|
||||
If non-nil, shared substructures anywhere in the structure are printed
|
||||
with `#N=' before the first occurrence (in the order of the print
|
||||
representation) and `#N#' in place of each subsequent occurrence,
|
||||
where N is a positive decimal integer.
|
||||
|
||||
There is no way to read this representation in standard Emacs,
|
||||
but if you need to do so, try the cl-read.el package."
|
||||
:type 'boolean
|
||||
:group 'cust-print)
|
||||
|
||||
|
||||
(defcustom custom-print-vectors nil
|
||||
"Non-nil if printing of vectors should obey `print-level' and `print-length'."
|
||||
:type 'boolean
|
||||
:group 'cust-print)
|
||||
|
||||
|
||||
;; Custom printers
|
||||
;;==========================================================
|
||||
|
||||
(defvar custom-printers nil
|
||||
;; e.g. '((symbolp . pkg::print-symbol))
|
||||
"An alist for custom printing of any type.
|
||||
Pairs are of the form (PREDICATE . PRINTER). If PREDICATE is true
|
||||
for an object, then PRINTER is called with the object.
|
||||
PRINTER should print to `standard-output' using cust-print-original-princ
|
||||
if the standard printer is sufficient, or cust-print-prin for complex things.
|
||||
The PRINTER should return the object being printed.
|
||||
|
||||
Don't modify this variable directly. Use `add-custom-printer' and
|
||||
`delete-custom-printer'")
|
||||
;; Should cust-print-original-princ and cust-print-prin be exported symbols?
|
||||
;; Or should the standard printers functions be replaced by
|
||||
;; CP ones in Emacs Lisp so that CP internal functions need not be called?
|
||||
|
||||
(defun add-custom-printer (pred printer)
|
||||
"Add a pair of PREDICATE and PRINTER to `custom-printers'.
|
||||
Any pair that has the same PREDICATE is first removed."
|
||||
(setq custom-printers (cons (cons pred printer)
|
||||
(delq (assq pred custom-printers)
|
||||
custom-printers)))
|
||||
;; Rather than updating here, we could wait until cust-print-top-level is called.
|
||||
(cust-print-update-custom-printers))
|
||||
|
||||
(defun delete-custom-printer (pred)
|
||||
"Delete the custom printer associated with PREDICATE."
|
||||
(setq custom-printers (delq (assq pred custom-printers)
|
||||
custom-printers))
|
||||
(cust-print-update-custom-printers))
|
||||
|
||||
|
||||
(defun cust-print-use-custom-printer (object)
|
||||
;; Default function returns nil.
|
||||
nil)
|
||||
|
||||
(defun cust-print-update-custom-printers ()
|
||||
;; Modify the definition of cust-print-use-custom-printer
|
||||
(defalias 'cust-print-use-custom-printer
|
||||
;; We don't really want to require the byte-compiler.
|
||||
;; (byte-compile
|
||||
`(lambda (object)
|
||||
(cond
|
||||
,@(mapcar (function
|
||||
(lambda (pair)
|
||||
`((,(car pair) object)
|
||||
(,(cdr pair) object))))
|
||||
custom-printers)
|
||||
;; Otherwise return nil.
|
||||
(t nil)
|
||||
))
|
||||
;; )
|
||||
))
|
||||
|
||||
|
||||
;; Saving and restoring emacs printing routines.
|
||||
;;====================================================
|
||||
|
||||
(defun cust-print-set-function-cell (symbol-pair)
|
||||
(defalias (car symbol-pair)
|
||||
(symbol-function (car (cdr symbol-pair)))))
|
||||
|
||||
(defun cust-print-original-princ (object &optional stream)) ; dummy def
|
||||
|
||||
;; Save emacs routines.
|
||||
(if (not (fboundp 'cust-print-original-prin1))
|
||||
(mapc 'cust-print-set-function-cell
|
||||
'((cust-print-original-prin1 prin1)
|
||||
(cust-print-original-princ princ)
|
||||
(cust-print-original-print print)
|
||||
(cust-print-original-prin1-to-string prin1-to-string)
|
||||
(cust-print-original-format format)
|
||||
(cust-print-original-message message)
|
||||
(cust-print-original-error error))))
|
||||
|
||||
|
||||
(defun custom-print-install ()
|
||||
"Replace print functions with general, customizable, Lisp versions.
|
||||
The Emacs subroutines are saved away, and you can reinstall them
|
||||
by running `custom-print-uninstall'."
|
||||
(interactive)
|
||||
(mapc 'cust-print-set-function-cell
|
||||
'((prin1 custom-prin1)
|
||||
(princ custom-princ)
|
||||
(print custom-print)
|
||||
(prin1-to-string custom-prin1-to-string)
|
||||
(format custom-format)
|
||||
(message custom-message)
|
||||
(error custom-error)
|
||||
))
|
||||
t)
|
||||
|
||||
(defun custom-print-uninstall ()
|
||||
"Reset print functions to their Emacs subroutines."
|
||||
(interactive)
|
||||
(mapc 'cust-print-set-function-cell
|
||||
'((prin1 cust-print-original-prin1)
|
||||
(princ cust-print-original-princ)
|
||||
(print cust-print-original-print)
|
||||
(prin1-to-string cust-print-original-prin1-to-string)
|
||||
(format cust-print-original-format)
|
||||
(message cust-print-original-message)
|
||||
(error cust-print-original-error)
|
||||
))
|
||||
t)
|
||||
|
||||
(defalias 'custom-print-funcs-installed-p 'custom-print-installed-p)
|
||||
(defun custom-print-installed-p ()
|
||||
"Return t if custom-print is currently installed, nil otherwise."
|
||||
(eq (symbol-function 'custom-prin1) (symbol-function 'prin1)))
|
||||
|
||||
(put 'with-custom-print-funcs 'edebug-form-spec '(body))
|
||||
(put 'with-custom-print 'edebug-form-spec '(body))
|
||||
|
||||
(defalias 'with-custom-print-funcs 'with-custom-print)
|
||||
(defmacro with-custom-print (&rest body)
|
||||
"Temporarily install the custom print package while executing BODY."
|
||||
`(unwind-protect
|
||||
(progn
|
||||
(custom-print-install)
|
||||
,@body)
|
||||
(custom-print-uninstall)))
|
||||
|
||||
|
||||
;; Lisp replacements for prin1 and princ, and for some subrs that use them
|
||||
;;===============================================================
|
||||
;; - so far only the printing and formatting subrs.
|
||||
|
||||
(defun custom-prin1 (object &optional stream)
|
||||
"Output the printed representation of OBJECT, any Lisp object.
|
||||
Quoting characters are printed when needed to make output that `read'
|
||||
can handle, whenever this is possible.
|
||||
Output stream is STREAM, or value of `standard-output' (which see).
|
||||
|
||||
This is the custom-print replacement for the standard `prin1'. It
|
||||
uses the appropriate printer depending on the values of `print-level'
|
||||
and `print-circle' (which see)."
|
||||
(cust-print-top-level object stream 'cust-print-original-prin1))
|
||||
|
||||
|
||||
(defun custom-princ (object &optional stream)
|
||||
"Output the printed representation of OBJECT, any Lisp object.
|
||||
No quoting characters are used; no delimiters are printed around
|
||||
the contents of strings.
|
||||
Output stream is STREAM, or value of `standard-output' (which see).
|
||||
|
||||
This is the custom-print replacement for the standard `princ'."
|
||||
(cust-print-top-level object stream 'cust-print-original-princ))
|
||||
|
||||
|
||||
(defun custom-prin1-to-string (object &optional noescape)
|
||||
"Return a string containing the printed representation of OBJECT,
|
||||
any Lisp object. Quoting characters are used when needed to make output
|
||||
that `read' can handle, whenever this is possible, unless the optional
|
||||
second argument NOESCAPE is non-nil.
|
||||
|
||||
This is the custom-print replacement for the standard `prin1-to-string'."
|
||||
(let ((buf (get-buffer-create " *custom-print-temp*")))
|
||||
;; We must erase the buffer before printing in case an error
|
||||
;; occurred during the last prin1-to-string and we are in debugger.
|
||||
(with-current-buffer buf
|
||||
(erase-buffer))
|
||||
;; We must be in the current-buffer when the print occurs.
|
||||
(if noescape
|
||||
(custom-princ object buf)
|
||||
(custom-prin1 object buf))
|
||||
(with-current-buffer buf
|
||||
(buffer-string)
|
||||
;; We could erase the buffer again, but why bother?
|
||||
)))
|
||||
|
||||
|
||||
(defun custom-print (object &optional stream)
|
||||
"Output the printed representation of OBJECT, with newlines around it.
|
||||
Quoting characters are printed when needed to make output that `read'
|
||||
can handle, whenever this is possible.
|
||||
Output stream is STREAM, or value of `standard-output' (which see).
|
||||
|
||||
This is the custom-print replacement for the standard `print'."
|
||||
(cust-print-original-princ "\n" stream)
|
||||
(custom-prin1 object stream)
|
||||
(cust-print-original-princ "\n" stream))
|
||||
|
||||
|
||||
(defun custom-format (fmt &rest args)
|
||||
"Format a string out of a control-string and arguments.
|
||||
The first argument is a control string. It, and subsequent arguments
|
||||
substituted into it, become the value, which is a string.
|
||||
It may contain %s or %d or %c to substitute successive following arguments.
|
||||
%s means print an argument as a string, %d means print as number in decimal,
|
||||
%c means print a number as a single character.
|
||||
The argument used by %s must be a string or a symbol;
|
||||
the argument used by %d, %b, %o, %x or %c must be a number.
|
||||
|
||||
This is the custom-print replacement for the standard `format'. It
|
||||
calls the Emacs `format' after first making strings for list,
|
||||
vector, or symbol args. The format specification for such args should
|
||||
be `%s' in any case, so a string argument will also work. The string
|
||||
is generated with `custom-prin1-to-string', which quotes quotable
|
||||
characters."
|
||||
(apply 'cust-print-original-format fmt
|
||||
(mapcar (function (lambda (arg)
|
||||
(if (or (listp arg) (vectorp arg) (symbolp arg))
|
||||
(custom-prin1-to-string arg)
|
||||
arg)))
|
||||
args)))
|
||||
|
||||
|
||||
(defun custom-message (fmt &rest args)
|
||||
"Print a one-line message at the bottom of the screen.
|
||||
The first argument is a control string.
|
||||
It may contain %s or %d or %c to print successive following arguments.
|
||||
%s means print an argument as a string, %d means print as number in decimal,
|
||||
%c means print a number as a single character.
|
||||
The argument used by %s must be a string or a symbol;
|
||||
the argument used by %d or %c must be a number.
|
||||
|
||||
This is the custom-print replacement for the standard `message'.
|
||||
See `custom-format' for the details."
|
||||
;; It doesn't work to princ the result of custom-format as in:
|
||||
;; (cust-print-original-princ (apply 'custom-format fmt args))
|
||||
;; because the echo area requires special handling
|
||||
;; to avoid duplicating the output.
|
||||
;; cust-print-original-message does it right.
|
||||
(apply 'cust-print-original-message fmt
|
||||
(mapcar (function (lambda (arg)
|
||||
(if (or (listp arg) (vectorp arg) (symbolp arg))
|
||||
(custom-prin1-to-string arg)
|
||||
arg)))
|
||||
args)))
|
||||
|
||||
|
||||
(defun custom-error (fmt &rest args)
|
||||
"Signal an error, making error message by passing all args to `format'.
|
||||
|
||||
This is the custom-print replacement for the standard `error'.
|
||||
See `custom-format' for the details."
|
||||
(signal 'error (list (apply 'custom-format fmt args))))
|
||||
|
||||
|
||||
|
||||
;; Support for custom prin1 and princ
|
||||
;;=========================================
|
||||
|
||||
;; Defs to quiet byte-compiler.
|
||||
(defvar circle-table)
|
||||
(defvar cust-print-current-level)
|
||||
|
||||
(defun cust-print-original-printer (object)) ; One of the standard printers.
|
||||
(defun cust-print-low-level-prin (object)) ; Used internally.
|
||||
(defun cust-print-prin (object)) ; Call this to print recursively.
|
||||
|
||||
(defun cust-print-top-level (object stream emacs-printer)
|
||||
;; Set up for printing.
|
||||
(let ((standard-output (or stream standard-output))
|
||||
;; circle-table will be non-nil if anything is circular.
|
||||
(circle-table (and print-circle
|
||||
(cust-print-preprocess-circle-tree object)))
|
||||
(cust-print-current-level (or print-level -1)))
|
||||
|
||||
(defalias 'cust-print-original-printer emacs-printer)
|
||||
(defalias 'cust-print-low-level-prin
|
||||
(cond
|
||||
((or custom-printers
|
||||
circle-table
|
||||
print-level ; comment out for version 19
|
||||
;; Emacs doesn't use print-level or print-length
|
||||
;; for vectors, but custom-print can.
|
||||
(if custom-print-vectors
|
||||
(or print-level print-length)))
|
||||
'cust-print-print-object)
|
||||
(t 'cust-print-original-printer)))
|
||||
(defalias 'cust-print-prin
|
||||
(if circle-table 'cust-print-print-circular 'cust-print-low-level-prin))
|
||||
|
||||
(cust-print-prin object)
|
||||
object))
|
||||
|
||||
|
||||
(defun cust-print-print-object (object)
|
||||
;; Test object type and print accordingly.
|
||||
;; Could be called as either cust-print-low-level-prin or cust-print-prin.
|
||||
(cond
|
||||
((null object) (cust-print-original-printer object))
|
||||
((cust-print-use-custom-printer object) object)
|
||||
((consp object) (cust-print-list object))
|
||||
((vectorp object) (cust-print-vector object))
|
||||
;; All other types, just print.
|
||||
(t (cust-print-original-printer object))))
|
||||
|
||||
|
||||
(defun cust-print-print-circular (object)
|
||||
;; Printer for `prin1' and `princ' that handles circular structures.
|
||||
;; If OBJECT appears multiply, and has not yet been printed,
|
||||
;; prefix with label; if it has been printed, use `#N#' instead.
|
||||
;; Otherwise, print normally.
|
||||
(let ((tag (assq object circle-table)))
|
||||
(if tag
|
||||
(let ((id (cdr tag)))
|
||||
(if (> id 0)
|
||||
(progn
|
||||
;; Already printed, so just print id.
|
||||
(cust-print-original-princ "#")
|
||||
(cust-print-original-princ id)
|
||||
(cust-print-original-princ "#"))
|
||||
;; Not printed yet, so label with id and print object.
|
||||
(setcdr tag (- id)) ; mark it as printed
|
||||
(cust-print-original-princ "#")
|
||||
(cust-print-original-princ (- id))
|
||||
(cust-print-original-princ "=")
|
||||
(cust-print-low-level-prin object)
|
||||
))
|
||||
;; Not repeated in structure.
|
||||
(cust-print-low-level-prin object))))
|
||||
|
||||
|
||||
;;================================================
|
||||
;; List and vector processing for print functions.
|
||||
|
||||
(defun cust-print-list (list)
|
||||
;; Print a list using print-length, print-level, and print-circle.
|
||||
(if (= cust-print-current-level 0)
|
||||
(cust-print-original-princ "#")
|
||||
(let ((cust-print-current-level (1- cust-print-current-level)))
|
||||
(cust-print-original-princ "(")
|
||||
(let ((length (or print-length 0)))
|
||||
|
||||
;; Print the first element always (even if length = 0).
|
||||
(cust-print-prin (car list))
|
||||
(setq list (cdr list))
|
||||
(if list (cust-print-original-princ " "))
|
||||
(setq length (1- length))
|
||||
|
||||
;; Print the rest of the elements.
|
||||
(while (and list (/= 0 length))
|
||||
(if (and (listp list)
|
||||
(not (assq list circle-table)))
|
||||
(progn
|
||||
(cust-print-prin (car list))
|
||||
(setq list (cdr list)))
|
||||
|
||||
;; cdr is not a list, or it is in circle-table.
|
||||
(cust-print-original-princ ". ")
|
||||
(cust-print-prin list)
|
||||
(setq list nil))
|
||||
|
||||
(setq length (1- length))
|
||||
(if list (cust-print-original-princ " ")))
|
||||
|
||||
(if (and list (= length 0)) (cust-print-original-princ "..."))
|
||||
(cust-print-original-princ ")"))))
|
||||
list)
|
||||
|
||||
|
||||
(defun cust-print-vector (vector)
|
||||
;; Print a vector according to print-length, print-level, and print-circle.
|
||||
(if (= cust-print-current-level 0)
|
||||
(cust-print-original-princ "#")
|
||||
(let ((cust-print-current-level (1- cust-print-current-level))
|
||||
(i 0)
|
||||
(len (length vector)))
|
||||
(cust-print-original-princ "[")
|
||||
|
||||
(if print-length
|
||||
(setq len (min print-length len)))
|
||||
;; Print the elements
|
||||
(while (< i len)
|
||||
(cust-print-prin (aref vector i))
|
||||
(setq i (1+ i))
|
||||
(if (< i (length vector)) (cust-print-original-princ " ")))
|
||||
|
||||
(if (< i (length vector)) (cust-print-original-princ "..."))
|
||||
(cust-print-original-princ "]")
|
||||
))
|
||||
vector)
|
||||
|
||||
|
||||
|
||||
;; Circular structure preprocessing
|
||||
;;==================================
|
||||
|
||||
(defun cust-print-preprocess-circle-tree (object)
|
||||
;; Fill up the table.
|
||||
(let (;; Table of tags for each object in an object to be printed.
|
||||
;; A tag is of the form:
|
||||
;; ( <object> <nil-t-or-id-number> )
|
||||
;; The id-number is generated after the entire table has been computed.
|
||||
;; During walk through, the real circle-table lives in the cdr so we
|
||||
;; can use setcdr to add new elements instead of having to setq the
|
||||
;; variable sometimes (poor man's locf).
|
||||
(circle-table (list nil)))
|
||||
(cust-print-walk-circle-tree object)
|
||||
|
||||
;; Reverse table so it is in the order that the objects will be printed.
|
||||
;; This pass could be avoided if we always added to the end of the
|
||||
;; table with setcdr in walk-circle-tree.
|
||||
(setcdr circle-table (nreverse (cdr circle-table)))
|
||||
|
||||
;; Walk through the table, assigning id-numbers to those
|
||||
;; objects which will be printed using #N= syntax. Delete those
|
||||
;; objects which will be printed only once (to speed up assq later).
|
||||
(let ((rest circle-table)
|
||||
(id -1))
|
||||
(while (cdr rest)
|
||||
(let ((tag (car (cdr rest))))
|
||||
(cond ((cdr tag)
|
||||
(setcdr tag id)
|
||||
(setq id (1- id))
|
||||
(setq rest (cdr rest)))
|
||||
;; Else delete this object.
|
||||
(t (setcdr rest (cdr (cdr rest))))))
|
||||
))
|
||||
;; Drop the car.
|
||||
(cdr circle-table)
|
||||
))
|
||||
|
||||
|
||||
|
||||
(defun cust-print-walk-circle-tree (object)
|
||||
(let (read-equivalent-p tag)
|
||||
(while object
|
||||
(setq read-equivalent-p
|
||||
(or (numberp object)
|
||||
(and (symbolp object)
|
||||
;; Check if it is uninterned.
|
||||
(eq object (intern-soft (symbol-name object)))))
|
||||
tag (and (not read-equivalent-p)
|
||||
(assq object (cdr circle-table))))
|
||||
(cond (tag
|
||||
;; Seen this object already, so note that.
|
||||
(setcdr tag t))
|
||||
|
||||
((not read-equivalent-p)
|
||||
;; Add a tag for this object.
|
||||
(setcdr circle-table
|
||||
(cons (list object)
|
||||
(cdr circle-table)))))
|
||||
(setq object
|
||||
(cond
|
||||
(tag ;; No need to descend since we have already.
|
||||
nil)
|
||||
|
||||
((consp object)
|
||||
;; Walk the car of the list recursively.
|
||||
(cust-print-walk-circle-tree (car object))
|
||||
;; But walk the cdr with the above while loop
|
||||
;; to avoid problems with max-lisp-eval-depth.
|
||||
;; And it should be faster than recursion.
|
||||
(cdr object))
|
||||
|
||||
((vectorp object)
|
||||
;; Walk the vector.
|
||||
(let ((i (length object))
|
||||
(j 0))
|
||||
(while (< j i)
|
||||
(cust-print-walk-circle-tree (aref object j))
|
||||
(setq j (1+ j))))))))))
|
||||
|
||||
|
||||
;; Example.
|
||||
;;=======================================
|
||||
|
||||
'(progn
|
||||
(progn
|
||||
;; Create some circular structures.
|
||||
(setq circ-sym (let ((x (make-symbol "FOO"))) (list x x)))
|
||||
(setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))
|
||||
(setcar (nthcdr 3 circ-list) circ-list)
|
||||
(aset (nth 2 circ-list) 2 circ-list)
|
||||
(setq dotted-circ-list (list 'a 'b 'c))
|
||||
(setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list)
|
||||
(setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7))
|
||||
(aset circ-vector 5 (make-symbol "-gensym-"))
|
||||
(setcar (cdr (aref circ-vector 4)) (aref circ-vector 5))
|
||||
nil)
|
||||
|
||||
(install-custom-print)
|
||||
;; (setq print-circle t)
|
||||
|
||||
(let ((print-circle t))
|
||||
(or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)")
|
||||
(error "circular object with array printing")))
|
||||
|
||||
(let ((print-circle t))
|
||||
(or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)")
|
||||
(error "circular object with array printing")))
|
||||
|
||||
(let* ((print-circle t)
|
||||
(x (list 'p 'q))
|
||||
(y (list (list 'a 'b) x 'foo x)))
|
||||
(setcdr (cdr (cdr (cdr y))) (cdr y))
|
||||
(or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))"
|
||||
)
|
||||
(error "circular list example from CL manual")))
|
||||
|
||||
(let ((print-circle nil))
|
||||
;; cl-packages.el is required to print uninterned symbols like #:FOO.
|
||||
;; (require 'cl-packages)
|
||||
(or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)")
|
||||
(error "uninterned symbols in list")))
|
||||
(let ((print-circle t))
|
||||
(or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)")
|
||||
(error "circular uninterned symbols in list")))
|
||||
|
||||
(uninstall-custom-print)
|
||||
)
|
||||
|
||||
(provide 'cust-print)
|
||||
|
||||
;;; cust-print.el ends here
|
||||
|
|
@ -90,8 +90,6 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
;;; PRIVATE: defsubst must be defined before they are first used
|
||||
|
||||
(defsubst derived-mode-hook-name (mode)
|
||||
|
|
@ -183,11 +181,11 @@ See Info node `(elisp)Derived Modes' for more details."
|
|||
|
||||
;; Process the keyword args.
|
||||
(while (keywordp (car body))
|
||||
(case (pop body)
|
||||
(:group (setq group (pop body)))
|
||||
(:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil))
|
||||
(:syntax-table (setq syntax (pop body)) (setq declare-syntax nil))
|
||||
(t (pop body))))
|
||||
(pcase (pop body)
|
||||
(`:group (setq group (pop body)))
|
||||
(`:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil))
|
||||
(`:syntax-table (setq syntax (pop body)) (setq declare-syntax nil))
|
||||
(_ (pop body))))
|
||||
|
||||
(setq docstring (derived-mode-make-docstring
|
||||
parent child docstring syntax abbrev))
|
||||
|
|
|
|||
|
|
@ -35,6 +35,8 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(require 'macroexp)
|
||||
|
||||
;;; The variable byte-code-vector is defined by the new bytecomp.el.
|
||||
;;; The function byte-decompile-lapcode is defined in byte-opt.el.
|
||||
;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt.
|
||||
|
|
@ -155,7 +157,7 @@ redefine OBJECT if it is a symbol."
|
|||
(t
|
||||
(insert "Uncompiled body: ")
|
||||
(let ((print-escape-newlines t))
|
||||
(prin1 (if (cdr obj) (cons 'progn obj) (car obj))
|
||||
(prin1 (macroexp-progn obj)
|
||||
(current-buffer))))))
|
||||
(if interactive-p
|
||||
(message "")))
|
||||
|
|
|
|||
|
|
@ -51,8 +51,6 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
(defun easy-mmode-pretty-mode-name (mode &optional lighter)
|
||||
"Turn the symbol MODE into a string intended for the user.
|
||||
If provided, LIGHTER will be used to help choose capitalization by,
|
||||
|
|
@ -99,7 +97,7 @@ the mode if the argument is `toggle'. If DOC is nil this
|
|||
function adds a basic doc-string stating these facts.
|
||||
|
||||
Optional INIT-VALUE is the initial value of the mode's variable.
|
||||
Optional LIGHTER is displayed in the modeline when the mode is on.
|
||||
Optional LIGHTER is displayed in the mode line when the mode is on.
|
||||
Optional KEYMAP is the default keymap bound to the mode keymap.
|
||||
If non-nil, it should be a variable name (whose value is a keymap),
|
||||
or an expression that returns either a keymap or a list of
|
||||
|
|
@ -153,10 +151,10 @@ For example, you could write
|
|||
;; Allow skipping the first three args.
|
||||
(cond
|
||||
((keywordp init-value)
|
||||
(setq body (list* init-value lighter keymap body)
|
||||
(setq body `(,init-value ,lighter ,keymap ,@body)
|
||||
init-value nil lighter nil keymap nil))
|
||||
((keywordp lighter)
|
||||
(setq body (list* lighter keymap body) lighter nil keymap nil))
|
||||
(setq body `(,lighter ,keymap ,@body) lighter nil keymap nil))
|
||||
((keywordp keymap) (push keymap body) (setq keymap nil)))
|
||||
|
||||
(let* ((last-message (make-symbol "last-message"))
|
||||
|
|
@ -182,18 +180,18 @@ For example, you could write
|
|||
;; Check keys.
|
||||
(while (keywordp (setq keyw (car body)))
|
||||
(setq body (cdr body))
|
||||
(case keyw
|
||||
(:init-value (setq init-value (pop body)))
|
||||
(:lighter (setq lighter (purecopy (pop body))))
|
||||
(:global (setq globalp (pop body)))
|
||||
(:extra-args (setq extra-args (pop body)))
|
||||
(:set (setq set (list :set (pop body))))
|
||||
(:initialize (setq initialize (list :initialize (pop body))))
|
||||
(:group (setq group (nconc group (list :group (pop body)))))
|
||||
(:type (setq type (list :type (pop body))))
|
||||
(:require (setq require (pop body)))
|
||||
(:keymap (setq keymap (pop body)))
|
||||
(:variable (setq variable (pop body))
|
||||
(pcase keyw
|
||||
(`:init-value (setq init-value (pop body)))
|
||||
(`:lighter (setq lighter (purecopy (pop body))))
|
||||
(`:global (setq globalp (pop body)))
|
||||
(`:extra-args (setq extra-args (pop body)))
|
||||
(`:set (setq set (list :set (pop body))))
|
||||
(`:initialize (setq initialize (list :initialize (pop body))))
|
||||
(`:group (setq group (nconc group (list :group (pop body)))))
|
||||
(`:type (setq type (list :type (pop body))))
|
||||
(`:require (setq require (pop body)))
|
||||
(`:keymap (setq keymap (pop body)))
|
||||
(`:variable (setq variable (pop body))
|
||||
(if (not (and (setq tmp (cdr-safe variable))
|
||||
(or (symbolp tmp)
|
||||
(functionp tmp))))
|
||||
|
|
@ -201,8 +199,8 @@ For example, you could write
|
|||
(setq mode variable)
|
||||
(setq mode (car variable))
|
||||
(setq setter (cdr variable))))
|
||||
(:after-hook (setq after-hook (pop body)))
|
||||
(t (push keyw extra-keywords) (push (pop body) extra-keywords))))
|
||||
(`:after-hook (setq after-hook (pop body)))
|
||||
(_ (push keyw extra-keywords) (push (pop body) extra-keywords))))
|
||||
|
||||
(setq keymap-sym (if (and keymap (symbolp keymap)) keymap
|
||||
(intern (concat mode-name "-map"))))
|
||||
|
|
@ -355,10 +353,10 @@ call another major mode in their body."
|
|||
;; Check keys.
|
||||
(while (keywordp (setq keyw (car keys)))
|
||||
(setq keys (cdr keys))
|
||||
(case keyw
|
||||
(:group (setq group (nconc group (list :group (pop keys)))))
|
||||
(:global (setq keys (cdr keys)))
|
||||
(t (push keyw extra-keywords) (push (pop keys) extra-keywords))))
|
||||
(pcase keyw
|
||||
(`:group (setq group (nconc group (list :group (pop keys)))))
|
||||
(`:global (setq keys (cdr keys)))
|
||||
(_ (push keyw extra-keywords) (push (pop keys) extra-keywords))))
|
||||
|
||||
(unless group
|
||||
;; We might as well provide a best-guess default group.
|
||||
|
|
@ -479,13 +477,13 @@ Valid keywords and arguments are:
|
|||
(while args
|
||||
(let ((key (pop args))
|
||||
(val (pop args)))
|
||||
(case key
|
||||
(:name (setq name val))
|
||||
(:dense (setq dense val))
|
||||
(:inherit (setq inherit val))
|
||||
(:suppress (setq suppress val))
|
||||
(:group)
|
||||
(t (message "Unknown argument %s in defmap" key)))))
|
||||
(pcase key
|
||||
(`:name (setq name val))
|
||||
(`:dense (setq dense val))
|
||||
(`:inherit (setq inherit val))
|
||||
(`:suppress (setq suppress val))
|
||||
(`:group)
|
||||
(_ (message "Unknown argument %s in defmap" key)))))
|
||||
(unless (keymapp m)
|
||||
(setq bs (append m bs))
|
||||
(setq m (if dense (make-keymap name) (make-sparse-keymap name))))
|
||||
|
|
|
|||
|
|
@ -29,8 +29,6 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
(defvar easy-menu-precalculate-equivalent-keybindings nil
|
||||
"Determine when equivalent key bindings are computed for easy-menu menus.
|
||||
It can take some time to calculate the equivalent key bindings that are shown
|
||||
|
|
@ -236,14 +234,14 @@ possibly preceded by keyword pairs as described in `easy-menu-define'."
|
|||
(keywordp (setq keyword (car menu-items))))
|
||||
(setq arg (cadr menu-items))
|
||||
(setq menu-items (cddr menu-items))
|
||||
(case keyword
|
||||
(:filter
|
||||
(pcase keyword
|
||||
(`:filter
|
||||
(setq filter `(lambda (menu)
|
||||
(easy-menu-filter-return (,arg menu) ,menu-name))))
|
||||
((:enable :active) (setq enable (or arg ''nil)))
|
||||
(:label (setq label arg))
|
||||
(:help (setq help arg))
|
||||
((:included :visible) (setq visible (or arg ''nil)))))
|
||||
((or `:enable `:active) (setq enable (or arg ''nil)))
|
||||
(`:label (setq label arg))
|
||||
(`:help (setq help arg))
|
||||
((or `:included `:visible) (setq visible (or arg ''nil)))))
|
||||
(if (equal visible ''nil)
|
||||
nil ; Invisible menu entry, return nil.
|
||||
(if (and visible (not (easy-menu-always-true-p visible)))
|
||||
|
|
@ -334,16 +332,16 @@ ITEM defines an item as in `easy-menu-define'."
|
|||
(setq keyword (aref item count))
|
||||
(setq arg (aref item (1+ count)))
|
||||
(setq count (+ 2 count))
|
||||
(case keyword
|
||||
((:included :visible) (setq visible (or arg ''nil)))
|
||||
(:key-sequence (setq cache arg cache-specified t))
|
||||
(:keys (setq keys arg no-name nil))
|
||||
(:label (setq label arg))
|
||||
((:active :enable) (setq active (or arg ''nil)))
|
||||
(:help (setq prop (cons :help (cons arg prop))))
|
||||
(:suffix (setq suffix arg))
|
||||
(:style (setq style arg))
|
||||
(:selected (setq selected (or arg ''nil)))))
|
||||
(pcase keyword
|
||||
((or `:included `:visible) (setq visible (or arg ''nil)))
|
||||
(`:key-sequence (setq cache arg cache-specified t))
|
||||
(`:keys (setq keys arg no-name nil))
|
||||
(`:label (setq label arg))
|
||||
((or `:active `:enable) (setq active (or arg ''nil)))
|
||||
(`:help (setq prop (cons :help (cons arg prop))))
|
||||
(`:suffix (setq suffix arg))
|
||||
(`:style (setq style arg))
|
||||
(`:selected (setq selected (or arg ''nil)))))
|
||||
(if suffix
|
||||
(setq label
|
||||
(if (stringp suffix)
|
||||
|
|
|
|||
|
|
@ -51,6 +51,8 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(require 'macroexp)
|
||||
|
||||
;;; Bug reporting
|
||||
|
||||
(defalias 'edebug-submit-bug-report 'report-emacs-bug)
|
||||
|
|
@ -1251,10 +1253,7 @@ expressions; a `progn' form will be returned enclosing these forms."
|
|||
((eq 'edebug-after (car sexp))
|
||||
(nth 3 sexp))
|
||||
((eq 'edebug-enter (car sexp))
|
||||
(let ((forms (nthcdr 2 (nth 1 (nth 3 sexp)))))
|
||||
(if (> (length forms) 1)
|
||||
(cons 'progn forms) ;; could return (values forms) instead.
|
||||
(car forms))))
|
||||
(macroexp-progn (nthcdr 2 (nth 1 (nth 3 sexp)))))
|
||||
(t sexp);; otherwise it is not wrapped, so just return it.
|
||||
)
|
||||
sexp))
|
||||
|
|
@ -3056,7 +3055,6 @@ Otherwise, toggle for all windows."
|
|||
(edebug-toggle-save-selected-window)
|
||||
(edebug-toggle-save-all-windows)))
|
||||
|
||||
|
||||
(defun edebug-where ()
|
||||
"Show the debug windows and where we stopped in the program."
|
||||
(interactive)
|
||||
|
|
@ -3736,12 +3734,16 @@ This prints the value into current buffer."
|
|||
|
||||
;;; Edebug Minor Mode
|
||||
|
||||
;; FIXME eh?
|
||||
(defvar gud-inhibit-global-bindings
|
||||
"Non-nil means don't do global rebindings of C-x C-a subcommands.")
|
||||
(defvar edebug-inhibit-emacs-lisp-mode-bindings nil
|
||||
"If non-nil, inhibit Edebug bindings on the C-x C-a key.
|
||||
By default, loading the `edebug' library causes these bindings to
|
||||
be installed in `emacs-lisp-mode-map'.")
|
||||
|
||||
(define-obsolete-variable-alias 'gud-inhibit-global-bindings
|
||||
'edebug-inhibit-emacs-lisp-mode-bindings "24.2")
|
||||
|
||||
;; Global GUD bindings for all emacs-lisp-mode buffers.
|
||||
(unless gud-inhibit-global-bindings
|
||||
(unless edebug-inhibit-emacs-lisp-mode-bindings
|
||||
(define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode)
|
||||
(define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode)
|
||||
(define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode)
|
||||
|
|
|
|||
|
|
@ -2044,7 +2044,7 @@ During executions, the list is first generated, then as each next method
|
|||
is called, the next method is popped off the stack.")
|
||||
|
||||
(defvar eieio-pre-method-execution-hooks nil
|
||||
"Hooks run just before a method is executed.
|
||||
"Abnormal hook run just before an EIEIO method is executed.
|
||||
The hook function must accept one argument, the list of forms
|
||||
about to be executed.")
|
||||
|
||||
|
|
|
|||
|
|
@ -96,11 +96,11 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
;; The doubly linked list is implemented as a circular list with a dummy
|
||||
;; node first and last. The dummy node is used as "the dll".
|
||||
(defstruct (ewoc--node
|
||||
(cl-defstruct (ewoc--node
|
||||
(:type vector) ;ewoc--node-nth needs this
|
||||
(:constructor nil)
|
||||
(:constructor ewoc--node-create (start-marker data)))
|
||||
|
|
@ -140,7 +140,7 @@ and (ewoc--node-nth dll -1) returns the last node."
|
|||
|
||||
;;; The ewoc data type
|
||||
|
||||
(defstruct (ewoc
|
||||
(cl-defstruct (ewoc
|
||||
(:constructor nil)
|
||||
(:constructor ewoc--create (buffer pretty-printer dll))
|
||||
(:conc-name ewoc--))
|
||||
|
|
@ -196,10 +196,10 @@ NODE and leaving the new node's start there. Return the new node."
|
|||
(save-excursion
|
||||
(let ((elemnode (ewoc--node-create
|
||||
(copy-marker (ewoc--node-start-marker node)) data)))
|
||||
(setf (ewoc--node-left elemnode) (ewoc--node-left node)
|
||||
(ewoc--node-right elemnode) node
|
||||
(ewoc--node-right (ewoc--node-left node)) elemnode
|
||||
(ewoc--node-left node) elemnode)
|
||||
(cl-setf (ewoc--node-left elemnode) (ewoc--node-left node)
|
||||
(ewoc--node-right elemnode) node
|
||||
(ewoc--node-right (ewoc--node-left node)) elemnode
|
||||
(ewoc--node-left node) elemnode)
|
||||
(ewoc--refresh-node pretty-printer elemnode dll)
|
||||
elemnode)))
|
||||
|
||||
|
|
@ -244,8 +244,8 @@ Normally, a newline is automatically inserted after the header,
|
|||
the footer and every node's printed representation. Optional
|
||||
fourth arg NOSEP non-nil inhibits this."
|
||||
(let* ((dummy-node (ewoc--node-create 'DL-LIST 'DL-LIST))
|
||||
(dll (progn (setf (ewoc--node-right dummy-node) dummy-node)
|
||||
(setf (ewoc--node-left dummy-node) dummy-node)
|
||||
(dll (progn (cl-setf (ewoc--node-right dummy-node) dummy-node)
|
||||
(cl-setf (ewoc--node-left dummy-node) dummy-node)
|
||||
dummy-node))
|
||||
(wrap (if nosep 'identity 'ewoc--wrap))
|
||||
(new-ewoc (ewoc--create (current-buffer)
|
||||
|
|
@ -258,12 +258,12 @@ fourth arg NOSEP non-nil inhibits this."
|
|||
;; Set default values
|
||||
(unless header (setq header ""))
|
||||
(unless footer (setq footer ""))
|
||||
(setf (ewoc--node-start-marker dll) (copy-marker pos)
|
||||
foot (ewoc--insert-new-node dll footer hf-pp dll)
|
||||
head (ewoc--insert-new-node foot header hf-pp dll)
|
||||
(ewoc--hf-pp new-ewoc) hf-pp
|
||||
(ewoc--footer new-ewoc) foot
|
||||
(ewoc--header new-ewoc) head))
|
||||
(cl-setf (ewoc--node-start-marker dll) (copy-marker pos)
|
||||
foot (ewoc--insert-new-node dll footer hf-pp dll)
|
||||
head (ewoc--insert-new-node foot header hf-pp dll)
|
||||
(ewoc--hf-pp new-ewoc) hf-pp
|
||||
(ewoc--footer new-ewoc) foot
|
||||
(ewoc--header new-ewoc) head))
|
||||
;; Return the ewoc
|
||||
new-ewoc))
|
||||
|
||||
|
|
@ -274,7 +274,7 @@ fourth arg NOSEP non-nil inhibits this."
|
|||
|
||||
(defun ewoc-set-data (node data)
|
||||
"Set NODE to encapsulate DATA."
|
||||
(setf (ewoc--node-data node) data))
|
||||
(cl-setf (ewoc--node-data node) data))
|
||||
|
||||
(defun ewoc-enter-first (ewoc data)
|
||||
"Enter DATA first in EWOC.
|
||||
|
|
@ -356,18 +356,18 @@ arguments will be passed to MAP-FUNCTION."
|
|||
;; If we are about to delete the node pointed at by last-node,
|
||||
;; set last-node to nil.
|
||||
(when (eq last node)
|
||||
(setf last nil (ewoc--last-node ewoc) nil))
|
||||
(cl-setf last nil (ewoc--last-node ewoc) nil))
|
||||
(delete-region (ewoc--node-start-marker node)
|
||||
(ewoc--node-start-marker (ewoc--node-next dll node)))
|
||||
(set-marker (ewoc--node-start-marker node) nil)
|
||||
(setf L (ewoc--node-left node)
|
||||
R (ewoc--node-right node)
|
||||
;; Link neighbors to each other.
|
||||
(ewoc--node-right L) R
|
||||
(ewoc--node-left R) L
|
||||
;; Forget neighbors.
|
||||
(ewoc--node-left node) nil
|
||||
(ewoc--node-right node) nil))))
|
||||
(cl-setf L (ewoc--node-left node)
|
||||
R (ewoc--node-right node)
|
||||
;; Link neighbors to each other.
|
||||
(ewoc--node-right L) R
|
||||
(ewoc--node-left R) L
|
||||
;; Forget neighbors.
|
||||
(ewoc--node-left node) nil
|
||||
(ewoc--node-right node) nil))))
|
||||
|
||||
(defun ewoc-filter (ewoc predicate &rest args)
|
||||
"Remove all elements in EWOC for which PREDICATE returns nil.
|
||||
|
|
@ -503,7 +503,7 @@ Return the node (or nil if we just passed the last node)."
|
|||
(ewoc--set-buffer-bind-dll ewoc
|
||||
(goto-char (ewoc--node-start-marker node))
|
||||
(if goal-column (move-to-column goal-column))
|
||||
(setf (ewoc--last-node ewoc) node)))
|
||||
(cl-setf (ewoc--last-node ewoc) node)))
|
||||
|
||||
(defun ewoc-refresh (ewoc)
|
||||
"Refresh all data in EWOC.
|
||||
|
|
@ -564,8 +564,8 @@ Return nil if the buffer has been deleted."
|
|||
((head (ewoc--header ewoc))
|
||||
(foot (ewoc--footer ewoc))
|
||||
(hf-pp (ewoc--hf-pp ewoc)))
|
||||
(setf (ewoc--node-data head) header
|
||||
(ewoc--node-data foot) footer)
|
||||
(cl-setf (ewoc--node-data head) header
|
||||
(ewoc--node-data foot) footer)
|
||||
(save-excursion
|
||||
(ewoc--refresh-node hf-pp head dll)
|
||||
(ewoc--refresh-node hf-pp foot dll))))
|
||||
|
|
|
|||
|
|
@ -28,13 +28,9 @@
|
|||
;; Provide an easy hook to tell if we are running with floats or not.
|
||||
;; Define pi and e via math-lib calls (much less prone to killer typos).
|
||||
(defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")
|
||||
(progn
|
||||
;; Simulate a defconst that doesn't declare the variable dynamically bound.
|
||||
(setq-default pi float-pi)
|
||||
(put 'pi 'variable-documentation
|
||||
"Obsolete since Emacs-23.3. Use `float-pi' instead.")
|
||||
(put 'pi 'risky-local-variable t)
|
||||
(push 'pi current-load-list))
|
||||
(defconst pi float-pi
|
||||
"Obsolete since Emacs-23.3. Use `float-pi' instead.")
|
||||
(internal-make-var-non-special 'pi)
|
||||
|
||||
(defconst float-e (exp 1) "The value of e (2.7182818...).")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*-
|
||||
;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t; coding: utf-8 -*-
|
||||
;;
|
||||
;; Copyright (C) 2004-2012 Free Software Foundation, Inc.
|
||||
;;
|
||||
|
|
@ -29,13 +29,11 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
;; Bound by the top-level `macroexpand-all', and modified to include any
|
||||
;; macros defined by `defmacro'.
|
||||
(defvar macroexpand-all-environment nil)
|
||||
|
||||
(defun maybe-cons (car cdr original-cons)
|
||||
(defun macroexp--cons (car cdr original-cons)
|
||||
"Return (CAR . CDR), using ORIGINAL-CONS if possible."
|
||||
(if (and (eq car (car original-cons)) (eq cdr (cdr original-cons)))
|
||||
original-cons
|
||||
|
|
@ -43,9 +41,9 @@
|
|||
|
||||
;; We use this special macro to iteratively process forms and share list
|
||||
;; structure of the result with the input. Doing so recursively using
|
||||
;; `maybe-cons' results in excessively deep recursion for very long
|
||||
;; `macroexp--cons' results in excessively deep recursion for very long
|
||||
;; input forms.
|
||||
(defmacro macroexp-accumulate (var+list &rest body)
|
||||
(defmacro macroexp--accumulate (var+list &rest body)
|
||||
"Return a list of the results of evaluating BODY for each element of LIST.
|
||||
Evaluate BODY with VAR bound to each `car' from LIST, in turn.
|
||||
Return a list of the values of the final form in BODY.
|
||||
|
|
@ -76,27 +74,27 @@ result will be eq to LIST).
|
|||
(setq ,tail (cdr ,tail)))
|
||||
(nconc (nreverse ,unshared) ,shared))))
|
||||
|
||||
(defun macroexpand-all-forms (forms &optional skip)
|
||||
(defun macroexp--all-forms (forms &optional skip)
|
||||
"Return FORMS with macros expanded. FORMS is a list of forms.
|
||||
If SKIP is non-nil, then don't expand that many elements at the start of
|
||||
FORMS."
|
||||
(macroexp-accumulate (form forms)
|
||||
(macroexp--accumulate (form forms)
|
||||
(if (or (null skip) (zerop skip))
|
||||
(macroexpand-all-1 form)
|
||||
(macroexp--expand-all form)
|
||||
(setq skip (1- skip))
|
||||
form)))
|
||||
|
||||
(defun macroexpand-all-clauses (clauses &optional skip)
|
||||
(defun macroexp--all-clauses (clauses &optional skip)
|
||||
"Return CLAUSES with macros expanded.
|
||||
CLAUSES is a list of lists of forms; any clause that's not a list is ignored.
|
||||
If SKIP is non-nil, then don't expand that many elements at the start of
|
||||
each clause."
|
||||
(macroexp-accumulate (clause clauses)
|
||||
(macroexp--accumulate (clause clauses)
|
||||
(if (listp clause)
|
||||
(macroexpand-all-forms clause skip)
|
||||
(macroexp--all-forms clause skip)
|
||||
clause)))
|
||||
|
||||
(defun macroexpand-all-1 (form)
|
||||
(defun macroexp--expand-all (form)
|
||||
"Expand all macros in FORM.
|
||||
This is an internal version of `macroexpand-all'.
|
||||
Assumes the caller has bound `macroexpand-all-environment'."
|
||||
|
|
@ -105,7 +103,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
|
|||
;; generates exceedingly deep expansions from relatively shallow input
|
||||
;; forms. We just process it `in reverse' -- first we expand all the
|
||||
;; arguments, _then_ we expand the top-level definition.
|
||||
(macroexpand (macroexpand-all-forms form 1)
|
||||
(macroexpand (macroexp--all-forms form 1)
|
||||
macroexpand-all-environment)
|
||||
;; Normal form; get its expansion, and then expand arguments.
|
||||
(let ((new-form (macroexpand form macroexpand-all-environment)))
|
||||
|
|
@ -118,34 +116,34 @@ Assumes the caller has bound `macroexpand-all-environment'."
|
|||
(setq form new-form))
|
||||
(pcase form
|
||||
(`(cond . ,clauses)
|
||||
(maybe-cons 'cond (macroexpand-all-clauses clauses) form))
|
||||
(macroexp--cons 'cond (macroexp--all-clauses clauses) form))
|
||||
(`(condition-case . ,(or `(,err ,body . ,handlers) dontcare))
|
||||
(maybe-cons
|
||||
(macroexp--cons
|
||||
'condition-case
|
||||
(maybe-cons err
|
||||
(maybe-cons (macroexpand-all-1 body)
|
||||
(macroexpand-all-clauses handlers 1)
|
||||
(macroexp--cons err
|
||||
(macroexp--cons (macroexp--expand-all body)
|
||||
(macroexp--all-clauses handlers 1)
|
||||
(cddr form))
|
||||
(cdr form))
|
||||
form))
|
||||
(`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2))
|
||||
(`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2))
|
||||
(`(function ,(and f `(lambda . ,_)))
|
||||
(maybe-cons 'function
|
||||
(maybe-cons (macroexpand-all-forms f 2)
|
||||
(macroexp--cons 'function
|
||||
(macroexp--cons (macroexp--all-forms f 2)
|
||||
nil
|
||||
(cdr form))
|
||||
form))
|
||||
(`(,(or `function `quote) . ,_) form)
|
||||
(`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare))
|
||||
(maybe-cons fun
|
||||
(maybe-cons (macroexpand-all-clauses bindings 1)
|
||||
(macroexpand-all-forms body)
|
||||
(macroexp--cons fun
|
||||
(macroexp--cons (macroexp--all-clauses bindings 1)
|
||||
(macroexp--all-forms body)
|
||||
(cdr form))
|
||||
form))
|
||||
(`(,(and fun `(lambda . ,_)) . ,args)
|
||||
;; Embedded lambda in function position.
|
||||
(maybe-cons (macroexpand-all-forms fun 2)
|
||||
(macroexpand-all-forms args)
|
||||
(macroexp--cons (macroexp--all-forms fun 2)
|
||||
(macroexp--all-forms args)
|
||||
form))
|
||||
;; The following few cases are for normal function calls that
|
||||
;; are known to funcall one of their arguments. The byte
|
||||
|
|
@ -161,41 +159,64 @@ Assumes the caller has bound `macroexpand-all-environment'."
|
|||
(format "%s quoted with ' rather than with #'"
|
||||
(list 'lambda (nth 1 f) '...))
|
||||
t)
|
||||
;; We don't use `maybe-cons' since there's clearly a change.
|
||||
;; We don't use `macroexp--cons' since there's clearly a change.
|
||||
(cons fun
|
||||
(cons (macroexpand-all-1 (list 'function f))
|
||||
(macroexpand-all-forms args))))
|
||||
(cons (macroexp--expand-all (list 'function f))
|
||||
(macroexp--all-forms args))))
|
||||
;; Second arg is a function:
|
||||
(`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
|
||||
(byte-compile-log-warning
|
||||
(format "%s quoted with ' rather than with #'"
|
||||
(list 'lambda (nth 1 f) '...))
|
||||
t)
|
||||
;; We don't use `maybe-cons' since there's clearly a change.
|
||||
;; We don't use `macroexp--cons' since there's clearly a change.
|
||||
(cons fun
|
||||
(cons (macroexpand-all-1 arg1)
|
||||
(cons (macroexpand-all-1
|
||||
(cons (macroexp--expand-all arg1)
|
||||
(cons (macroexp--expand-all
|
||||
(list 'function f))
|
||||
(macroexpand-all-forms args)))))
|
||||
;; Macro expand compiler macros. This cannot be delayed to
|
||||
;; byte-optimize-form because the output of the compiler-macro can
|
||||
;; use macros.
|
||||
;; FIXME: Don't depend on CL.
|
||||
(`(,(pred (lambda (fun)
|
||||
(and (symbolp fun)
|
||||
(eq (get fun 'byte-compile)
|
||||
'cl-byte-compile-compiler-macro)
|
||||
(functionp 'compiler-macroexpand))))
|
||||
. ,_)
|
||||
(let ((newform (with-no-warnings (compiler-macroexpand form))))
|
||||
(if (eq form newform)
|
||||
(macroexpand-all-forms form 1)
|
||||
(macroexpand-all-1 newform))))
|
||||
(`(,_ . ,_)
|
||||
;; For every other list, we just expand each argument (for
|
||||
;; setq/setq-default this works alright because the variable names
|
||||
;; are symbols).
|
||||
(macroexpand-all-forms form 1))
|
||||
(macroexp--all-forms args)))))
|
||||
(`(,func . ,_)
|
||||
;; Macro expand compiler macros. This cannot be delayed to
|
||||
;; byte-optimize-form because the output of the compiler-macro can
|
||||
;; use macros.
|
||||
(let ((handler nil))
|
||||
(while (and (symbolp func)
|
||||
(not (setq handler (get func 'compiler-macro)))
|
||||
(fboundp func))
|
||||
;; Follow the sequence of aliases.
|
||||
(setq func (symbol-function func)))
|
||||
(if (null handler)
|
||||
;; No compiler macro. We just expand each argument (for
|
||||
;; setq/setq-default this works alright because the variable names
|
||||
;; are symbols).
|
||||
(macroexp--all-forms form 1)
|
||||
;; If the handler is not loaded yet, try (auto)loading the
|
||||
;; function itself, which may in turn load the handler.
|
||||
(when (and (not (functionp handler))
|
||||
(fboundp func) (eq (car-safe (symbol-function func))
|
||||
'autoload))
|
||||
(ignore-errors
|
||||
(load (nth 1 (symbol-function func))
|
||||
'noerror 'nomsg)))
|
||||
(let ((newform (condition-case err
|
||||
(apply handler form (cdr form))
|
||||
(error (message "Compiler-macro error: %S" err)
|
||||
form))))
|
||||
(if (eq form newform)
|
||||
;; The compiler macro did not find anything to do.
|
||||
(if (equal form (setq newform (macroexp--all-forms form 1)))
|
||||
form
|
||||
;; Maybe after processing the args, some new opportunities
|
||||
;; appeared, so let's try the compiler macro again.
|
||||
(setq form (condition-case err
|
||||
(apply handler newform (cdr newform))
|
||||
(error (message "Compiler-macro error: %S" err)
|
||||
newform)))
|
||||
(if (eq newform form)
|
||||
newform
|
||||
(macroexp--expand-all newform)))
|
||||
(macroexp--expand-all newform))))))
|
||||
|
||||
(t form))))
|
||||
|
||||
;;;###autoload
|
||||
|
|
@ -205,7 +226,89 @@ If no macros are expanded, FORM is returned unchanged.
|
|||
The second optional arg ENVIRONMENT specifies an environment of macro
|
||||
definitions to shadow the loaded ones for use in file byte-compilation."
|
||||
(let ((macroexpand-all-environment environment))
|
||||
(macroexpand-all-1 form)))
|
||||
(macroexp--expand-all form)))
|
||||
|
||||
;;; Handy functions to use in macros.
|
||||
|
||||
(defun macroexp-progn (exps)
|
||||
"Return an expression equivalent to `(progn ,@EXPS)."
|
||||
(if (cdr exps) `(progn ,@exps) (car exps)))
|
||||
|
||||
(defun macroexp-unprogn (exp)
|
||||
"Turn EXP into a list of expressions to execute in sequence."
|
||||
(if (eq (car-safe exp) 'progn) (cdr exp) (list exp)))
|
||||
|
||||
(defun macroexp-let* (bindings exp)
|
||||
"Return an expression equivalent to `(let* ,bindings ,exp)."
|
||||
(cond
|
||||
((null bindings) exp)
|
||||
((eq 'let* (car-safe exp)) `(let* (,@bindings ,@(cadr exp)) ,@(cddr exp)))
|
||||
(t `(let* ,bindings ,exp))))
|
||||
|
||||
(defun macroexp-if (test then else)
|
||||
"Return an expression equivalent to `(if ,test ,then ,else)."
|
||||
(cond
|
||||
((eq (car-safe else) 'if)
|
||||
(if (equal test (nth 1 else))
|
||||
;; Doing a test a second time: get rid of the redundancy.
|
||||
`(if ,test ,then ,@(nthcdr 3 else))
|
||||
`(cond (,test ,then)
|
||||
(,(nth 1 else) ,(nth 2 else))
|
||||
(t ,@(nthcdr 3 else)))))
|
||||
((eq (car-safe else) 'cond)
|
||||
`(cond (,test ,then)
|
||||
;; Doing a test a second time: get rid of the redundancy, as above.
|
||||
,@(remove (assoc test else) (cdr else))))
|
||||
;; Invert the test if that lets us reduce the depth of the tree.
|
||||
((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then))
|
||||
(t `(if ,test ,then ,else))))
|
||||
|
||||
(defmacro macroexp-let² (test var exp &rest exps)
|
||||
"Bind VAR to a copyable expression that returns the value of EXP.
|
||||
This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated
|
||||
symbol which EXPS can find in VAR.
|
||||
TEST should be the name of a predicate on EXP checking whether the `let' can
|
||||
be skipped; if nil, as is usual, `macroexp-const-p' is used."
|
||||
(declare (indent 3) (debug (sexp form sexp body)))
|
||||
(let ((bodysym (make-symbol "body"))
|
||||
(expsym (make-symbol "exp")))
|
||||
`(let* ((,expsym ,exp)
|
||||
(,var (if (,(or test #'macroexp-const-p) ,expsym)
|
||||
,expsym (make-symbol "x")))
|
||||
(,bodysym ,(macroexp-progn exps)))
|
||||
(if (eq ,var ,expsym) ,bodysym
|
||||
(macroexp-let* (list (list ,var ,expsym))
|
||||
,bodysym)))))
|
||||
|
||||
(defsubst macroexp--const-symbol-p (symbol &optional any-value)
|
||||
"Non-nil if SYMBOL is constant.
|
||||
If ANY-VALUE is nil, only return non-nil if the value of the symbol is the
|
||||
symbol itself."
|
||||
(or (memq symbol '(nil t))
|
||||
(keywordp symbol)
|
||||
(if any-value
|
||||
(or (memq symbol byte-compile-const-variables)
|
||||
;; FIXME: We should provide a less intrusive way to find out
|
||||
;; if a variable is "constant".
|
||||
(and (boundp symbol)
|
||||
(condition-case nil
|
||||
(progn (set symbol (symbol-value symbol)) nil)
|
||||
(setting-constant t)))))))
|
||||
|
||||
(defun macroexp-const-p (exp)
|
||||
"Return non-nil if EXP will always evaluate to the same value."
|
||||
(cond ((consp exp) (or (eq (car exp) 'quote)
|
||||
(and (eq (car exp) 'function)
|
||||
(symbolp (cadr exp)))))
|
||||
;; It would sometimes make sense to pass `any-value', but it's not
|
||||
;; always safe since a "constant" variable may not actually always have
|
||||
;; the same value.
|
||||
((symbolp exp) (macroexp--const-symbol-p exp))
|
||||
(t t)))
|
||||
|
||||
(defun macroexp-copyable-p (exp)
|
||||
"Return non-nil if EXP can be copied without extra cost."
|
||||
(or (symbolp exp) (macroexp-const-p exp)))
|
||||
|
||||
(provide 'macroexp)
|
||||
|
||||
|
|
|
|||
|
|
@ -1362,6 +1362,9 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages."
|
|||
map)
|
||||
"Local keymap for `package-menu-mode' buffers.")
|
||||
|
||||
(defvar package-menu--new-package-list nil
|
||||
"List of newly-available packages since `list-packages' was last called.")
|
||||
|
||||
(define-derived-mode package-menu-mode tabulated-list-mode "Package Menu"
|
||||
"Major mode for browsing a list of packages.
|
||||
Letters do not insert themselves; instead, they are commands.
|
||||
|
|
@ -1415,9 +1418,10 @@ or a list of package names (symbols) to display."
|
|||
(when (or (eq packages t) (memq name packages))
|
||||
(let ((hold (assq name package-load-list)))
|
||||
(package--push name (cdr elt)
|
||||
(if (and hold (null (cadr hold)))
|
||||
"disabled"
|
||||
"available")
|
||||
(cond
|
||||
((and hold (null (cadr hold))) "disabled")
|
||||
((memq name package-menu--new-package-list) "new")
|
||||
(t "available"))
|
||||
info-list))))
|
||||
|
||||
;; Obsolete packages:
|
||||
|
|
@ -1442,6 +1446,7 @@ identifier (NAME . VERSION-LIST)."
|
|||
(face (cond
|
||||
((string= status "built-in") 'font-lock-builtin-face)
|
||||
((string= status "available") 'default)
|
||||
((string= status "new") 'bold)
|
||||
((string= status "held") 'font-lock-constant-face)
|
||||
((string= status "disabled") 'font-lock-warning-face)
|
||||
((string= status "installed") 'font-lock-comment-face)
|
||||
|
|
@ -1487,7 +1492,7 @@ If optional arg BUTTON is non-nil, describe its associated package."
|
|||
(defun package-menu-mark-install (&optional _num)
|
||||
"Mark a package for installation and move to the next line."
|
||||
(interactive "p")
|
||||
(if (string-equal (package-menu-get-status) "available")
|
||||
(if (member (package-menu-get-status) '("available" "new"))
|
||||
(tabulated-list-put-tag "I" t)
|
||||
(forward-line)))
|
||||
|
||||
|
|
@ -1536,7 +1541,7 @@ If optional arg BUTTON is non-nil, describe its associated package."
|
|||
(status (aref (cadr entry) 2)))
|
||||
(cond ((equal status "installed")
|
||||
(push pkg installed))
|
||||
((equal status "available")
|
||||
((member status '("available" "new"))
|
||||
(push pkg available)))))
|
||||
;; Loop through list of installed packages, finding upgrades
|
||||
(dolist (pkg installed)
|
||||
|
|
@ -1642,16 +1647,18 @@ packages marked for deletion are removed."
|
|||
(sB (aref (cadr B) 2)))
|
||||
(cond ((string= sA sB)
|
||||
(package-menu--name-predicate A B))
|
||||
((string= sA "available") t)
|
||||
((string= sA "new") t)
|
||||
((string= sB "new") nil)
|
||||
((string= sA "available") t)
|
||||
((string= sB "available") nil)
|
||||
((string= sA "installed") t)
|
||||
((string= sA "installed") t)
|
||||
((string= sB "installed") nil)
|
||||
((string= sA "held") t)
|
||||
((string= sA "held") t)
|
||||
((string= sB "held") nil)
|
||||
((string= sA "built-in") t)
|
||||
((string= sA "built-in") t)
|
||||
((string= sB "built-in") nil)
|
||||
((string= sA "obsolete") t)
|
||||
((string= sB "obsolete") nil)
|
||||
((string= sA "obsolete") t)
|
||||
((string= sB "obsolete") nil)
|
||||
(t (string< sA sB)))))
|
||||
|
||||
(defun package-menu--description-predicate (A B)
|
||||
|
|
@ -1676,22 +1683,36 @@ The list is displayed in a buffer named `*Packages*'."
|
|||
;; Initialize the package system if necessary.
|
||||
(unless package--initialized
|
||||
(package-initialize t))
|
||||
(unless no-fetch
|
||||
(package-refresh-contents))
|
||||
(let ((buf (get-buffer-create "*Packages*")))
|
||||
(with-current-buffer buf
|
||||
(package-menu-mode)
|
||||
(package-menu--generate nil t))
|
||||
;; The package menu buffer has keybindings. If the user types
|
||||
;; `M-x list-packages', that suggests it should become current.
|
||||
(switch-to-buffer buf))
|
||||
(let ((upgrades (package-menu--find-upgrades)))
|
||||
(if upgrades
|
||||
(message "%d package%s can be upgraded; type `%s' to mark %s for upgrading."
|
||||
(length upgrades)
|
||||
(if (= (length upgrades) 1) "" "s")
|
||||
(substitute-command-keys "\\[package-menu-mark-upgrades]")
|
||||
(if (= (length upgrades) 1) "it" "them")))))
|
||||
(let (old-archives new-packages)
|
||||
(unless no-fetch
|
||||
;; Read the locally-cached archive-contents.
|
||||
(package-read-all-archive-contents)
|
||||
(setq old-archives package-archive-contents)
|
||||
;; Fetch the remote list of packages.
|
||||
(package-refresh-contents)
|
||||
;; Find which packages are new.
|
||||
(dolist (elt package-archive-contents)
|
||||
(unless (assq (car elt) old-archives)
|
||||
(push (car elt) new-packages))))
|
||||
|
||||
;; Generate the Package Menu.
|
||||
(let ((buf (get-buffer-create "*Packages*")))
|
||||
(with-current-buffer buf
|
||||
(package-menu-mode)
|
||||
(set (make-local-variable 'package-menu--new-package-list)
|
||||
new-packages)
|
||||
(package-menu--generate nil t))
|
||||
;; The package menu buffer has keybindings. If the user types
|
||||
;; `M-x list-packages', that suggests it should become current.
|
||||
(switch-to-buffer buf))
|
||||
|
||||
(let ((upgrades (package-menu--find-upgrades)))
|
||||
(if upgrades
|
||||
(message "%d package%s can be upgraded; type `%s' to mark %s for upgrading."
|
||||
(length upgrades)
|
||||
(if (= (length upgrades) 1) "" "s")
|
||||
(substitute-command-keys "\\[package-menu-mark-upgrades]")
|
||||
(if (= (length upgrades) 1) "it" "them"))))))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'package-list-packages 'list-packages)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*-
|
||||
;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*-
|
||||
|
||||
;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
|
||||
|
||||
|
|
@ -53,15 +53,40 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(require 'macroexp)
|
||||
|
||||
;; Macro-expansion of pcase is reasonably fast, so it's not a problem
|
||||
;; when byte-compiling a file, but when interpreting the code, if the pcase
|
||||
;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
|
||||
;; memoize previous macro expansions to try and avoid recomputing them
|
||||
;; over and over again.
|
||||
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
|
||||
;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
|
||||
;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
|
||||
|
||||
(defconst pcase--dontcare-upats '(t _ dontcare))
|
||||
|
||||
(def-edebug-spec
|
||||
pcase-UPAT
|
||||
(&or symbolp
|
||||
("or" &rest pcase-UPAT)
|
||||
("and" &rest pcase-UPAT)
|
||||
("`" pcase-QPAT)
|
||||
("guard" form)
|
||||
("let" pcase-UPAT form)
|
||||
("pred"
|
||||
&or lambda-expr
|
||||
;; Punt on macros/special forms.
|
||||
(functionp &rest form)
|
||||
sexp)
|
||||
sexp))
|
||||
|
||||
(def-edebug-spec
|
||||
pcase-QPAT
|
||||
(&or ("," pcase-UPAT)
|
||||
(pcase-QPAT . pcase-QPAT)
|
||||
sexp))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro pcase (exp &rest cases)
|
||||
"Perform ML-style pattern matching on EXP.
|
||||
|
|
@ -94,7 +119,7 @@ PRED patterns can refer to variables bound earlier in the pattern.
|
|||
E.g. you can match pairs where the cdr is larger than the car with a pattern
|
||||
like `(,a . ,(pred (< a))) or, with more checks:
|
||||
`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
|
||||
(declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars.
|
||||
(declare (indent 1) (debug (form &rest (pcase-UPAT body))))
|
||||
;; We want to use a weak hash table as a cache, but the key will unavoidably
|
||||
;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
|
||||
;; we're called so it'll be immediately GC'd. So we use (car cases) as key
|
||||
|
|
@ -105,31 +130,49 @@ like `(,a . ,(pred (< a))) or, with more checks:
|
|||
(if (and (equal exp (car data)) (equal cases (cadr data)))
|
||||
;; We have the right expansion.
|
||||
(cddr data)
|
||||
;; (when (gethash (car cases) pcase--memoize-1)
|
||||
;; (message "pcase-memoize failed because of weak key!!"))
|
||||
;; (when (gethash (car cases) pcase--memoize-2)
|
||||
;; (message "pcase-memoize failed because of eq test on %S"
|
||||
;; (car cases)))
|
||||
(when data
|
||||
(message "pcase-memoize: equal first branch, yet different"))
|
||||
(let ((expansion (pcase--expand exp cases)))
|
||||
(puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize)
|
||||
(puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
|
||||
;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
|
||||
;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
|
||||
expansion))))
|
||||
|
||||
(defun pcase--let* (bindings body)
|
||||
(cond
|
||||
((null bindings) (macroexp-progn body))
|
||||
((pcase--trivial-upat-p (caar bindings))
|
||||
(macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
|
||||
(t
|
||||
(let ((binding (pop bindings)))
|
||||
(pcase--expand
|
||||
(cadr binding)
|
||||
`((,(car binding) ,(pcase--let* bindings body))
|
||||
;; We can either signal an error here, or just use `dontcare' which
|
||||
;; generates more efficient code. In practice, if we use `dontcare'
|
||||
;; we will still often get an error and the few cases where we don't
|
||||
;; do not matter that much, so it's a better choice.
|
||||
(dontcare nil)))))))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro pcase-let* (bindings &rest body)
|
||||
"Like `let*' but where you can use `pcase' patterns for bindings.
|
||||
BODY should be an expression, and BINDINGS should be a list of bindings
|
||||
of the form (UPAT EXP)."
|
||||
(declare (indent 1)
|
||||
(debug ((&rest &or (sexp &optional form) symbolp) body)))
|
||||
(cond
|
||||
((null bindings) (if (> (length body) 1) `(progn ,@body) (car body)))
|
||||
((pcase--trivial-upat-p (caar bindings))
|
||||
`(let (,(car bindings)) (pcase-let* ,(cdr bindings) ,@body)))
|
||||
(t
|
||||
`(pcase ,(cadr (car bindings))
|
||||
(,(caar bindings) (pcase-let* ,(cdr bindings) ,@body))
|
||||
;; We can either signal an error here, or just use `dontcare' which
|
||||
;; generates more efficient code. In practice, if we use `dontcare' we
|
||||
;; will still often get an error and the few cases where we don't do not
|
||||
;; matter that much, so it's a better choice.
|
||||
(dontcare nil)))))
|
||||
(debug ((&rest (pcase-UPAT &optional form)) body)))
|
||||
(let ((cached (gethash bindings pcase--memoize)))
|
||||
;; cached = (BODY . EXPANSION)
|
||||
(if (equal (car cached) body)
|
||||
(cdr cached)
|
||||
(let ((expansion (pcase--let* bindings body)))
|
||||
(puthash bindings (cons body expansion) pcase--memoize)
|
||||
expansion))))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro pcase-let (bindings &rest body)
|
||||
|
|
@ -152,7 +195,7 @@ of the form (UPAT EXP)."
|
|||
`(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
|
||||
|
||||
(defmacro pcase-dolist (spec &rest body)
|
||||
(declare (indent 1))
|
||||
(declare (indent 1) (debug ((pcase-UPAT form) body)))
|
||||
(if (pcase--trivial-upat-p (car spec))
|
||||
`(dolist ,spec ,@body)
|
||||
(let ((tmpvar (make-symbol "x")))
|
||||
|
|
@ -167,68 +210,66 @@ of the form (UPAT EXP)."
|
|||
(defun pcase--expand (exp cases)
|
||||
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
|
||||
;; (emacs-pid) exp (sxhash cases))
|
||||
(let* ((defs (if (symbolp exp) '()
|
||||
(let ((sym (make-symbol "x")))
|
||||
(prog1 `((,sym ,exp)) (setq exp sym)))))
|
||||
(seen '())
|
||||
(codegen
|
||||
(lambda (code vars)
|
||||
(let ((prev (assq code seen)))
|
||||
(if (not prev)
|
||||
(let ((res (pcase-codegen code vars)))
|
||||
(push (list code vars res) seen)
|
||||
res)
|
||||
;; Since we use a tree-based pattern matching
|
||||
;; technique, the leaves (the places that contain the
|
||||
;; code to run once a pattern is matched) can get
|
||||
;; copied a very large number of times, so to avoid
|
||||
;; code explosion, we need to keep track of how many
|
||||
;; times we've used each leaf and move it
|
||||
;; to a separate function if that number is too high.
|
||||
;;
|
||||
;; We've already used this branch. So it is shared.
|
||||
(let* ((code (car prev)) (cdrprev (cdr prev))
|
||||
(prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
|
||||
(res (car cddrprev)))
|
||||
(unless (symbolp res)
|
||||
;; This is the first repeat, so we have to move
|
||||
;; the branch to a separate function.
|
||||
(let ((bsym
|
||||
(make-symbol (format "pcase-%d" (length defs)))))
|
||||
(push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
|
||||
(setcar res 'funcall)
|
||||
(setcdr res (cons bsym (mapcar #'cdr prevvars)))
|
||||
(setcar (cddr prev) bsym)
|
||||
(setq res bsym)))
|
||||
(setq vars (copy-sequence vars))
|
||||
(let ((args (mapcar (lambda (pa)
|
||||
(let ((v (assq (car pa) vars)))
|
||||
(setq vars (delq v vars))
|
||||
(cdr v)))
|
||||
prevvars)))
|
||||
;; If some of `vars' were not found in `prevvars', that's
|
||||
;; OK it just means those vars aren't present in all
|
||||
;; branches, so they can be used within the pattern
|
||||
;; (e.g. by a `guard/let/pred') but not in the branch.
|
||||
;; FIXME: But if some of `prevvars' are not in `vars' we
|
||||
;; should remove them from `prevvars'!
|
||||
`(funcall ,res ,@args)))))))
|
||||
(main
|
||||
(pcase--u
|
||||
(mapcar (lambda (case)
|
||||
`((match ,exp . ,(car case))
|
||||
,(apply-partially
|
||||
(if (pcase--small-branch-p (cdr case))
|
||||
;; Don't bother sharing multiple
|
||||
;; occurrences of this leaf since it's small.
|
||||
#'pcase-codegen codegen)
|
||||
(cdr case))))
|
||||
cases))))
|
||||
(if (null defs) main
|
||||
(pcase--let* defs main))))
|
||||
(macroexp-let² macroexp-copyable-p val exp
|
||||
(let* ((defs ())
|
||||
(seen '())
|
||||
(codegen
|
||||
(lambda (code vars)
|
||||
(let ((prev (assq code seen)))
|
||||
(if (not prev)
|
||||
(let ((res (pcase-codegen code vars)))
|
||||
(push (list code vars res) seen)
|
||||
res)
|
||||
;; Since we use a tree-based pattern matching
|
||||
;; technique, the leaves (the places that contain the
|
||||
;; code to run once a pattern is matched) can get
|
||||
;; copied a very large number of times, so to avoid
|
||||
;; code explosion, we need to keep track of how many
|
||||
;; times we've used each leaf and move it
|
||||
;; to a separate function if that number is too high.
|
||||
;;
|
||||
;; We've already used this branch. So it is shared.
|
||||
(let* ((code (car prev)) (cdrprev (cdr prev))
|
||||
(prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
|
||||
(res (car cddrprev)))
|
||||
(unless (symbolp res)
|
||||
;; This is the first repeat, so we have to move
|
||||
;; the branch to a separate function.
|
||||
(let ((bsym
|
||||
(make-symbol (format "pcase-%d" (length defs)))))
|
||||
(push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
|
||||
(setcar res 'funcall)
|
||||
(setcdr res (cons bsym (mapcar #'cdr prevvars)))
|
||||
(setcar (cddr prev) bsym)
|
||||
(setq res bsym)))
|
||||
(setq vars (copy-sequence vars))
|
||||
(let ((args (mapcar (lambda (pa)
|
||||
(let ((v (assq (car pa) vars)))
|
||||
(setq vars (delq v vars))
|
||||
(cdr v)))
|
||||
prevvars)))
|
||||
;; If some of `vars' were not found in `prevvars', that's
|
||||
;; OK it just means those vars aren't present in all
|
||||
;; branches, so they can be used within the pattern
|
||||
;; (e.g. by a `guard/let/pred') but not in the branch.
|
||||
;; FIXME: But if some of `prevvars' are not in `vars' we
|
||||
;; should remove them from `prevvars'!
|
||||
`(funcall ,res ,@args)))))))
|
||||
(main
|
||||
(pcase--u
|
||||
(mapcar (lambda (case)
|
||||
`((match ,val . ,(car case))
|
||||
,(apply-partially
|
||||
(if (pcase--small-branch-p (cdr case))
|
||||
;; Don't bother sharing multiple
|
||||
;; occurrences of this leaf since it's small.
|
||||
#'pcase-codegen codegen)
|
||||
(cdr case))))
|
||||
cases))))
|
||||
(macroexp-let* defs main))))
|
||||
|
||||
(defun pcase-codegen (code vars)
|
||||
;; Don't use let*, otherwise pcase--let* may merge it with some surrounding
|
||||
;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
|
||||
;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
|
||||
;; codegen from later metamorphosing this let into a funcall.
|
||||
`(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
|
||||
|
|
@ -248,30 +289,7 @@ of the form (UPAT EXP)."
|
|||
(cond
|
||||
((eq else :pcase--dontcare) then)
|
||||
((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
|
||||
((eq (car-safe else) 'if)
|
||||
(if (equal test (nth 1 else))
|
||||
;; Doing a test a second time: get rid of the redundancy.
|
||||
;; FIXME: ideally, this should never happen because the pcase--split-*
|
||||
;; funs should have eliminated such things, but pcase--split-member
|
||||
;; is imprecise, so in practice it can happen occasionally.
|
||||
`(if ,test ,then ,@(nthcdr 3 else))
|
||||
`(cond (,test ,then)
|
||||
(,(nth 1 else) ,(nth 2 else))
|
||||
(t ,@(nthcdr 3 else)))))
|
||||
((eq (car-safe else) 'cond)
|
||||
`(cond (,test ,then)
|
||||
;; Doing a test a second time: get rid of the redundancy, as above.
|
||||
,@(remove (assoc test else) (cdr else))))
|
||||
;; Invert the test if that lets us reduce the depth of the tree.
|
||||
((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then))
|
||||
(t `(if ,test ,then ,else))))
|
||||
|
||||
;; Again, try and reduce nesting.
|
||||
(defun pcase--let* (binders body)
|
||||
(if (eq (car-safe body) 'let*)
|
||||
`(let* ,(append binders (nth 1 body))
|
||||
,@(nthcdr 2 body))
|
||||
`(let* ,binders ,body)))
|
||||
(t (macroexp-if test then else))))
|
||||
|
||||
(defun pcase--upat (qpattern)
|
||||
(cond
|
||||
|
|
@ -589,21 +607,17 @@ Otherwise, it defers to REST which is a list of branches of the form
|
|||
;; A upat of the form (let VAR EXP).
|
||||
;; (pcase--u1 matches code
|
||||
;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
|
||||
(let* ((exp
|
||||
(let* ((exp (nth 2 upat))
|
||||
(found (assq exp vars)))
|
||||
(if found (cdr found)
|
||||
(let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
|
||||
(env (mapcar (lambda (v) (list v (cdr (assq v vars))))
|
||||
vs)))
|
||||
(if env `(let* ,env ,exp) exp)))))
|
||||
(sym (if (symbolp exp) exp (make-symbol "x")))
|
||||
(body
|
||||
(pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
|
||||
code vars rest)))
|
||||
(if (eq sym exp)
|
||||
body
|
||||
`(let* ((,sym ,exp)) ,body))))
|
||||
(macroexp-let²
|
||||
macroexp-copyable-p sym
|
||||
(let* ((exp (nth 2 upat))
|
||||
(found (assq exp vars)))
|
||||
(if found (cdr found)
|
||||
(let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
|
||||
(env (mapcar (lambda (v) (list v (cdr (assq v vars))))
|
||||
vs)))
|
||||
(if env (macroexp-let* env exp) exp))))
|
||||
(pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
|
||||
code vars rest)))
|
||||
((eq (car-safe upat) '\`)
|
||||
(put sym 'pcase-used t)
|
||||
(pcase--q1 sym (cadr upat) matches code vars rest))
|
||||
|
|
@ -695,7 +709,7 @@ Otherwise, it defers to REST which is a list of branches of the form
|
|||
;; can't signal errors and our byte-compiler is not that clever.
|
||||
;; FIXME: Some of those let bindings occur too early (they are used in
|
||||
;; `then-body', but only within some sub-branch).
|
||||
(pcase--let*
|
||||
(macroexp-let*
|
||||
`(,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
|
||||
,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
|
||||
then-body)
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@
|
|||
;; the target buffer are marked automatically with colored overlays
|
||||
;; (for non-color displays see below) giving you feedback over the
|
||||
;; extents of the matched (sub) expressions. The (non-)validity is
|
||||
;; shown only in the modeline without throwing the errors at you. If
|
||||
;; shown only in the mode line without throwing the errors at you. If
|
||||
;; you want to know the reason why RE Builder considers it as invalid
|
||||
;; call `reb-force-update' ("\C-c\C-u") which should reveal the error.
|
||||
|
||||
|
|
|
|||
|
|
@ -121,7 +121,7 @@
|
|||
;; - smie-indent-comment doesn't interact well with mis-indented lines (where
|
||||
;; the indent rules don't do what the user wants). Not sure what to do.
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
(defgroup smie nil
|
||||
"Simple Minded Indentation Engine."
|
||||
|
|
@ -155,7 +155,7 @@
|
|||
(defvar smie-warning-count 0)
|
||||
|
||||
(defun smie-set-prec2tab (table x y val &optional override)
|
||||
(assert (and x y))
|
||||
(cl-assert (and x y))
|
||||
(let* ((key (cons x y))
|
||||
(old (gethash key table)))
|
||||
(if (and old (not (eq old val)))
|
||||
|
|
@ -166,7 +166,7 @@
|
|||
;; don't hide real conflicts.
|
||||
(puthash key (gethash key override) table)
|
||||
(display-warning 'smie (format "Conflict: %s %s/%s %s" x old val y))
|
||||
(incf smie-warning-count))
|
||||
(cl-incf smie-warning-count))
|
||||
(puthash key val table))))
|
||||
|
||||
(put 'smie-precs->prec2 'pure t)
|
||||
|
|
@ -268,8 +268,8 @@ be either:
|
|||
(unless (consp rhs)
|
||||
(signal 'wrong-type-argument `(consp ,rhs)))
|
||||
(if (not (member (car rhs) nts))
|
||||
(pushnew (car rhs) first-ops)
|
||||
(pushnew (car rhs) first-nts)
|
||||
(cl-pushnew (car rhs) first-ops)
|
||||
(cl-pushnew (car rhs) first-nts)
|
||||
(when (consp (cdr rhs))
|
||||
;; If the first is not an OP we add the second (which
|
||||
;; should be an OP if BNF is an "operator grammar").
|
||||
|
|
@ -282,16 +282,16 @@ be either:
|
|||
(when (member (cadr rhs) nts)
|
||||
(error "Adjacent non-terminals: %s %s"
|
||||
(car rhs) (cadr rhs)))
|
||||
(pushnew (cadr rhs) first-ops)))
|
||||
(cl-pushnew (cadr rhs) first-ops)))
|
||||
(let ((shr (reverse rhs)))
|
||||
(if (not (member (car shr) nts))
|
||||
(pushnew (car shr) last-ops)
|
||||
(pushnew (car shr) last-nts)
|
||||
(cl-pushnew (car shr) last-ops)
|
||||
(cl-pushnew (car shr) last-nts)
|
||||
(when (consp (cdr shr))
|
||||
(when (member (cadr shr) nts)
|
||||
(error "Adjacent non-terminals: %s %s"
|
||||
(cadr shr) (car shr)))
|
||||
(pushnew (cadr shr) last-ops)))))
|
||||
(cl-pushnew (cadr shr) last-ops)))))
|
||||
(push (cons nt first-ops) first-ops-table)
|
||||
(push (cons nt last-ops) last-ops-table)
|
||||
(push (cons nt first-nts) first-nts-table)
|
||||
|
|
@ -307,7 +307,7 @@ be either:
|
|||
(dolist (op (cdr (assoc first-nt first-ops-table)))
|
||||
(unless (member op first-ops)
|
||||
(setq again t)
|
||||
(push op (cdr first-ops))))))))
|
||||
(cl-push op (cdr first-ops))))))))
|
||||
;; Same thing for last-ops.
|
||||
(setq again t)
|
||||
(while (prog1 again (setq again nil))
|
||||
|
|
@ -318,7 +318,7 @@ be either:
|
|||
(dolist (op (cdr (assoc last-nt last-ops-table)))
|
||||
(unless (member op last-ops)
|
||||
(setq again t)
|
||||
(push op (cdr last-ops))))))))
|
||||
(cl-push op (cdr last-ops))))))))
|
||||
;; Now generate the 2D precedence table.
|
||||
(dolist (rules bnf)
|
||||
(dolist (rhs (cdr rules))
|
||||
|
|
@ -416,12 +416,12 @@ from the table, e.g. the table will not include things like (\"if\" . \"else\").
|
|||
(if no-inners
|
||||
(let ((last (car (last rhs))))
|
||||
(unless (member last nts)
|
||||
(pushnew (cons (car rhs) last) alist :test #'equal)))
|
||||
(cl-pushnew (cons (car rhs) last) alist :test #'equal)))
|
||||
;; Reverse so that the "real" closer gets there first,
|
||||
;; which is important for smie-close-block.
|
||||
(dolist (term (reverse (cdr rhs)))
|
||||
(unless (member term nts)
|
||||
(pushnew (cons (car rhs) term) alist :test #'equal)))))))
|
||||
(cl-pushnew (cons (car rhs) term) alist :test #'equal)))))))
|
||||
(nreverse alist)))
|
||||
|
||||
(defun smie-bnf--set-class (table token class)
|
||||
|
|
@ -483,7 +483,7 @@ CSTS is a list of pairs representing arcs in a graph."
|
|||
(push (concat "." (car elem)) res))
|
||||
(if (eq (cddr elem) val)
|
||||
(push (concat (car elem) ".") res)))
|
||||
(assert res)
|
||||
(cl-assert res)
|
||||
res))
|
||||
cycle)))
|
||||
(mapconcat
|
||||
|
|
@ -498,9 +498,9 @@ CSTS is a list of pairs representing arcs in a graph."
|
|||
;; (right (nth 1 (assoc (cdr k) grammar))))
|
||||
;; (when (and left right)
|
||||
;; (cond
|
||||
;; ((< left right) (assert (eq v '<)))
|
||||
;; ((> left right) (assert (eq v '>)))
|
||||
;; (t (assert (eq v '=))))))))
|
||||
;; ((< left right) (cl-assert (eq v '<)))
|
||||
;; ((> left right) (cl-assert (eq v '>)))
|
||||
;; (t (cl-assert (eq v '=))))))))
|
||||
;; prec2))
|
||||
|
||||
(put 'smie-prec2->grammar 'pure t)
|
||||
|
|
@ -514,25 +514,28 @@ PREC2 is a table as returned by `smie-precs->prec2' or
|
|||
;; final `table'. The value of each "variable" is kept in the `car'.
|
||||
(let ((table ())
|
||||
(csts ())
|
||||
(eqs ())
|
||||
tmp x y)
|
||||
(eqs ()))
|
||||
;; From `prec2' we construct a list of constraints between
|
||||
;; variables (aka "precedence levels"). These can be either
|
||||
;; equality constraints (in `eqs') or `<' constraints (in `csts').
|
||||
(maphash (lambda (k v)
|
||||
(when (consp k)
|
||||
(if (setq tmp (assoc (car k) table))
|
||||
(setq x (cddr tmp))
|
||||
(setq x (cons nil nil))
|
||||
(push (cons (car k) (cons nil x)) table))
|
||||
(if (setq tmp (assoc (cdr k) table))
|
||||
(setq y (cdr tmp))
|
||||
(setq y (cons nil (cons nil nil)))
|
||||
(push (cons (cdr k) y) table))
|
||||
(ecase v
|
||||
(= (push (cons x y) eqs))
|
||||
(< (push (cons x y) csts))
|
||||
(> (push (cons y x) csts)))))
|
||||
(let ((tmp (assoc (car k) table))
|
||||
x y)
|
||||
(if tmp
|
||||
(setq x (cddr tmp))
|
||||
(setq x (cons nil nil))
|
||||
(push (cons (car k) (cons nil x)) table))
|
||||
(if (setq tmp (assoc (cdr k) table))
|
||||
(setq y (cdr tmp))
|
||||
(setq y (cons nil (cons nil nil)))
|
||||
(push (cons (cdr k) y) table))
|
||||
(pcase v
|
||||
(`= (push (cons x y) eqs))
|
||||
(`< (push (cons x y) csts))
|
||||
(`> (push (cons y x) csts))
|
||||
(_ (error "SMIE error: prec2 has %S↦%S which ∉ {<,+,>}"
|
||||
k v))))))
|
||||
prec2)
|
||||
;; First process the equality constraints.
|
||||
(let ((eqs eqs))
|
||||
|
|
@ -572,13 +575,13 @@ PREC2 is a table as returned by `smie-precs->prec2' or
|
|||
(unless (caar cst)
|
||||
(setcar (car cst) i)
|
||||
;; (smie-check-grammar table prec2 'step1)
|
||||
(incf i))
|
||||
(cl-incf i))
|
||||
(setq csts (delq cst csts))))
|
||||
(unless progress
|
||||
(error "Can't resolve the precedence cycle: %s"
|
||||
(smie-debug--describe-cycle
|
||||
table (smie-debug--prec2-cycle csts)))))
|
||||
(incf i 10))
|
||||
(cl-incf i 10))
|
||||
;; Propagate equality constraints back to their sources.
|
||||
(dolist (eq (nreverse eqs))
|
||||
(when (null (cadr eq))
|
||||
|
|
@ -589,8 +592,8 @@ PREC2 is a table as returned by `smie-precs->prec2' or
|
|||
;; So set it here rather than below since doing it below
|
||||
;; makes it more difficult to obey the equality constraints.
|
||||
(setcar (cdr eq) i)
|
||||
(incf i))
|
||||
(assert (or (null (caar eq)) (eq (caar eq) (cadr eq))))
|
||||
(cl-incf i))
|
||||
(cl-assert (or (null (caar eq)) (eq (caar eq) (cadr eq))))
|
||||
(setcar (car eq) (cadr eq))
|
||||
;; (smie-check-grammar table prec2 'step2)
|
||||
)
|
||||
|
|
@ -598,19 +601,19 @@ PREC2 is a table as returned by `smie-precs->prec2' or
|
|||
;; left side of any < constraint).
|
||||
(dolist (x table)
|
||||
(unless (nth 1 x)
|
||||
(setf (nth 1 x) i)
|
||||
(incf i)) ;See other (incf i) above.
|
||||
(cl-setf (nth 1 x) i)
|
||||
(cl-incf i)) ;See other (cl-incf i) above.
|
||||
(unless (nth 2 x)
|
||||
(setf (nth 2 x) i)
|
||||
(incf i)))) ;See other (incf i) above.
|
||||
(cl-setf (nth 2 x) i)
|
||||
(cl-incf i)))) ;See other (cl-incf i) above.
|
||||
;; Mark closers and openers.
|
||||
(dolist (x (gethash :smie-open/close-alist prec2))
|
||||
(let* ((token (car x))
|
||||
(cons (case (cdr x)
|
||||
(closer (cddr (assoc token table)))
|
||||
(opener (cdr (assoc token table))))))
|
||||
(assert (numberp (car cons)))
|
||||
(setf (car cons) (list (car cons)))))
|
||||
(cons (pcase (cdr x)
|
||||
(`closer (cddr (assoc token table)))
|
||||
(`opener (cdr (assoc token table))))))
|
||||
(cl-assert (numberp (car cons)))
|
||||
(cl-setf (car cons) (list (car cons)))))
|
||||
(let ((ca (gethash :smie-closer-alist prec2)))
|
||||
(when ca (push (cons :smie-closer-alist ca) table)))
|
||||
;; (smie-check-grammar table prec2 'step3)
|
||||
|
|
@ -706,19 +709,19 @@ Possible return values:
|
|||
(condition-case err
|
||||
(progn (goto-char pos) (funcall next-sexp 1) nil)
|
||||
(scan-error (throw 'return
|
||||
(list t (caddr err)
|
||||
(list t (cl-caddr err)
|
||||
(buffer-substring-no-properties
|
||||
(caddr err)
|
||||
(+ (caddr err)
|
||||
(if (< (point) (caddr err))
|
||||
(cl-caddr err)
|
||||
(+ (cl-caddr err)
|
||||
(if (< (point) (cl-caddr err))
|
||||
-1 1)))))))
|
||||
(if (eq pos (point))
|
||||
;; We did not move, so let's abort the loop.
|
||||
(throw 'return (list t (point))))))
|
||||
((not (numberp (funcall op-back toklevels)))
|
||||
;; A token like a paren-close.
|
||||
(assert (numberp ; Otherwise, why mention it in smie-grammar.
|
||||
(funcall op-forw toklevels)))
|
||||
(cl-assert (numberp ; Otherwise, why mention it in smie-grammar.
|
||||
(funcall op-forw toklevels)))
|
||||
(push toklevels levels))
|
||||
(t
|
||||
(while (and levels (< (funcall op-back toklevels)
|
||||
|
|
@ -1672,12 +1675,12 @@ KEYWORDS are additional arguments, which can use the following keywords:
|
|||
(while keywords
|
||||
(let ((k (pop keywords))
|
||||
(v (pop keywords)))
|
||||
(case k
|
||||
(:forward-token
|
||||
(pcase k
|
||||
(`:forward-token
|
||||
(set (make-local-variable 'smie-forward-token-function) v))
|
||||
(:backward-token
|
||||
(`:backward-token
|
||||
(set (make-local-variable 'smie-backward-token-function) v))
|
||||
(t (message "smie-setup: ignoring unknown keyword %s" k)))))
|
||||
(_ (message "smie-setup: ignoring unknown keyword %s" k)))))
|
||||
(let ((ca (cdr (assq :smie-closer-alist grammar))))
|
||||
(when ca
|
||||
(set (make-local-variable 'smie-closer-alist) ca)
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@
|
|||
|
||||
;; Note: PPSS stands for `parse-partial-sexp state'
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
(defvar font-lock-beginning-of-syntax-function)
|
||||
|
||||
|
|
@ -181,7 +181,7 @@ Note: back-references in REGEXPs do not work."
|
|||
;; If there's more than 1 rule, and the rule want to apply
|
||||
;; highlight to match 0, create an extra group to be able to
|
||||
;; tell when *this* match 0 has succeeded.
|
||||
(incf offset)
|
||||
(cl-incf offset)
|
||||
(setq re (concat "\\(" re "\\)")))
|
||||
(setq re (syntax-propertize--shift-groups re offset))
|
||||
(let ((code '())
|
||||
|
|
@ -215,7 +215,7 @@ Note: back-references in REGEXPs do not work."
|
|||
(setq offset 0)))
|
||||
;; Now construct the code for each subgroup rules.
|
||||
(dolist (case (cdr rule))
|
||||
(assert (null (cddr case)))
|
||||
(cl-assert (null (cddr case)))
|
||||
(let* ((gn (+ offset (car case)))
|
||||
(action (nth 1 case))
|
||||
(thiscode
|
||||
|
|
@ -260,7 +260,7 @@ Note: back-references in REGEXPs do not work."
|
|||
code))))
|
||||
(push (cons condition (nreverse code))
|
||||
branches))
|
||||
(incf offset (regexp-opt-depth orig-re))
|
||||
(cl-incf offset (regexp-opt-depth orig-re))
|
||||
re))
|
||||
rules
|
||||
"\\|")))
|
||||
|
|
@ -418,8 +418,8 @@ Point is at POS when this function returns."
|
|||
(* 2 (/ (cdr (aref syntax-ppss-stats 5))
|
||||
(1+ (car (aref syntax-ppss-stats 5)))))))
|
||||
(progn
|
||||
(incf (car (aref syntax-ppss-stats 0)))
|
||||
(incf (cdr (aref syntax-ppss-stats 0)) (- pos old-pos))
|
||||
(cl-incf (car (aref syntax-ppss-stats 0)))
|
||||
(cl-incf (cdr (aref syntax-ppss-stats 0)) (- pos old-pos))
|
||||
(parse-partial-sexp old-pos pos nil nil old-ppss))
|
||||
|
||||
(cond
|
||||
|
|
@ -435,8 +435,8 @@ Point is at POS when this function returns."
|
|||
(setq pt-min (or (syntax-ppss-toplevel-pos old-ppss)
|
||||
(nth 2 old-ppss)))
|
||||
(<= pt-min pos) (< (- pos pt-min) syntax-ppss-max-span))
|
||||
(incf (car (aref syntax-ppss-stats 1)))
|
||||
(incf (cdr (aref syntax-ppss-stats 1)) (- pos pt-min))
|
||||
(cl-incf (car (aref syntax-ppss-stats 1)))
|
||||
(cl-incf (cdr (aref syntax-ppss-stats 1)) (- pos pt-min))
|
||||
(setq ppss (parse-partial-sexp pt-min pos)))
|
||||
;; The OLD-* data can't be used. Consult the cache.
|
||||
(t
|
||||
|
|
@ -464,8 +464,8 @@ Point is at POS when this function returns."
|
|||
;; Use the best of OLD-POS and CACHE.
|
||||
(if (or (not old-pos) (< old-pos pt-min))
|
||||
(setq pt-best pt-min ppss-best ppss)
|
||||
(incf (car (aref syntax-ppss-stats 4)))
|
||||
(incf (cdr (aref syntax-ppss-stats 4)) (- pos old-pos))
|
||||
(cl-incf (car (aref syntax-ppss-stats 4)))
|
||||
(cl-incf (cdr (aref syntax-ppss-stats 4)) (- pos old-pos))
|
||||
(setq pt-best old-pos ppss-best old-ppss))
|
||||
|
||||
;; Use the `syntax-begin-function' if available.
|
||||
|
|
@ -490,21 +490,21 @@ Point is at POS when this function returns."
|
|||
(not (memq (get-text-property (point) 'face)
|
||||
'(font-lock-string-face font-lock-doc-face
|
||||
font-lock-comment-face))))
|
||||
(incf (car (aref syntax-ppss-stats 5)))
|
||||
(incf (cdr (aref syntax-ppss-stats 5)) (- pos (point)))
|
||||
(cl-incf (car (aref syntax-ppss-stats 5)))
|
||||
(cl-incf (cdr (aref syntax-ppss-stats 5)) (- pos (point)))
|
||||
(setq pt-best (point) ppss-best nil))
|
||||
|
||||
(cond
|
||||
;; Quick case when we found a nearby pos.
|
||||
((< (- pos pt-best) syntax-ppss-max-span)
|
||||
(incf (car (aref syntax-ppss-stats 2)))
|
||||
(incf (cdr (aref syntax-ppss-stats 2)) (- pos pt-best))
|
||||
(cl-incf (car (aref syntax-ppss-stats 2)))
|
||||
(cl-incf (cdr (aref syntax-ppss-stats 2)) (- pos pt-best))
|
||||
(setq ppss (parse-partial-sexp pt-best pos nil nil ppss-best)))
|
||||
;; Slow case: compute the state from some known position and
|
||||
;; populate the cache so we won't need to do it again soon.
|
||||
(t
|
||||
(incf (car (aref syntax-ppss-stats 3)))
|
||||
(incf (cdr (aref syntax-ppss-stats 3)) (- pos pt-min))
|
||||
(cl-incf (car (aref syntax-ppss-stats 3)))
|
||||
(cl-incf (cdr (aref syntax-ppss-stats 3)) (- pos pt-min))
|
||||
|
||||
;; If `pt-min' is too far, add a few intermediate entries.
|
||||
(while (> (- pos pt-min) (* 2 syntax-ppss-max-span))
|
||||
|
|
@ -513,7 +513,7 @@ Point is at POS when this function returns."
|
|||
nil nil ppss))
|
||||
(let ((pair (cons pt-min ppss)))
|
||||
(if cache-pred
|
||||
(push pair (cdr cache-pred))
|
||||
(cl-push pair (cdr cache-pred))
|
||||
(push pair syntax-ppss-cache))))
|
||||
|
||||
;; Compute the actual return value.
|
||||
|
|
@ -533,7 +533,7 @@ Point is at POS when this function returns."
|
|||
(let ((pair (cons pos ppss)))
|
||||
(if cache-pred
|
||||
(if (> (- (caar cache-pred) pos) syntax-ppss-max-span)
|
||||
(push pair (cdr cache-pred))
|
||||
(cl-push pair (cdr cache-pred))
|
||||
(setcar cache-pred pair))
|
||||
(if (or (null syntax-ppss-cache)
|
||||
(> (- (caar syntax-ppss-cache) pos)
|
||||
|
|
|
|||
|
|
@ -33,9 +33,9 @@
|
|||
;; triggered-p is nil if the timer is active (waiting to be triggered),
|
||||
;; t if it is inactive ("already triggered", in theory)
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
(defstruct (timer
|
||||
(cl-defstruct (timer
|
||||
(:constructor nil)
|
||||
(:copier nil)
|
||||
(:constructor timer-create ())
|
||||
|
|
@ -54,15 +54,15 @@
|
|||
(timer--low-seconds timer)
|
||||
(timer--usecs timer)))
|
||||
|
||||
(defsetf timer--time
|
||||
(cl-defsetf timer--time
|
||||
(lambda (timer time)
|
||||
(or (timerp timer) (error "Invalid timer"))
|
||||
(setf (timer--high-seconds timer) (pop time))
|
||||
(setf (timer--low-seconds timer)
|
||||
(if (consp time) (car time) time))
|
||||
(setf (timer--usecs timer) (or (and (consp time) (consp (cdr time))
|
||||
(cadr time))
|
||||
0))))
|
||||
(cl-setf (timer--high-seconds timer) (pop time))
|
||||
(cl-setf (timer--low-seconds timer)
|
||||
(if (consp time) (car time) time))
|
||||
(cl-setf (timer--usecs timer) (or (and (consp time) (consp (cdr time))
|
||||
(cadr time))
|
||||
0))))
|
||||
|
||||
|
||||
(defun timer-set-time (timer time &optional delta)
|
||||
|
|
@ -70,8 +70,8 @@
|
|||
TIME must be in the internal format returned by, e.g., `current-time'.
|
||||
If optional third argument DELTA is a positive number, make the timer
|
||||
fire repeatedly that many seconds apart."
|
||||
(setf (timer--time timer) time)
|
||||
(setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta))
|
||||
(cl-setf (timer--time timer) time)
|
||||
(cl-setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta))
|
||||
timer)
|
||||
|
||||
(defun timer-set-idle-time (timer secs &optional repeat)
|
||||
|
|
@ -81,10 +81,10 @@ time format (HIGH LOW USECS) returned by, e.g., `current-idle-time'.
|
|||
If optional third argument REPEAT is non-nil, make the timer
|
||||
fire each time Emacs is idle for that many seconds."
|
||||
(if (consp secs)
|
||||
(setf (timer--time timer) secs)
|
||||
(setf (timer--time timer) '(0 0 0))
|
||||
(cl-setf (timer--time timer) secs)
|
||||
(cl-setf (timer--time timer) '(0 0 0))
|
||||
(timer-inc-time timer secs))
|
||||
(setf (timer--repeat-delay timer) repeat)
|
||||
(cl-setf (timer--repeat-delay timer) repeat)
|
||||
timer)
|
||||
|
||||
(defun timer-next-integral-multiple-of-time (time secs)
|
||||
|
|
@ -124,8 +124,8 @@ SECS may be either an integer or a floating point number."
|
|||
(defun timer-inc-time (timer secs &optional usecs)
|
||||
"Increment the time set in TIMER by SECS seconds and USECS microseconds.
|
||||
SECS may be a fraction. If USECS is omitted, that means it is zero."
|
||||
(setf (timer--time timer)
|
||||
(timer-relative-time (timer--time timer) secs usecs)))
|
||||
(cl-setf (timer--time timer)
|
||||
(timer-relative-time (timer--time timer) secs usecs)))
|
||||
|
||||
(defun timer-set-time-with-usecs (timer time usecs &optional delta)
|
||||
"Set the trigger time of TIMER to TIME plus USECS.
|
||||
|
|
@ -133,9 +133,9 @@ TIME must be in the internal format returned by, e.g., `current-time'.
|
|||
The microsecond count from TIME is ignored, and USECS is used instead.
|
||||
If optional fourth argument DELTA is a positive number, make the timer
|
||||
fire repeatedly that many seconds apart."
|
||||
(setf (timer--time timer) time)
|
||||
(setf (timer--usecs timer) usecs)
|
||||
(setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta))
|
||||
(cl-setf (timer--time timer) time)
|
||||
(cl-setf (timer--usecs timer) usecs)
|
||||
(cl-setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta))
|
||||
timer)
|
||||
(make-obsolete 'timer-set-time-with-usecs
|
||||
"use `timer-set-time' and `timer-inc-time' instead."
|
||||
|
|
@ -145,8 +145,8 @@ fire repeatedly that many seconds apart."
|
|||
"Make TIMER call FUNCTION with optional ARGS when triggering."
|
||||
(or (timerp timer)
|
||||
(error "Invalid timer"))
|
||||
(setf (timer--function timer) function)
|
||||
(setf (timer--args timer) args)
|
||||
(cl-setf (timer--function timer) function)
|
||||
(cl-setf (timer--args timer) args)
|
||||
timer)
|
||||
|
||||
(defun timer--activate (timer &optional triggered-p reuse-cell idle)
|
||||
|
|
@ -170,8 +170,8 @@ fire repeatedly that many seconds apart."
|
|||
(cond (last (setcdr last reuse-cell))
|
||||
(idle (setq timer-idle-list reuse-cell))
|
||||
(t (setq timer-list reuse-cell)))
|
||||
(setf (timer--triggered timer) triggered-p)
|
||||
(setf (timer--idle-delay timer) idle)
|
||||
(cl-setf (timer--triggered timer) triggered-p)
|
||||
(cl-setf (timer--idle-delay timer) idle)
|
||||
nil)
|
||||
(error "Invalid or uninitialized timer")))
|
||||
|
||||
|
|
@ -294,7 +294,7 @@ This function is called, by name, directly by the C code."
|
|||
(apply (timer--function timer) (timer--args timer)))
|
||||
(error nil))
|
||||
(if retrigger
|
||||
(setf (timer--triggered timer) nil)))
|
||||
(cl-setf (timer--triggered timer) nil)))
|
||||
(error "Bogus timer event"))))
|
||||
|
||||
;; This function is incompatible with the one in levents.el.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue