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

Merge from trunk

Browse source
This commit is contained in:
Stefan Monnier 2010-09-30 01:28:20 +02:00
commit a01a793208
456 changed files with 24133 additions and 20038 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -383,9 +383,11 @@
form))
((or (byte-code-function-p fn)
(eq 'lambda (car-safe fn)))
(byte-optimize-form-code-walker
(byte-compile-unfold-lambda form)
for-effect))
(let ((newform (byte-compile-unfold-lambda form)))
(if (eq newform form)
;; Some error occured, avoid infinite recursion
form
(byte-optimize-form-code-walker newform for-effect))))
((memq fn '(let let*))
;; recursively enter the optimizer for the bindings and body
;; of a let or let*. This for depth-firstness: forms that

13
lisp/emacs-lisp/byte-run.el
View file

@ -108,10 +108,11 @@ The return value of this function is not used."
(defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key))
(defun set-advertised-calling-convention (function signature)
(defun set-advertised-calling-convention (function signature when)
"Set the advertised SIGNATURE of FUNCTION.
This will allow the byte-compiler to warn the programmer when she uses
an obsolete calling convention."
an obsolete calling convention. WHEN specifies since when the calling
convention was modified."
(puthash (indirect-function function) signature
advertised-signature-table))
@ -132,7 +133,7 @@ was first made obsolete, for example a date or a release number."
obsolete-name)
(set-advertised-calling-convention
;; New code should always provide the `when' argument.
'make-obsolete '(obsolete-name current-name when))
'make-obsolete '(obsolete-name current-name when) "23.1")
(defmacro define-obsolete-function-alias (obsolete-name current-name
&optional when docstring)
@ -153,7 +154,7 @@ See the docstrings of `defalias' and `make-obsolete' for more details."
(set-advertised-calling-convention
;; New code should always provide the `when' argument.
'define-obsolete-function-alias
'(obsolete-name current-name when &optional docstring))
'(obsolete-name current-name when &optional docstring) "23.1")
(defun make-obsolete-variable (obsolete-name current-name &optional when)
"Make the byte-compiler warn that OBSOLETE-NAME is obsolete.
@ -175,7 +176,7 @@ was first made obsolete, for example a date or a release number."
obsolete-name)
(set-advertised-calling-convention
;; New code should always provide the `when' argument.
'make-obsolete-variable '(obsolete-name current-name when))
'make-obsolete-variable '(obsolete-name current-name when) "23.1")
(defmacro define-obsolete-variable-alias (obsolete-name current-name
&optional when docstring)
@ -210,7 +211,7 @@ CURRENT-NAME, if it does not already have them:
(set-advertised-calling-convention
;; New code should always provide the `when' argument.
'define-obsolete-variable-alias
'(obsolete-name current-name when &optional docstring))
'(obsolete-name current-name when &optional docstring) "23.1")
;; FIXME This is only defined in this file because the variable- and
;; function- versions are too. Unlike those two, this one is not used

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

@ -308,7 +308,7 @@ If it is 'byte, then only byte-level optimizations will be logged."
(defconst byte-compile-warning-types
'(redefine callargs free-vars unresolved
obsolete noruntime cl-functions interactive-only
make-local mapcar constants suspicious)
make-local mapcar constants suspicious lexical)
"The list of warning types used when `byte-compile-warnings' is t.")
(defcustom byte-compile-warnings t
"List of warnings that the byte-compiler should issue (t for all).
@ -1461,7 +1461,7 @@ extra args."
(not (and (eq (get func 'byte-compile)
'cl-byte-compile-compiler-macro)
(string-match "\\`c[ad]+r\\'" (symbol-name func)))))
(byte-compile-warn "Function `%s' from cl package called at runtime"
(byte-compile-warn "function `%s' from cl package called at runtime"
func)))
form)
@ -2268,6 +2268,11 @@ list that represents a doc string reference.
;; Since there is no doc string, we can compile this as a normal form,
;; and not do a file-boundary.
(byte-compile-keep-pending form)
(when (and (symbolp (nth 1 form))
(not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
(byte-compile-warning-enabled-p 'lexical))
(byte-compile-warn "global/dynamic var `%s' lacks a prefix"
(nth 1 form)))
(push (nth 1 form) byte-compile-bound-variables)
(if (eq (car form) 'defconst)
(push (nth 1 form) byte-compile-const-variables))
@ -4162,6 +4167,11 @@ if LFORMINFO is nil (meaning all bindings are dynamic)."
(defun byte-compile-defvar (form)
;; This is not used for file-level defvar/consts with doc strings.
(when (and (symbolp (nth 1 form))
(not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
(byte-compile-warning-enabled-p 'lexical))
(byte-compile-warn "global/dynamic var `%s' lacks a prefix"
(nth 1 form)))
(let ((fun (nth 0 form))
(var (nth 1 form))
(value (nth 2 form))

299
lisp/emacs-lisp/eieio.el
View file

@ -5,7 +5,7 @@
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Version: 1.3
;; Keywords: OO, lisp
;; This file is part of GNU Emacs.
@ -31,6 +31,11 @@
;; Emacs running environment.
;;
;; See eieio.texi for complete documentation on using this package.
;;
;; Note: the implementation of the c3 algorithm is based on:
;; Kim Barrett et al.: A Monotonic Superclass Linearization for Dylan
;; Retrieved from:
;; http://192.220.96.201/dylan/linearization-oopsla96.html
;; There is funny stuff going on with typep and deftype. This
;; is the only way I seem to be able to make this stuff load properly.
@ -44,7 +49,7 @@
(require 'cl)
(require 'eieio-comp))
(defvar eieio-version "1.2"
(defvar eieio-version "1.3"
"Current version of EIEIO.")
(defun eieio-version ()
@ -79,7 +84,7 @@
"*This hook is executed, then cleared each time `defclass' is called.")
(defvar eieio-error-unsupported-class-tags nil
"*Non-nil to throw an error if an encountered tag us unsupported.
"Non-nil to throw an error if an encountered tag is unsupported.
This may prevent classes from CLOS applications from being used with EIEIO
since EIEIO does not support all CLOS tags.")
@ -170,6 +175,13 @@ Stored outright without modifications or stripping.")
(defconst method-generic-after 6 "Index into generic :after tag on a method.")
(defconst method-num-slots 7 "Number of indexes into a method's vector.")
(defsubst eieio-specialized-key-to-generic-key (key)
"Convert a specialized KEY into a generic method key."
(cond ((eq key method-static) 0) ;; don't convert
((< key method-num-lists) (+ key 3)) ;; The conversion
(t key) ;; already generic.. maybe.
))
;; How to specialty compile stuff.
(autoload 'byte-compile-file-form-defmethod "eieio-comp"
"This function is used to byte compile methods in a nice way.")
@ -243,8 +255,7 @@ Methods with only primary implementations are executed in an optimized way."
))
(defmacro class-option-assoc (list option)
"Return from LIST the found OPTION.
Return nil if it doesn't exist."
"Return from LIST the found OPTION, or nil if it doesn't exist."
`(car-safe (cdr (memq ,option ,list))))
(defmacro class-option (class option)
@ -518,7 +529,7 @@ See `defclass' for more information."
;; Make sure the method invocation order is a valid value.
(let ((io (class-option-assoc options :method-invocation-order)))
(when (and io (not (member io '(:depth-first :breadth-first))))
(when (and io (not (member io '(:depth-first :breadth-first :c3))))
(error "Method invocation order %s is not allowed" io)
))
@ -800,11 +811,11 @@ See `defclass' for more information."
(defun eieio-perform-slot-validation-for-default (slot spec value skipnil)
"For SLOT, signal if SPEC does not match VALUE.
If SKIPNIL is non-nil, then if VALUE is nil return t instead."
(let ((val (eieio-default-eval-maybe value)))
(if (and (not eieio-skip-typecheck)
(not (and skipnil (null val)))
(not (eieio-perform-slot-validation spec val)))
(signal 'invalid-slot-type (list slot spec val)))))
(if (and (not (eieio-eval-default-p value))
(not eieio-skip-typecheck)
(not (and skipnil (null value)))
(not (eieio-perform-slot-validation spec value)))
(signal 'invalid-slot-type (list slot spec value))))
(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc
&optional defaultoverride skipnil)
@ -1340,7 +1351,7 @@ Summary:
(if (= key -1)
(signal 'wrong-type-argument (list :static 'non-class-arg)))
;; generics are higher
(setq key (+ key 3)))
(setq key (eieio-specialized-key-to-generic-key key)))
;; Put this lambda into the symbol so we can find it
(if (byte-code-function-p (car-safe body))
(eieiomt-add method (car-safe body) key argclass)
@ -1516,13 +1527,21 @@ Fills in OBJ's SLOT with its default value."
(eieio-default-eval-maybe val))
obj cl 'oref-default))))
(defsubst eieio-eval-default-p (val)
"Whether the default value VAL should be evaluated for use."
(and (consp val) (symbolp (car val)) (fboundp (car val))))
(defun eieio-default-eval-maybe (val)
"Check VAL, and return what `oref-default' would provide."
;; check for quoted things, and unquote them
(if (and (listp val) (eq (car val) 'quote))
(car (cdr val))
;; return it verbatim
val))
(cond
;; Is it a function call? If so, evaluate it.
((eieio-eval-default-p val)
(eval val))
;;;; check for quoted things, and unquote them
;;((and (consp val) (eq (car val) 'quote))
;; (car (cdr val)))
;; return it verbatim
(t val)))
;;; Object Set macros
;;
@ -1677,6 +1696,116 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
(if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
(class-children-fast class))
(defun eieio-c3-candidate (class remaining-inputs)
"Returns CLASS if it can go in the result now, otherwise nil"
;; Ensure CLASS is not in any position but the first in any of the
;; element lists of REMAINING-INPUTS.
(and (not (let ((found nil))
(while (and remaining-inputs (not found))
(setq found (member class (cdr (car remaining-inputs)))
remaining-inputs (cdr remaining-inputs)))
found))
class))
(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs)
"Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible.
If a consistent order does not exist, signal an error."
(if (let ((tail remaining-inputs)
(found nil))
(while (and tail (not found))
(setq found (car tail) tail (cdr tail)))
(not found))
;; If all remaining inputs are empty lists, we are done.
(nreverse reversed-partial-result)
;; Otherwise, we try to find the next element of the result. This
;; is achieved by considering the first element of each
;; (non-empty) input list and accepting a candidate if it is
;; consistent with the rests of the input lists.
(let* ((found nil)
(tail remaining-inputs)
(next (progn
(while (and tail (not found))
(setq found (and (car tail)
(eieio-c3-candidate (caar tail)
remaining-inputs))
tail (cdr tail)))
found)))
(if next
;; The graph is consistent so far, add NEXT to result and
;; merge input lists, dropping NEXT from their heads where
;; applicable.
(eieio-c3-merge-lists
(cons next reversed-partial-result)
(mapcar (lambda (l) (if (eq (first l) next) (rest l) l))
remaining-inputs))
;; The graph is inconsistent, give up
(signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
(defun eieio-class-precedence-dfs (class)
"Return all parents of CLASS in depth-first order."
(let* ((parents (class-parents-fast class))
(classes (copy-sequence
(apply #'append
(list class)
(or
(mapcar
(lambda (parent)
(cons parent
(eieio-class-precedence-dfs parent)))
parents)
'((eieio-default-superclass))))))
(tail classes))
;; Remove duplicates.
(while tail
(setcdr tail (delq (car tail) (cdr tail)))
(setq tail (cdr tail)))
classes))
(defun eieio-class-precedence-bfs (class)
"Return all parents of CLASS in breadth-first order."
(let ((result)
(queue (or (class-parents-fast class)
'(eieio-default-superclass))))
(while queue
(let ((head (pop queue)))
(unless (member head result)
(push head result)
(unless (eq head 'eieio-default-superclass)
(setq queue (append queue (or (class-parents-fast head)
'(eieio-default-superclass))))))))
(cons class (nreverse result)))
)
(defun eieio-class-precedence-c3 (class)
"Return all parents of CLASS in c3 order."
(let ((parents (class-parents-fast class)))
(eieio-c3-merge-lists
(list class)
(append
(or
(mapcar
(lambda (x)
(eieio-class-precedence-c3 x))
parents)
'((eieio-default-superclass)))
(list parents))))
)
(defun class-precedence-list (class)
"Return (transitively closed) list of parents of CLASS.
The order, in which the parents are returned depends on the
method invocation orders of the involved classes."
(if (or (null class) (eq class 'eieio-default-superclass))
nil
(case (class-method-invocation-order class)
(:depth-first
(eieio-class-precedence-dfs class))
(:breadth-first
(eieio-class-precedence-bfs class))
(:c3
(eieio-class-precedence-c3 class))))
)
;; Official CLOS functions.
(defalias 'class-direct-superclasses 'class-parents)
(defalias 'class-direct-subclasses 'class-children)
@ -1714,7 +1843,8 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
p (cdr p)))
(if child t)))
(defun object-slots (obj) "Return list of slots available in OBJ."
(defun object-slots (obj)
"Return list of slots available in OBJ."
(if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj)))
(aref (class-v (object-class-fast obj)) class-public-a))
@ -2008,14 +2138,26 @@ This should only be called from a generic function."
keys (append (make-list (length tlambdas) method-before) keys))
)
;; If there were no methods found, then there could be :static methods.
(when (not lambdas)
(if mclass
;; For the case of a class,
;; if there were no methods found, then there could be :static methods.
(when (not lambdas)
(setq tlambdas
(eieio-generic-form method method-static mclass))
(setq lambdas (cons tlambdas lambdas)
keys (cons method-static keys)
primarymethodlist ;; Re-use even with bad name here
(eieiomt-method-list method method-static mclass)))
;; For the case of no class (ie - mclass == nil) then there may
;; be a primary method.
(setq tlambdas
(eieio-generic-form method method-static mclass))
(setq lambdas (cons tlambdas lambdas)
keys (cons method-static keys)
primarymethodlist ;; Re-use even with bad name here
(eieiomt-method-list method method-static mclass)))
(eieio-generic-form method method-primary nil))
(when tlambdas
(setq lambdas (cons tlambdas lambdas)
keys (cons method-primary keys)
primarymethodlist
(eieiomt-method-list method method-primary nil)))
)
(run-hook-with-args 'eieio-pre-method-execution-hooks
primarymethodlist)
@ -2142,37 +2284,23 @@ CLASS is the starting class to search from in the method tree.
If CLASS is nil, then an empty list of methods should be returned."
;; Note: eieiomt - the MT means MethodTree. See more comments below
;; for the rest of the eieiomt methods.
(let ((lambdas nil)
(mclass (list class)))
(while mclass
;; Note: a nil can show up in the class list once we start
;; searching through the method tree.
(when (car mclass)
;; lookup the form to use for the PRIMARY object for the next level
(let ((tmpl (eieio-generic-form method key (car mclass))))
(when (or (not lambdas)
;; This prevents duplicates coming out of the
;; class method optimizer. Perhaps we should
;; just not optimize before/afters?
(not (eq (car tmpl) (car (car lambdas)))))
(setq lambdas (cons tmpl lambdas))
(if (null (car lambdas))
(setq lambdas (cdr lambdas))))))
;; Add new classes to mclass. Since our input might not be a class
;; protect against that.
(if (car mclass)
;; If there is a class, append any methods it may provide
;; to the remainder of the class list.
(let ((io (class-method-invocation-order (car mclass))))
(if (eq io :depth-first)
;; Depth first.
(setq mclass (append (eieiomt-next (car mclass)) (cdr mclass)))
;; Breadth first.
(setq mclass (append (cdr mclass) (eieiomt-next (car mclass)))))
)
;; Advance to next entry in mclass if it is nil.
(setq mclass (cdr mclass)))
)
;; Collect lambda expressions stored for the class and its parent
;; classes.
(let (lambdas)
(dolist (ancestor (class-precedence-list class))
;; Lookup the form to use for the PRIMARY object for the next level
(let ((tmpl (eieio-generic-form method key ancestor)))
(when (and tmpl
(or (not lambdas)
;; This prevents duplicates coming out of the
;; class method optimizer. Perhaps we should
;; just not optimize before/afters?
(not (member tmpl lambdas))))
(push tmpl lambdas))))
;; Return collected lambda. For :after methods, return in current
;; order (most general class last); Otherwise, reverse order.
(if (eq key method-after)
lambdas
(nreverse lambdas))))
@ -2206,6 +2334,7 @@ Use `next-method-p' to find out if there is a next method to call."
(apply 'no-next-method (car newargs) (cdr newargs))
(let* ((eieio-generic-call-next-method-list
(cdr eieio-generic-call-next-method-list))
(eieio-generic-call-arglst newargs)
(scoped-class (cdr next))
(fcn (car next))
)
@ -2298,32 +2427,18 @@ nil for superclasses. This function performs no type checking!"
(defun eieiomt-sym-optimize (s)
"Find the next class above S which has a function body for the optimizer."
;; (message "Optimizing %S" s)
(let* ((es (intern-soft (symbol-name s))) ;external symbol of class
(io (class-method-invocation-order es))
(ov nil)
(cont t))
;; This converts ES from a single symbol to a list of parent classes.
(setq es (eieiomt-next es))
;; Loop over ES, then its children individually.
;; We can have multiple hits only at one level of the parent tree.
(while (and es cont)
(setq ov (intern-soft (symbol-name (car es)) eieiomt-optimizing-obarray))
(if (fboundp ov)
(progn
(set s ov) ;store ov as our next symbol
(setq cont nil))
(if (eq io :depth-first)
;; Pre-pend the subclasses of (car es) so we get
;; DEPTH FIRST optimization.
(setq es (append (eieiomt-next (car es)) (cdr es)))
;; Else, we are breadth first.
;; (message "Class %s is breadth first" es)
(setq es (append (cdr es) (eieiomt-next (car es))))
)))
;; If there is no nearest call, then set our value to nil
(if (not es) (set s nil))
))
;; Set the value to nil in case there is no nearest cell.
(set s nil)
;; Find the nearest cell that has a function body. If we find one,
;; we replace the nil from above.
(let ((external-symbol (intern-soft (symbol-name s))))
(catch 'done
(dolist (ancestor (rest (class-precedence-list external-symbol)))
(let ((ov (intern-soft (symbol-name ancestor)
eieiomt-optimizing-obarray)))
(when (fboundp ov)
(set s ov) ;; store ov as our next symbol
(throw 'done ancestor)))))))
(defun eieio-generic-form (method key class)
"Return the lambda form belonging to METHOD using KEY based upon CLASS.
@ -2332,7 +2447,7 @@ no form, but has a parent class, then trace to that parent class.
The first time a form is requested from a symbol, an optimized path
is memorized for faster future use."
(let ((emto (aref (get method 'eieio-method-obarray)
(if class key (+ key 3)))))
(if class key (eieio-specialized-key-to-generic-key key)))))
(if (class-p class)
;; 1) find our symbol
(let ((cs (intern-soft (symbol-name class) emto)))
@ -2365,7 +2480,7 @@ is memorized for faster future use."
nil)))
;; for a generic call, what is a list, is the function body we want.
(let ((emtl (aref (get method 'eieio-method-tree)
(if class key (+ key 3)))))
(if class key (eieio-specialized-key-to-generic-key key)))))
(if emtl
;; The car of EMTL is supposed to be a class, which in this
;; case is nil, so skip it.
@ -2430,6 +2545,11 @@ This is usually a symbol that starts with `:'."
(put 'unbound-slot 'error-conditions '(unbound-slot error nil))
(put 'unbound-slot 'error-message "Unbound slot")
(intern "inconsistent-class-hierarchy")
(put 'inconsistent-class-hierarchy 'error-conditions
'(inconsistent-class-hierarchy error nil))
(put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy")
;;; Here are some CLOS items that need the CL package
;;
@ -2525,6 +2645,17 @@ dynamically set from SLOTS."
(slot (aref scoped-class class-public-a))
(defaults (aref scoped-class class-public-d)))
(while slot
;; For each slot, see if we need to evaluate it.
;;
;; Paul Landes said in an email:
;; > CL evaluates it if it can, and otherwise, leaves it as
;; > the quoted thing as you already have. This is by the
;; > Sonya E. Keene book and other things I've look at on the
;; > web.
(let ((dflt (eieio-default-eval-maybe (car defaults))))
(when (not (eq dflt (car defaults)))
(eieio-oset this (car slot) dflt) ))
;; Next.
(setq slot (cdr slot)
defaults (cdr defaults))))
;; Shared initialize will parse our slots for us.

19
lisp/emacs-lisp/float-sup.el
View file

@ -35,25 +35,24 @@
;; 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 pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")
(defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")
(defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.")
;; It's too inconvenient to make `e' a constant because it's used as
;; a temporary variable all the time.
(defvar e (exp 1) "The value of e (2.7182818...).")
(defconst float-e (exp 1) "The value of e (2.7182818...).")
(defconst degrees-to-radians (/ pi 180.0)
(defconst degrees-to-radians (/ float-pi 180.0)
"Degrees to radian conversion constant.")
(defconst radians-to-degrees (/ 180.0 pi)
(defconst radians-to-degrees (/ 180.0 float-pi)
"Radian to degree conversion constant.")
;; these expand to a single multiply by a float when byte compiled
(defmacro degrees-to-radians (x)
"Convert ARG from degrees to radians."
(list '* (/ pi 180.0) x))
"Convert X from degrees to radians."
(list '* degrees-to-radians x))
(defmacro radians-to-degrees (x)
"Convert ARG from radians to degrees."
(list '* (/ 180.0 pi) x))
"Convert X from radians to degrees."
(list '* radians-to-degrees x))
(provide 'lisp-float-type)

12
lisp/emacs-lisp/lisp.el
View file

@ -141,15 +141,19 @@ A negative argument means move backward but still to a less deep spot.
This command assumes point is not in a string or comment."
(interactive "^p")
(or arg (setq arg 1))
(let ((inc (if (> arg 0) 1 -1)))
(let ((inc (if (> arg 0) 1 -1))
pos)
(while (/= arg 0)
(if forward-sexp-function
(if (null forward-sexp-function)
(goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))
(condition-case err
(while (let ((pos (point)))
(while (progn (setq pos (point))
(forward-sexp inc)
(/= (point) pos)))
(scan-error (goto-char (nth 2 err))))
(goto-char (or (scan-lists (point) inc 1) (buffer-end arg))))
(if (= (point) pos)
(signal 'scan-error
(list "Unbalanced parentheses" (point) (point)))))
(setq arg (- arg inc)))))
(defun kill-sexp (&optional arg)

2
lisp/emacs-lisp/package.el
View file

@ -1273,7 +1273,7 @@ Letters do not insert themselves; instead, they are commands.
(setq mode-name "Package Menu")
(setq truncate-lines t)
(setq buffer-read-only t)
(setq revert-buffer-function 'package-menu-revert)
(set (make-local-variable 'revert-buffer-function) 'package-menu-revert)
(setq header-line-format
(mapconcat
(lambda (pair)

13
lisp/emacs-lisp/pcase.el
View file

@ -76,8 +76,8 @@ BODY should be an expression, and BINDINGS should be a list of bindings
of the form (UPAT EXP)."
(if (null bindings) body
`(pcase ,(cadr (car bindings))
(,(caar bindings) (plet* ,(cdr bindings) ,body))
(t (error "Pattern match failure in `plet'")))))
(,(caar bindings) (pcase-let* ,(cdr bindings) ,body))
(t (error "Pattern match failure in `pcase-let'")))))
;;;###autoload
(defmacro pcase-let (bindings body)
@ -85,13 +85,14 @@ of the form (UPAT EXP)."
BODY should be an expression, and BINDINGS should be a list of bindings
of the form (UPAT EXP)."
(if (null (cdr bindings))
`(plet* ,bindings ,body)
`(pcase-let* ,bindings ,body)
(setq bindings (mapcar (lambda (x) (cons (make-symbol "x") x)) bindings))
`(let ,(mapcar (lambda (binding) (list (nth 0 binding) (nth 2 binding)))
bindings)
(plet* ,(mapcar (lambda (binding) (list (nth 1 binding) (nth 0 binding)))
bindings)
,body))))
(pcase-let*
,(mapcar (lambda (binding) (list (nth 1 binding) (nth 0 binding)))
bindings)
,body))))
(defun pcase-expand (exp cases)
(let* ((defs (if (symbolp exp) '()

202
lisp/emacs-lisp/smie.el
View file

@ -159,7 +159,8 @@ one of those elements share the same precedence level and associativity."
(last-nts ())
(first-nts ()))
(dolist (rhs (cdr rules))
(assert (consp rhs))
(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)
@ -307,6 +308,40 @@ from the table, e.g. the table will not include things like (\"if\" . \"else\").
(nreverse alist)))
(defun smie-debug--prec2-cycle (csts)
"Return a cycle in CSTS, assuming there's one.
CSTS is a list of pairs representing arcs in a graph."
;; A PATH is of the form (START . REST) where REST is a reverse
;; list of nodes through which the path goes.
(let ((paths (mapcar (lambda (pair) (list (car pair) (cdr pair))) csts))
(cycle nil))
(while (null cycle)
(dolist (path (prog1 paths (setq paths nil)))
(dolist (cst csts)
(when (eq (car cst) (nth 1 path))
(if (eq (cdr cst) (car path))
(setq cycle path)
(push (cons (car path) (cons (cdr cst) (cdr path)))
paths))))))
(cons (car cycle) (nreverse (cdr cycle)))))
(defun smie-debug--describe-cycle (table cycle)
(let ((names
(mapcar (lambda (val)
(let ((res nil))
(dolist (elem table)
(if (eq (cdr elem) val)
(push (concat "." (car elem)) res))
(if (eq (cddr elem) val)
(push (concat (car elem) ".") res)))
(assert res)
res))
cycle)))
(mapconcat
(lambda (elems) (mapconcat 'identity elems "="))
(append names (list (car names)))
" < ")))
(defun smie-prec2-levels (prec2)
;; FIXME: Rather than only return an alist of precedence levels, we should
;; also extract other useful data from it:
@ -387,7 +422,9 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or
(incf i))
(setq csts (delq cst csts))))
(unless progress
(error "Can't resolve the precedence table to precedence levels")))
(error "Can't resolve the precedence cycle: %s"
(smie-debug--describe-cycle
table (smie-debug--prec2-cycle csts)))))
(incf i 10))
;; Propagate equalities back to their source.
(dolist (eq (nreverse eqs))
@ -450,7 +487,7 @@ it should move backward to the beginning of the previous token.")
(skip-syntax-forward "w_'"))
(point))))
(defun smie-associative-p (toklevels)
(defun smie--associative-p (toklevels)
;; in "a + b + c" we want to stop at each +, but in
;; "if a then b elsif c then d else c" we don't want to stop at each keyword.
;; To distinguish the two cases, we made smie-prec2-levels choose
@ -535,13 +572,13 @@ Possible return values:
;; If the new operator is not the last in the BNF rule,
;; ans is not associative, it's one of the inner operators
;; (like the "in" in "let .. in .. end"), so keep looking.
((not (smie-associative-p toklevels))
((not (smie--associative-p toklevels))
(push toklevels levels))
;; The new operator is associative. Two cases:
;; - it's really just an associative operator (like + or ;)
;; in which case we should have stopped right before.
((and lastlevels
(smie-associative-p (car lastlevels)))
(smie--associative-p (car lastlevels)))
(throw 'return
(prog1 (list (or (car toklevels) t) (point) token)
(goto-char pos))))
@ -720,6 +757,7 @@ If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\"
;; This not is one of the begin..end we know how to check.
(blink-matching-check-mismatch start end))
((not start) t)
((eq t (car (rassoc ender smie-closer-alist))) nil)
(t
(goto-char start)
(let ((starter (funcall smie-forward-token-function)))
@ -732,45 +770,42 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'.
smie-closer-alist ; Optimization.
(eq (char-before) last-command-event) ; Sanity check.
(memq last-command-event smie-blink-matching-triggers)
(save-excursion
;; FIXME: Here we assume that closers all end
;; with a word-syntax char.
(unless (eq ?\w (char-syntax last-command-event))
(forward-char -1))
(and (looking-at "\\>")
(not (nth 8 (syntax-ppss))))))
(not (nth 8 (syntax-ppss))))
(save-excursion
(let ((pos (point))
(token (funcall smie-backward-token-function)))
(if (= 1 (length token))
;; The trigger char is itself a token but is not
;; one of the closers (e.g. ?\; in Octave mode),
;; so go back to the previous token
(setq token (save-excursion
(funcall smie-backward-token-function)))
(goto-char pos))
;; Here we assume that smie-backward-token-function
;; returns a token that is a string and whose content
;; match the buffer's representation of this token.
(when (and (> (length token) 1) (stringp token)
(memq (aref token (1- (length token)))
smie-blink-matching-triggers)
(not (eq (aref token (1- (length token)))
last-command-event)))
;; Token ends with a trigger char, so don't blink for
;; anything else than this trigger char, lest we'd blink
;; both when inserting the trigger char and when inserting a
;; subsequent SPC.
(setq token nil))
(when (and (rassoc token smie-closer-alist)
(or smie-blink-matching-inners
(null (nth 2 (assoc token smie-op-levels)))))
;; The major mode might set blink-matching-check-function
;; buffer-locally so that interactive calls to
;; blink-matching-open work right, but let's not presume
;; that's the case.
(let ((blink-matching-check-function #'smie-blink-matching-check))
(blink-matching-open)))))))
(when (and (eq (point) (1- pos))
(= 1 (length token))
(not (rassoc token smie-closer-alist)))
;; The trigger char is itself a token but is not one of the
;; closers (e.g. ?\; in Octave mode), so go back to the
;; previous token.
(setq pos (point))
(setq token (save-excursion
(funcall smie-backward-token-function))))
(when (rassoc token smie-closer-alist)
;; We're after a close token. Let's still make sure we
;; didn't skip a comment to find that token.
(funcall smie-forward-token-function)
(when (and (save-excursion
;; Trigger can be SPC, or reindent.
(skip-chars-forward " \n\t")
(>= (point) pos))
;; If token ends with a trigger char, so don't blink for
;; anything else than this trigger char, lest we'd blink
;; both when inserting the trigger char and when
;; inserting a subsequent trigger char like SPC.
(or (eq (point) pos)
(not (memq (char-before)
smie-blink-matching-triggers)))
(or smie-blink-matching-inners
(null (nth 2 (assoc token smie-op-levels)))))
;; The major mode might set blink-matching-check-function
;; buffer-locally so that interactive calls to
;; blink-matching-open work right, but let's not presume
;; that's the case.
(let ((blink-matching-check-function #'smie-blink-matching-check))
(blink-matching-open))))))))
;;; The indentation engine.
@ -821,7 +856,7 @@ position of its parent, or the position right after its parent.
A nil offset for indentation after an opening token defaults
to `smie-indent-basic'.")
(defun smie-indent-hanging-p ()
(defun smie-indent--hanging-p ()
;; A hanging keyword is one that's at the end of a line except it's not at
;; the beginning of a line.
(and (save-excursion
@ -830,19 +865,19 @@ to `smie-indent-basic'.")
(forward-char 1))
(skip-chars-forward " \t")
(eolp))
(not (smie-bolp))))
(not (smie-indent--bolp))))
(defun smie-bolp ()
(defun smie-indent--bolp ()
(save-excursion (skip-chars-backward " \t") (bolp)))
(defun smie-indent-offset (elem)
(defun smie-indent--offset (elem)
(or (cdr (assq elem smie-indent-rules))
(cdr (assq t smie-indent-rules))
smie-indent-basic))
(defvar smie-indent-debug-log)
(defun smie-indent-offset-rule (tokinfo &optional after parent)
(defun smie-indent--offset-rule (tokinfo &optional after parent)
"Apply the OFFSET-RULES in TOKINFO.
Point is expected to be right in front of the token corresponding to TOKINFO.
If computing the indentation after the token, then AFTER is the position
@ -857,10 +892,10 @@ PARENT if non-nil should be the parent info returned by `smie-backward-sexp'."
((not (consp rule)) (setq offset rule))
((eq (car rule) '+) (setq offset rule))
((eq (car rule) :hanging)
(when (smie-indent-hanging-p)
(when (smie-indent--hanging-p)
(setq rules (cdr rule))))
((eq (car rule) :bolp)
(when (smie-bolp)
(when (smie-indent--bolp)
(setq rules (cdr rule))))
((eq (car rule) :eolp)
(unless after
@ -900,13 +935,13 @@ PARENT if non-nil should be the parent info returned by `smie-backward-sexp'."
(push (list (point) offset tokinfo) smie-indent-debug-log))
offset))
(defun smie-indent-column (offset &optional base parent virtual-point)
(defun smie-indent--column (offset &optional base parent virtual-point)
"Compute the actual column to use for a given OFFSET.
BASE is the base position to use, and PARENT is the parent info, if any.
If VIRTUAL-POINT is non-nil, then `point' is virtual."
(cond
((eq (car-safe offset) '+)
(apply '+ (mapcar (lambda (offset) (smie-indent-column offset nil parent))
(apply '+ (mapcar (lambda (offset) (smie-indent--column offset nil parent))
(cdr offset))))
((integerp offset)
(+ offset
@ -941,7 +976,7 @@ If VIRTUAL-POINT is non-nil, then `point' is virtual."
(smie-indent-virtual))
((eq offset nil) nil)
((and (symbolp offset) (boundp 'offset))
(smie-indent-column (symbol-value offset) base parent virtual-point))
(smie-indent--column (symbol-value offset) base parent virtual-point))
(t (error "Unknown indentation offset %s" offset))))
(defun smie-indent-forward-token ()
@ -974,11 +1009,11 @@ This is used when we're not trying to indent point but just
need to compute the column at which point should be indented
in order to figure out the indentation of some other (further down) point."
;; Trust pre-existing indentation on other lines.
(if (smie-bolp) (current-column) (smie-indent-calculate)))
(if (smie-indent--bolp) (current-column) (smie-indent-calculate)))
(defun smie-indent-fixindent ()
;; Obey the `fixindent' special comment.
(and (smie-bolp)
(and (smie-indent--bolp)
(save-excursion
(comment-normalize-vars)
(re-search-forward (concat comment-start-skip
@ -1018,14 +1053,14 @@ in order to figure out the indentation of some other (further down) point."
(save-excursion
(goto-char pos)
;; Different cases:
;; - smie-bolp: "indent according to others".
;; - smie-indent--bolp: "indent according to others".
;; - common hanging: "indent according to others".
;; - SML-let hanging: "indent like parent".
;; - if-after-else: "indent-like parent".
;; - middle-of-line: "trust current position".
(cond
((null (cdr toklevels)) nil) ;Not a keyword.
((smie-bolp)
((smie-indent--bolp)
;; For an open-paren-like thingy at BOL, always indent only
;; based on other rules (typically smie-indent-after-keyword).
nil)
@ -1037,8 +1072,8 @@ in order to figure out the indentation of some other (further down) point."
;; By default use point unless we're hanging.
`((:before . ,token) (:hanging nil) point)))
;; (after (prog1 (point) (goto-char pos)))
(offset (smie-indent-offset-rule tokinfo)))
(smie-indent-column offset)))))
(offset (smie-indent--offset-rule tokinfo)))
(smie-indent--column offset)))))
;; FIXME: This still looks too much like black magic!!
;; FIXME: Rather than a bunch of rules like (PARENT . TOKEN), we
@ -1054,7 +1089,7 @@ in order to figure out the indentation of some other (further down) point."
point)))
(offset (save-excursion
(goto-char pos)
(smie-indent-offset-rule tokinfo nil parent))))
(smie-indent--offset-rule tokinfo nil parent))))
;; Different behaviors:
;; - align with parent.
;; - parent + offset.
@ -1079,10 +1114,10 @@ in order to figure out the indentation of some other (further down) point."
nil)
((eq (car parent) (car toklevels))
;; We bumped into a same-level operator. align with it.
(if (and (smie-bolp) (/= (point) pos)
(if (and (smie-indent--bolp) (/= (point) pos)
(save-excursion
(goto-char (goto-char (cadr parent)))
(not (smie-bolp)))
(not (smie-indent--bolp)))
;; Check the offset of `token' rather then its parent
;; because its parent may have used a special rule. E.g.
;; function foo;
@ -1119,7 +1154,7 @@ in order to figure out the indentation of some other (further down) point."
;; So as to align with the earliest appropriate place.
(smie-indent-virtual)))
(tokinfo
(if (and (= (point) pos) (smie-bolp)
(if (and (= (point) pos) (smie-indent--bolp)
(or (eq offset 'point)
(and (consp offset) (memq 'point offset))))
;; Since we started at BOL, we're not computing a virtual
@ -1127,7 +1162,7 @@ in order to figure out the indentation of some other (further down) point."
;; we can't use `current-column' which would cause
;; indentation to depend on itself.
nil
(smie-indent-column offset 'parent parent
(smie-indent--column offset 'parent parent
;; If we're still at pos, indent-virtual
;; will inf-loop.
(unless (= (point) pos) 'virtual))))))))))
@ -1137,8 +1172,12 @@ in order to figure out the indentation of some other (further down) point."
;; Don't do it for virtual indentations. We should normally never be "in
;; front of a comment" when doing virtual-indentation anyway. And if we are
;; (as can happen in octave-mode), moving forward can lead to inf-loops.
(and (smie-bolp)
(looking-at comment-start-skip)
(and (smie-indent--bolp)
(let ((pos (point)))
(save-excursion
(beginning-of-line)
(and (re-search-forward comment-start-skip (line-end-position) t)
(eq pos (or (match-end 1) (match-beginning 0))))))
(save-excursion
(forward-comment (point-max))
(skip-chars-forward " \t\r\n")
@ -1159,6 +1198,20 @@ in order to figure out the indentation of some other (further down) point."
(if (looking-at (regexp-quote continue))
(current-column))))))))
(defun smie-indent-comment-close ()
(and (boundp 'comment-end-skip)
comment-end-skip
(not (looking-at " \t*$")) ;Not just a \n comment-closer.
(looking-at comment-end-skip)
(nth 4 (syntax-ppss))
(save-excursion
(goto-char (nth 8 (syntax-ppss)))
(current-column))))
(defun smie-indent-comment-inside ()
(and (nth 4 (syntax-ppss))
'noindent))
(defun smie-indent-after-keyword ()
;; Indentation right after a special keyword.
(save-excursion
@ -1178,13 +1231,13 @@ in order to figure out the indentation of some other (further down) point."
;; Using the BNF syntax, we could come up with better
;; defaults, but we only have the precedence levels here.
(setq tokinfo (list tok 'default-rule
(if (cadr toklevel) 0 (smie-indent-offset t)))))
(if (cadr toklevel) 0 (smie-indent--offset t)))))
(let ((offset
(or (smie-indent-offset-rule tokinfo pos)
(smie-indent-offset t))))
(or (smie-indent--offset-rule tokinfo pos)
(smie-indent--offset t))))
(let ((before (point)))
(goto-char pos)
(smie-indent-column offset before)))))))
(smie-indent--column offset before)))))))
(defun smie-indent-exps ()
;; Indentation of sequences of simple expressions without
@ -1207,7 +1260,7 @@ in order to figure out the indentation of some other (further down) point."
arg)
(while (and (null (car (smie-backward-sexp)))
(push (point) positions)
(not (smie-bolp))))
(not (smie-indent--bolp))))
(save-excursion
;; Figure out if the atom we just skipped is an argument rather
;; than a function.
@ -1232,17 +1285,18 @@ in order to figure out the indentation of some other (further down) point."
(positions
;; We're the first arg.
(goto-char (car positions))
;; FIXME: Use smie-indent-column.
(+ (smie-indent-offset 'args)
;; FIXME: Use smie-indent--column.
(+ (smie-indent--offset 'args)
;; We used to use (smie-indent-virtual), but that
;; doesn't seem right since it might then indent args less than
;; the function itself.
(current-column)))))))
(defvar smie-indent-functions
'(smie-indent-fixindent smie-indent-bob smie-indent-close smie-indent-comment
smie-indent-comment-continue smie-indent-keyword smie-indent-after-keyword
smie-indent-exps)
'(smie-indent-fixindent smie-indent-bob smie-indent-close
smie-indent-comment smie-indent-comment-continue smie-indent-comment-close
smie-indent-comment-inside smie-indent-keyword smie-indent-after-keyword
smie-indent-exps)
"Functions to compute the indentation.
Each function is called with no argument, shouldn't move point, and should
return either nil if it has no opinion, or an integer representing the column

48
lisp/emacs-lisp/syntax.el
View file

@ -57,7 +57,11 @@
;; syntax-ppss-flush-cache since that would not only flush the cache but also
;; reset syntax-propertize--done which should not be done in this case).
"Mode-specific function to apply the syntax-table properties.
Called with 2 arguments: START and END.")
Called with 2 arguments: START and END.
This function can call `syntax-ppss' on any position before END, but it
should not call `syntax-ppss-flush-cache', which means that it should not
call `syntax-ppss' on some position and later modify the buffer on some
earlier position.")
(defvar syntax-propertize-chunk-size 500)
@ -109,15 +113,35 @@ Put first the functions more likely to cause a change and cheaper to compute.")
t t s 1))
re t t))
(defmacro syntax-propertize-precompile-rules (&rest rules)
"Return a precompiled form of RULES to pass to `syntax-propertize-rules'.
The arg RULES can be of the same form as in `syntax-propertize-rules'.
The return value is an object that can be passed as a rule to
`syntax-propertize-rules'.
I.e. this is useful only when you want to share rules among several
syntax-propertize-functions."
(declare (debug syntax-propertize-rules))
;; Precompile? Yeah, right!
;; Seriously, tho, this is a macro for 2 reasons:
;; - we could indeed do some pre-compilation at some point in the future,
;; e.g. fi/when we switch to a DFA-based implementation of
;; syntax-propertize-rules.
;; - this lets Edebug properly annotate the expressions inside RULES.
`',rules)
(defmacro syntax-propertize-rules (&rest rules)
"Make a function that applies RULES for use in `syntax-propertize-function'.
The function will scan the buffer, applying the rules where they match.
The buffer is scanned a single time, like \"lex\" would, rather than once
per rule.
Each rule has the form (REGEXP HIGHLIGHT1 ... HIGHLIGHTn), where REGEXP
is an expression (evaluated at time of macro-expansion) that returns a regexp,
and where HIGHLIGHTs have the form (NUMBER SYNTAX) which means to
Each RULE can be a symbol, in which case that symbol's value should be,
at macro-expansion time, a precompiled set of rules, as returned
by `syntax-propertize-precompile-rules'.
Otherwise, RULE should have the form (REGEXP HIGHLIGHT1 ... HIGHLIGHTn), where
REGEXP is an expression (evaluated at time of macro-expansion) that returns
a regexp, and where HIGHLIGHTs have the form (NUMBER SYNTAX) which means to
apply the property SYNTAX to the chars matched by the subgroup NUMBER
of the regular expression, if NUMBER did match.
SYNTAX is an expression that returns a value to apply as `syntax-table'
@ -132,11 +156,18 @@ Also SYNTAX is free to move point, in which case RULES may not be applied to
some parts of the text or may be applied several times to other parts.
Note: back-references in REGEXPs do not work."
(declare (debug (&rest (form &rest
(declare (debug (&rest &or symbolp ;FIXME: edebug this eval step.
(form &rest
(numberp
[&or stringp
[&or stringp ;FIXME: Use &wrap
("prog1" [&or stringp def-form] def-body)
def-form])))))
(let ((newrules nil))
(while rules
(if (symbolp (car rules))
(setq rules (append (symbol-value (pop rules)) rules))
(push (pop rules) newrules)))
(setq rules (nreverse newrules)))
(let* ((offset 0)
(branches '())
;; We'd like to use a real DFA-based lexer, usually, but since Emacs
@ -145,7 +176,8 @@ Note: back-references in REGEXPs do not work."
(re
(mapconcat
(lambda (rule)
(let ((re (eval (car rule))))
(let* ((orig-re (eval (car rule)))
(re orig-re))
(when (and (assq 0 rule) (cdr rules))
;; 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
@ -229,7 +261,7 @@ Note: back-references in REGEXPs do not work."
code))))
(push (cons condition (nreverse code))
branches))
(incf offset (regexp-opt-depth re))
(incf offset (regexp-opt-depth orig-re))
re))
rules
"\\|")))

29
lisp/emacs-lisp/warnings.el
View file

@ -119,9 +119,9 @@ See also `warning-suppress-log-types'."
:type '(repeat (repeat symbol))
:version "22.1")
;;; The autoload cookie is so that programs can bind this variable
;;; safely, testing the existing value, before they call one of the
;;; warnings functions.
;; The autoload cookie is so that programs can bind this variable
;; safely, testing the existing value, before they call one of the
;; warnings functions.
;;;###autoload
(defvar warning-prefix-function nil
"Function to generate warning prefixes.
@ -132,9 +132,9 @@ The warnings buffer is current when this function is called
and the function can insert text in it. This text becomes
the beginning of the warning.")
;;; The autoload cookie is so that programs can bind this variable
;;; safely, testing the existing value, before they call one of the
;;; warnings functions.
;; The autoload cookie is so that programs can bind this variable
;; safely, testing the existing value, before they call one of the
;; warnings functions.
;;;###autoload
(defvar warning-series nil
"Non-nil means treat multiple `display-warning' calls as a series.
@ -146,16 +146,16 @@ A symbol with a function definition is like t, except
also call that function before the next warning.")
(put 'warning-series 'risky-local-variable t)
;;; The autoload cookie is so that programs can bind this variable
;;; safely, testing the existing value, before they call one of the
;;; warnings functions.
;; The autoload cookie is so that programs can bind this variable
;; safely, testing the existing value, before they call one of the
;; warnings functions.
;;;###autoload
(defvar warning-fill-prefix nil
"Non-nil means fill each warning text using this string as `fill-prefix'.")
;;; The autoload cookie is so that programs can bind this variable
;;; safely, testing the existing value, before they call one of the
;;; warnings functions.
;; The autoload cookie is so that programs can bind this variable
;; safely, testing the existing value, before they call one of the
;; warnings functions.
;;;###autoload
(defvar warning-type-format (purecopy " (%s)")
"Format for displaying the warning type in the warning message.
@ -241,6 +241,8 @@ See also `warning-series', `warning-prefix-function' and
(with-current-buffer buffer
;; If we created the buffer, disable undo.
(unless old
(special-mode)
(setq buffer-read-only t)
(setq buffer-undo-list t))
(goto-char (point-max))
(when (and warning-series (symbolp warning-series))
@ -248,6 +250,7 @@ See also `warning-series', `warning-prefix-function' and
(prog1 (point-marker)
(unless (eq warning-series t)
(funcall warning-series)))))
(let ((inhibit-read-only t))
(unless (bolp)
(newline))
(setq start (point))
@ -262,7 +265,7 @@ See also `warning-series', `warning-prefix-function' and
(let ((fill-prefix warning-fill-prefix)
(fill-column 78))
(fill-region start (point))))
(setq end (point))
(setq end (point)))
(when (and (markerp warning-series)
(eq (marker-buffer warning-series) buffer))
(goto-char warning-series)))