[COMMIT] Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
12 years, 8 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1336314599 -3600
# Node ID 289cf21be887b161e4e22c42088a1184d81058c0
# Parent 2a870a7b86bd98f693893df8bce0337bfa9a4c66
Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
This reflects better understanding on my part of the &environment macro
keyword, and I've expanded the Lisp manual and docstrings to reflect that.
lisp/ChangeLog addition:
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (block): Comment on why we can't use &environment
here.
* cl-macs.el (defmacro*): Document &environment in more detail.
* cl-macs.el (macrolet): Use &environment, instead of referencing
byte-compile-macro-environment directly.
* cl-macs.el (symbol-macrolet): Ditto.
* cl-macs.el (lexical-let): Ditto.
* cl-macs.el (labels): Ditto.
man/ChangeLog addition:
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/macros.texi (Expansion):
Cross-reference to documentation of #'cl-prettyexpand, #'defmacro*
when talking about #'macroexpand.
tests/ChangeLog addition:
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
Use &environment appropriately in #'macrolet, instead of relying
on #'macroexpand to guess what we mean.
diff -r 2a870a7b86bd -r 289cf21be887 lisp/ChangeLog
--- a/lisp/ChangeLog Sun May 06 05:22:19 2012 +0100
+++ b/lisp/ChangeLog Sun May 06 15:29:59 2012 +0100
＠＠ -1,3 +1,14 ＠＠
+2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (block): Comment on why we can't use &environment
+ here.
+ * cl-macs.el (defmacro*): Document &environment in more detail.
+ * cl-macs.el (macrolet): Use &environment, instead of referencing
+ byte-compile-macro-environment directly.
+ * cl-macs.el (symbol-macrolet): Ditto.
+ * cl-macs.el (lexical-let): Ditto.
+ * cl-macs.el (labels): Ditto.
+
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el:
diff -r 2a870a7b86bd -r 289cf21be887 lisp/cl-macs.el
--- a/lisp/cl-macs.el Sun May 06 05:22:19 2012 +0100
+++ b/lisp/cl-macs.el Sun May 06 15:29:59 2012 +0100
＠＠ -229,8 +229,12 ＠＠
macro expansion time, reflects all the arguments supplied to the macro,
as if it had been declared with a single &rest argument.
- &environment specifies local semantics for various macros for use within
- the expansion of BODY. See the ENVIRONMENT argument to `macroexpand'.
+ &environment allows access to the macro environment at the time of
+ expansion; it is most relevant when it's necessary to force macro expansion
+ of the body of a form at the time of macro expansion of its top level.
+ &environment is followed by variable name, and this variable will be bound
+ to the value of the macro environment within BODY. See the ENVIRONMENT
+ argument to `macroexpand'.
-- The macro arg list syntax allows for \"destructuring\" -- see also
`destructuring-bind', which destructures exactly like `defmacro*', and
＠＠ -715,6 +719,8 ＠＠
;; as such it can eliminate it if that's appropriate:
(put (cdar cl-active-block-names) 'cl-block-name name)
`(catch ',(cdar cl-active-block-names)
+ ;; Can't use &environment, since #'block is used in
+ ;; #'cl-transform-lambda.
,(cl-macroexpand-all body byte-compile-macro-environment))))
;;;###autoload
＠＠ -1693,7 +1699,7 ＠＠
'(cl-progv-after))))
;;;###autoload
-(defmacro* macrolet ((&rest macros) &body form)
+(defmacro* macrolet ((&rest macros) &body form &environment env)
"Make temporary macro definitions.
This is like `flet', but for macros instead of functions."
(cl-macroexpand-all (cons 'progn form)
＠＠ -1704,10 +1710,10 ＠＠
collect
(list* name 'lambda (cdr (cl-transform-lambda details
name))))
- byte-compile-macro-environment)))
+ env)))
;;;###autoload
-(defmacro* symbol-macrolet ((&rest symbol-macros) &body form)
+(defmacro* symbol-macrolet ((&rest symbol-macros) &body form &environment env)
"Make temporary symbol macro definitions.
Elements in SYMBOL-MACROS look like (NAME EXPANSION).
Within the body FORMs, a reference to NAME is replaced with its EXPANSION,
＠＠ -1717,11 +1723,11 ＠＠
for (name expansion) in symbol-macros
do (check-type name symbol)
collect (list (eq-hash name) expansion))
- byte-compile-macro-environment)))
+ env)))
(defvar cl-closure-vars nil)
;;;###autoload
-(defmacro lexical-let (bindings &rest body)
+(defmacro* lexical-let (bindings &rest body &environment env)
"Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp."
＠＠ -1743,7 +1749,7 ＠＠
t))
vars)
(list '(defun . cl-defun-expander))
- byte-compile-macro-environment))))
+ env))))
(if (not (get (car (last cl-closure-vars)) 'used))
(list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars)
(sublis (mapcar #'(lambda (x)
＠＠ -3888,7 +3894,7 ＠＠
(list 'progn form))
;;;###autoload
-(defmacro labels (bindings &rest body)
+(defmacro* labels (bindings &rest body &environment env)
"Make temporary function bindings.
This is like `flet', except the bindings are lexical instead of dynamic.
＠＠ -3908,8 +3914,7 ＠＠
;; XEmacs; the byte-compiler has a much better implementation of `labels'
;; in `byte-compile-initial-macro-environment' that is used in compiled
;; code.
- (let ((vars nil) (sets nil)
- (byte-compile-macro-environment byte-compile-macro-environment))
+ (let ((vars nil) (sets nil))
(while bindings
(let ((var (gensym)))
(push var vars)
＠＠ -3919,9 +3924,8 ＠＠
(push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
(list 'list* '(quote funcall) (list 'quote var)
'cl-labels-args))
- byte-compile-macro-environment)))
- (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
- byte-compile-macro-environment)))
+ env)))
+ (cl-macroexpand-all `(lexical-let ,vars (setq ,＠sets) ,＠body) env)))
;;;###autoload
(defmacro flet (functions &rest form)
diff -r 2a870a7b86bd -r 289cf21be887 man/ChangeLog
--- a/man/ChangeLog Sun May 06 05:22:19 2012 +0100
+++ b/man/ChangeLog Sun May 06 15:29:59 2012 +0100
＠＠ -1,3 +1,9 ＠＠
+2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lispref/macros.texi (Expansion):
+ Cross-reference to documentation of #'cl-prettyexpand, #'defmacro*
+ when talking about #'macroexpand.
+
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/searching.texi (Regular Expressions):
diff -r 2a870a7b86bd -r 289cf21be887 man/lispref/macros.texi
--- a/man/lispref/macros.texi Sun May 06 05:22:19 2012 +0100
+++ b/man/lispref/macros.texi Sun May 06 15:29:59 2012 +0100
＠＠ -88,7 +88,9 ＠＠
this is unusual.
You can see the expansion of a given macro call by calling
-＠code{macroexpand}.
+＠code{macroexpand}. However, in normal use, ＠code{cl-prettyexpand} will be
+more helpful, since it expands ＠emph{all} the macros in the form, and prints
+the output with more readable indentation. ＠pxref{(cl)Efficiency Concerns}.
＠defun macroexpand form &optional environment
＠cindex macro expansion
＠＠ -106,9 +108,16 ＠＠
Normally there is no need for that, since a call to an inline function is
no harder to understand than a call to an ordinary function.
-If ＠var{environment} is provided, it specifies an alist of macro
-definitions that shadow the currently defined macros. Byte compilation
-uses this feature.
+If ＠var{environment} is provided, it specifies an alist of macro definitions
+that shadow the currently defined macros. Byte compilation uses this feature.
+
+To access ＠var{environment} within the body of a macro, define the macro using
+＠code{defmacro*} or ＠code{macrolet}, and use the ＠code{&environment} lambda
+list keyword. This may be necessary if you need to force macro expansion of
+the body of a form at the same time as top-level macro expansion.
+＠pxref{(cl)Argument Lists}.
+
+Macro expansion examples:
＠smallexample
＠group
diff -r 2a870a7b86bd -r 289cf21be887 src/ChangeLog
--- a/src/ChangeLog Sun May 06 05:22:19 2012 +0100
+++ b/src/ChangeLog Sun May 06 15:29:59 2012 +0100
＠＠ -1,3 +1,14 ＠＠
+012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * eval.c:
+ * eval.c (Fmacroexpand):
+ Don't prepend any supplied environment to
+ Vbyte_compile_macro_environment, leave that up to our callers
+ (that's what the &environment argument is for).
+ Document that one should normally access
+ byte-compile-macro-environment using the &environment lambda list
+ keyword.
+
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* regex.c:
diff -r 2a870a7b86bd -r 289cf21be887 src/eval.c
--- a/src/eval.c Sun May 06 05:22:19 2012 +0100
+++ b/src/eval.c Sun May 06 15:29:59 2012 +0100
＠＠ -1565,22 +1565,10 ＠＠
REGISTER Lisp_Object expander, sym, def, tem;
int speccount = specpdl_depth ();
- if (!NILP (environment) &&
- !EQ (environment, Vbyte_compile_macro_environment))
- {
- if (NILP (Vbyte_compile_macro_environment))
- {
- specbind (Qbyte_compile_macro_environment, environment);
- }
- else
- {
- specbind (Qbyte_compile_macro_environment,
- nconc2 (Fcopy_list (environment),
- Vbyte_compile_macro_environment));
- }
- }
-
- environment = Vbyte_compile_macro_environment;
+ if (!EQ (environment, Vbyte_compile_macro_environment))
+ {
+ specbind (Qbyte_compile_macro_environment, environment);
+ }
while (1)
{
＠＠ -7661,6 +7649,10 ＠＠
Alist of macros defined in the file being compiled.
Each element looks like (MACRONAME . DEFINITION). It is
\(MACRONAME . nil) when a macro is redefined as a function.
+
+You should normally access this using the &environment argument to
+#'macrolet, #'defmacro* and friends, and not directly; see the documentation
+of those macros.
*/);
Vbyte_compile_macro_environment = Qnil;
diff -r 2a870a7b86bd -r 289cf21be887 tests/ChangeLog
--- a/tests/ChangeLog Sun May 06 05:22:19 2012 +0100
+++ b/tests/ChangeLog Sun May 06 15:29:59 2012 +0100
＠＠ -1,3 +1,9 ＠＠
+2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el:
+ Use &environment appropriately in #'macrolet, instead of relying
+ on #'macroexpand to guess what we mean.
+
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/regexp-tests.el (equal):
diff -r 2a870a7b86bd -r 289cf21be887 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sun May 06 05:22:19 2012 +0100
+++ b/tests/automated/lisp-tests.el Sun May 06 15:29:59 2012 +0100
＠＠ -2957,10 +2957,10 ＠＠
(append form (list 1 [hi there] 40 "this is a string" pi)))
(with-second-arguments (&optional form)
(append form (list pi e ''hello ''there [40 50 60])))
- (with-both-arguments (&optional form)
+ (with-both-arguments (&optional form &environment env)
(append form
- (macroexpand '(with-first-arguments))
- (macroexpand '(with-second-arguments)))))
+ (macroexpand '(with-first-arguments) env)
+ (macroexpand '(with-second-arguments) env))))
(with-temp-buffer
(Assert
＠＠ -2986,4 +2986,20 ＠＠
(Assert (not (funcall (intern "eq") #'bookend #'refer-to-bookend))
"checking two mutually recursive functions compiled OK"))))
+;; Test macroexpand's handling of the ENVIRONMENT argument. We augmented it
+;; quietly for about four months, and this was incorrect.
+
+(Check-Error
+ void-variable
+ (macrolet
+ ((with-first-arguments (&optional form)
+ (append form (list 1 [hi there] 40 "this is a string" pi)))
+ (with-second-arguments (&optional form)
+ (append form (list pi e ''hello ''there [40 50 60])))
+ (with-both-arguments (&optional form)
+ (append form
+ (macroexpand '(with-first-arguments))
+ (macroexpand '(with-second-arguments)))))
+ (with-both-arguments (list))))
+
;;; end of lisp-tests.el
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit/XEmacs: kehoea: Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
12 years, 8 months
Bitbucket
Bitbucket
1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/changeset/289cf21be887/
changeset: 289cf21be887
user: kehoea
date: 2012-05-06 16:29:59
summary: Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
This reflects better understanding on my part of the &environment macro
keyword, and I've expanded the Lisp manual and docstrings to reflect that.
lisp/ChangeLog addition:
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (block): Comment on why we can't use &environment
here.
* cl-macs.el (defmacro*): Document &environment in more detail.
* cl-macs.el (macrolet): Use &environment, instead of referencing
byte-compile-macro-environment directly.
* cl-macs.el (symbol-macrolet): Ditto.
* cl-macs.el (lexical-let): Ditto.
* cl-macs.el (labels): Ditto.
man/ChangeLog addition:
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/macros.texi (Expansion):
Cross-reference to documentation of #'cl-prettyexpand, #'defmacro*
when talking about #'macroexpand.
tests/ChangeLog addition:
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
Use &environment appropriately in #'macrolet, instead of relying
on #'macroexpand to guess what we mean.
affected #: 8 files
diff -r 2a870a7b86bd98f693893df8bce0337bfa9a4c66 -r 289cf21be887b161e4e22c42088a1184d81058c0 lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
＠＠ -1,3 +1,14 ＠＠
+2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (block): Comment on why we can't use &environment
+ here.
+ * cl-macs.el (defmacro*): Document &environment in more detail.
+ * cl-macs.el (macrolet): Use &environment, instead of referencing
+ byte-compile-macro-environment directly.
+ * cl-macs.el (symbol-macrolet): Ditto.
+ * cl-macs.el (lexical-let): Ditto.
+ * cl-macs.el (labels): Ditto.
+
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el:
diff -r 2a870a7b86bd98f693893df8bce0337bfa9a4c66 -r 289cf21be887b161e4e22c42088a1184d81058c0 lisp/cl-macs.el
--- a/lisp/cl-macs.el
+++ b/lisp/cl-macs.el
＠＠ -229,8 +229,12 ＠＠
macro expansion time, reflects all the arguments supplied to the macro,
as if it had been declared with a single &rest argument.
- &environment specifies local semantics for various macros for use within
- the expansion of BODY. See the ENVIRONMENT argument to `macroexpand'.
+ &environment allows access to the macro environment at the time of
+ expansion; it is most relevant when it's necessary to force macro expansion
+ of the body of a form at the time of macro expansion of its top level.
+ &environment is followed by variable name, and this variable will be bound
+ to the value of the macro environment within BODY. See the ENVIRONMENT
+ argument to `macroexpand'.
-- The macro arg list syntax allows for \"destructuring\" -- see also
`destructuring-bind', which destructures exactly like `defmacro*', and
＠＠ -715,6 +719,8 ＠＠
;; as such it can eliminate it if that's appropriate:
(put (cdar cl-active-block-names) 'cl-block-name name)
`(catch ',(cdar cl-active-block-names)
+ ;; Can't use &environment, since #'block is used in
+ ;; #'cl-transform-lambda.
,(cl-macroexpand-all body byte-compile-macro-environment))))
;;;###autoload
＠＠ -1693,7 +1699,7 ＠＠
'(cl-progv-after))))
;;;###autoload
-(defmacro* macrolet ((&rest macros) &body form)
+(defmacro* macrolet ((&rest macros) &body form &environment env)
"Make temporary macro definitions.
This is like `flet', but for macros instead of functions."
(cl-macroexpand-all (cons 'progn form)
＠＠ -1704,10 +1710,10 ＠＠
collect
(list* name 'lambda (cdr (cl-transform-lambda details
name))))
- byte-compile-macro-environment)))
+ env)))
;;;###autoload
-(defmacro* symbol-macrolet ((&rest symbol-macros) &body form)
+(defmacro* symbol-macrolet ((&rest symbol-macros) &body form &environment env)
"Make temporary symbol macro definitions.
Elements in SYMBOL-MACROS look like (NAME EXPANSION).
Within the body FORMs, a reference to NAME is replaced with its EXPANSION,
＠＠ -1717,11 +1723,11 ＠＠
for (name expansion) in symbol-macros
do (check-type name symbol)
collect (list (eq-hash name) expansion))
- byte-compile-macro-environment)))
+ env)))
(defvar cl-closure-vars nil)
;;;###autoload
-(defmacro lexical-let (bindings &rest body)
+(defmacro* lexical-let (bindings &rest body &environment env)
"Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp."
＠＠ -1743,7 +1749,7 ＠＠
t))
vars)
(list '(defun . cl-defun-expander))
- byte-compile-macro-environment))))
+ env))))
(if (not (get (car (last cl-closure-vars)) 'used))
(list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars)
(sublis (mapcar #'(lambda (x)
＠＠ -3888,7 +3894,7 ＠＠
(list 'progn form))
;;;###autoload
-(defmacro labels (bindings &rest body)
+(defmacro* labels (bindings &rest body &environment env)
"Make temporary function bindings.
This is like `flet', except the bindings are lexical instead of dynamic.
＠＠ -3908,8 +3914,7 ＠＠
;; XEmacs; the byte-compiler has a much better implementation of `labels'
;; in `byte-compile-initial-macro-environment' that is used in compiled
;; code.
- (let ((vars nil) (sets nil)
- (byte-compile-macro-environment byte-compile-macro-environment))
+ (let ((vars nil) (sets nil))
(while bindings
(let ((var (gensym)))
(push var vars)
＠＠ -3919,9 +3924,8 ＠＠
(push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
(list 'list* '(quote funcall) (list 'quote var)
'cl-labels-args))
- byte-compile-macro-environment)))
- (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
- byte-compile-macro-environment)))
+ env)))
+ (cl-macroexpand-all `(lexical-let ,vars (setq ,＠sets) ,＠body) env)))
;;;###autoload
(defmacro flet (functions &rest form)
diff -r 2a870a7b86bd98f693893df8bce0337bfa9a4c66 -r 289cf21be887b161e4e22c42088a1184d81058c0 man/ChangeLog
--- a/man/ChangeLog
+++ b/man/ChangeLog
＠＠ -1,3 +1,9 ＠＠
+2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lispref/macros.texi (Expansion):
+ Cross-reference to documentation of #'cl-prettyexpand, #'defmacro*
+ when talking about #'macroexpand.
+
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/searching.texi (Regular Expressions):
diff -r 2a870a7b86bd98f693893df8bce0337bfa9a4c66 -r 289cf21be887b161e4e22c42088a1184d81058c0 man/lispref/macros.texi
--- a/man/lispref/macros.texi
+++ b/man/lispref/macros.texi
＠＠ -88,7 +88,9 ＠＠
this is unusual.
You can see the expansion of a given macro call by calling
-＠code{macroexpand}.
+＠code{macroexpand}. However, in normal use, ＠code{cl-prettyexpand} will be
+more helpful, since it expands ＠emph{all} the macros in the form, and prints
+the output with more readable indentation. ＠pxref{(cl)Efficiency Concerns}.
＠defun macroexpand form &optional environment
＠cindex macro expansion
＠＠ -106,9 +108,16 ＠＠
Normally there is no need for that, since a call to an inline function is
no harder to understand than a call to an ordinary function.
-If ＠var{environment} is provided, it specifies an alist of macro
-definitions that shadow the currently defined macros. Byte compilation
-uses this feature.
+If ＠var{environment} is provided, it specifies an alist of macro definitions
+that shadow the currently defined macros. Byte compilation uses this feature.
+
+To access ＠var{environment} within the body of a macro, define the macro using
+＠code{defmacro*} or ＠code{macrolet}, and use the ＠code{&environment} lambda
+list keyword. This may be necessary if you need to force macro expansion of
+the body of a form at the same time as top-level macro expansion.
+＠pxref{(cl)Argument Lists}.
+
+Macro expansion examples:
＠smallexample
＠group
diff -r 2a870a7b86bd98f693893df8bce0337bfa9a4c66 -r 289cf21be887b161e4e22c42088a1184d81058c0 src/ChangeLog
--- a/src/ChangeLog
+++ b/src/ChangeLog
＠＠ -1,3 +1,14 ＠＠
+012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * eval.c:
+ * eval.c (Fmacroexpand):
+ Don't prepend any supplied environment to
+ Vbyte_compile_macro_environment, leave that up to our callers
+ (that's what the &environment argument is for).
+ Document that one should normally access
+ byte-compile-macro-environment using the &environment lambda list
+ keyword.
+
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* regex.c:
diff -r 2a870a7b86bd98f693893df8bce0337bfa9a4c66 -r 289cf21be887b161e4e22c42088a1184d81058c0 src/eval.c
--- a/src/eval.c
+++ b/src/eval.c
＠＠ -1565,22 +1565,10 ＠＠
REGISTER Lisp_Object expander, sym, def, tem;
int speccount = specpdl_depth ();
- if (!NILP (environment) &&
- !EQ (environment, Vbyte_compile_macro_environment))
- {
- if (NILP (Vbyte_compile_macro_environment))
- {
- specbind (Qbyte_compile_macro_environment, environment);
- }
- else
- {
- specbind (Qbyte_compile_macro_environment,
- nconc2 (Fcopy_list (environment),
- Vbyte_compile_macro_environment));
- }
- }
-
- environment = Vbyte_compile_macro_environment;
+ if (!EQ (environment, Vbyte_compile_macro_environment))
+ {
+ specbind (Qbyte_compile_macro_environment, environment);
+ }
while (1)
{
＠＠ -7661,6 +7649,10 ＠＠
Alist of macros defined in the file being compiled.
Each element looks like (MACRONAME . DEFINITION). It is
\(MACRONAME . nil) when a macro is redefined as a function.
+
+You should normally access this using the &environment argument to
+#'macrolet, #'defmacro* and friends, and not directly; see the documentation
+of those macros.
*/);
Vbyte_compile_macro_environment = Qnil;
diff -r 2a870a7b86bd98f693893df8bce0337bfa9a4c66 -r 289cf21be887b161e4e22c42088a1184d81058c0 tests/ChangeLog
--- a/tests/ChangeLog
+++ b/tests/ChangeLog
＠＠ -1,3 +1,9 ＠＠
+2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el:
+ Use &environment appropriately in #'macrolet, instead of relying
+ on #'macroexpand to guess what we mean.
+
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/regexp-tests.el (equal):
diff -r 2a870a7b86bd98f693893df8bce0337bfa9a4c66 -r 289cf21be887b161e4e22c42088a1184d81058c0 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el
+++ b/tests/automated/lisp-tests.el
＠＠ -2957,10 +2957,10 ＠＠
(append form (list 1 [hi there] 40 "this is a string" pi)))
(with-second-arguments (&optional form)
(append form (list pi e ''hello ''there [40 50 60])))
- (with-both-arguments (&optional form)
+ (with-both-arguments (&optional form &environment env)
(append form
- (macroexpand '(with-first-arguments))
- (macroexpand '(with-second-arguments)))))
+ (macroexpand '(with-first-arguments) env)
+ (macroexpand '(with-second-arguments) env))))
(with-temp-buffer
(Assert
＠＠ -2986,4 +2986,20 ＠＠
(Assert (not (funcall (intern "eq") #'bookend #'refer-to-bookend))
"checking two mutually recursive functions compiled OK"))))
+;; Test macroexpand's handling of the ENVIRONMENT argument. We augmented it
+;; quietly for about four months, and this was incorrect.
+
+(Check-Error
+ void-variable
+ (macrolet
+ ((with-first-arguments (&optional form)
+ (append form (list 1 [hi there] 40 "this is a string" pi)))
+ (with-second-arguments (&optional form)
+ (append form (list pi e ''hello ''there [40 50 60])))
+ (with-both-arguments (&optional form)
+ (append form
+ (macroexpand '(with-first-arguments))
+ (macroexpand '(with-second-arguments)))))
+ (with-both-arguments (list))))
+
;;; end of lisp-tests.el
Repository URL: https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Descend special forms more exhaustively, #'byte-optimize-form-code-walker
12 years, 8 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1336278139 -3600
# Node ID 2a870a7b86bd98f693893df8bce0337bfa9a4c66
# Parent e9c3fe82127d71edcf53529e7227785809922ff9
Descend special forms more exhaustively, #'byte-optimize-form-code-walker
lisp/ChangeLog addition:
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el:
* byte-optimize.el (or):
* byte-optimize.el (byte-optimize-or):
Declare for-effect properly, it's not free.
* byte-optimize.el (byte-optimize-condition-case): New.
* byte-optimize.el (byte-optimize-form-code-walker):
Be more exhaustive in descending special forms, for the sake of
lexically-oriented optimizers such as that for #'labels.
diff -r e9c3fe82127d -r 2a870a7b86bd lisp/ChangeLog
--- a/lisp/ChangeLog Sat May 05 20:48:24 2012 +0100
+++ b/lisp/ChangeLog Sun May 06 05:22:19 2012 +0100
＠＠ -1,3 +1,14 ＠＠
+2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * byte-optimize.el:
+ * byte-optimize.el (or):
+ * byte-optimize.el (byte-optimize-or):
+ Declare for-effect properly, it's not free.
+ * byte-optimize.el (byte-optimize-condition-case): New.
+ * byte-optimize.el (byte-optimize-form-code-walker):
+ Be more exhaustive in descending special forms, for the sake of
+ lexically-oriented optimizers such as that for #'labels.
+
2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
Co-operate with the byte-optimizer in the bytecomp.el labels
diff -r e9c3fe82127d -r 2a870a7b86bd lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Sat May 05 20:48:24 2012 +0100
+++ b/lisp/byte-optimize.el Sun May 06 05:22:19 2012 +0100
＠＠ -363,6 +363,28 ＠＠
form
(nconc (subseq form 0 offset) body))))
+;; Setting this to the byte-optimizer property of condition-case gives an
+;; infinite loop, as of So 6 Mai 2012 05:10:44 IST
+(defun byte-optimize-condition-case (form &optional for-effect)
+ (let ((modified nil)
+ (result nil)
+ (new nil))
+ (setq result
+ (list* (car form) (nth 1 form)
+ (prog1
+ (setq new (byte-optimize-form (nth 2 form) for-effect))
+ (setq modified (or modified (eq new (nth 2 form)))))
+ (mapcar #'(lambda (handler)
+ (if (eq (cdr handler)
+ (setq new
+ (byte-optimize-body (cdr handler)
+ for-effect)))
+ handler
+ (setq modified t)
+ (cons (car handler) new)))
+ (cdddr form))))
+ (if modified result form)))
+
;;; implementing source-level optimizers
(defun byte-optimize-form-code-walker (form for-effect)
＠＠ -503,35 +525,32 ＠＠
((memq fn '(defun defmacro))
(if (eq (setq tmp (cons 'lambda (cddr form)))
(setq tmp (byte-optimize-lambda tmp)))
- (cons fn (cdr tmp))
- form))
+ form
+ (nconc (subseq form 0 2) (cdr tmp))))
((eq fn 'condition-case)
- (list* fn (nth 1 form) (byte-optimize-form (nth 2 form) for-effect)
- (mapcar #'(lambda (handler)
- (cons (car handler)
- (byte-optimize-body (cdr handler)
- for-effect)))
- (cdddr form))))
+ (if (eq (setq tmp (byte-optimize-condition-case form for-effect))
+ form)
+ form
+ tmp))
((eq fn 'unwind-protect)
- ;; the "protected" part of an unwind-protect is compiled (and thus
- ;; optimized) as a top-level form, so don't do it here. But the
+ ;; the "protected" part of an unwind-protect is compiled (and
+ ;; thus optimized) as a top-level form, but do it here too for
+ ;; the sake of lexically-oriented code (labels, and so on). The
;; non-protected part has the same for-effect status as the
- ;; unwind-protect itself. (The protected part is always for effect,
- ;; but that isn't handled properly yet.)
+ ;; unwind-protect itself.
(cons fn
(cons (byte-optimize-form (nth 1 form) for-effect)
- (cdr (cdr form)))))
+ (byte-optimize-body (cddr form) t))))
((eq fn 'catch)
- ;; the body of a catch is compiled (and thus optimized) as a
- ;; top-level form, so don't do it here. The tag is never
- ;; for-effect. The body should have the same for-effect status
- ;; as the catch form itself, but that isn't handled properly yet.
+ ;; The body of a catch is compiled (and thus optimized) as a
+ ;; top-level form, but do it here too for the sake of
+ ;; lexically-oriented code. The tag is never for-effect.
(cons fn
(cons (byte-optimize-form (nth 1 form) nil)
- (cdr (cdr form)))))
+ (byte-optimize-body (cddr form) for-effect))))
;; If optimization is on, this is the only place that macros are
;; expanded. If optimization is off, then macroexpansion happens
＠＠ -974,7 +993,7 ＠＠
(nth 1 form))
((byte-optimize-predicate form))))
-(defun byte-optimize-or (form)
+(defun byte-optimize-or (form &optional for-effect)
;; Throw away unneeded nils, and simplify if less than 2 args.
;; XEmacs; change to be more careful about discarding multiple values.
(if (memq nil form)
＠＠ -1057,6 +1076,8 ＠＠
(put 'and 'byte-optimizer 'byte-optimize-and)
(put 'or 'byte-optimizer 'byte-optimize-or)
+(put 'or 'byte-for-effect-optimizer
+ #'(lambda (form) (byte-optimize-or form t)))
(put 'cond 'byte-optimizer 'byte-optimize-cond)
(put 'if 'byte-optimizer 'byte-optimize-if)
(put 'while 'byte-optimizer 'byte-optimize-while)
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit/XEmacs: kehoea: Descend special forms more exhaustively, #'byte-optimize-form-code-walker
12 years, 8 months
Bitbucket
Bitbucket
1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/changeset/2a870a7b86bd/
changeset: 2a870a7b86bd
user: kehoea
date: 2012-05-06 06:22:19
summary: Descend special forms more exhaustively, #'byte-optimize-form-code-walker
lisp/ChangeLog addition:
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el:
* byte-optimize.el (or):
* byte-optimize.el (byte-optimize-or):
Declare for-effect properly, it's not free.
* byte-optimize.el (byte-optimize-condition-case): New.
* byte-optimize.el (byte-optimize-form-code-walker):
Be more exhaustive in descending special forms, for the sake of
lexically-oriented optimizers such as that for #'labels.
affected #: 2 files
diff -r e9c3fe82127d71edcf53529e7227785809922ff9 -r 2a870a7b86bd98f693893df8bce0337bfa9a4c66 lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
＠＠ -1,3 +1,14 ＠＠
+2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * byte-optimize.el:
+ * byte-optimize.el (or):
+ * byte-optimize.el (byte-optimize-or):
+ Declare for-effect properly, it's not free.
+ * byte-optimize.el (byte-optimize-condition-case): New.
+ * byte-optimize.el (byte-optimize-form-code-walker):
+ Be more exhaustive in descending special forms, for the sake of
+ lexically-oriented optimizers such as that for #'labels.
+
2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
Co-operate with the byte-optimizer in the bytecomp.el labels
diff -r e9c3fe82127d71edcf53529e7227785809922ff9 -r 2a870a7b86bd98f693893df8bce0337bfa9a4c66 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el
+++ b/lisp/byte-optimize.el
＠＠ -363,6 +363,28 ＠＠
form
(nconc (subseq form 0 offset) body))))
+;; Setting this to the byte-optimizer property of condition-case gives an
+;; infinite loop, as of So 6 Mai 2012 05:10:44 IST
+(defun byte-optimize-condition-case (form &optional for-effect)
+ (let ((modified nil)
+ (result nil)
+ (new nil))
+ (setq result
+ (list* (car form) (nth 1 form)
+ (prog1
+ (setq new (byte-optimize-form (nth 2 form) for-effect))
+ (setq modified (or modified (eq new (nth 2 form)))))
+ (mapcar #'(lambda (handler)
+ (if (eq (cdr handler)
+ (setq new
+ (byte-optimize-body (cdr handler)
+ for-effect)))
+ handler
+ (setq modified t)
+ (cons (car handler) new)))
+ (cdddr form))))
+ (if modified result form)))
+
;;; implementing source-level optimizers
(defun byte-optimize-form-code-walker (form for-effect)
＠＠ -503,35 +525,32 ＠＠
((memq fn '(defun defmacro))
(if (eq (setq tmp (cons 'lambda (cddr form)))
(setq tmp (byte-optimize-lambda tmp)))
- (cons fn (cdr tmp))
- form))
+ form
+ (nconc (subseq form 0 2) (cdr tmp))))
((eq fn 'condition-case)
- (list* fn (nth 1 form) (byte-optimize-form (nth 2 form) for-effect)
- (mapcar #'(lambda (handler)
- (cons (car handler)
- (byte-optimize-body (cdr handler)
- for-effect)))
- (cdddr form))))
+ (if (eq (setq tmp (byte-optimize-condition-case form for-effect))
+ form)
+ form
+ tmp))
((eq fn 'unwind-protect)
- ;; the "protected" part of an unwind-protect is compiled (and thus
- ;; optimized) as a top-level form, so don't do it here. But the
+ ;; the "protected" part of an unwind-protect is compiled (and
+ ;; thus optimized) as a top-level form, but do it here too for
+ ;; the sake of lexically-oriented code (labels, and so on). The
;; non-protected part has the same for-effect status as the
- ;; unwind-protect itself. (The protected part is always for effect,
- ;; but that isn't handled properly yet.)
+ ;; unwind-protect itself.
(cons fn
(cons (byte-optimize-form (nth 1 form) for-effect)
- (cdr (cdr form)))))
+ (byte-optimize-body (cddr form) t))))
((eq fn 'catch)
- ;; the body of a catch is compiled (and thus optimized) as a
- ;; top-level form, so don't do it here. The tag is never
- ;; for-effect. The body should have the same for-effect status
- ;; as the catch form itself, but that isn't handled properly yet.
+ ;; The body of a catch is compiled (and thus optimized) as a
+ ;; top-level form, but do it here too for the sake of
+ ;; lexically-oriented code. The tag is never for-effect.
(cons fn
(cons (byte-optimize-form (nth 1 form) nil)
- (cdr (cdr form)))))
+ (byte-optimize-body (cddr form) for-effect))))
;; If optimization is on, this is the only place that macros are
;; expanded. If optimization is off, then macroexpansion happens
＠＠ -974,7 +993,7 ＠＠
(nth 1 form))
((byte-optimize-predicate form))))
-(defun byte-optimize-or (form)
+(defun byte-optimize-or (form &optional for-effect)
;; Throw away unneeded nils, and simplify if less than 2 args.
;; XEmacs; change to be more careful about discarding multiple values.
(if (memq nil form)
＠＠ -1057,6 +1076,8 ＠＠
(put 'and 'byte-optimizer 'byte-optimize-and)
(put 'or 'byte-optimizer 'byte-optimize-or)
+(put 'or 'byte-for-effect-optimizer
+ #'(lambda (form) (byte-optimize-or form t)))
(put 'cond 'byte-optimizer 'byte-optimize-cond)
(put 'if 'byte-optimizer 'byte-optimize-if)
(put 'while 'byte-optimizer 'byte-optimize-while)
Repository URL: https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Co-operate with the byte-optimizer in the bytecomp.el labels implementation.
12 years, 8 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1336247304 -3600
# Node ID e9c3fe82127d71edcf53529e7227785809922ff9
# Parent b7ae5f44b95017d6cee969e8353e73eb16a62f01
Co-operate with the byte-optimizer in the bytecomp.el labels implementation.
lisp/ChangeLog addition:
2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
Co-operate with the byte-optimizer in the bytecomp.el labels
implementation, don't work against it.
* byte-optimize.el:
* byte-optimize.el (byte-compile-inline-expand):
Call #'byte-compile-unfold-lambda explicitly here, don't assume
that the byte-optimizer will do it.
* byte-optimize.el (byte-compile-unfold-lambda):
Call #'byte-optimize-body on the body, don't just mapcar
#'byte-optimize-form along it.
* byte-optimize.el (byte-optimize-lambda): New. Optimize a lambda
form.
* byte-optimize.el (byte-optimize-form-code-walker):
Descend lambda expressions, defun, and defmacro, relevant for
lexically-oriented operators like #'labels.
* byte-optimize.el (byte-optimize-body): Only return a non-eq
object if we've actually optimized something
* bytecomp.el (byte-compile-initial-macro-environment):
In the labels implementation, work with the byte optimizer, not
against it; warn when labels are defined but not used,
automatically inline labels that are used only once.
* bytecomp.el (byte-recompile-directory):
No need to wrap #'byte-compile-report-error in a lambda with
#'call-with-condition-handler here.
* bytecomp.el (byte-compile-form):
Don't inline compiled-function objects, they're probably labels.
* bytecomp.el (byte-compile-funcall):
No longer inline lambdas, trust the byte optimizer to have done it
properly, even for labels.
* cl-extra.el (cl-macroexpand-all):
Treat labels established by the byte compiler distinctly from
those established by cl-macs.el.
* cl-macs.el (cl-do-proclaim):
Treat labels established by the byte compiler distinctly from
those established by cl-macs.el.
* gui.el (make-gui-button):
When referring to the #'gui-button-action label, quote it using
function, otherwise there's a warning from the byte compiler.
diff -r b7ae5f44b950 -r e9c3fe82127d lisp/ChangeLog
--- a/lisp/ChangeLog Sat May 05 18:42:00 2012 +0100
+++ b/lisp/ChangeLog Sat May 05 20:48:24 2012 +0100
＠＠ -1,3 +1,44 ＠＠
+2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Co-operate with the byte-optimizer in the bytecomp.el labels
+ implementation, don't work against it.
+
+ * byte-optimize.el:
+ * byte-optimize.el (byte-compile-inline-expand):
+ Call #'byte-compile-unfold-lambda explicitly here, don't assume
+ that the byte-optimizer will do it.
+ * byte-optimize.el (byte-compile-unfold-lambda):
+ Call #'byte-optimize-body on the body, don't just mapcar
+ #'byte-optimize-form along it.
+ * byte-optimize.el (byte-optimize-lambda): New. Optimize a lambda
+ form.
+ * byte-optimize.el (byte-optimize-form-code-walker):
+ Descend lambda expressions, defun, and defmacro, relevant for
+ lexically-oriented operators like #'labels.
+ * byte-optimize.el (byte-optimize-body): Only return a non-eq
+ object if we've actually optimized something
+ * bytecomp.el (byte-compile-initial-macro-environment):
+ In the labels implementation, work with the byte optimizer, not
+ against it; warn when labels are defined but not used,
+ automatically inline labels that are used only once.
+ * bytecomp.el (byte-recompile-directory):
+ No need to wrap #'byte-compile-report-error in a lambda with
+ #'call-with-condition-handler here.
+ * bytecomp.el (byte-compile-form):
+ Don't inline compiled-function objects, they're probably labels.
+ * bytecomp.el (byte-compile-funcall):
+ No longer inline lambdas, trust the byte optimizer to have done it
+ properly, even for labels.
+ * cl-extra.el (cl-macroexpand-all):
+ Treat labels established by the byte compiler distinctly from
+ those established by cl-macs.el.
+ * cl-macs.el (cl-do-proclaim):
+ Treat labels established by the byte compiler distinctly from
+ those established by cl-macs.el.
+ * gui.el (make-gui-button):
+ When referring to the #'gui-button-action label, quote it using
+ function, otherwise there's a warning from the byte compiler.
+
2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
Remove some redundant functions; turn other utility functions into
diff -r b7ae5f44b950 -r e9c3fe82127d lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Sat May 05 18:42:00 2012 +0100
+++ b/lisp/byte-optimize.el Sat May 05 20:48:24 2012 +0100
＠＠ -284,19 +284,10 ＠＠
(error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name))
(if (symbolp fn)
(byte-compile-inline-expand (cons fn (cdr form)))
- (if (compiled-function-p fn)
- (progn
- (fetch-bytecode fn)
- (cons (list 'lambda (compiled-function-arglist fn)
- (list 'byte-code
- (compiled-function-instructions fn)
- (compiled-function-constants fn)
- (compiled-function-stack-depth fn)))
- (cdr form)))
- (if (eq (car-safe fn) 'lambda)
- (cons fn (cdr form))
- ;; Give up on inlining.
- form))))))
+ (if (or (eq (car-safe fn) 'lambda) (compiled-function-p fn))
+ (byte-compile-unfold-lambda (cons fn (cdr form)))
+ ;; Give up on inlining.
+ form)))))
;;; ((lambda ...) ...)
;;;
＠＠ -354,7 +345,7 ＠＠
(byte-compile-warn
"attempt to open-code %s with too many arguments" name))
form)
- (setq body (mapcar 'byte-optimize-form body))
+ (setq body (byte-optimize-body body nil))
(let ((newform
(if bindings
(cons 'let (cons (nreverse bindings) body))
＠＠ -363,6 +354,15 ＠＠
newform)))))
+(defun byte-optimize-lambda (form)
+ (let* ((offset 2) (body (nthcdr offset form)))
+ (if (stringp (car body)) (setq body (nthcdr (incf offset) form)))
+ (if (eq 'interactive (car-safe (car body)))
+ (setq body (nthcdr (incf offset) form)))
+ (if (eq body (setq body (byte-optimize-body body nil)))
+ form
+ (nconc (subseq form 0 offset) body))))
+
;;; implementing source-level optimizers
(defun byte-optimize-form-code-walker (form for-effect)
＠＠ -390,9 +390,19 ＠＠
(and (nth 1 form)
(not for-effect)
form))
- ((or (compiled-function-p fn)
- (eq 'lambda (car-safe fn)))
- (byte-compile-unfold-lambda form))
+ ((eq fn 'function)
+ (when (cddr form)
+ (byte-compile-warn "malformed function form: %S" form))
+ (cond
+ (for-effect nil)
+ ((and (eq (car-safe (cadr form)) 'lambda)
+ (not (eq (cadr form) (setq tmp (byte-optimize-lambda
+ (cadr form))))))
+ (list fn tmp))
+ (t form)))
+ ((and (eq 'lambda (car-safe fn))
+ (not (eq form (setq form (byte-compile-unfold-lambda form)))))
+ form)
((memq fn '(let let*))
;; recursively enter the optimizer for the bindings and body
;; of a let or let*. This for depth-firstness: forms that
＠＠ -490,11 +500,19 ＠＠
(prin1-to-string form))
nil)
- ((memq fn '(defun defmacro function
- condition-case save-window-excursion))
- ;; These forms are compiled as constants or by breaking out
- ;; all the subexpressions and compiling them separately.
- form)
+ ((memq fn '(defun defmacro))
+ (if (eq (setq tmp (cons 'lambda (cddr form)))
+ (setq tmp (byte-optimize-lambda tmp)))
+ (cons fn (cdr tmp))
+ form))
+
+ ((eq fn 'condition-case)
+ (list* fn (nth 1 form) (byte-optimize-form (nth 2 form) for-effect)
+ (mapcar #'(lambda (handler)
+ (cons (car handler)
+ (byte-optimize-body (cdr handler)
+ for-effect)))
+ (cdddr form))))
((eq fn 'unwind-protect)
;; the "protected" part of an unwind-protect is compiled (and thus
＠＠ -524,8 +542,11 ＠＠
byte-compile-macro-environment))))
(byte-optimize-form form for-effect))
+ ((compiled-function-p fn)
+ (cons fn (mapcar #'byte-optimize-form (cdr form))))
+
((not (symbolp fn))
- (byte-compile-warn "%s is a malformed function" (prin1-to-string fn))
+ (byte-compile-warn "%S is a malformed function" fn)
form)
;; Support compiler macros as in cl.el.
＠＠ -593,14 +614,17 ＠＠
;; all-for-effect is true. Returns a new list of forms.
(let ((rest forms)
(result nil)
+ (modified nil)
fe new)
(while rest
(setq fe (or all-for-effect (cdr rest)))
(setq new (and (car rest) (byte-optimize-form (car rest) fe)))
(if (or new (not fe))
- (setq result (cons new result)))
+ (setq result (cons new result)
+ modified (or modified (not (eq new (car rest)))))
+ (setq modified t))
(setq rest (cdr rest)))
- (nreverse result)))
+ (if modified (nreverse result) forms)))
;;; some source-level optimizers
diff -r b7ae5f44b950 -r e9c3fe82127d lisp/bytecomp.el
--- a/lisp/bytecomp.el Sat May 05 18:42:00 2012 +0100
+++ b/lisp/bytecomp.el Sat May 05 20:48:24 2012 +0100
＠＠ -522,150 +522,222 ＠＠
#'(lambda (form &optional read-only)
(list wrapper form))))
(labels
- . ,#'(lambda (bindings &rest body)
- (let* ((names (mapcar 'car bindings))
- (lambdas (mapcar
- (function*
- (lambda ((name . definition))
- (cons 'lambda (cdr (cl-transform-lambda
- definition name)))))
- bindings))
- (placeholders
- (mapcar #'(lambda (lambda)
- (make-byte-code (second lambda) "\xc0\x87"
- ;; This list is used for
- ;; the byte-optimize
- ;; property, if the
- ;; function is to be
- ;; inlined. See
- ;; cl-do-proclaim.
- (vector nil) 1))
- lambdas))
- (byte-compile-macro-environment
- (pairlis names (mapcar
- #'(lambda (placeholder)
- `(lambda (&rest cl-labels-args)
- ;; Be careful not to quote
- ;; PLACEHOLDER, otherwise
- ;; byte-optimize-funcall inlines
- ;; it.
- (list* 'funcall ,placeholder
- cl-labels-args)))
- placeholders)
- byte-compile-macro-environment))
- (gensym (gensym)))
- (labels
- ((byte-compile-transform-labels (form names lambdas
- placeholders)
- (let* ((inline
- (mapcan
- #'(lambda (name placeholder lambda)
- (and
- (eq
- (getf (aref
- (compiled-function-constants
- placeholder) 0)
- 'byte-optimizer)
- 'byte-compile-inline-expand)
- `(((function ,placeholder)
- ,(byte-compile-lambda lambda name)
- (function ,lambda)))))
- names placeholders lambdas))
- (compiled
- (mapcar* #'byte-compile-lambda
- (if (not inline)
- lambdas
- ;; See further down for the
- ;; rationale of the sublis calls.
- (sublis (pairlis
- (mapcar #'cadar inline)
- (mapcar #'third inline))
- (sublis
- (pairlis
- (mapcar #'car inline)
- (mapcar #'second inline))
- lambdas :test #'equal)
-:test #'eq))
- names))
- elt)
- (mapc #'(lambda (placeholder function)
- (nsubst function placeholder compiled
-:test #'eq
-:descend-structures t))
- placeholders compiled)
- (when inline
- (dolist (triad inline)
- (nsubst (setq elt (elt compiled
- (position (cadar triad)
- placeholders)))
- (second triad) compiled :test #'eq
-:descend-structures t)
- (setf (second triad) elt))
- ;; For inlined labels: first, replace uses of
- ;; the placeholder in places where it's not an
- ;; evident, explicit funcall (that is, where
- ;; it is not to be inlined) with the compiled
- ;; function:
- (setq form (sublis
- (pairlis (mapcar #'car inline)
- (mapcar #'second inline))
- form :test #'equal)
- ;; Now replace uses of the placeholder
- ;; where it is an evident funcall with the
- ;; lambda, quoted as a function, to allow
- ;; byte-optimize-funcall to do its
- ;; thing. Note that the lambdas still have
- ;; the placeholders, so there's no risk
- ;; of recursive inlining.
- form (sublis (pairlis
- (mapcar #'cadar inline)
- (mapcar #'third inline))
- form :test #'eq)))
- (sublis (pairlis placeholders compiled) form
-:test #'eq))))
- (put gensym 'byte-compile
- #'(lambda (form)
- (let* ((names (cadr (cl-pop2 form)))
- (lambdas (mapcar #'cadr (cdr (pop form))))
- (placeholders (cadr (pop form))))
- (byte-compile-body-do-effect
- (byte-compile-transform-labels form names
- lambdas
- placeholders)))))
- (put gensym 'byte-hunk-handler
- #'(lambda (form)
- (let* ((names (cadr (cl-pop2 form)))
- (lambdas (mapcar #'cadr (cdr (pop form))))
- (placeholders (cadr (pop form))))
- (byte-compile-file-form
- (cons 'progn
- (byte-compile-transform-labels
- form names lambdas placeholders))))))
- (setq body
- (cl-macroexpand-all `(,gensym ',names (list ,＠lambdas)
- ',placeholders ,＠body)
- byte-compile-macro-environment))
- (if (position 'lambda (mapcar #'(lambda (object)
- (car-safe (cdr-safe
- object)))
- (cdr (third body)))
- :key #'car-safe :test-not #'eq)
- ;; #'lexical-let has worked its magic, not all the
- ;; lambdas are lambdas. Give up on pre-compiling the
- ;; labels.
- (setq names (mapcar #'copy-symbol names)
- lambdas (cdr (third body))
- body (sublis (pairlis placeholders names)
- (nthcdr 4 body) :test #'eq)
- lambdas (sublis (pairlis placeholders names)
- lambdas :test #'eq)
- body (cl-macroexpand-all
- `(lexical-let
- ,names
- (setf ,＠(mapcan #'list names lambdas))
- ,＠body)
- byte-compile-macro-environment))
- body)))))
+ . ,(symbol-macrolet ((wrapper '#:labels))
+ (labels
+ ((cannot-inline-alist (placeholders lambdas)
+ (let ((inline
+ ;; What labels should be inline?
+ (remove-if-not
+ #'(lambda (placeholder)
+ (eq 'byte-compile-inline-expand
+ (get placeholder
+ 'byte-optimizer)))
+ placeholders)))
+ ;; Which of those labels--that should be
+ ;; inline--reference themeselves, or other labels that
+ ;; should be inline? Give a an alist mapping them to
+ ;; their data placeholders.
+ (mapcan
+ #'(lambda (placeholder lambda)
+ (and
+ (eq 'byte-compile-inline-expand
+ (get placeholder 'byte-optimizer))
+ (block find
+ (subst-if nil
+ #'(lambda (tree)
+ (if (memq tree inline)
+ (return-from find t)))
+ lambda)
+ nil)
+ `((,placeholder
+ . ,(get placeholder
+ 'byte-compile-data-placeholder)))))
+ placeholders lambdas)))
+ (destructure-labels (form for-effect)
+ (let* ((names (cadr (cl-pop2 form)))
+ (lambdas (mapcar #'cadr (cdr (pop form))))
+ (placeholders (cadr (pop form)))
+ (cannot-inline-alist (cannot-inline-alist
+ placeholders lambdas))
+ (lambdas (sublis cannot-inline-alist
+ lambdas :test #'eq)))
+ ;; Used specially, note the bindings in our callers.
+ (setq byte-compile-function-environment
+ (pairlis
+ (mapcar #'cdr cannot-inline-alist)
+ (mapcar #'car cannot-inline-alist)
+ (pairlis placeholders lambdas
+ byte-compile-function-environment)))
+ (if (memq byte-optimize '(t source))
+ (setq lambdas
+ (mapcar #'cadr (mapcar #'byte-optimize-form
+ lambdas))
+ form (byte-optimize-body form for-effect)))
+ (values placeholders lambdas names form)))
+ (warn-about-unused-labels (names placeholders)
+ (when (memq 'unused-vars byte-compile-warnings)
+ (loop
+ for placeholder in placeholders
+ for name in names
+ if (eql 0 (+ (get placeholder
+ 'byte-compile-label-calls 0)
+ (get (get placeholder
+ 'byte-compile-data-placeholder
+ '#:no-such-data-placeholder)
+ 'byte-compile-label-calls 0)))
+ do (byte-compile-warn
+ "label %s bound but not referenced" name))))
+ (byte-compile-transform-labels (form names lambdas
+ placeholders)
+ (let ((compiled
+ (mapcar* #'byte-compile-lambda lambdas names)))
+ (warn-about-unused-labels names placeholders)
+ (mapc #'(lambda (placeholder function)
+ (nsubst function placeholder compiled
+:test #'eq
+:descend-structures t)
+ (nsubst function
+ (get placeholder
+ 'byte-compile-data-placeholder)
+ compiled :test #'eq
+:descend-structures t))
+ placeholders compiled)
+ (sublis (pairlis
+ placeholders compiled
+ (pairlis
+ (mapcar*
+ #'get placeholders
+ (load-time-value
+ (let ((list
+ (list
+ 'byte-compile-data-placeholder)))
+ (nconc list list))))
+ compiled))
+ form :test #'eq))))
+ (put wrapper 'byte-compile
+ #'(lambda (form)
+ (let ((byte-compile-function-environment
+ byte-compile-function-environment))
+ (multiple-value-bind
+ (placeholders lambdas names form)
+ (destructure-labels form for-effect)
+ (byte-compile-body-do-effect
+ (byte-compile-transform-labels form names
+ lambdas
+ placeholders))))))
+ (put wrapper 'byte-hunk-handler
+ #'(lambda (form)
+ (let ((byte-compile-function-environment
+ byte-compile-function-environment))
+ (multiple-value-bind
+ (placeholders lambdas names form)
+ (destructure-labels form t)
+ (byte-compile-file-form
+ (cons 'progn
+ (byte-compile-transform-labels
+ form names lambdas placeholders)))))))
+ (put wrapper 'cl-compiler-macro
+ ;; This is only used when optimizing code.
+ #'(lambda (form &rest ignore)
+ (let ((byte-compile-function-environment
+ byte-compile-function-environment)
+ byte-optimize-form retry)
+ (multiple-value-bind
+ (placeholders lambdas)
+ (destructure-labels form for-effect)
+ ;; Optimize most of the form, in passing
+ ;; expanding macros.
+ (setq byte-optimize-form
+ (mapcar #'byte-optimize-form
+ (list* (nth 1 form) `(list ,＠lambdas)
+ (cdddr form))))
+ ;; It may be reasonable to inline any labels
+ ;; used only once.
+ (dolist (placeholder placeholders)
+ (and
+ (not (eq 'byte-compile-inline-expand
+ (get placeholder 'byte-optimizer)))
+ (eql 0 (get (get placeholder
+ 'byte-compile-data-placeholder
+ '#:no-such-data-placeholder)
+ 'byte-compile-label-calls 0))
+ (eql 1 (get placeholder
+ 'byte-compile-label-calls 0))
+ (progn
+ (byte-compile-log
+ "label %s is used only once, inlining it"
+ placeholder)
+ (setq retry t)
+ (cl-do-proclaim `(inline ,placeholder) t))))
+ (when retry
+ (multiple-value-setq
+ (placeholders lambdas)
+ (destructure-labels form for-effect))
+ (setq byte-optimize-form
+ (mapcar #'byte-optimize-form
+ (list* (nth 1 form)
+ `(list ,＠lambdas)
+ (cdddr form)))))
+ (if (equal (cdr form) byte-optimize-form)
+ form
+ (cons (car form) byte-optimize-form)))))))
+ #'(lambda (bindings &rest body)
+ (let* ((names (mapcar 'car bindings))
+ (lambdas (mapcar
+ (function*
+ (lambda ((name . definition))
+ `#'(lambda ,＠(cdr (cl-transform-lambda
+ definition name)))))
+ bindings))
+ (placeholders (mapcar #'copy-symbol names))
+ (byte-compile-macro-environment
+ (pairlis names
+ (mapcar
+ #'(lambda (placeholder)
+ `(lambda (&rest byte-compile-labels-args)
+ (put
+ ',placeholder
+ 'byte-compile-label-calls
+ (1+ (get ',placeholder
+ 'byte-compile-label-calls
+ 0)))
+ (cons ',placeholder
+ byte-compile-labels-args)))
+ placeholders)
+ byte-compile-macro-environment)))
+ ;; Tell the macroexpansion code what symbol to use when
+ ;; expanding #'FUNCTION-NAME:
+ (mapc #'put placeholders
+ (load-time-value
+ (let ((list (list 'byte-compile-data-placeholder)))
+ (nconc list list)))
+ (mapcar #'copy-symbol names))
+ (setq body
+ (cl-macroexpand-all
+ `(,wrapper ',names (list ,＠lambdas) ',placeholders
+ ,＠body)
+ byte-compile-macro-environment))
+ (if (position 'lambda (mapcar #'(lambda (object)
+ (car-safe (cdr-safe
+ object)))
+ (cdr (third body)))
+:key #'car-safe :test-not #'eq)
+ ;; #'lexical-let has worked its magic, not all the
+ ;; lambdas are lambdas. Give up on pre-compiling the
+ ;; labels.
+ (setq names (mapcar #'copy-symbol names)
+ lambdas (cdr (third body))
+ body (sublis (pairlis placeholders names)
+ (nthcdr 4 body) :test #'eq)
+ lambdas (sublis (pairlis placeholders names)
+ lambdas :test #'eq)
+ body (cl-macroexpand-all
+ `(lexical-let
+ ,names
+ (setf ,＠(mapcan #'list names lambdas))
+ ,＠body)
+ byte-compile-macro-environment))
+ body)))))
(flet .
,#'(lambda (bindings &rest body)
(let* ((names (mapcar 'car bindings))
＠＠ -1642,8 +1714,7 ＠＠
(unwind-protect
(call-with-condition-handler
- #'(lambda (error-info)
- (byte-compile-report-error error-info))
+ #'byte-compile-report-error
#'(lambda ()
(progn ,＠body)))
;; Always set point in log to start of interesting output.
＠＠ -3010,8 +3081,7 ＠＠
(if (memq 'callargs byte-compile-warnings)
(byte-compile-callargs-warn form))
(byte-compile-normal-call form))))
- ((and (or (compiled-function-p (car form))
- (eq (car-safe (car form)) 'lambda))
+ ((and (eq (car-safe (car form)) 'lambda)
;; if the form comes out the same way it went in, that's
;; because it was malformed, and we couldn't unfold it.
(not (eq form (setq form (byte-compile-unfold-lambda form)))))
＠＠ -3048,9 +3118,8 ＠＠
(map nil
(function*
(lambda ((function . nargs))
- ;; Document that the car of OBJECT, a symbol, describes a function
- ;; taking keyword arguments from the argument index described by
- ;; the cdr of OBJECT.
+ ;; Document that FUNCTION, a symbol, describes a function taking
+ ;; keyword arguments from the argument index described by NARGS.
(put function 'byte-compile-keyword-start nargs)))
'((adjoin . 3) (assoc* . 3) (assoc-if . 3) (assoc-if-not . 3)
(count . 3) (count-if . 3) (count-if-not . 3) (define-behavior . 3)
＠＠ -4175,34 +4244,8 ＠＠
(byte-compile-constp (second form)))
(byte-compile-callargs-warn (cons (cl-const-expr-val (second form))
(nthcdr 2 form))))
- (if (and byte-optimize
- (eq 'function (car-safe (cadr form)))
- (eq 'lambda (car-safe (cadadr form)))
- (or
- (not (eq (setq form (cons (cadadr form) (cddr form)))
- (setq form (byte-compile-unfold-lambda form))))
- (prog1 nil (setq form `(funcall #',(car form) ,＠(cdr form))))))
- ;; The byte-compile part of the #'labels implementation, above,
- ;; happens after macroexpansion and after the source optimizer has
- ;; done its thing. When labels are to be made inline we can have code
- ;; that looks like (funcall #'(lambda ...) ...), when the code that
- ;; the optimizer saw looked like (funcall #<compiled-function ...>
- ;; ...).
- ;;
- ;; So, the optimizer doesn't have the opportunity to transform the
- ;; former to (let (...) ...), and it's reasonable to do that here (since
- ;; the labels implementation doesn't change other code that would need
- ;; running through the optimizer; the lambda itself has already been
- ;; through the optimizer).
- ;;
- ;; Equally reasonable, and conceptually a bit clearer, would be to do
- ;; the transformation to (funcall #'(lambda ...) ...) in the
- ;; byte-optimizer, breaking most of the #'sublis calls out of the
- ;; byte-compile method.
- (byte-compile-form form)
- (mapc 'byte-compile-form (cdr form))
- (byte-compile-out 'byte-call (length (cdr (cdr form))))))
-
+ (mapc 'byte-compile-form (cdr form))
+ (byte-compile-out 'byte-call (length (cdr (cdr form)))))
(defun byte-compile-let (form)
;; First compute the binding values in the old scope.
diff -r b7ae5f44b950 -r e9c3fe82127d lisp/cl-extra.el
--- a/lisp/cl-extra.el Sat May 05 18:42:00 2012 +0100
+++ b/lisp/cl-extra.el Sat May 05 20:48:24 2012 +0100
＠＠ -569,19 +569,26 ＠＠
;; This is a bit of a hack; special-case symbols with bindings as
;; labels.
(let ((found (cdr (assq (cadr form) env))))
- (if (and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
- (if (consp (nth 2 (nth 2 found)))
- ;; It's a cons; this is the implementation of
- ;; labels in cl-macs.el.
- (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env)
- ;; It's an atom, almost certainly a compiled function;
- ;; we're using the implementation of labels in
- ;; bytecomp.el. Quote it with FUNCTION so that code can
- ;; tell uses as data apart from the uses with funcall,
- ;; where it's unquoted. #### We should warn if (car form)
- ;; above is quote, rather than function.
- (list 'function (nth 2 (nth 2 found))))
- form))))
+ (cond
+ ((and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
+ ;; This is the implementation of labels in cl-macs.el.
+ (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env))
+ ((and (consp found) (eq (nth 1 (nth 1 found))
+ 'byte-compile-labels-args))
+ ;; We're using the implementation of labels in
+ ;; bytecomp.el. Quote its data-placeholder with FUNCTION so
+ ;; that code can tell uses as data apart from the uses with
+ ;; funcall.
+ (unless (eq 'function (car form))
+ (byte-compile-warn
+ "deprecated: '%s, use #'%s instead to quote it as a function"
+ (cadr form) (cadr form)))
+ (setq found (get (nth 1 (nth 1 (nth 3 found)))
+ 'byte-compile-data-placeholder))
+ (put found 'byte-compile-label-calls
+ (1+ (get found 'byte-compile-label-calls 0)))
+ (list 'function found))
+ (t 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)))
diff -r b7ae5f44b950 -r e9c3fe82127d lisp/cl-macs.el
--- a/lisp/cl-macs.el Sat May 05 18:42:00 2012 +0100
+++ b/lisp/cl-macs.el Sat May 05 20:48:24 2012 +0100
＠＠ -1863,39 +1863,40 ＠＠
byte-compile-bound-variables))))
((eq (car-safe spec) 'inline)
- (while (setq spec (cdr spec))
- (let ((assq (cdr (assq (car spec) byte-compile-macro-environment))))
- (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args)
- (atom (setq assq (nth 2 (nth 2 assq)))))
- ;; It's a label, and we're using the labels
- ;; implementation in bytecomp.el. Tell the compiler
- ;; to inline it, don't mark the symbol to be inlined
- ;; globally.
- (setf (getf (aref (compiled-function-constants assq) 0)
- 'byte-optimizer)
- 'byte-compile-inline-expand)
- (or (memq (get (car spec) 'byte-optimizer)
- '(nil byte-compile-inline-expand))
- (error
- "%s already has a byte-optimizer, can't make it inline"
- (car spec)))
- (put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))))
+ (while (setq spec (cdr spec))
+ (let* ((assq (cdr (assq (car spec)
+ byte-compile-macro-environment)))
+ (symbol (if (and (consp assq)
+ (eq (nth 1 (nth 1 assq))
+ 'byte-compile-labels-args))
+ ;; It's a label, and we're using the labels
+ ;; implementation in bytecomp.el. Tell the
+ ;; compiler to inline it, don't mark the
+ ;; symbol to be inlined globally.
+ (nth 1 (nth 1 (nth 3 assq)))
+ (car spec))))
+ (or (memq (get symbol 'byte-optimizer)
+ '(nil byte-compile-inline-expand))
+ (error
+ "%s already has a byte-optimizer, can't make it inline"
+ symbol))
+ (put symbol 'byte-optimizer 'byte-compile-inline-expand))))
((eq (car-safe spec) 'notinline)
(while (setq spec (cdr spec))
- (let ((assq (cdr (assq (car spec) byte-compile-macro-environment))))
- (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args)
- (atom (setq assq (nth 2 (nth 2 assq)))))
- ;; It's a label, and we're using the labels
- ;; implementation in bytecomp.el. Tell the compiler
- ;; not to inline it.
- (if (eq 'byte-compile-inline-expand
- (getf (aref (compiled-function-constants assq) 0)
- 'byte-optimizer))
- (remf (aref (compiled-function-constants assq) 0)
- 'byte-optimizer))
- (if (eq (get (car spec) 'byte-optimizer)
- 'byte-compile-inline-expand)
- (put (car spec) 'byte-optimizer nil))))))
+ (let* ((assq (cdr (assq (car spec)
+ byte-compile-macro-environment)))
+ (symbol (if (and (consp assq)
+ (eq (nth 1 (nth 1 assq))
+ 'byte-compile-labels-args))
+ ;; It's a label, and we're using the labels
+ ;; implementation in bytecomp.el. Tell the
+ ;; compiler not to inline it, don't mark the
+ ;; symbol to be notinline globally.
+ (nth 1 (nth 1 (nth 3 assq)))
+ (car spec))))
+ (if (eq (get symbol 'byte-optimizer)
+ 'byte-compile-inline-expand)
+ (put symbol 'byte-optimizer nil)))))
((eq (car-safe spec) 'optimize)
(let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
'((0 . nil) (1 . t) (2 . t) (3 . t))))
diff -r b7ae5f44b950 -r e9c3fe82127d lisp/gui.el
--- a/lisp/gui.el Sat May 05 18:42:00 2012 +0100
+++ b/lisp/gui.el Sat May 05 20:48:24 2012 +0100
＠＠ -105,10 +105,10 ＠＠
(vector 'button
:descriptor string
:face 'gui-button-face
-:callback-ex `(lambda (image-instance event)
- (gui-button-action image-instance
- (quote ,action)
- (quote ,user-data))))))
+:callback-ex
+ `(lambda (image-instance event)
+ (funcall ,#'gui-button-action image-instance ',action
+ ',user-data)))))
(defun insert-gui-button (button &optional pos buffer)
"Insert GUI button BUTTON at POS in BUFFER."
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit/XEmacs: kehoea: Co-operate with the byte-optimizer in the bytecomp.el labels implementation.
12 years, 8 months
Bitbucket
Bitbucket
1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/changeset/e9c3fe82127d/
changeset: e9c3fe82127d
user: kehoea
date: 2012-05-05 21:48:24
summary: Co-operate with the byte-optimizer in the bytecomp.el labels implementation.
lisp/ChangeLog addition:
2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
Co-operate with the byte-optimizer in the bytecomp.el labels
implementation, don't work against it.
* byte-optimize.el:
* byte-optimize.el (byte-compile-inline-expand):
Call #'byte-compile-unfold-lambda explicitly here, don't assume
that the byte-optimizer will do it.
* byte-optimize.el (byte-compile-unfold-lambda):
Call #'byte-optimize-body on the body, don't just mapcar
#'byte-optimize-form along it.
* byte-optimize.el (byte-optimize-lambda): New. Optimize a lambda
form.
* byte-optimize.el (byte-optimize-form-code-walker):
Descend lambda expressions, defun, and defmacro, relevant for
lexically-oriented operators like #'labels.
* byte-optimize.el (byte-optimize-body): Only return a non-eq
object if we've actually optimized something
* bytecomp.el (byte-compile-initial-macro-environment):
In the labels implementation, work with the byte optimizer, not
against it; warn when labels are defined but not used,
automatically inline labels that are used only once.
* bytecomp.el (byte-recompile-directory):
No need to wrap #'byte-compile-report-error in a lambda with
#'call-with-condition-handler here.
* bytecomp.el (byte-compile-form):
Don't inline compiled-function objects, they're probably labels.
* bytecomp.el (byte-compile-funcall):
No longer inline lambdas, trust the byte optimizer to have done it
properly, even for labels.
* cl-extra.el (cl-macroexpand-all):
Treat labels established by the byte compiler distinctly from
those established by cl-macs.el.
* cl-macs.el (cl-do-proclaim):
Treat labels established by the byte compiler distinctly from
those established by cl-macs.el.
* gui.el (make-gui-button):
When referring to the #'gui-button-action label, quote it using
function, otherwise there's a warning from the byte compiler.
affected #: 6 files
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r e9c3fe82127d71edcf53529e7227785809922ff9 lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
＠＠ -1,3 +1,44 ＠＠
+2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Co-operate with the byte-optimizer in the bytecomp.el labels
+ implementation, don't work against it.
+
+ * byte-optimize.el:
+ * byte-optimize.el (byte-compile-inline-expand):
+ Call #'byte-compile-unfold-lambda explicitly here, don't assume
+ that the byte-optimizer will do it.
+ * byte-optimize.el (byte-compile-unfold-lambda):
+ Call #'byte-optimize-body on the body, don't just mapcar
+ #'byte-optimize-form along it.
+ * byte-optimize.el (byte-optimize-lambda): New. Optimize a lambda
+ form.
+ * byte-optimize.el (byte-optimize-form-code-walker):
+ Descend lambda expressions, defun, and defmacro, relevant for
+ lexically-oriented operators like #'labels.
+ * byte-optimize.el (byte-optimize-body): Only return a non-eq
+ object if we've actually optimized something
+ * bytecomp.el (byte-compile-initial-macro-environment):
+ In the labels implementation, work with the byte optimizer, not
+ against it; warn when labels are defined but not used,
+ automatically inline labels that are used only once.
+ * bytecomp.el (byte-recompile-directory):
+ No need to wrap #'byte-compile-report-error in a lambda with
+ #'call-with-condition-handler here.
+ * bytecomp.el (byte-compile-form):
+ Don't inline compiled-function objects, they're probably labels.
+ * bytecomp.el (byte-compile-funcall):
+ No longer inline lambdas, trust the byte optimizer to have done it
+ properly, even for labels.
+ * cl-extra.el (cl-macroexpand-all):
+ Treat labels established by the byte compiler distinctly from
+ those established by cl-macs.el.
+ * cl-macs.el (cl-do-proclaim):
+ Treat labels established by the byte compiler distinctly from
+ those established by cl-macs.el.
+ * gui.el (make-gui-button):
+ When referring to the #'gui-button-action label, quote it using
+ function, otherwise there's a warning from the byte compiler.
+
2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
Remove some redundant functions; turn other utility functions into
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r e9c3fe82127d71edcf53529e7227785809922ff9 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el
+++ b/lisp/byte-optimize.el
＠＠ -284,19 +284,10 ＠＠
(error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name))
(if (symbolp fn)
(byte-compile-inline-expand (cons fn (cdr form)))
- (if (compiled-function-p fn)
- (progn
- (fetch-bytecode fn)
- (cons (list 'lambda (compiled-function-arglist fn)
- (list 'byte-code
- (compiled-function-instructions fn)
- (compiled-function-constants fn)
- (compiled-function-stack-depth fn)))
- (cdr form)))
- (if (eq (car-safe fn) 'lambda)
- (cons fn (cdr form))
- ;; Give up on inlining.
- form))))))
+ (if (or (eq (car-safe fn) 'lambda) (compiled-function-p fn))
+ (byte-compile-unfold-lambda (cons fn (cdr form)))
+ ;; Give up on inlining.
+ form)))))
;;; ((lambda ...) ...)
;;;
＠＠ -354,7 +345,7 ＠＠
(byte-compile-warn
"attempt to open-code %s with too many arguments" name))
form)
- (setq body (mapcar 'byte-optimize-form body))
+ (setq body (byte-optimize-body body nil))
(let ((newform
(if bindings
(cons 'let (cons (nreverse bindings) body))
＠＠ -363,6 +354,15 ＠＠
newform)))))
+(defun byte-optimize-lambda (form)
+ (let* ((offset 2) (body (nthcdr offset form)))
+ (if (stringp (car body)) (setq body (nthcdr (incf offset) form)))
+ (if (eq 'interactive (car-safe (car body)))
+ (setq body (nthcdr (incf offset) form)))
+ (if (eq body (setq body (byte-optimize-body body nil)))
+ form
+ (nconc (subseq form 0 offset) body))))
+
;;; implementing source-level optimizers
(defun byte-optimize-form-code-walker (form for-effect)
＠＠ -390,9 +390,19 ＠＠
(and (nth 1 form)
(not for-effect)
form))
- ((or (compiled-function-p fn)
- (eq 'lambda (car-safe fn)))
- (byte-compile-unfold-lambda form))
+ ((eq fn 'function)
+ (when (cddr form)
+ (byte-compile-warn "malformed function form: %S" form))
+ (cond
+ (for-effect nil)
+ ((and (eq (car-safe (cadr form)) 'lambda)
+ (not (eq (cadr form) (setq tmp (byte-optimize-lambda
+ (cadr form))))))
+ (list fn tmp))
+ (t form)))
+ ((and (eq 'lambda (car-safe fn))
+ (not (eq form (setq form (byte-compile-unfold-lambda form)))))
+ form)
((memq fn '(let let*))
;; recursively enter the optimizer for the bindings and body
;; of a let or let*. This for depth-firstness: forms that
＠＠ -490,11 +500,19 ＠＠
(prin1-to-string form))
nil)
- ((memq fn '(defun defmacro function
- condition-case save-window-excursion))
- ;; These forms are compiled as constants or by breaking out
- ;; all the subexpressions and compiling them separately.
- form)
+ ((memq fn '(defun defmacro))
+ (if (eq (setq tmp (cons 'lambda (cddr form)))
+ (setq tmp (byte-optimize-lambda tmp)))
+ (cons fn (cdr tmp))
+ form))
+
+ ((eq fn 'condition-case)
+ (list* fn (nth 1 form) (byte-optimize-form (nth 2 form) for-effect)
+ (mapcar #'(lambda (handler)
+ (cons (car handler)
+ (byte-optimize-body (cdr handler)
+ for-effect)))
+ (cdddr form))))
((eq fn 'unwind-protect)
;; the "protected" part of an unwind-protect is compiled (and thus
＠＠ -524,8 +542,11 ＠＠
byte-compile-macro-environment))))
(byte-optimize-form form for-effect))
+ ((compiled-function-p fn)
+ (cons fn (mapcar #'byte-optimize-form (cdr form))))
+
((not (symbolp fn))
- (byte-compile-warn "%s is a malformed function" (prin1-to-string fn))
+ (byte-compile-warn "%S is a malformed function" fn)
form)
;; Support compiler macros as in cl.el.
＠＠ -593,14 +614,17 ＠＠
;; all-for-effect is true. Returns a new list of forms.
(let ((rest forms)
(result nil)
+ (modified nil)
fe new)
(while rest
(setq fe (or all-for-effect (cdr rest)))
(setq new (and (car rest) (byte-optimize-form (car rest) fe)))
(if (or new (not fe))
- (setq result (cons new result)))
+ (setq result (cons new result)
+ modified (or modified (not (eq new (car rest)))))
+ (setq modified t))
(setq rest (cdr rest)))
- (nreverse result)))
+ (if modified (nreverse result) forms)))
;;; some source-level optimizers
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r e9c3fe82127d71edcf53529e7227785809922ff9 lisp/bytecomp.el
--- a/lisp/bytecomp.el
+++ b/lisp/bytecomp.el
＠＠ -522,150 +522,222 ＠＠
#'(lambda (form &optional read-only)
(list wrapper form))))
(labels
- . ,#'(lambda (bindings &rest body)
- (let* ((names (mapcar 'car bindings))
- (lambdas (mapcar
- (function*
- (lambda ((name . definition))
- (cons 'lambda (cdr (cl-transform-lambda
- definition name)))))
- bindings))
- (placeholders
- (mapcar #'(lambda (lambda)
- (make-byte-code (second lambda) "\xc0\x87"
- ;; This list is used for
- ;; the byte-optimize
- ;; property, if the
- ;; function is to be
- ;; inlined. See
- ;; cl-do-proclaim.
- (vector nil) 1))
- lambdas))
- (byte-compile-macro-environment
- (pairlis names (mapcar
- #'(lambda (placeholder)
- `(lambda (&rest cl-labels-args)
- ;; Be careful not to quote
- ;; PLACEHOLDER, otherwise
- ;; byte-optimize-funcall inlines
- ;; it.
- (list* 'funcall ,placeholder
- cl-labels-args)))
- placeholders)
- byte-compile-macro-environment))
- (gensym (gensym)))
- (labels
- ((byte-compile-transform-labels (form names lambdas
- placeholders)
- (let* ((inline
- (mapcan
- #'(lambda (name placeholder lambda)
- (and
- (eq
- (getf (aref
- (compiled-function-constants
- placeholder) 0)
- 'byte-optimizer)
- 'byte-compile-inline-expand)
- `(((function ,placeholder)
- ,(byte-compile-lambda lambda name)
- (function ,lambda)))))
- names placeholders lambdas))
- (compiled
- (mapcar* #'byte-compile-lambda
- (if (not inline)
- lambdas
- ;; See further down for the
- ;; rationale of the sublis calls.
- (sublis (pairlis
- (mapcar #'cadar inline)
- (mapcar #'third inline))
- (sublis
- (pairlis
- (mapcar #'car inline)
- (mapcar #'second inline))
- lambdas :test #'equal)
-:test #'eq))
- names))
- elt)
- (mapc #'(lambda (placeholder function)
- (nsubst function placeholder compiled
-:test #'eq
-:descend-structures t))
- placeholders compiled)
- (when inline
- (dolist (triad inline)
- (nsubst (setq elt (elt compiled
- (position (cadar triad)
- placeholders)))
- (second triad) compiled :test #'eq
-:descend-structures t)
- (setf (second triad) elt))
- ;; For inlined labels: first, replace uses of
- ;; the placeholder in places where it's not an
- ;; evident, explicit funcall (that is, where
- ;; it is not to be inlined) with the compiled
- ;; function:
- (setq form (sublis
- (pairlis (mapcar #'car inline)
- (mapcar #'second inline))
- form :test #'equal)
- ;; Now replace uses of the placeholder
- ;; where it is an evident funcall with the
- ;; lambda, quoted as a function, to allow
- ;; byte-optimize-funcall to do its
- ;; thing. Note that the lambdas still have
- ;; the placeholders, so there's no risk
- ;; of recursive inlining.
- form (sublis (pairlis
- (mapcar #'cadar inline)
- (mapcar #'third inline))
- form :test #'eq)))
- (sublis (pairlis placeholders compiled) form
-:test #'eq))))
- (put gensym 'byte-compile
- #'(lambda (form)
- (let* ((names (cadr (cl-pop2 form)))
- (lambdas (mapcar #'cadr (cdr (pop form))))
- (placeholders (cadr (pop form))))
- (byte-compile-body-do-effect
- (byte-compile-transform-labels form names
- lambdas
- placeholders)))))
- (put gensym 'byte-hunk-handler
- #'(lambda (form)
- (let* ((names (cadr (cl-pop2 form)))
- (lambdas (mapcar #'cadr (cdr (pop form))))
- (placeholders (cadr (pop form))))
- (byte-compile-file-form
- (cons 'progn
- (byte-compile-transform-labels
- form names lambdas placeholders))))))
- (setq body
- (cl-macroexpand-all `(,gensym ',names (list ,＠lambdas)
- ',placeholders ,＠body)
- byte-compile-macro-environment))
- (if (position 'lambda (mapcar #'(lambda (object)
- (car-safe (cdr-safe
- object)))
- (cdr (third body)))
- :key #'car-safe :test-not #'eq)
- ;; #'lexical-let has worked its magic, not all the
- ;; lambdas are lambdas. Give up on pre-compiling the
- ;; labels.
- (setq names (mapcar #'copy-symbol names)
- lambdas (cdr (third body))
- body (sublis (pairlis placeholders names)
- (nthcdr 4 body) :test #'eq)
- lambdas (sublis (pairlis placeholders names)
- lambdas :test #'eq)
- body (cl-macroexpand-all
- `(lexical-let
- ,names
- (setf ,＠(mapcan #'list names lambdas))
- ,＠body)
- byte-compile-macro-environment))
- body)))))
+ . ,(symbol-macrolet ((wrapper '#:labels))
+ (labels
+ ((cannot-inline-alist (placeholders lambdas)
+ (let ((inline
+ ;; What labels should be inline?
+ (remove-if-not
+ #'(lambda (placeholder)
+ (eq 'byte-compile-inline-expand
+ (get placeholder
+ 'byte-optimizer)))
+ placeholders)))
+ ;; Which of those labels--that should be
+ ;; inline--reference themeselves, or other labels that
+ ;; should be inline? Give a an alist mapping them to
+ ;; their data placeholders.
+ (mapcan
+ #'(lambda (placeholder lambda)
+ (and
+ (eq 'byte-compile-inline-expand
+ (get placeholder 'byte-optimizer))
+ (block find
+ (subst-if nil
+ #'(lambda (tree)
+ (if (memq tree inline)
+ (return-from find t)))
+ lambda)
+ nil)
+ `((,placeholder
+ . ,(get placeholder
+ 'byte-compile-data-placeholder)))))
+ placeholders lambdas)))
+ (destructure-labels (form for-effect)
+ (let* ((names (cadr (cl-pop2 form)))
+ (lambdas (mapcar #'cadr (cdr (pop form))))
+ (placeholders (cadr (pop form)))
+ (cannot-inline-alist (cannot-inline-alist
+ placeholders lambdas))
+ (lambdas (sublis cannot-inline-alist
+ lambdas :test #'eq)))
+ ;; Used specially, note the bindings in our callers.
+ (setq byte-compile-function-environment
+ (pairlis
+ (mapcar #'cdr cannot-inline-alist)
+ (mapcar #'car cannot-inline-alist)
+ (pairlis placeholders lambdas
+ byte-compile-function-environment)))
+ (if (memq byte-optimize '(t source))
+ (setq lambdas
+ (mapcar #'cadr (mapcar #'byte-optimize-form
+ lambdas))
+ form (byte-optimize-body form for-effect)))
+ (values placeholders lambdas names form)))
+ (warn-about-unused-labels (names placeholders)
+ (when (memq 'unused-vars byte-compile-warnings)
+ (loop
+ for placeholder in placeholders
+ for name in names
+ if (eql 0 (+ (get placeholder
+ 'byte-compile-label-calls 0)
+ (get (get placeholder
+ 'byte-compile-data-placeholder
+ '#:no-such-data-placeholder)
+ 'byte-compile-label-calls 0)))
+ do (byte-compile-warn
+ "label %s bound but not referenced" name))))
+ (byte-compile-transform-labels (form names lambdas
+ placeholders)
+ (let ((compiled
+ (mapcar* #'byte-compile-lambda lambdas names)))
+ (warn-about-unused-labels names placeholders)
+ (mapc #'(lambda (placeholder function)
+ (nsubst function placeholder compiled
+:test #'eq
+:descend-structures t)
+ (nsubst function
+ (get placeholder
+ 'byte-compile-data-placeholder)
+ compiled :test #'eq
+:descend-structures t))
+ placeholders compiled)
+ (sublis (pairlis
+ placeholders compiled
+ (pairlis
+ (mapcar*
+ #'get placeholders
+ (load-time-value
+ (let ((list
+ (list
+ 'byte-compile-data-placeholder)))
+ (nconc list list))))
+ compiled))
+ form :test #'eq))))
+ (put wrapper 'byte-compile
+ #'(lambda (form)
+ (let ((byte-compile-function-environment
+ byte-compile-function-environment))
+ (multiple-value-bind
+ (placeholders lambdas names form)
+ (destructure-labels form for-effect)
+ (byte-compile-body-do-effect
+ (byte-compile-transform-labels form names
+ lambdas
+ placeholders))))))
+ (put wrapper 'byte-hunk-handler
+ #'(lambda (form)
+ (let ((byte-compile-function-environment
+ byte-compile-function-environment))
+ (multiple-value-bind
+ (placeholders lambdas names form)
+ (destructure-labels form t)
+ (byte-compile-file-form
+ (cons 'progn
+ (byte-compile-transform-labels
+ form names lambdas placeholders)))))))
+ (put wrapper 'cl-compiler-macro
+ ;; This is only used when optimizing code.
+ #'(lambda (form &rest ignore)
+ (let ((byte-compile-function-environment
+ byte-compile-function-environment)
+ byte-optimize-form retry)
+ (multiple-value-bind
+ (placeholders lambdas)
+ (destructure-labels form for-effect)
+ ;; Optimize most of the form, in passing
+ ;; expanding macros.
+ (setq byte-optimize-form
+ (mapcar #'byte-optimize-form
+ (list* (nth 1 form) `(list ,＠lambdas)
+ (cdddr form))))
+ ;; It may be reasonable to inline any labels
+ ;; used only once.
+ (dolist (placeholder placeholders)
+ (and
+ (not (eq 'byte-compile-inline-expand
+ (get placeholder 'byte-optimizer)))
+ (eql 0 (get (get placeholder
+ 'byte-compile-data-placeholder
+ '#:no-such-data-placeholder)
+ 'byte-compile-label-calls 0))
+ (eql 1 (get placeholder
+ 'byte-compile-label-calls 0))
+ (progn
+ (byte-compile-log
+ "label %s is used only once, inlining it"
+ placeholder)
+ (setq retry t)
+ (cl-do-proclaim `(inline ,placeholder) t))))
+ (when retry
+ (multiple-value-setq
+ (placeholders lambdas)
+ (destructure-labels form for-effect))
+ (setq byte-optimize-form
+ (mapcar #'byte-optimize-form
+ (list* (nth 1 form)
+ `(list ,＠lambdas)
+ (cdddr form)))))
+ (if (equal (cdr form) byte-optimize-form)
+ form
+ (cons (car form) byte-optimize-form)))))))
+ #'(lambda (bindings &rest body)
+ (let* ((names (mapcar 'car bindings))
+ (lambdas (mapcar
+ (function*
+ (lambda ((name . definition))
+ `#'(lambda ,＠(cdr (cl-transform-lambda
+ definition name)))))
+ bindings))
+ (placeholders (mapcar #'copy-symbol names))
+ (byte-compile-macro-environment
+ (pairlis names
+ (mapcar
+ #'(lambda (placeholder)
+ `(lambda (&rest byte-compile-labels-args)
+ (put
+ ',placeholder
+ 'byte-compile-label-calls
+ (1+ (get ',placeholder
+ 'byte-compile-label-calls
+ 0)))
+ (cons ',placeholder
+ byte-compile-labels-args)))
+ placeholders)
+ byte-compile-macro-environment)))
+ ;; Tell the macroexpansion code what symbol to use when
+ ;; expanding #'FUNCTION-NAME:
+ (mapc #'put placeholders
+ (load-time-value
+ (let ((list (list 'byte-compile-data-placeholder)))
+ (nconc list list)))
+ (mapcar #'copy-symbol names))
+ (setq body
+ (cl-macroexpand-all
+ `(,wrapper ',names (list ,＠lambdas) ',placeholders
+ ,＠body)
+ byte-compile-macro-environment))
+ (if (position 'lambda (mapcar #'(lambda (object)
+ (car-safe (cdr-safe
+ object)))
+ (cdr (third body)))
+:key #'car-safe :test-not #'eq)
+ ;; #'lexical-let has worked its magic, not all the
+ ;; lambdas are lambdas. Give up on pre-compiling the
+ ;; labels.
+ (setq names (mapcar #'copy-symbol names)
+ lambdas (cdr (third body))
+ body (sublis (pairlis placeholders names)
+ (nthcdr 4 body) :test #'eq)
+ lambdas (sublis (pairlis placeholders names)
+ lambdas :test #'eq)
+ body (cl-macroexpand-all
+ `(lexical-let
+ ,names
+ (setf ,＠(mapcan #'list names lambdas))
+ ,＠body)
+ byte-compile-macro-environment))
+ body)))))
(flet .
,#'(lambda (bindings &rest body)
(let* ((names (mapcar 'car bindings))
＠＠ -1642,8 +1714,7 ＠＠
(unwind-protect
(call-with-condition-handler
- #'(lambda (error-info)
- (byte-compile-report-error error-info))
+ #'byte-compile-report-error
#'(lambda ()
(progn ,＠body)))
;; Always set point in log to start of interesting output.
＠＠ -3010,8 +3081,7 ＠＠
(if (memq 'callargs byte-compile-warnings)
(byte-compile-callargs-warn form))
(byte-compile-normal-call form))))
- ((and (or (compiled-function-p (car form))
- (eq (car-safe (car form)) 'lambda))
+ ((and (eq (car-safe (car form)) 'lambda)
;; if the form comes out the same way it went in, that's
;; because it was malformed, and we couldn't unfold it.
(not (eq form (setq form (byte-compile-unfold-lambda form)))))
＠＠ -3048,9 +3118,8 ＠＠
(map nil
(function*
(lambda ((function . nargs))
- ;; Document that the car of OBJECT, a symbol, describes a function
- ;; taking keyword arguments from the argument index described by
- ;; the cdr of OBJECT.
+ ;; Document that FUNCTION, a symbol, describes a function taking
+ ;; keyword arguments from the argument index described by NARGS.
(put function 'byte-compile-keyword-start nargs)))
'((adjoin . 3) (assoc* . 3) (assoc-if . 3) (assoc-if-not . 3)
(count . 3) (count-if . 3) (count-if-not . 3) (define-behavior . 3)
＠＠ -4175,34 +4244,8 ＠＠
(byte-compile-constp (second form)))
(byte-compile-callargs-warn (cons (cl-const-expr-val (second form))
(nthcdr 2 form))))
- (if (and byte-optimize
- (eq 'function (car-safe (cadr form)))
- (eq 'lambda (car-safe (cadadr form)))
- (or
- (not (eq (setq form (cons (cadadr form) (cddr form)))
- (setq form (byte-compile-unfold-lambda form))))
- (prog1 nil (setq form `(funcall #',(car form) ,＠(cdr form))))))
- ;; The byte-compile part of the #'labels implementation, above,
- ;; happens after macroexpansion and after the source optimizer has
- ;; done its thing. When labels are to be made inline we can have code
- ;; that looks like (funcall #'(lambda ...) ...), when the code that
- ;; the optimizer saw looked like (funcall #<compiled-function ...>
- ;; ...).
- ;;
- ;; So, the optimizer doesn't have the opportunity to transform the
- ;; former to (let (...) ...), and it's reasonable to do that here (since
- ;; the labels implementation doesn't change other code that would need
- ;; running through the optimizer; the lambda itself has already been
- ;; through the optimizer).
- ;;
- ;; Equally reasonable, and conceptually a bit clearer, would be to do
- ;; the transformation to (funcall #'(lambda ...) ...) in the
- ;; byte-optimizer, breaking most of the #'sublis calls out of the
- ;; byte-compile method.
- (byte-compile-form form)
- (mapc 'byte-compile-form (cdr form))
- (byte-compile-out 'byte-call (length (cdr (cdr form))))))
-
+ (mapc 'byte-compile-form (cdr form))
+ (byte-compile-out 'byte-call (length (cdr (cdr form)))))
(defun byte-compile-let (form)
;; First compute the binding values in the old scope.
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r e9c3fe82127d71edcf53529e7227785809922ff9 lisp/cl-extra.el
--- a/lisp/cl-extra.el
+++ b/lisp/cl-extra.el
＠＠ -569,19 +569,26 ＠＠
;; This is a bit of a hack; special-case symbols with bindings as
;; labels.
(let ((found (cdr (assq (cadr form) env))))
- (if (and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
- (if (consp (nth 2 (nth 2 found)))
- ;; It's a cons; this is the implementation of
- ;; labels in cl-macs.el.
- (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env)
- ;; It's an atom, almost certainly a compiled function;
- ;; we're using the implementation of labels in
- ;; bytecomp.el. Quote it with FUNCTION so that code can
- ;; tell uses as data apart from the uses with funcall,
- ;; where it's unquoted. #### We should warn if (car form)
- ;; above is quote, rather than function.
- (list 'function (nth 2 (nth 2 found))))
- form))))
+ (cond
+ ((and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
+ ;; This is the implementation of labels in cl-macs.el.
+ (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env))
+ ((and (consp found) (eq (nth 1 (nth 1 found))
+ 'byte-compile-labels-args))
+ ;; We're using the implementation of labels in
+ ;; bytecomp.el. Quote its data-placeholder with FUNCTION so
+ ;; that code can tell uses as data apart from the uses with
+ ;; funcall.
+ (unless (eq 'function (car form))
+ (byte-compile-warn
+ "deprecated: '%s, use #'%s instead to quote it as a function"
+ (cadr form) (cadr form)))
+ (setq found (get (nth 1 (nth 1 (nth 3 found)))
+ 'byte-compile-data-placeholder))
+ (put found 'byte-compile-label-calls
+ (1+ (get found 'byte-compile-label-calls 0)))
+ (list 'function found))
+ (t 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)))
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r e9c3fe82127d71edcf53529e7227785809922ff9 lisp/cl-macs.el
--- a/lisp/cl-macs.el
+++ b/lisp/cl-macs.el
＠＠ -1863,39 +1863,40 ＠＠
byte-compile-bound-variables))))
((eq (car-safe spec) 'inline)
- (while (setq spec (cdr spec))
- (let ((assq (cdr (assq (car spec) byte-compile-macro-environment))))
- (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args)
- (atom (setq assq (nth 2 (nth 2 assq)))))
- ;; It's a label, and we're using the labels
- ;; implementation in bytecomp.el. Tell the compiler
- ;; to inline it, don't mark the symbol to be inlined
- ;; globally.
- (setf (getf (aref (compiled-function-constants assq) 0)
- 'byte-optimizer)
- 'byte-compile-inline-expand)
- (or (memq (get (car spec) 'byte-optimizer)
- '(nil byte-compile-inline-expand))
- (error
- "%s already has a byte-optimizer, can't make it inline"
- (car spec)))
- (put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))))
+ (while (setq spec (cdr spec))
+ (let* ((assq (cdr (assq (car spec)
+ byte-compile-macro-environment)))
+ (symbol (if (and (consp assq)
+ (eq (nth 1 (nth 1 assq))
+ 'byte-compile-labels-args))
+ ;; It's a label, and we're using the labels
+ ;; implementation in bytecomp.el. Tell the
+ ;; compiler to inline it, don't mark the
+ ;; symbol to be inlined globally.
+ (nth 1 (nth 1 (nth 3 assq)))
+ (car spec))))
+ (or (memq (get symbol 'byte-optimizer)
+ '(nil byte-compile-inline-expand))
+ (error
+ "%s already has a byte-optimizer, can't make it inline"
+ symbol))
+ (put symbol 'byte-optimizer 'byte-compile-inline-expand))))
((eq (car-safe spec) 'notinline)
(while (setq spec (cdr spec))
- (let ((assq (cdr (assq (car spec) byte-compile-macro-environment))))
- (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args)
- (atom (setq assq (nth 2 (nth 2 assq)))))
- ;; It's a label, and we're using the labels
- ;; implementation in bytecomp.el. Tell the compiler
- ;; not to inline it.
- (if (eq 'byte-compile-inline-expand
- (getf (aref (compiled-function-constants assq) 0)
- 'byte-optimizer))
- (remf (aref (compiled-function-constants assq) 0)
- 'byte-optimizer))
- (if (eq (get (car spec) 'byte-optimizer)
- 'byte-compile-inline-expand)
- (put (car spec) 'byte-optimizer nil))))))
+ (let* ((assq (cdr (assq (car spec)
+ byte-compile-macro-environment)))
+ (symbol (if (and (consp assq)
+ (eq (nth 1 (nth 1 assq))
+ 'byte-compile-labels-args))
+ ;; It's a label, and we're using the labels
+ ;; implementation in bytecomp.el. Tell the
+ ;; compiler not to inline it, don't mark the
+ ;; symbol to be notinline globally.
+ (nth 1 (nth 1 (nth 3 assq)))
+ (car spec))))
+ (if (eq (get symbol 'byte-optimizer)
+ 'byte-compile-inline-expand)
+ (put symbol 'byte-optimizer nil)))))
((eq (car-safe spec) 'optimize)
(let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
'((0 . nil) (1 . t) (2 . t) (3 . t))))
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r e9c3fe82127d71edcf53529e7227785809922ff9 lisp/gui.el
--- a/lisp/gui.el
+++ b/lisp/gui.el
＠＠ -105,10 +105,10 ＠＠
(vector 'button
:descriptor string
:face 'gui-button-face
-:callback-ex `(lambda (image-instance event)
- (gui-button-action image-instance
- (quote ,action)
- (quote ,user-data))))))
+:callback-ex
+ `(lambda (image-instance event)
+ (funcall ,#'gui-button-action image-instance ',action
+ ',user-data)))))
(defun insert-gui-button (button &optional pos buffer)
"Insert GUI button BUTTON at POS in BUFFER."
Repository URL: https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Re: [COMMIT] Support predefined character classes in #'skip-chars-{forward, backward}, too
12 years, 8 months
Aidan Kehoe
Aidan Kehoe
Ar an séiú lá de mí Bealtaine, scríobh Stephen J. Turnbull:
> Aidan Kehoe writes:
>
> > +It is also possible to specify named character classes as part of your
> > +character set; for example, ＠samp{[:xdigit:]} will match hexadecimal
> > +digits, ＠samp{[:nonascii:]} will match characters outside the basic
> > +ASCII set. These are documented elsewhere, ＠pxref{Char Classes}.
>
> I think this documentation should mention the (obvious) way to specify
> character sets like "[:alnum" (ie, ":]alnum").
Go for it.
> Also, is "[:alnum" a valid character set or a syntax error? I think it
> probably should be the latter.
It’s the former, which is what GNU does too. It would be reasonable and
compatible to add compile-time warnings to point out that the user has
probably mistyped things.
> > + /* XEmacs; we need this, because we unify treatment of ASCII and non-ASCII
> > + (possible matches) in charset_mule. [:alpha:] matches all characters
> > + with word syntax, with the exception of [0-9]. We don't need
> > + BIT_MULTIBYTE. */
>
> Is this really a good idea? In particular, do grep and Emacs agree
> with this definition of "[:alpha:]"? (The man page for grep on Mac OS
> X suggests that it only includes ASCII characters.)
grep has no understanding of XEmacs character syntax. GNU Emacs [:alpha:]
matches any non-ASCII character with word syntax, and the ASCII characters
[a-zA-Z] . My comment is a little inaccurate, in that what has word syntax
varies with mode, and our behaviour is actually closer to what GNU does than
to what I say.
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Remove some redundant functions, change others to labels, lisp/
12 years, 8 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1336239720 -3600
# Node ID b7ae5f44b95017d6cee969e8353e73eb16a62f01
# Parent ddf56c45634e53e4b1cdfd4777a53c95f6501fb5
Remove some redundant functions, change others to labels, lisp/
lisp/ChangeLog addition:
2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
Remove some redundant functions; turn other utility functions into
labels, avoiding visibility in the global namespace, and reducing
the size of the dumped binary.
* auto-save.el (auto-save-unhex): Removed.
* auto-save.el (auto-save-unescape-name): Use #'string-to-number
instead of #'auto-save-unhex.
* files.el (save-some-buffers):
* files.el (save-some-buffers-1): Changed to a label.
* files.el (not-modified):
* gui.el (make-gui-button):
* gui.el (gui-button-action): Changed to a label.
* gui.el (insert-gui-button):
* indent.el (indent-for-tab-command):
* indent.el (insert-tab): Changed to a label.
* indent.el (indent-rigidly):
* isearch-mode.el:
* isearch-mode.el (isearch-ring-adjust):
* isearch-mode.el (isearch-ring-adjust1): Changed to a label.
* isearch-mode.el (isearch-pre-command-hook):
* isearch-mode.el (isearch-maybe-frob-keyboard-macros): Changed to
a label.
* isearch-mode.el (isearch-highlight):
* isearch-mode.el (isearch-make-extent): Changed to a label.
* itimer.el:
* itimer.el (itimer-decrement): Removed, replaced uses with decf.
* itimer.el (itimer-increment): Removed, replaced uses with incf.
* itimer.el (itimer-signum): Removed, replaced uses with minusp, plusp.
* itimer.el (itimer-name):
* itimer.el (check-itimer): Removed, replaced with #'check-type calls.
* itimer.el (itimer-value):
* itimer.el (check-itimer-coerce-string): Removed.
* itimer.el (itimer-restart):
* itimer.el (itimer-function):
* itimer.el (check-nonnegative-number): Removed.
* itimer.el (itimer-uses-arguments):
* itimer.el (check-string): Removed.
* itimer.el (itimer-function-arguments):
* itimer.el (itimer-recorded-run-time):
* itimer.el (set-itimer-name):
* itimer.el (set-itimer-value):
* itimer.el (set-itimer-value-internal):
* itimer.el (set-itimer-restart):
* itimer.el (set-itimer-function):
* itimer.el (set-itimer-is-idle):
* itimer.el (set-itimer-recorded-run-time):
* itimer.el (get-itimer):
* itimer.el (delete-itimer):
* itimer.el (start-itimer):
* itimer.el (activate-itimer):
* itimer.el (itimer-edit-set-field):
* itimer.el (itimer-edit-next-field):
* itimer.el (itimer-edit-previous-field):
Use incf, decf, plusp, minusp and the more general argument type
checking macros.
* lib-complete.el:
* lib-complete.el (lib-complete:better-root): Changed to a label.
* lib-complete.el (lib-complete:get-completion-table): Changed to
a label.
* lib-complete.el (read-library-internal): Include labels.
* lib-complete.el (lib-complete:cache-completions): Changed to a
label.
* minibuf.el (read-buffer): Use #'set-difference, don't reinvent it.
* newcomment.el (comment-padright): Use a label instead of
repeating a lambda expression.
* packages.el (package-get-key):
* packages.el (package-get-key-1): Removed, use #'getf instead.
* simple.el (kill-backward-chars): Removed; this isn't used.
* simple.el (what-cursor-position):
(lambda (arg) (format "%S" arg) -> #'prin1-to-string.
* simple.el (debug-print-1): Renamed to #'debug-print.
* simple.el (debug-print): Removed, #'debug-print-1 was equivalent.
* subr.el (integer-to-bit-vector): check-nonnegative-number no
longer available.
* widget.el (define-widget):
* widget.el (define-widget-keywords): Removed, this was long obsolete.
diff -r ddf56c45634e -r b7ae5f44b950 lisp/ChangeLog
--- a/lisp/ChangeLog Fri May 04 21:12:51 2012 +0100
+++ b/lisp/ChangeLog Sat May 05 18:42:00 2012 +0100
＠＠ -1,3 +1,82 ＠＠
+2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Remove some redundant functions; turn other utility functions into
+ labels, avoiding visibility in the global namespace, and reducing
+ the size of the dumped binary.
+
+ * auto-save.el (auto-save-unhex): Removed.
+ * auto-save.el (auto-save-unescape-name): Use #'string-to-number
+ instead of #'auto-save-unhex.
+ * files.el (save-some-buffers):
+ * files.el (save-some-buffers-1): Changed to a label.
+ * files.el (not-modified):
+ * gui.el (make-gui-button):
+ * gui.el (gui-button-action): Changed to a label.
+ * gui.el (insert-gui-button):
+ * indent.el (indent-for-tab-command):
+ * indent.el (insert-tab): Changed to a label.
+ * indent.el (indent-rigidly):
+ * isearch-mode.el:
+ * isearch-mode.el (isearch-ring-adjust):
+ * isearch-mode.el (isearch-ring-adjust1): Changed to a label.
+ * isearch-mode.el (isearch-pre-command-hook):
+ * isearch-mode.el (isearch-maybe-frob-keyboard-macros): Changed to
+ a label.
+ * isearch-mode.el (isearch-highlight):
+ * isearch-mode.el (isearch-make-extent): Changed to a label.
+ * itimer.el:
+ * itimer.el (itimer-decrement): Removed, replaced uses with decf.
+ * itimer.el (itimer-increment): Removed, replaced uses with incf.
+ * itimer.el (itimer-signum): Removed, replaced uses with minusp, plusp.
+ * itimer.el (itimer-name):
+ * itimer.el (check-itimer): Removed, replaced with #'check-type calls.
+ * itimer.el (itimer-value):
+ * itimer.el (check-itimer-coerce-string): Removed.
+ * itimer.el (itimer-restart):
+ * itimer.el (itimer-function):
+ * itimer.el (check-nonnegative-number): Removed.
+ * itimer.el (itimer-uses-arguments):
+ * itimer.el (check-string): Removed.
+ * itimer.el (itimer-function-arguments):
+ * itimer.el (itimer-recorded-run-time):
+ * itimer.el (set-itimer-name):
+ * itimer.el (set-itimer-value):
+ * itimer.el (set-itimer-value-internal):
+ * itimer.el (set-itimer-restart):
+ * itimer.el (set-itimer-function):
+ * itimer.el (set-itimer-is-idle):
+ * itimer.el (set-itimer-recorded-run-time):
+ * itimer.el (get-itimer):
+ * itimer.el (delete-itimer):
+ * itimer.el (start-itimer):
+ * itimer.el (activate-itimer):
+ * itimer.el (itimer-edit-set-field):
+ * itimer.el (itimer-edit-next-field):
+ * itimer.el (itimer-edit-previous-field):
+ Use incf, decf, plusp, minusp and the more general argument type
+ checking macros.
+ * lib-complete.el:
+ * lib-complete.el (lib-complete:better-root): Changed to a label.
+ * lib-complete.el (lib-complete:get-completion-table): Changed to
+ a label.
+ * lib-complete.el (read-library-internal): Include labels.
+ * lib-complete.el (lib-complete:cache-completions): Changed to a
+ label.
+ * minibuf.el (read-buffer): Use #'set-difference, don't reinvent it.
+ * newcomment.el (comment-padright): Use a label instead of
+ repeating a lambda expression.
+ * packages.el (package-get-key):
+ * packages.el (package-get-key-1): Removed, use #'getf instead.
+ * simple.el (kill-backward-chars): Removed; this isn't used.
+ * simple.el (what-cursor-position):
+ (lambda (arg) (format "%S" arg) -> #'prin1-to-string.
+ * simple.el (debug-print-1): Renamed to #'debug-print.
+ * simple.el (debug-print): Removed, #'debug-print-1 was equivalent.
+ * subr.el (integer-to-bit-vector): check-nonnegative-number no
+ longer available.
+ * widget.el (define-widget):
+ * widget.el (define-widget-keywords): Removed, this was long obsolete.
+
2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
Avoid #'delq in core code, for the sake of style and a (very
diff -r ddf56c45634e -r b7ae5f44b950 lisp/auto-save.el
--- a/lisp/auto-save.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/auto-save.el Sat May 05 18:42:00 2012 +0100
＠＠ -412,24 +412,15 ＠＠
(char-to-string char))))
str ""))
-(defun auto-save-unhex (x)
- (if (> x ?9)
- (if (>= x ?a)
- (+ 10 (- x ?a))
- (+ 10 (- x ?A)))
- (- x ?0)))
-
(defun auto-save-unescape-name (str)
"Undo any escaping of evil nasty characters in a file name.
See `auto-save-escape-name'."
(setq str (or str ""))
(let ((tmp "")
(case-fold-search t))
- (while (string-match "=[0-9a-f][0-9a-f]" str)
+ (while (string-match #r"=\([0-9a-f][0-9a-f]\)" str)
(let* ((start (match-beginning 0))
- (ch1 (auto-save-unhex (elt str (+ start 1))))
- (code (+ (* 16 ch1)
- (auto-save-unhex (elt str (+ start 2))))))
+ (code (string-to-number (match-string 1 str) 16)))
(setq tmp (concat tmp (substring str 0 start)
(char-to-string code))
str (substring str (match-end 0)))))
diff -r ddf56c45634e -r b7ae5f44b950 lisp/files.el
--- a/lisp/files.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/files.el Sat May 05 18:42:00 2012 +0100
＠＠ -3175,85 +3175,88 ＠＠
If PRED is a zero-argument function, it indicates for each buffer whether
to consider it or not when called with that buffer current."
(interactive "P")
- (save-excursion
- ;; `delete-other-windows' can bomb during autoloads generation, so
- ;; guard it well.
- (if (or noninteractive
- (eq (selected-window) (minibuffer-window))
- (not save-some-buffers-query-display-buffer))
- ;; If playing with windows is unsafe or undesired, just do the
- ;; usual drill.
- (save-some-buffers-1 arg pred nil)
- ;; Else, protect the windows.
- (when (save-window-excursion
- (save-some-buffers-1 arg pred t))
- ;; Force redisplay.
- (sit-for 0)))))
-
-;; XEmacs - do not use queried flag
-(defun save-some-buffers-1 (arg pred switch-buffer)
- (let* ((switched nil)
- (last-buffer nil)
- (files-done
- (map-y-or-n-p
- (lambda (buffer)
- (prog1
- (and (buffer-modified-p buffer)
- (not (buffer-base-buffer buffer))
- ;; XEmacs addition:
- (not (symbol-value-in-buffer 'save-buffers-skip buffer))
- (or
- (buffer-file-name buffer)
- (and pred
- (progn
- (set-buffer buffer)
- (and buffer-offer-save (> (buffer-size) 0)))))
- (or (not (functionp pred))
- (with-current-buffer buffer (funcall pred)))
- (if arg
- t
- ;; #### We should provide a per-buffer means to
- ;; disable the switching. For instance, you might
- ;; want to turn it off for buffers the contents of
- ;; which is meaningless to humans, such as
- ;; `.newsrc.eld'.
- (when (and switch-buffer
- ;; map-y-or-n-p is displaying help
- (not (eq last-buffer buffer)))
- (unless (one-window-p)
- (delete-other-windows))
- (setq switched t)
- ;; #### Consider using `display-buffer' here for 21.1!
- ;;(display-buffer buffer nil (selected-frame)))
- (switch-to-buffer buffer t))
- (if (buffer-file-name buffer)
- (format "Save file %s? "
- (buffer-file-name buffer))
- (format "Save buffer %s? "
- (buffer-name buffer)))))
- (setq last-buffer buffer)))
- (lambda (buffer)
- (set-buffer buffer)
- (condition-case ()
- (save-buffer)
- (error nil)))
- (buffer-list)
- '("buffer" "buffers" "save")
- save-some-buffers-action-alist))
- (abbrevs-done
- (and save-abbrevs abbrevs-changed
- (progn
- (if (or arg
- (eq save-abbrevs 'silently)
- (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name)))
- (write-abbrev-file nil))
- ;; Don't keep bothering user if he says no.
- (setq abbrevs-changed nil)
- t))))
- (or (> files-done 0) abbrevs-done
- (display-message 'no-log "(No files need saving)"))
- switched))
-
+ (labels
+ ;; XEmacs - do not use queried flag, make this function a label.
+ ((save-some-buffers-1 (arg pred switch-buffer)
+ (let* ((switched nil)
+ (last-buffer nil)
+ (files-done
+ (map-y-or-n-p
+ (lambda (buffer)
+ (prog1
+ (and (buffer-modified-p buffer)
+ (not (buffer-base-buffer buffer))
+ ;; XEmacs addition:
+ (not (symbol-value-in-buffer
+ 'save-buffers-skip buffer))
+ (or
+ (buffer-file-name buffer)
+ (and pred
+ (progn
+ (set-buffer buffer)
+ (and buffer-offer-save (> (buffer-size)
+ 0)))))
+ (or (not (functionp pred))
+ (with-current-buffer buffer (funcall pred)))
+ (if arg
+ t
+ ;; #### We should provide a per-buffer means
+ ;; to disable the switching. For instance,
+ ;; you might want to turn it off for buffers
+ ;; the contents of which is meaningless to
+ ;; humans, such as `.newsrc.eld'.
+ (when (and switch-buffer
+ ;; map-y-or-n-p is displaying help
+ (not (eq last-buffer buffer)))
+ (unless (one-window-p)
+ (delete-other-windows))
+ (setq switched t)
+ ;; #### Consider using `display-buffer'
+ ;; here for 21.1!
+ ;;(display-buffer buffer nil (selected-frame)))
+ (switch-to-buffer buffer t))
+ (if (buffer-file-name buffer)
+ (format "Save file %s? "
+ (buffer-file-name buffer))
+ (format "Save buffer %s? "
+ (buffer-name buffer)))))
+ (setq last-buffer buffer)))
+ (lambda (buffer)
+ (set-buffer buffer)
+ (condition-case ()
+ (save-buffer)
+ (error nil)))
+ (buffer-list)
+ '("buffer" "buffers" "save")
+ save-some-buffers-action-alist))
+ (abbrevs-done
+ (and save-abbrevs abbrevs-changed
+ (progn
+ (if (or arg
+ (eq save-abbrevs 'silently)
+ (y-or-n-p (format "Save abbrevs in %s? "
+ abbrev-file-name)))
+ (write-abbrev-file nil))
+ ;; Don't keep bothering user if he says no.
+ (setq abbrevs-changed nil)
+ t))))
+ (or (> files-done 0) abbrevs-done
+ (display-message 'no-log "(No files need saving)"))
+ switched)))
+ (save-excursion
+ ;; `delete-other-windows' can bomb during autoloads generation, so
+ ;; guard it well.
+ (if (or noninteractive
+ (eq (selected-window) (minibuffer-window))
+ (not save-some-buffers-query-display-buffer))
+ ;; If playing with windows is unsafe or undesired, just do the
+ ;; usual drill.
+ (save-some-buffers-1 arg pred nil)
+ ;; Else, protect the windows.
+ (when (save-window-excursion
+ (save-some-buffers-1 arg pred t))
+ ;; Force redisplay.
+ (sit-for 0))))))
(defun not-modified (&optional arg)
diff -r ddf56c45634e -r b7ae5f44b950 lisp/gui.el
--- a/lisp/gui.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/gui.el Sat May 05 18:42:00 2012 +0100
＠＠ -91,24 +91,24 ＠＠
(set-face-foreground 'gui-button-face '(((win color) . "black")))))
-(defun gui-button-action (instance action user-data)
- (let ((domain (image-instance-domain instance)))
- (with-current-buffer (if (windowp domain)
- (window-buffer domain) nil)
- (funcall action user-data))))
-
(defun make-gui-button (string &optional action user-data)
"Make a GUI button whose label is STRING and whose action is ACTION.
If the button is inserted in a buffer and then clicked on, and ACTION
is non-nil, ACTION will be called with one argument, USER-DATA.
When ACTION is called, the buffer containing the button is made current."
- (vector 'button
- :descriptor string
- :face 'gui-button-face
- :callback-ex `(lambda (image-instance event)
- (gui-button-action image-instance
- (quote ,action)
- (quote ,user-data)))))
+ (labels
+ ((gui-button-action (instance action user-data)
+ (let ((domain (image-instance-domain instance)))
+ (with-current-buffer (if (windowp domain)
+ (window-buffer domain) nil)
+ (funcall action user-data)))))
+ (vector 'button
+:descriptor string
+:face 'gui-button-face
+:callback-ex `(lambda (image-instance event)
+ (gui-button-action image-instance
+ (quote ,action)
+ (quote ,user-data))))))
(defun insert-gui-button (button &optional pos buffer)
"Insert GUI button BUTTON at POS in BUFFER."
diff -r ddf56c45634e -r b7ae5f44b950 lisp/indent.el
--- a/lisp/indent.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/indent.el Sat May 05 18:42:00 2012 +0100
＠＠ -48,20 +48,20 ＠＠
(defun indent-for-tab-command (&optional prefix-arg)
"Indent line in proper way for current major mode."
(interactive "P")
- (if (eq indent-line-function 'indent-to-left-margin)
- (insert-tab prefix-arg)
- (if prefix-arg
- (funcall indent-line-function prefix-arg)
- (funcall indent-line-function))))
-
-(defun insert-tab (&optional prefix-arg)
- (let ((count (prefix-numeric-value prefix-arg)))
- (if abbrev-mode
- (expand-abbrev))
- (if indent-tabs-mode
- (insert-char ?\t count)
- ;; XEmacs: (Need the `1+')
- (indent-to (* tab-width (1+ (/ (current-column) tab-width)))))))
+ (labels
+ ((insert-tab (&optional prefix-arg)
+ (let ((count (prefix-numeric-value prefix-arg)))
+ (if abbrev-mode
+ (expand-abbrev))
+ (if indent-tabs-mode
+ (insert-char ?\t count)
+ ;; XEmacs: (Need the `1+')
+ (indent-to (* tab-width (1+ (/ (current-column) tab-width))))))))
+ (if (eq indent-line-function 'indent-to-left-margin)
+ (insert-tab prefix-arg)
+ (if prefix-arg
+ (funcall indent-line-function prefix-arg)
+ (funcall indent-line-function)))))
(defun indent-rigidly (start end count)
"Indent all lines starting in the region sideways by COUNT columns.
diff -r ddf56c45634e -r b7ae5f44b950 lisp/isearch-mode.el
--- a/lisp/isearch-mode.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/isearch-mode.el Sat May 05 18:42:00 2012 +0100
＠＠ -1220,38 +1220,37 ＠＠
;;===========================================================
;; Search Ring
-(defun isearch-ring-adjust1 (advance)
- ;; Helper for isearch-ring-adjust
- (let* ((ring (if isearch-regexp regexp-search-ring search-ring))
- (length (length ring))
- (yank-pointer-name (if isearch-regexp
- 'regexp-search-ring-yank-pointer
- 'search-ring-yank-pointer))
- (yank-pointer (eval yank-pointer-name)))
- (if (zerop length)
- ()
- (set yank-pointer-name
- (setq yank-pointer
- (mod (+ (or yank-pointer 0)
- ;; XEmacs change
- (if advance -1 (if yank-pointer 1 0)))
- length)))
- (setq isearch-string (nth yank-pointer ring)
- isearch-message (mapconcat 'isearch-text-char-description
- isearch-string "")))))
-
(defun isearch-ring-adjust (advance)
;; Helper for isearch-ring-advance and isearch-ring-retreat
; (if (cdr isearch-cmds) ;; is there more than one thing on stack?
; (isearch-pop-state))
- (isearch-ring-adjust1 advance)
- (if search-ring-update
- (progn
- (isearch-search)
- (isearch-update))
- (isearch-edit-string)
- )
- (isearch-push-state))
+ (labels
+ ((isearch-ring-adjust1 (advance)
+ ;; Helper for isearch-ring-adjust
+ (let* ((ring (if isearch-regexp regexp-search-ring search-ring))
+ (length (length ring))
+ (yank-pointer-name (if isearch-regexp
+ 'regexp-search-ring-yank-pointer
+ 'search-ring-yank-pointer))
+ (yank-pointer (symbol-value yank-pointer-name)))
+ (if (zerop length)
+ ()
+ (set yank-pointer-name
+ (setq yank-pointer
+ (mod (+ (or yank-pointer 0)
+ ;; XEmacs change
+ (if advance -1 (if yank-pointer 1 0)))
+ length)))
+ (setq isearch-string (nth yank-pointer ring)
+ isearch-message (mapconcat 'isearch-text-char-description
+ isearch-string ""))))))
+ (isearch-ring-adjust1 advance)
+ (if search-ring-update
+ (progn
+ (isearch-search)
+ (isearch-update))
+ (isearch-edit-string))
+ (isearch-push-state)))
(defun isearch-ring-advance ()
"Advance to the next search string in the ring."
＠＠ -1582,60 +1581,70 ＠＠
;; cases.
(setq this-command (key-binding (this-command-keys))))
(t
- (isearch-maybe-frob-keyboard-macros)
- (if (and this-command
- (symbolp this-command)
- (get this-command 'isearch-command))
- nil ; then continue.
- (isearch-done)))))
-
-(defun isearch-maybe-frob-keyboard-macros ()
- ;;
- ;; If the command about to be executed is `self-insert-command' then change
- ;; the command to `isearch-printing-char' instead, meaning add the last-
- ;; typed character to the search string.
- ;;
- ;; If `this-command' is a string or a vector (that is, a keyboard macro)
- ;; and it contains only one command, which is bound to self-insert-command,
- ;; then do the same thing as for self-inserting commands: arrange for that
- ;; character to be added to the search string. If we didn't do this, then
- ;; typing a compose sequence (a la x-compose.el) would terminate the search
- ;; and insert the character, instead of searching for that character.
- ;;
- ;; We should continue doing this, since it's pretty much the behavior one
- ;; would expect, but it will stop being so necessary once key-translation-
- ;; map exists and is used by x-compose.el and things like it, since the
- ;; translation will have been done before we see the keys.
- ;;
- (cond ((eq this-command 'self-insert-command)
- (setq this-command 'isearch-printing-char))
- ((and (or (stringp this-command) (vectorp this-command))
- (eq (key-binding this-command) 'self-insert-command))
- (setq last-command-event (character-to-event (aref this-command 0))
- last-command-char (and (stringp this-command)
- (aref this-command 0))
- this-command 'isearch-printing-char))
- ((and (null this-command)
- (eq 'key-press (event-type last-command-event))
- (current-local-map)
- (let* ((this-command-keys (this-command-keys))
- (this-command-keys (or (lookup-key function-key-map
- this-command-keys)
- this-command-keys))
- (lookup-key (lookup-key global-map this-command-keys)))
- (and (eq 'self-insert-command lookup-key)
- ;; The feature here that a modification of
- ;; last-command-event is respected is undocumented, and
- ;; only applies when this-command is nil. The design
- ;; isn't reat, and I welcome suggestions for a better
- ;; one.
- (setq last-command-event
- (find-if 'key-press-event-p this-command-keys
-:from-end t)
- last-command-char
- (event-to-character last-command-event)
- this-command 'isearch-printing-char)))))))
-
+ (labels
+ ((isearch-maybe-frob-keyboard-macros ()
+ ;; If the command about to be executed is
+ ;; `self-insert-command' then change the command to
+ ;; `isearch-printing-char' instead, meaning add the last-
+ ;; typed character to the search string.
+ ;;
+ ;; If `this-command' is a string or a vector (that is, a
+ ;; keyboard macro) and it contains only one command, which is
+ ;; bound to self-insert-command, then do the same thing as for
+ ;; self-inserting commands: arrange for that character to be
+ ;; added to the search string. If we didn't do this, then
+ ;; typing a compose sequence (a la x-compose.el) would
+ ;; terminate the search and insert the character, instead of
+ ;; searching for that character.
+ ;;
+ ;; We should continue doing this, since it's pretty much the
+ ;; behavior one would expect, but it will stop being so
+ ;; necessary once key-translation- map exists and is used by
+ ;; x-compose.el and things like it, since the translation will
+ ;; have been done before we see the keys.
+ ;;
+ (cond ((eq this-command 'self-insert-command)
+ (setq this-command 'isearch-printing-char))
+ ((and (or (stringp this-command) (vectorp this-command))
+ (eq (key-binding this-command)
+ 'self-insert-command))
+ (setq last-command-event
+ (character-to-event (aref this-command 0))
+ last-command-char (and (stringp this-command)
+ (aref this-command 0))
+ this-command 'isearch-printing-char))
+ ((and (null this-command)
+ (eq 'key-press (event-type last-command-event))
+ (current-local-map)
+ (let* ((this-command-keys (this-command-keys))
+ (this-command-keys (or (lookup-key
+ function-key-map
+ this-command-keys)
+ this-command-keys))
+ (lookup-key (lookup-key global-map
+ this-command-keys)))
+ (and (eq 'self-insert-command lookup-key)
+ ;; The feature here that a modification
+ ;; of last-command-event is respected is
+ ;; undocumented, and only applies when
+ ;; this-command is nil. The design isn't
+ ;; great, and I welcome suggestions for a
+ ;; better one.
+ (setq last-command-event
+ (find-if 'key-press-event-p
+ this-command-keys
+:from-end t)
+ last-command-char
+ (event-to-character
+ last-command-event)
+ this-command
+ 'isearch-printing-char))))))))
+ (isearch-maybe-frob-keyboard-macros)
+ (if (and this-command
+ (symbolp this-command)
+ (get this-command 'isearch-command))
+ nil ; then continue.
+ (isearch-done))))))
;;;========================================================
;;; Highlighting
＠＠ -1645,24 +1654,25 ＠＠
;; this face is initialized by faces.el since isearch is preloaded.
;(make-face 'isearch)
-(defun isearch-make-extent (begin end)
- (let ((x (make-extent begin end (current-buffer))))
- ;; make the isearch extent always take precedence over any mouse-
- ;; highlighted extents we may be passing through, since isearch, being
- ;; modal, is more interesting (there's nothing they could do with a
- ;; mouse-highlighted extent while in the midst of a search anyway).
- (set-extent-priority x (+ mouse-highlight-priority 2))
- (set-extent-face x 'isearch)
- (setq isearch-extent x)))
-
(defun isearch-highlight (begin end)
- (if (null search-highlight)
- nil
- ;; make sure isearch-extent is in the current buffer
- (or (and (extentp isearch-extent)
- (extent-live-p isearch-extent))
- (isearch-make-extent begin end))
- (set-extent-endpoints isearch-extent begin end (current-buffer))))
+ (labels
+ ((isearch-make-extent (begin end)
+ (let ((x (make-extent begin end (current-buffer))))
+ ;; make the isearch extent always take precedence over any mouse-
+ ;; highlighted extents we may be passing through, since isearch,
+ ;; being modal, is more interesting (there's nothing they could do
+ ;; with a mouse-highlighted extent while in the midst of a search
+ ;; anyway).
+ (set-extent-priority x (+ mouse-highlight-priority 2))
+ (set-extent-face x 'isearch)
+ (setq isearch-extent x))))
+ (if (null search-highlight)
+ nil
+ ;; make sure isearch-extent is in the current buffer
+ (or (and (extentp isearch-extent)
+ (extent-live-p isearch-extent))
+ (isearch-make-extent begin end))
+ (set-extent-endpoints isearch-extent begin end (current-buffer)))))
;; This used to have a TOTALLY flag that also deleted the extent. I
;; don't think this is necessary any longer, as isearch-highlight can
diff -r ddf56c45634e -r b7ae5f44b950 lisp/itimer.el
--- a/lisp/itimer.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/itimer.el Sat May 05 18:42:00 2012 +0100
＠＠ -102,62 +102,6 ＠＠
(defvar itimer-edit-start-marker nil)
-;; macros must come first... or byte-compile'd code will throw back its
-;; head and scream.
-
-(defmacro itimer-decrement (variable)
- (list 'setq variable (list '1- variable)))
-
-(defmacro itimer-increment (variable)
- (list 'setq variable (list '1+ variable)))
-
-(defmacro itimer-signum (n)
- (list 'if (list '> n 0) 1
- (list 'if (list 'zerop n) 0 -1)))
-
-;; Itimer access functions should behave as if they were subrs. These
-;; macros are used to check the arguments to the itimer functions and
-;; signal errors appropriately if the arguments are not valid.
-
-(defmacro check-itimer (var)
- "If VAR is not bound to an itimer, signal `wrong-type-argument'.
-This is a macro."
- (list 'setq var
- (list 'if (list 'itimerp var) var
- (list 'signal ''wrong-type-argument
- (list 'list ''itimerp var)))))
-
-(defmacro check-itimer-coerce-string (var)
- "If VAR is bound to a string, look up the itimer that it names and
-bind VAR to it. Otherwise, if VAR is not bound to an itimer, signal
-`wrong-type-argument'. This is a macro."
- (list 'setq var
- (list 'cond
- (list (list 'itimerp var) var)
- (list (list 'stringp var) (list 'get-itimer var))
- (list t (list 'signal ''wrong-type-argument
- (list 'list ''string-or-itimer-p var))))))
-
-(defmacro check-nonnegative-number (var)
- "If VAR is not bound to a number, signal `wrong-type-argument'.
-If VAR is not bound to a positive number, signal `args-out-of-range'.
-This is a macro."
- (list 'setq var
- (list 'if (list 'not (list 'numberp var))
- (list 'signal ''wrong-type-argument
- (list 'list ''natnump var))
- (list 'if (list '< var 0)
- (list 'signal ''args-out-of-range (list 'list var))
- var))))
-
-(defmacro check-string (var)
- "If VAR is not bound to a string, signal `wrong-type-argument'.
-This is a macro."
- (list 'setq var
- (list 'if (list 'stringp var) var
- (list 'signal ''wrong-type-argument
- (list 'list ''stringp var)))))
-
;; Functions to access and modify itimer attributes.
(defun itimerp (object)
＠＠ -173,24 +117,24 ＠＠
(defun itimer-name (itimer)
"Return the name of ITIMER."
- (check-itimer itimer)
+ (check-type itimer itimer)
(car itimer))
(defun itimer-value (itimer)
"Return the number of seconds until ITIMER expires."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 1 itimer))
(defun itimer-restart (itimer)
"Return the value to which ITIMER will be set at restart.
The value nil is returned if this itimer isn't set to restart."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 2 itimer))
(defun itimer-function (itimer)
"Return the function of ITIMER.
This function is called each time ITIMER expires."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 3 itimer))
(defun itimer-is-idle (itimer)
＠＠ -198,31 +142,31 ＠＠
Normal timers expire after a set interval. Idle timers expire
only after Emacs has been idle for a specific interval. ``Idle''
means no command events have occurred within the interval."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 4 itimer))
(defun itimer-uses-arguments (itimer)
"Return non-nil if the function of ITIMER will be called with arguments.
ITIMER's function is called with the arguments each time ITIMER expires.
The arguments themselves are retrievable with `itimer-function-arguments'."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 5 itimer))
(defun itimer-function-arguments (itimer)
"Return the function arguments of ITIMER as a list.
ITIMER's function is called with these arguments each time ITIMER expires."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 6 itimer))
(defun itimer-recorded-run-time (itimer)
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 7 itimer))
(defun set-itimer-name (itimer name)
"Set the name of ITIMER to be NAME.
NAME is an identifier for the itimer. It must be a string. If an active
itimer already exists with this name, an error is signaled."
- (check-string name)
+ (check-type name string)
(and (itimer-live-p itimer)
(get-itimer name)
(error "itimer named \"%s\" already existing and activated" name))
＠＠ -235,8 +179,9 ＠＠
VALUE can be a floating point number. Otherwise it
must be an integer.
Returns VALUE."
- (check-itimer itimer)
- (check-nonnegative-number value)
+ (check-type itimer itimer)
+ (check-type value number)
+ (check-argument-range value 0 nil)
(let ((inhibit-quit t))
;; If the itimer is in the active list, and under the new
;; timeout value would expire before we would normally
＠＠ -253,8 +198,9 ＠＠
;; Same as set-itimer-value but does not wakeup the driver.
;; Only should be used by the drivers when processing expired timers.
(defun set-itimer-value-internal (itimer value)
- (check-itimer itimer)
- (check-nonnegative-number value)
+ (check-type itimer itimer)
+ (check-type value number)
+ (check-argument-range value 0 nil)
(setcar (cdr itimer) value))
(defun set-itimer-restart (itimer restart)
＠＠ -264,22 +210,24 ＠＠
RESTART can be a floating point number. Otherwise it
must be an integer.
Returns RESTART."
- (check-itimer itimer)
- (if restart (check-nonnegative-number restart))
+ (check-type itimer itimer)
+ (when restart
+ (check-type restart number)
+ (check-argument-range restart 0 nil))
(setcar (cdr (cdr itimer)) restart))
(defun set-itimer-function (itimer function)
"Set the function of ITIMER to be FUNCTION.
FUNCTION will be called when itimer expires.
Returns FUNCTION."
- (check-itimer itimer)
+ (check-type itimer itimer)
(setcar (nthcdr 3 itimer) function))
(defun set-itimer-is-idle (itimer flag)
"Set flag that says whether ITIMER is an idle timer.
If FLAG is non-nil, then ITIMER will be considered an idle timer.
Returns FLAG."
- (check-itimer itimer)
+ (check-type itimer itimer)
(setcar (nthcdr 4 itimer) flag))
(defun set-itimer-uses-arguments (itimer flag)
＠＠ -287,23 +235,23 ＠＠
If FLAG is non-nil, then the function will be called with one argument,
otherwise the function will be called with no arguments.
Returns FLAG."
- (check-itimer itimer)
+ (check-type itimer itimer)
(setcar (nthcdr 5 itimer) flag))
(defun set-itimer-function-arguments (itimer &optional arguments)
"Set the function arguments of ITIMER to be ARGUMENTS.
The function of ITIMER will be called with ARGUMENTS when itimer expires.
Returns ARGUMENTS."
- (check-itimer itimer)
+ (check-type itimer itimer)
(setcar (nthcdr 6 itimer) arguments))
(defun set-itimer-recorded-run-time (itimer time)
- (check-itimer itimer)
+ (check-type itimer itimer)
(setcar (nthcdr 7 itimer) time))
(defun get-itimer (name)
"Return itimer named NAME, or nil if there is none."
- (check-string name)
+ (check-type name string)
(assoc name itimer-list))
(defun read-itimer (prompt &optional initial-input)
＠＠ -315,7 +263,8 ＠＠
(defun delete-itimer (itimer)
"Deletes ITIMER. ITIMER may be an itimer or the name of one."
- (check-itimer-coerce-string itimer)
+ (if (stringp itimer) (setq itimer (get-itimer itimer)))
+ (check-type itimer itimer)
(setq itimer-list (delete* itimer itimer-list)))
(defun start-itimer (name function value &optional restart
＠＠ -362,15 +311,18 ＠＠
;; hard to imagine the user specifying these interactively
nil
nil ))
- (check-string name)
- (check-nonnegative-number value)
- (if restart (check-nonnegative-number restart))
+ (check-type name string)
+ (check-type value number)
+ (check-argument-range value 0 nil)
+ (when restart
+ (check-type restart number)
+ (check-argument-range restart 0 nil))
;; Make proposed itimer name unique if it's not already.
(let ((oname name)
(num 2))
(while (get-itimer name)
(setq name (format "%s<%d>" oname num))
- (itimer-increment num)))
+ (incf num)))
(activate-itimer (list name value restart function is-idle
with-args function-arguments (list 0 0 0)))
(car itimer-list))
＠＠ -387,7 +339,7 ＠＠
"Activate ITIMER, which was previously created with `make-itimer'.
ITIMER will be added to the global list of running itimers,
its FUNCTION will be called when it expires, and so on."
- (check-itimer itimer)
+ (check-type itimer itimer)
(if (memq itimer itimer-list)
(error "itimer already activated"))
(if (not (numberp (itimer-value itimer)))
＠＠ -408,7 +360,7 ＠＠
(num 1))
(while (get-itimer name)
(setq name (format "%s<%d>" oname num))
- (itimer-increment num))
+ (incf num))
(setcar itimer name))
;; signal an error if the timer's name matches an already
;; activated timer.
＠＠ -569,7 +521,7 ＠＠
(while (and (>= opoint (point)) (< n 6))
(forward-sexp 2)
(backward-sexp)
- (itimer-increment n))
+ (incf n))
(cond ((eq n 1) (error "Cannot change itimer name."))
((eq n 2) 'value)
((eq n 3) 'restart)
＠＠ -630,7 +582,7 ＠＠
(defun itimer-edit-next-field (count)
(interactive "p")
(itimer-edit-beginning-of-field)
- (cond ((> (itimer-signum count) 0)
+ (cond ((plusp count)
(while (not (zerop count))
(forward-sexp)
;; wrap from eob to itimer-edit-start-marker
＠＠ -645,8 +597,8 ＠＠
(progn
(forward-sexp 2)
(backward-sexp)))
- (itimer-decrement count)))
- ((< (itimer-signum count) 0)
+ (decf count)))
+ ((minusp count)
(while (not (zerop count))
(backward-sexp)
;; treat fields at beginning of line as if they weren't there.
＠＠ -657,7 +609,7 ＠＠
(progn
(goto-char (point-max))
(backward-sexp)))
- (itimer-increment count)))))
+ (incf count)))))
(defun itimer-edit-previous-field (count)
(interactive "p")
diff -r ddf56c45634e -r b7ae5f44b950 lisp/lib-complete.el
--- a/lisp/lib-complete.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/lib-complete.el Sat May 05 18:42:00 2012 +0100
＠＠ -118,90 +118,90 ＠＠
(<root> <modtimes> <completion-table>)")
-(defun lib-complete:better-root (ROOT1 ROOT2)
- "Return non-nil if ROOT1 is a superset of ROOT2."
- (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
- (string-match
- (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
- ROOT2)))
-
-(defun lib-complete:get-completion-table (FILE PATH FILTER)
- (let* ((subdir (file-name-directory FILE))
- (root (file-name-nondirectory FILE))
- (PATH
- (mapcar
- (function (lambda (dir) (file-name-as-directory
- (expand-file-name (or dir "")))))
- PATH))
- (key (vector PATH subdir FILTER))
- (real-dirs
- (if subdir
- (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
- PATH))
- (path-modtimes
- (mapcar
- (function (lambda (fn) (if fn (nth 5 (file-attributes fn)))))
- real-dirs))
- (cache-entry (assoc key lib-complete:cache))
- (cache-records (cdr cache-entry)))
- ;; Look for cached entry
- (catch 'table
- (while cache-records
- (if (and
- (lib-complete:better-root (nth 0 (car cache-records)) root)
- (equal (nth 1 (car cache-records)) path-modtimes))
- (throw 'table (nth 2 (car cache-records))))
- (setq cache-records (cdr cache-records)))
- ;; Otherwise build completions
- (let ((completion-list
- (progn-with-message "(building completion table...)"
- (library-all-completions FILE PATH nil 'fast)))
- (completion-table (make-vector 127 0)))
- (while completion-list
- (let ((completion
- (if (or (not FILTER)
- (file-directory-p (car completion-list)))
- (car completion-list)
- (funcall FILTER (car completion-list)))))
- (if completion
- (intern completion completion-table)))
- (setq completion-list (cdr completion-list)))
- ;; Cache the completions
- (lib-complete:cache-completions key root
- path-modtimes completion-table)
- completion-table))))
-
(defvar lib-complete:max-cache-size 40
"*Maximum number of search paths which are cached.")
-(defun lib-complete:cache-completions (key root modtimes table)
- (let* ((cache-entry (assoc key lib-complete:cache))
- (cache-records (cdr cache-entry))
- (new-cache-records (list (list root modtimes table))))
- (if (not cache-entry) nil
- ;; Remove old cache entry
- (setq lib-complete:cache (delete* cache-entry lib-complete:cache))
- ;; Copy non-redundant entries from old cache entry
- (while cache-records
- (if (or (equal root (nth 0 (car cache-records)))
- (lib-complete:better-root root (nth 0 (car cache-records))))
- nil
- (setq new-cache-records
- (cons (car cache-records) new-cache-records)))
- (setq cache-records (cdr cache-records))))
- ;; Add entry to front of cache
- (setq lib-complete:cache
- (cons (cons key (nreverse new-cache-records)) lib-complete:cache))
- ;; Trim cache
- (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
- (if tail (setcdr tail nil)))))
-
;;=== Read a filename, with completion in a search path ===================
(defun read-library-internal (FILE FILTER FLAG)
"Don't call this."
;; Relies on read-library-internal-search-path being let-bound
(declare (special read-library-internal-search-path))
+ (labels
+ ((lib-complete:better-root (ROOT1 ROOT2)
+ ; Return non-nil if ROOT1 is a superset of ROOT2.
+ (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
+ (string-match
+ (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
+ ROOT2)))
+ (lib-complete:get-completion-table (FILE PATH FILTER)
+ (let* ((subdir (file-name-directory FILE))
+ (root (file-name-nondirectory FILE))
+ (PATH
+ (mapcar
+ (function (lambda (dir) (file-name-as-directory
+ (expand-file-name (or dir "")))))
+ PATH))
+ (key (vector PATH subdir FILTER))
+ (real-dirs
+ (if subdir
+ (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
+ PATH))
+ (path-modtimes
+ (mapcar
+ (function (lambda (fn) (if fn (nth 5 (file-attributes fn)))))
+ real-dirs))
+ (cache-entry (assoc key lib-complete:cache))
+ (cache-records (cdr cache-entry)))
+ ;; Look for cached entry
+ (catch 'table
+ (while cache-records
+ (if (and
+ (lib-complete:better-root (nth 0 (car cache-records)) root)
+ (equal (nth 1 (car cache-records)) path-modtimes))
+ (throw 'table (nth 2 (car cache-records))))
+ (setq cache-records (cdr cache-records)))
+ ;; Otherwise build completions
+ (let ((completion-list
+ (progn-with-message "(building completion table...)"
+ (library-all-completions FILE PATH nil 'fast)))
+ (completion-table (make-vector 127 0)))
+ (while completion-list
+ (let ((completion
+ (if (or (not FILTER)
+ (file-directory-p (car completion-list)))
+ (car completion-list)
+ (funcall FILTER (car completion-list)))))
+ (if completion
+ (intern completion completion-table)))
+ (setq completion-list (cdr completion-list)))
+ ;; Cache the completions
+ (lib-complete:cache-completions key root
+ path-modtimes completion-table)
+ completion-table))))
+ (lib-complete:cache-completions (key root modtimes table)
+ (let* ((cache-entry (assoc key lib-complete:cache))
+ (cache-records (cdr cache-entry))
+ (new-cache-records (list (list root modtimes table))))
+ (if (not cache-entry) nil
+ ;; Remove old cache entry
+ (setq lib-complete:cache (delete* cache-entry lib-complete:cache))
+ ;; Copy non-redundant entries from old cache entry
+ (while cache-records
+ (if (or (equal root (nth 0 (car cache-records)))
+ (lib-complete:better-root root
+ (nth 0 (car cache-records))))
+ nil
+ (setq new-cache-records
+ (cons (car cache-records) new-cache-records)))
+ (setq cache-records (cdr cache-records))))
+ ;; Add entry to front of cache
+ (setq lib-complete:cache
+ (cons (cons key (nreverse new-cache-records))
+ lib-complete:cache))
+ ;; Trim cache
+ (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
+ (if tail (setcdr tail nil))))))
(let ((completion-table
(lib-complete:get-completion-table
FILE read-library-internal-search-path FILTER)))
＠＠ -212,7 +212,7 ＠＠
((eq FLAG nil) (try-completion FILE completion-table nil))
((eq FLAG t) (all-completions FILE completion-table nil))
((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
- )))
+ ))))
(defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH
FULL FILTER)
diff -r ddf56c45634e -r b7ae5f44b950 lisp/minibuf.el
--- a/lisp/minibuf.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/minibuf.el Sat May 05 18:42:00 2012 +0100
＠＠ -1479,8 +1479,7 ＠＠
default))
prompt))
(alist (mapcar #'(lambda (b) (cons (buffer-name b) b))
- (remove-if (lambda (elt) (member elt exclude))
- (buffer-list))))
+ (set-difference (buffer-list) exclude)))
result)
(while (progn
(setq result (completing-read prompt alist nil require-match
diff -r ddf56c45634e -r b7ae5f44b950 lisp/newcomment.el
--- a/lisp/newcomment.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/newcomment.el Sat May 05 18:42:00 2012 +0100
＠＠ -577,12 +577,14 ＠＠
(concat lpad s (when multi (make-string n (aref str (1- (match-end 1))))) rpad)
;; construct a regexp that would match anything from just S
;; to any possible output of this function for any N.
- (concat (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?"))
- lpad "") ;padding is not required
- (regexp-quote s)
- (when multi "+") ;the last char of S might be repeated
- (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?"))
- rpad "")))))) ;padding is not required
+ (labels
+ ((regexp-quote-with-? (c) (concat (regexp-quote (string c)) "?")))
+ (concat (mapconcat #'regexp-quote-with-?
+ lpad "") ;padding is not required
+ (regexp-quote s)
+ (when multi "+") ;the last char of S might be repeated
+ (mapconcat #'regexp-quote-with-?
+ rpad ""))))))) ;padding is not required
(defun comment-padleft (str &optional n)
"Construct a string composed of `comment-padding' plus STR.
diff -r ddf56c45634e -r b7ae5f44b950 lisp/packages.el
--- a/lisp/packages.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/packages.el Sat May 05 18:42:00 2012 +0100
＠＠ -91,19 +91,9 ＠＠
`("site-packages" ,＠(when (featurep 'mule) '("mule-packages"))
"xemacs-packages"))
-(defun package-get-key-1 (info key)
- "Locate keyword `key' in list."
- (cond ((null info)
- nil)
- ((eq (car info) key)
- (nth 1 info))
- (t (package-get-key-1 (cddr info) key))))
-
(defun package-get-key (name key)
"Get info `key' from package `name'."
- (let ((info (assq name packages-package-list)))
- (when info
- (package-get-key-1 (cdr info) key))))
+ (getf (cdr (assq name packages-package-list)) key))
(defun package-provide (name &rest attributes)
(let ((info (if (and attributes (floatp (car attributes)))
diff -r ddf56c45634e -r b7ae5f44b950 lisp/simple.el
--- a/lisp/simple.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/simple.el Sat May 05 18:42:00 2012 +0100
＠＠ -407,12 +407,6 ＠＠
(if (eq arg '-) (setq arg -1))
(kill-region (point) (+ (point) arg)))
-;; Internal subroutine of backward-delete-char
-(defun kill-backward-chars (arg)
- (if (listp arg) (setq arg (car arg)))
- (if (eq arg '-) (setq arg -1))
- (kill-region (point) (- (point) arg)))
-
(defun backward-delete-char-untabify (arg &optional killp)
"Delete characters backward, changing tabs into spaces.
Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
＠＠ -824,8 +818,7 ＠＠
percent narrowed-details col hscroll)
(message "Char: %s (%s %s) point=%d of %d(%d%%)%s column %d %s"
(text-char-description char) unicode-string
- (mapconcat (lambda (arg) (format "%S" arg))
- (split-char char) " ")
+ (mapconcat #'prin1-to-string (split-char char) " ")
pos total
percent narrowed-details col hscroll)))))
＠＠ -4766,8 +4759,8 ＠＠
(cond ((featurep 'xemacs) "XEmacs")
(t "Emacs")))
-(defun debug-print-1 (&rest args)
- "Send a debugging-type string to standard output.
+(defun debug-print (&rest args)
+ "Send a string to the debugging output.
If the first argument is a string, it is considered to be a format
specifier if there are sufficient numbers of other args, and the string is
formatted using (apply #'format args). Otherwise, each argument is printed
＠＠ -4790,15 +4783,6 ＠＠
(incf i))
(terpri)))))
-(defun debug-print (&rest args)
- "Send a string to the debugging output.
-If the first argument is a string, it is considered to be a format
-specifier if there are sufficient numbers of other args, and the string is
-formatted using (apply #'format args). Otherwise, each argument is printed
-individually in a numbered list."
- (let ((standard-output 'external-debugging-output))
- (apply #'debug-print-1 args)))
-
(defun debug-backtrace ()
"Send a backtrace to the debugging output."
(let ((standard-output 'external-debugging-output))
diff -r ddf56c45634e -r b7ae5f44b950 lisp/subr.el
--- a/lisp/subr.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/subr.el Sat May 05 18:42:00 2012 +0100
＠＠ -975,9 +975,9 ＠＠
"Return INTEGER converted to a bit vector.
Optional argument MINLENGTH gives a minimum length for the returned vector.
If MINLENGTH is not given, zero high-order bits will be ignored."
- (check-argument-type #'integerp integer)
+ (check-type integer integer)
(setq minlength (or minlength 0))
- (check-nonnegative-number minlength)
+ (check-type minlength natnum)
(read (format (format "#*%%0%db" minlength) integer)))
;; XEmacs addition.
diff -r ddf56c45634e -r b7ae5f44b950 lisp/widget.el
--- a/lisp/widget.el Fri May 04 21:12:51 2012 +0100
+++ b/lisp/widget.el Sat May 05 18:42:00 2012 +0100
＠＠ -34,19 +34,6 ＠＠
;;; Code:
-;; Neither XEmacs, nor latest GNU Emacs need this -- provided for
-;; compatibility.
-;; (defalias 'define-widget-keywords 'ignore)
-
-(defmacro define-widget-keywords (&rest keys)
- "This doesn't do anything in Emacs 20 or XEmacs."
- `(eval-and-compile
- (let ((keywords (quote ,keys)))
- (while keywords
- (or (boundp (car keywords))
- (set (car keywords) (car keywords)))
- (setq keywords (cdr keywords))))))
-
(defun define-widget (name class doc &rest args)
"Define a new widget type named NAME from CLASS.
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit/XEmacs: kehoea: Remove some redundant functions, change others to labels, lisp/
12 years, 8 months
Bitbucket
Bitbucket
1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/changeset/b7ae5f44b950/
changeset: b7ae5f44b950
user: kehoea
date: 2012-05-05 19:42:00
summary: Remove some redundant functions, change others to labels, lisp/
lisp/ChangeLog addition:
2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
Remove some redundant functions; turn other utility functions into
labels, avoiding visibility in the global namespace, and reducing
the size of the dumped binary.
* auto-save.el (auto-save-unhex): Removed.
* auto-save.el (auto-save-unescape-name): Use #'string-to-number
instead of #'auto-save-unhex.
* files.el (save-some-buffers):
* files.el (save-some-buffers-1): Changed to a label.
* files.el (not-modified):
* gui.el (make-gui-button):
* gui.el (gui-button-action): Changed to a label.
* gui.el (insert-gui-button):
* indent.el (indent-for-tab-command):
* indent.el (insert-tab): Changed to a label.
* indent.el (indent-rigidly):
* isearch-mode.el:
* isearch-mode.el (isearch-ring-adjust):
* isearch-mode.el (isearch-ring-adjust1): Changed to a label.
* isearch-mode.el (isearch-pre-command-hook):
* isearch-mode.el (isearch-maybe-frob-keyboard-macros): Changed to
a label.
* isearch-mode.el (isearch-highlight):
* isearch-mode.el (isearch-make-extent): Changed to a label.
* itimer.el:
* itimer.el (itimer-decrement): Removed, replaced uses with decf.
* itimer.el (itimer-increment): Removed, replaced uses with incf.
* itimer.el (itimer-signum): Removed, replaced uses with minusp, plusp.
* itimer.el (itimer-name):
* itimer.el (check-itimer): Removed, replaced with #'check-type calls.
* itimer.el (itimer-value):
* itimer.el (check-itimer-coerce-string): Removed.
* itimer.el (itimer-restart):
* itimer.el (itimer-function):
* itimer.el (check-nonnegative-number): Removed.
* itimer.el (itimer-uses-arguments):
* itimer.el (check-string): Removed.
* itimer.el (itimer-function-arguments):
* itimer.el (itimer-recorded-run-time):
* itimer.el (set-itimer-name):
* itimer.el (set-itimer-value):
* itimer.el (set-itimer-value-internal):
* itimer.el (set-itimer-restart):
* itimer.el (set-itimer-function):
* itimer.el (set-itimer-is-idle):
* itimer.el (set-itimer-recorded-run-time):
* itimer.el (get-itimer):
* itimer.el (delete-itimer):
* itimer.el (start-itimer):
* itimer.el (activate-itimer):
* itimer.el (itimer-edit-set-field):
* itimer.el (itimer-edit-next-field):
* itimer.el (itimer-edit-previous-field):
Use incf, decf, plusp, minusp and the more general argument type
checking macros.
* lib-complete.el:
* lib-complete.el (lib-complete:better-root): Changed to a label.
* lib-complete.el (lib-complete:get-completion-table): Changed to
a label.
* lib-complete.el (read-library-internal): Include labels.
* lib-complete.el (lib-complete:cache-completions): Changed to a
label.
* minibuf.el (read-buffer): Use #'set-difference, don't reinvent it.
* newcomment.el (comment-padright): Use a label instead of
repeating a lambda expression.
* packages.el (package-get-key):
* packages.el (package-get-key-1): Removed, use #'getf instead.
* simple.el (kill-backward-chars): Removed; this isn't used.
* simple.el (what-cursor-position):
(lambda (arg) (format "%S" arg) -> #'prin1-to-string.
* simple.el (debug-print-1): Renamed to #'debug-print.
* simple.el (debug-print): Removed, #'debug-print-1 was equivalent.
* subr.el (integer-to-bit-vector): check-nonnegative-number no
longer available.
* widget.el (define-widget):
* widget.el (define-widget-keywords): Removed, this was long obsolete.
affected #: 14 files
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
＠＠ -1,3 +1,82 ＠＠
+2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Remove some redundant functions; turn other utility functions into
+ labels, avoiding visibility in the global namespace, and reducing
+ the size of the dumped binary.
+
+ * auto-save.el (auto-save-unhex): Removed.
+ * auto-save.el (auto-save-unescape-name): Use #'string-to-number
+ instead of #'auto-save-unhex.
+ * files.el (save-some-buffers):
+ * files.el (save-some-buffers-1): Changed to a label.
+ * files.el (not-modified):
+ * gui.el (make-gui-button):
+ * gui.el (gui-button-action): Changed to a label.
+ * gui.el (insert-gui-button):
+ * indent.el (indent-for-tab-command):
+ * indent.el (insert-tab): Changed to a label.
+ * indent.el (indent-rigidly):
+ * isearch-mode.el:
+ * isearch-mode.el (isearch-ring-adjust):
+ * isearch-mode.el (isearch-ring-adjust1): Changed to a label.
+ * isearch-mode.el (isearch-pre-command-hook):
+ * isearch-mode.el (isearch-maybe-frob-keyboard-macros): Changed to
+ a label.
+ * isearch-mode.el (isearch-highlight):
+ * isearch-mode.el (isearch-make-extent): Changed to a label.
+ * itimer.el:
+ * itimer.el (itimer-decrement): Removed, replaced uses with decf.
+ * itimer.el (itimer-increment): Removed, replaced uses with incf.
+ * itimer.el (itimer-signum): Removed, replaced uses with minusp, plusp.
+ * itimer.el (itimer-name):
+ * itimer.el (check-itimer): Removed, replaced with #'check-type calls.
+ * itimer.el (itimer-value):
+ * itimer.el (check-itimer-coerce-string): Removed.
+ * itimer.el (itimer-restart):
+ * itimer.el (itimer-function):
+ * itimer.el (check-nonnegative-number): Removed.
+ * itimer.el (itimer-uses-arguments):
+ * itimer.el (check-string): Removed.
+ * itimer.el (itimer-function-arguments):
+ * itimer.el (itimer-recorded-run-time):
+ * itimer.el (set-itimer-name):
+ * itimer.el (set-itimer-value):
+ * itimer.el (set-itimer-value-internal):
+ * itimer.el (set-itimer-restart):
+ * itimer.el (set-itimer-function):
+ * itimer.el (set-itimer-is-idle):
+ * itimer.el (set-itimer-recorded-run-time):
+ * itimer.el (get-itimer):
+ * itimer.el (delete-itimer):
+ * itimer.el (start-itimer):
+ * itimer.el (activate-itimer):
+ * itimer.el (itimer-edit-set-field):
+ * itimer.el (itimer-edit-next-field):
+ * itimer.el (itimer-edit-previous-field):
+ Use incf, decf, plusp, minusp and the more general argument type
+ checking macros.
+ * lib-complete.el:
+ * lib-complete.el (lib-complete:better-root): Changed to a label.
+ * lib-complete.el (lib-complete:get-completion-table): Changed to
+ a label.
+ * lib-complete.el (read-library-internal): Include labels.
+ * lib-complete.el (lib-complete:cache-completions): Changed to a
+ label.
+ * minibuf.el (read-buffer): Use #'set-difference, don't reinvent it.
+ * newcomment.el (comment-padright): Use a label instead of
+ repeating a lambda expression.
+ * packages.el (package-get-key):
+ * packages.el (package-get-key-1): Removed, use #'getf instead.
+ * simple.el (kill-backward-chars): Removed; this isn't used.
+ * simple.el (what-cursor-position):
+ (lambda (arg) (format "%S" arg) -> #'prin1-to-string.
+ * simple.el (debug-print-1): Renamed to #'debug-print.
+ * simple.el (debug-print): Removed, #'debug-print-1 was equivalent.
+ * subr.el (integer-to-bit-vector): check-nonnegative-number no
+ longer available.
+ * widget.el (define-widget):
+ * widget.el (define-widget-keywords): Removed, this was long obsolete.
+
2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
Avoid #'delq in core code, for the sake of style and a (very
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/auto-save.el
--- a/lisp/auto-save.el
+++ b/lisp/auto-save.el
＠＠ -412,24 +412,15 ＠＠
(char-to-string char))))
str ""))
-(defun auto-save-unhex (x)
- (if (> x ?9)
- (if (>= x ?a)
- (+ 10 (- x ?a))
- (+ 10 (- x ?A)))
- (- x ?0)))
-
(defun auto-save-unescape-name (str)
"Undo any escaping of evil nasty characters in a file name.
See `auto-save-escape-name'."
(setq str (or str ""))
(let ((tmp "")
(case-fold-search t))
- (while (string-match "=[0-9a-f][0-9a-f]" str)
+ (while (string-match #r"=\([0-9a-f][0-9a-f]\)" str)
(let* ((start (match-beginning 0))
- (ch1 (auto-save-unhex (elt str (+ start 1))))
- (code (+ (* 16 ch1)
- (auto-save-unhex (elt str (+ start 2))))))
+ (code (string-to-number (match-string 1 str) 16)))
(setq tmp (concat tmp (substring str 0 start)
(char-to-string code))
str (substring str (match-end 0)))))
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/files.el
--- a/lisp/files.el
+++ b/lisp/files.el
＠＠ -3175,85 +3175,88 ＠＠
If PRED is a zero-argument function, it indicates for each buffer whether
to consider it or not when called with that buffer current."
(interactive "P")
- (save-excursion
- ;; `delete-other-windows' can bomb during autoloads generation, so
- ;; guard it well.
- (if (or noninteractive
- (eq (selected-window) (minibuffer-window))
- (not save-some-buffers-query-display-buffer))
- ;; If playing with windows is unsafe or undesired, just do the
- ;; usual drill.
- (save-some-buffers-1 arg pred nil)
- ;; Else, protect the windows.
- (when (save-window-excursion
- (save-some-buffers-1 arg pred t))
- ;; Force redisplay.
- (sit-for 0)))))
-
-;; XEmacs - do not use queried flag
-(defun save-some-buffers-1 (arg pred switch-buffer)
- (let* ((switched nil)
- (last-buffer nil)
- (files-done
- (map-y-or-n-p
- (lambda (buffer)
- (prog1
- (and (buffer-modified-p buffer)
- (not (buffer-base-buffer buffer))
- ;; XEmacs addition:
- (not (symbol-value-in-buffer 'save-buffers-skip buffer))
- (or
- (buffer-file-name buffer)
- (and pred
- (progn
- (set-buffer buffer)
- (and buffer-offer-save (> (buffer-size) 0)))))
- (or (not (functionp pred))
- (with-current-buffer buffer (funcall pred)))
- (if arg
- t
- ;; #### We should provide a per-buffer means to
- ;; disable the switching. For instance, you might
- ;; want to turn it off for buffers the contents of
- ;; which is meaningless to humans, such as
- ;; `.newsrc.eld'.
- (when (and switch-buffer
- ;; map-y-or-n-p is displaying help
- (not (eq last-buffer buffer)))
- (unless (one-window-p)
- (delete-other-windows))
- (setq switched t)
- ;; #### Consider using `display-buffer' here for 21.1!
- ;;(display-buffer buffer nil (selected-frame)))
- (switch-to-buffer buffer t))
- (if (buffer-file-name buffer)
- (format "Save file %s? "
- (buffer-file-name buffer))
- (format "Save buffer %s? "
- (buffer-name buffer)))))
- (setq last-buffer buffer)))
- (lambda (buffer)
- (set-buffer buffer)
- (condition-case ()
- (save-buffer)
- (error nil)))
- (buffer-list)
- '("buffer" "buffers" "save")
- save-some-buffers-action-alist))
- (abbrevs-done
- (and save-abbrevs abbrevs-changed
- (progn
- (if (or arg
- (eq save-abbrevs 'silently)
- (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name)))
- (write-abbrev-file nil))
- ;; Don't keep bothering user if he says no.
- (setq abbrevs-changed nil)
- t))))
- (or (> files-done 0) abbrevs-done
- (display-message 'no-log "(No files need saving)"))
- switched))
-
+ (labels
+ ;; XEmacs - do not use queried flag, make this function a label.
+ ((save-some-buffers-1 (arg pred switch-buffer)
+ (let* ((switched nil)
+ (last-buffer nil)
+ (files-done
+ (map-y-or-n-p
+ (lambda (buffer)
+ (prog1
+ (and (buffer-modified-p buffer)
+ (not (buffer-base-buffer buffer))
+ ;; XEmacs addition:
+ (not (symbol-value-in-buffer
+ 'save-buffers-skip buffer))
+ (or
+ (buffer-file-name buffer)
+ (and pred
+ (progn
+ (set-buffer buffer)
+ (and buffer-offer-save (> (buffer-size)
+ 0)))))
+ (or (not (functionp pred))
+ (with-current-buffer buffer (funcall pred)))
+ (if arg
+ t
+ ;; #### We should provide a per-buffer means
+ ;; to disable the switching. For instance,
+ ;; you might want to turn it off for buffers
+ ;; the contents of which is meaningless to
+ ;; humans, such as `.newsrc.eld'.
+ (when (and switch-buffer
+ ;; map-y-or-n-p is displaying help
+ (not (eq last-buffer buffer)))
+ (unless (one-window-p)
+ (delete-other-windows))
+ (setq switched t)
+ ;; #### Consider using `display-buffer'
+ ;; here for 21.1!
+ ;;(display-buffer buffer nil (selected-frame)))
+ (switch-to-buffer buffer t))
+ (if (buffer-file-name buffer)
+ (format "Save file %s? "
+ (buffer-file-name buffer))
+ (format "Save buffer %s? "
+ (buffer-name buffer)))))
+ (setq last-buffer buffer)))
+ (lambda (buffer)
+ (set-buffer buffer)
+ (condition-case ()
+ (save-buffer)
+ (error nil)))
+ (buffer-list)
+ '("buffer" "buffers" "save")
+ save-some-buffers-action-alist))
+ (abbrevs-done
+ (and save-abbrevs abbrevs-changed
+ (progn
+ (if (or arg
+ (eq save-abbrevs 'silently)
+ (y-or-n-p (format "Save abbrevs in %s? "
+ abbrev-file-name)))
+ (write-abbrev-file nil))
+ ;; Don't keep bothering user if he says no.
+ (setq abbrevs-changed nil)
+ t))))
+ (or (> files-done 0) abbrevs-done
+ (display-message 'no-log "(No files need saving)"))
+ switched)))
+ (save-excursion
+ ;; `delete-other-windows' can bomb during autoloads generation, so
+ ;; guard it well.
+ (if (or noninteractive
+ (eq (selected-window) (minibuffer-window))
+ (not save-some-buffers-query-display-buffer))
+ ;; If playing with windows is unsafe or undesired, just do the
+ ;; usual drill.
+ (save-some-buffers-1 arg pred nil)
+ ;; Else, protect the windows.
+ (when (save-window-excursion
+ (save-some-buffers-1 arg pred t))
+ ;; Force redisplay.
+ (sit-for 0))))))
(defun not-modified (&optional arg)
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/gui.el
--- a/lisp/gui.el
+++ b/lisp/gui.el
＠＠ -91,24 +91,24 ＠＠
(set-face-foreground 'gui-button-face '(((win color) . "black")))))
-(defun gui-button-action (instance action user-data)
- (let ((domain (image-instance-domain instance)))
- (with-current-buffer (if (windowp domain)
- (window-buffer domain) nil)
- (funcall action user-data))))
-
(defun make-gui-button (string &optional action user-data)
"Make a GUI button whose label is STRING and whose action is ACTION.
If the button is inserted in a buffer and then clicked on, and ACTION
is non-nil, ACTION will be called with one argument, USER-DATA.
When ACTION is called, the buffer containing the button is made current."
- (vector 'button
- :descriptor string
- :face 'gui-button-face
- :callback-ex `(lambda (image-instance event)
- (gui-button-action image-instance
- (quote ,action)
- (quote ,user-data)))))
+ (labels
+ ((gui-button-action (instance action user-data)
+ (let ((domain (image-instance-domain instance)))
+ (with-current-buffer (if (windowp domain)
+ (window-buffer domain) nil)
+ (funcall action user-data)))))
+ (vector 'button
+:descriptor string
+:face 'gui-button-face
+:callback-ex `(lambda (image-instance event)
+ (gui-button-action image-instance
+ (quote ,action)
+ (quote ,user-data))))))
(defun insert-gui-button (button &optional pos buffer)
"Insert GUI button BUTTON at POS in BUFFER."
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/indent.el
--- a/lisp/indent.el
+++ b/lisp/indent.el
＠＠ -48,20 +48,20 ＠＠
(defun indent-for-tab-command (&optional prefix-arg)
"Indent line in proper way for current major mode."
(interactive "P")
- (if (eq indent-line-function 'indent-to-left-margin)
- (insert-tab prefix-arg)
- (if prefix-arg
- (funcall indent-line-function prefix-arg)
- (funcall indent-line-function))))
-
-(defun insert-tab (&optional prefix-arg)
- (let ((count (prefix-numeric-value prefix-arg)))
- (if abbrev-mode
- (expand-abbrev))
- (if indent-tabs-mode
- (insert-char ?\t count)
- ;; XEmacs: (Need the `1+')
- (indent-to (* tab-width (1+ (/ (current-column) tab-width)))))))
+ (labels
+ ((insert-tab (&optional prefix-arg)
+ (let ((count (prefix-numeric-value prefix-arg)))
+ (if abbrev-mode
+ (expand-abbrev))
+ (if indent-tabs-mode
+ (insert-char ?\t count)
+ ;; XEmacs: (Need the `1+')
+ (indent-to (* tab-width (1+ (/ (current-column) tab-width))))))))
+ (if (eq indent-line-function 'indent-to-left-margin)
+ (insert-tab prefix-arg)
+ (if prefix-arg
+ (funcall indent-line-function prefix-arg)
+ (funcall indent-line-function)))))
(defun indent-rigidly (start end count)
"Indent all lines starting in the region sideways by COUNT columns.
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/isearch-mode.el
--- a/lisp/isearch-mode.el
+++ b/lisp/isearch-mode.el
＠＠ -1220,38 +1220,37 ＠＠
;;===========================================================
;; Search Ring
-(defun isearch-ring-adjust1 (advance)
- ;; Helper for isearch-ring-adjust
- (let* ((ring (if isearch-regexp regexp-search-ring search-ring))
- (length (length ring))
- (yank-pointer-name (if isearch-regexp
- 'regexp-search-ring-yank-pointer
- 'search-ring-yank-pointer))
- (yank-pointer (eval yank-pointer-name)))
- (if (zerop length)
- ()
- (set yank-pointer-name
- (setq yank-pointer
- (mod (+ (or yank-pointer 0)
- ;; XEmacs change
- (if advance -1 (if yank-pointer 1 0)))
- length)))
- (setq isearch-string (nth yank-pointer ring)
- isearch-message (mapconcat 'isearch-text-char-description
- isearch-string "")))))
-
(defun isearch-ring-adjust (advance)
;; Helper for isearch-ring-advance and isearch-ring-retreat
; (if (cdr isearch-cmds) ;; is there more than one thing on stack?
; (isearch-pop-state))
- (isearch-ring-adjust1 advance)
- (if search-ring-update
- (progn
- (isearch-search)
- (isearch-update))
- (isearch-edit-string)
- )
- (isearch-push-state))
+ (labels
+ ((isearch-ring-adjust1 (advance)
+ ;; Helper for isearch-ring-adjust
+ (let* ((ring (if isearch-regexp regexp-search-ring search-ring))
+ (length (length ring))
+ (yank-pointer-name (if isearch-regexp
+ 'regexp-search-ring-yank-pointer
+ 'search-ring-yank-pointer))
+ (yank-pointer (symbol-value yank-pointer-name)))
+ (if (zerop length)
+ ()
+ (set yank-pointer-name
+ (setq yank-pointer
+ (mod (+ (or yank-pointer 0)
+ ;; XEmacs change
+ (if advance -1 (if yank-pointer 1 0)))
+ length)))
+ (setq isearch-string (nth yank-pointer ring)
+ isearch-message (mapconcat 'isearch-text-char-description
+ isearch-string ""))))))
+ (isearch-ring-adjust1 advance)
+ (if search-ring-update
+ (progn
+ (isearch-search)
+ (isearch-update))
+ (isearch-edit-string))
+ (isearch-push-state)))
(defun isearch-ring-advance ()
"Advance to the next search string in the ring."
＠＠ -1582,60 +1581,70 ＠＠
;; cases.
(setq this-command (key-binding (this-command-keys))))
(t
- (isearch-maybe-frob-keyboard-macros)
- (if (and this-command
- (symbolp this-command)
- (get this-command 'isearch-command))
- nil ; then continue.
- (isearch-done)))))
-
-(defun isearch-maybe-frob-keyboard-macros ()
- ;;
- ;; If the command about to be executed is `self-insert-command' then change
- ;; the command to `isearch-printing-char' instead, meaning add the last-
- ;; typed character to the search string.
- ;;
- ;; If `this-command' is a string or a vector (that is, a keyboard macro)
- ;; and it contains only one command, which is bound to self-insert-command,
- ;; then do the same thing as for self-inserting commands: arrange for that
- ;; character to be added to the search string. If we didn't do this, then
- ;; typing a compose sequence (a la x-compose.el) would terminate the search
- ;; and insert the character, instead of searching for that character.
- ;;
- ;; We should continue doing this, since it's pretty much the behavior one
- ;; would expect, but it will stop being so necessary once key-translation-
- ;; map exists and is used by x-compose.el and things like it, since the
- ;; translation will have been done before we see the keys.
- ;;
- (cond ((eq this-command 'self-insert-command)
- (setq this-command 'isearch-printing-char))
- ((and (or (stringp this-command) (vectorp this-command))
- (eq (key-binding this-command) 'self-insert-command))
- (setq last-command-event (character-to-event (aref this-command 0))
- last-command-char (and (stringp this-command)
- (aref this-command 0))
- this-command 'isearch-printing-char))
- ((and (null this-command)
- (eq 'key-press (event-type last-command-event))
- (current-local-map)
- (let* ((this-command-keys (this-command-keys))
- (this-command-keys (or (lookup-key function-key-map
- this-command-keys)
- this-command-keys))
- (lookup-key (lookup-key global-map this-command-keys)))
- (and (eq 'self-insert-command lookup-key)
- ;; The feature here that a modification of
- ;; last-command-event is respected is undocumented, and
- ;; only applies when this-command is nil. The design
- ;; isn't reat, and I welcome suggestions for a better
- ;; one.
- (setq last-command-event
- (find-if 'key-press-event-p this-command-keys
-:from-end t)
- last-command-char
- (event-to-character last-command-event)
- this-command 'isearch-printing-char)))))))
-
+ (labels
+ ((isearch-maybe-frob-keyboard-macros ()
+ ;; If the command about to be executed is
+ ;; `self-insert-command' then change the command to
+ ;; `isearch-printing-char' instead, meaning add the last-
+ ;; typed character to the search string.
+ ;;
+ ;; If `this-command' is a string or a vector (that is, a
+ ;; keyboard macro) and it contains only one command, which is
+ ;; bound to self-insert-command, then do the same thing as for
+ ;; self-inserting commands: arrange for that character to be
+ ;; added to the search string. If we didn't do this, then
+ ;; typing a compose sequence (a la x-compose.el) would
+ ;; terminate the search and insert the character, instead of
+ ;; searching for that character.
+ ;;
+ ;; We should continue doing this, since it's pretty much the
+ ;; behavior one would expect, but it will stop being so
+ ;; necessary once key-translation- map exists and is used by
+ ;; x-compose.el and things like it, since the translation will
+ ;; have been done before we see the keys.
+ ;;
+ (cond ((eq this-command 'self-insert-command)
+ (setq this-command 'isearch-printing-char))
+ ((and (or (stringp this-command) (vectorp this-command))
+ (eq (key-binding this-command)
+ 'self-insert-command))
+ (setq last-command-event
+ (character-to-event (aref this-command 0))
+ last-command-char (and (stringp this-command)
+ (aref this-command 0))
+ this-command 'isearch-printing-char))
+ ((and (null this-command)
+ (eq 'key-press (event-type last-command-event))
+ (current-local-map)
+ (let* ((this-command-keys (this-command-keys))
+ (this-command-keys (or (lookup-key
+ function-key-map
+ this-command-keys)
+ this-command-keys))
+ (lookup-key (lookup-key global-map
+ this-command-keys)))
+ (and (eq 'self-insert-command lookup-key)
+ ;; The feature here that a modification
+ ;; of last-command-event is respected is
+ ;; undocumented, and only applies when
+ ;; this-command is nil. The design isn't
+ ;; great, and I welcome suggestions for a
+ ;; better one.
+ (setq last-command-event
+ (find-if 'key-press-event-p
+ this-command-keys
+:from-end t)
+ last-command-char
+ (event-to-character
+ last-command-event)
+ this-command
+ 'isearch-printing-char))))))))
+ (isearch-maybe-frob-keyboard-macros)
+ (if (and this-command
+ (symbolp this-command)
+ (get this-command 'isearch-command))
+ nil ; then continue.
+ (isearch-done))))))
;;;========================================================
;;; Highlighting
＠＠ -1645,24 +1654,25 ＠＠
;; this face is initialized by faces.el since isearch is preloaded.
;(make-face 'isearch)
-(defun isearch-make-extent (begin end)
- (let ((x (make-extent begin end (current-buffer))))
- ;; make the isearch extent always take precedence over any mouse-
- ;; highlighted extents we may be passing through, since isearch, being
- ;; modal, is more interesting (there's nothing they could do with a
- ;; mouse-highlighted extent while in the midst of a search anyway).
- (set-extent-priority x (+ mouse-highlight-priority 2))
- (set-extent-face x 'isearch)
- (setq isearch-extent x)))
-
(defun isearch-highlight (begin end)
- (if (null search-highlight)
- nil
- ;; make sure isearch-extent is in the current buffer
- (or (and (extentp isearch-extent)
- (extent-live-p isearch-extent))
- (isearch-make-extent begin end))
- (set-extent-endpoints isearch-extent begin end (current-buffer))))
+ (labels
+ ((isearch-make-extent (begin end)
+ (let ((x (make-extent begin end (current-buffer))))
+ ;; make the isearch extent always take precedence over any mouse-
+ ;; highlighted extents we may be passing through, since isearch,
+ ;; being modal, is more interesting (there's nothing they could do
+ ;; with a mouse-highlighted extent while in the midst of a search
+ ;; anyway).
+ (set-extent-priority x (+ mouse-highlight-priority 2))
+ (set-extent-face x 'isearch)
+ (setq isearch-extent x))))
+ (if (null search-highlight)
+ nil
+ ;; make sure isearch-extent is in the current buffer
+ (or (and (extentp isearch-extent)
+ (extent-live-p isearch-extent))
+ (isearch-make-extent begin end))
+ (set-extent-endpoints isearch-extent begin end (current-buffer)))))
;; This used to have a TOTALLY flag that also deleted the extent. I
;; don't think this is necessary any longer, as isearch-highlight can
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/itimer.el
--- a/lisp/itimer.el
+++ b/lisp/itimer.el
＠＠ -102,62 +102,6 ＠＠
(defvar itimer-edit-start-marker nil)
-;; macros must come first... or byte-compile'd code will throw back its
-;; head and scream.
-
-(defmacro itimer-decrement (variable)
- (list 'setq variable (list '1- variable)))
-
-(defmacro itimer-increment (variable)
- (list 'setq variable (list '1+ variable)))
-
-(defmacro itimer-signum (n)
- (list 'if (list '> n 0) 1
- (list 'if (list 'zerop n) 0 -1)))
-
-;; Itimer access functions should behave as if they were subrs. These
-;; macros are used to check the arguments to the itimer functions and
-;; signal errors appropriately if the arguments are not valid.
-
-(defmacro check-itimer (var)
- "If VAR is not bound to an itimer, signal `wrong-type-argument'.
-This is a macro."
- (list 'setq var
- (list 'if (list 'itimerp var) var
- (list 'signal ''wrong-type-argument
- (list 'list ''itimerp var)))))
-
-(defmacro check-itimer-coerce-string (var)
- "If VAR is bound to a string, look up the itimer that it names and
-bind VAR to it. Otherwise, if VAR is not bound to an itimer, signal
-`wrong-type-argument'. This is a macro."
- (list 'setq var
- (list 'cond
- (list (list 'itimerp var) var)
- (list (list 'stringp var) (list 'get-itimer var))
- (list t (list 'signal ''wrong-type-argument
- (list 'list ''string-or-itimer-p var))))))
-
-(defmacro check-nonnegative-number (var)
- "If VAR is not bound to a number, signal `wrong-type-argument'.
-If VAR is not bound to a positive number, signal `args-out-of-range'.
-This is a macro."
- (list 'setq var
- (list 'if (list 'not (list 'numberp var))
- (list 'signal ''wrong-type-argument
- (list 'list ''natnump var))
- (list 'if (list '< var 0)
- (list 'signal ''args-out-of-range (list 'list var))
- var))))
-
-(defmacro check-string (var)
- "If VAR is not bound to a string, signal `wrong-type-argument'.
-This is a macro."
- (list 'setq var
- (list 'if (list 'stringp var) var
- (list 'signal ''wrong-type-argument
- (list 'list ''stringp var)))))
-
;; Functions to access and modify itimer attributes.
(defun itimerp (object)
＠＠ -173,24 +117,24 ＠＠
(defun itimer-name (itimer)
"Return the name of ITIMER."
- (check-itimer itimer)
+ (check-type itimer itimer)
(car itimer))
(defun itimer-value (itimer)
"Return the number of seconds until ITIMER expires."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 1 itimer))
(defun itimer-restart (itimer)
"Return the value to which ITIMER will be set at restart.
The value nil is returned if this itimer isn't set to restart."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 2 itimer))
(defun itimer-function (itimer)
"Return the function of ITIMER.
This function is called each time ITIMER expires."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 3 itimer))
(defun itimer-is-idle (itimer)
＠＠ -198,31 +142,31 ＠＠
Normal timers expire after a set interval. Idle timers expire
only after Emacs has been idle for a specific interval. ``Idle''
means no command events have occurred within the interval."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 4 itimer))
(defun itimer-uses-arguments (itimer)
"Return non-nil if the function of ITIMER will be called with arguments.
ITIMER's function is called with the arguments each time ITIMER expires.
The arguments themselves are retrievable with `itimer-function-arguments'."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 5 itimer))
(defun itimer-function-arguments (itimer)
"Return the function arguments of ITIMER as a list.
ITIMER's function is called with these arguments each time ITIMER expires."
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 6 itimer))
(defun itimer-recorded-run-time (itimer)
- (check-itimer itimer)
+ (check-type itimer itimer)
(nth 7 itimer))
(defun set-itimer-name (itimer name)
"Set the name of ITIMER to be NAME.
NAME is an identifier for the itimer. It must be a string. If an active
itimer already exists with this name, an error is signaled."
- (check-string name)
+ (check-type name string)
(and (itimer-live-p itimer)
(get-itimer name)
(error "itimer named \"%s\" already existing and activated" name))
＠＠ -235,8 +179,9 ＠＠
VALUE can be a floating point number. Otherwise it
must be an integer.
Returns VALUE."
- (check-itimer itimer)
- (check-nonnegative-number value)
+ (check-type itimer itimer)
+ (check-type value number)
+ (check-argument-range value 0 nil)
(let ((inhibit-quit t))
;; If the itimer is in the active list, and under the new
;; timeout value would expire before we would normally
＠＠ -253,8 +198,9 ＠＠
;; Same as set-itimer-value but does not wakeup the driver.
;; Only should be used by the drivers when processing expired timers.
(defun set-itimer-value-internal (itimer value)
- (check-itimer itimer)
- (check-nonnegative-number value)
+ (check-type itimer itimer)
+ (check-type value number)
+ (check-argument-range value 0 nil)
(setcar (cdr itimer) value))
(defun set-itimer-restart (itimer restart)
＠＠ -264,22 +210,24 ＠＠
RESTART can be a floating point number. Otherwise it
must be an integer.
Returns RESTART."
- (check-itimer itimer)
- (if restart (check-nonnegative-number restart))
+ (check-type itimer itimer)
+ (when restart
+ (check-type restart number)
+ (check-argument-range restart 0 nil))
(setcar (cdr (cdr itimer)) restart))
(defun set-itimer-function (itimer function)
"Set the function of ITIMER to be FUNCTION.
FUNCTION will be called when itimer expires.
Returns FUNCTION."
- (check-itimer itimer)
+ (check-type itimer itimer)
(setcar (nthcdr 3 itimer) function))
(defun set-itimer-is-idle (itimer flag)
"Set flag that says whether ITIMER is an idle timer.
If FLAG is non-nil, then ITIMER will be considered an idle timer.
Returns FLAG."
- (check-itimer itimer)
+ (check-type itimer itimer)
(setcar (nthcdr 4 itimer) flag))
(defun set-itimer-uses-arguments (itimer flag)
＠＠ -287,23 +235,23 ＠＠
If FLAG is non-nil, then the function will be called with one argument,
otherwise the function will be called with no arguments.
Returns FLAG."
- (check-itimer itimer)
+ (check-type itimer itimer)
(setcar (nthcdr 5 itimer) flag))
(defun set-itimer-function-arguments (itimer &optional arguments)
"Set the function arguments of ITIMER to be ARGUMENTS.
The function of ITIMER will be called with ARGUMENTS when itimer expires.
Returns ARGUMENTS."
- (check-itimer itimer)
+ (check-type itimer itimer)
(setcar (nthcdr 6 itimer) arguments))
(defun set-itimer-recorded-run-time (itimer time)
- (check-itimer itimer)
+ (check-type itimer itimer)
(setcar (nthcdr 7 itimer) time))
(defun get-itimer (name)
"Return itimer named NAME, or nil if there is none."
- (check-string name)
+ (check-type name string)
(assoc name itimer-list))
(defun read-itimer (prompt &optional initial-input)
＠＠ -315,7 +263,8 ＠＠
(defun delete-itimer (itimer)
"Deletes ITIMER. ITIMER may be an itimer or the name of one."
- (check-itimer-coerce-string itimer)
+ (if (stringp itimer) (setq itimer (get-itimer itimer)))
+ (check-type itimer itimer)
(setq itimer-list (delete* itimer itimer-list)))
(defun start-itimer (name function value &optional restart
＠＠ -362,15 +311,18 ＠＠
;; hard to imagine the user specifying these interactively
nil
nil ))
- (check-string name)
- (check-nonnegative-number value)
- (if restart (check-nonnegative-number restart))
+ (check-type name string)
+ (check-type value number)
+ (check-argument-range value 0 nil)
+ (when restart
+ (check-type restart number)
+ (check-argument-range restart 0 nil))
;; Make proposed itimer name unique if it's not already.
(let ((oname name)
(num 2))
(while (get-itimer name)
(setq name (format "%s<%d>" oname num))
- (itimer-increment num)))
+ (incf num)))
(activate-itimer (list name value restart function is-idle
with-args function-arguments (list 0 0 0)))
(car itimer-list))
＠＠ -387,7 +339,7 ＠＠
"Activate ITIMER, which was previously created with `make-itimer'.
ITIMER will be added to the global list of running itimers,
its FUNCTION will be called when it expires, and so on."
- (check-itimer itimer)
+ (check-type itimer itimer)
(if (memq itimer itimer-list)
(error "itimer already activated"))
(if (not (numberp (itimer-value itimer)))
＠＠ -408,7 +360,7 ＠＠
(num 1))
(while (get-itimer name)
(setq name (format "%s<%d>" oname num))
- (itimer-increment num))
+ (incf num))
(setcar itimer name))
;; signal an error if the timer's name matches an already
;; activated timer.
＠＠ -569,7 +521,7 ＠＠
(while (and (>= opoint (point)) (< n 6))
(forward-sexp 2)
(backward-sexp)
- (itimer-increment n))
+ (incf n))
(cond ((eq n 1) (error "Cannot change itimer name."))
((eq n 2) 'value)
((eq n 3) 'restart)
＠＠ -630,7 +582,7 ＠＠
(defun itimer-edit-next-field (count)
(interactive "p")
(itimer-edit-beginning-of-field)
- (cond ((> (itimer-signum count) 0)
+ (cond ((plusp count)
(while (not (zerop count))
(forward-sexp)
;; wrap from eob to itimer-edit-start-marker
＠＠ -645,8 +597,8 ＠＠
(progn
(forward-sexp 2)
(backward-sexp)))
- (itimer-decrement count)))
- ((< (itimer-signum count) 0)
+ (decf count)))
+ ((minusp count)
(while (not (zerop count))
(backward-sexp)
;; treat fields at beginning of line as if they weren't there.
＠＠ -657,7 +609,7 ＠＠
(progn
(goto-char (point-max))
(backward-sexp)))
- (itimer-increment count)))))
+ (incf count)))))
(defun itimer-edit-previous-field (count)
(interactive "p")
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/lib-complete.el
--- a/lisp/lib-complete.el
+++ b/lisp/lib-complete.el
＠＠ -118,90 +118,90 ＠＠
(<root><modtimes><completion-table>)")
-(defun lib-complete:better-root (ROOT1 ROOT2)
- "Return non-nil if ROOT1 is a superset of ROOT2."
- (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
- (string-match
- (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
- ROOT2)))
-
-(defun lib-complete:get-completion-table (FILE PATH FILTER)
- (let* ((subdir (file-name-directory FILE))
- (root (file-name-nondirectory FILE))
- (PATH
- (mapcar
- (function (lambda (dir) (file-name-as-directory
- (expand-file-name (or dir "")))))
- PATH))
- (key (vector PATH subdir FILTER))
- (real-dirs
- (if subdir
- (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
- PATH))
- (path-modtimes
- (mapcar
- (function (lambda (fn) (if fn (nth 5 (file-attributes fn)))))
- real-dirs))
- (cache-entry (assoc key lib-complete:cache))
- (cache-records (cdr cache-entry)))
- ;; Look for cached entry
- (catch 'table
- (while cache-records
- (if (and
- (lib-complete:better-root (nth 0 (car cache-records)) root)
- (equal (nth 1 (car cache-records)) path-modtimes))
- (throw 'table (nth 2 (car cache-records))))
- (setq cache-records (cdr cache-records)))
- ;; Otherwise build completions
- (let ((completion-list
- (progn-with-message "(building completion table...)"
- (library-all-completions FILE PATH nil 'fast)))
- (completion-table (make-vector 127 0)))
- (while completion-list
- (let ((completion
- (if (or (not FILTER)
- (file-directory-p (car completion-list)))
- (car completion-list)
- (funcall FILTER (car completion-list)))))
- (if completion
- (intern completion completion-table)))
- (setq completion-list (cdr completion-list)))
- ;; Cache the completions
- (lib-complete:cache-completions key root
- path-modtimes completion-table)
- completion-table))))
-
(defvar lib-complete:max-cache-size 40
"*Maximum number of search paths which are cached.")
-(defun lib-complete:cache-completions (key root modtimes table)
- (let* ((cache-entry (assoc key lib-complete:cache))
- (cache-records (cdr cache-entry))
- (new-cache-records (list (list root modtimes table))))
- (if (not cache-entry) nil
- ;; Remove old cache entry
- (setq lib-complete:cache (delete* cache-entry lib-complete:cache))
- ;; Copy non-redundant entries from old cache entry
- (while cache-records
- (if (or (equal root (nth 0 (car cache-records)))
- (lib-complete:better-root root (nth 0 (car cache-records))))
- nil
- (setq new-cache-records
- (cons (car cache-records) new-cache-records)))
- (setq cache-records (cdr cache-records))))
- ;; Add entry to front of cache
- (setq lib-complete:cache
- (cons (cons key (nreverse new-cache-records)) lib-complete:cache))
- ;; Trim cache
- (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
- (if tail (setcdr tail nil)))))
-
;;=== Read a filename, with completion in a search path ===================
(defun read-library-internal (FILE FILTER FLAG)
"Don't call this."
;; Relies on read-library-internal-search-path being let-bound
(declare (special read-library-internal-search-path))
+ (labels
+ ((lib-complete:better-root (ROOT1 ROOT2)
+ ; Return non-nil if ROOT1 is a superset of ROOT2.
+ (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
+ (string-match
+ (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
+ ROOT2)))
+ (lib-complete:get-completion-table (FILE PATH FILTER)
+ (let* ((subdir (file-name-directory FILE))
+ (root (file-name-nondirectory FILE))
+ (PATH
+ (mapcar
+ (function (lambda (dir) (file-name-as-directory
+ (expand-file-name (or dir "")))))
+ PATH))
+ (key (vector PATH subdir FILTER))
+ (real-dirs
+ (if subdir
+ (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
+ PATH))
+ (path-modtimes
+ (mapcar
+ (function (lambda (fn) (if fn (nth 5 (file-attributes fn)))))
+ real-dirs))
+ (cache-entry (assoc key lib-complete:cache))
+ (cache-records (cdr cache-entry)))
+ ;; Look for cached entry
+ (catch 'table
+ (while cache-records
+ (if (and
+ (lib-complete:better-root (nth 0 (car cache-records)) root)
+ (equal (nth 1 (car cache-records)) path-modtimes))
+ (throw 'table (nth 2 (car cache-records))))
+ (setq cache-records (cdr cache-records)))
+ ;; Otherwise build completions
+ (let ((completion-list
+ (progn-with-message "(building completion table...)"
+ (library-all-completions FILE PATH nil 'fast)))
+ (completion-table (make-vector 127 0)))
+ (while completion-list
+ (let ((completion
+ (if (or (not FILTER)
+ (file-directory-p (car completion-list)))
+ (car completion-list)
+ (funcall FILTER (car completion-list)))))
+ (if completion
+ (intern completion completion-table)))
+ (setq completion-list (cdr completion-list)))
+ ;; Cache the completions
+ (lib-complete:cache-completions key root
+ path-modtimes completion-table)
+ completion-table))))
+ (lib-complete:cache-completions (key root modtimes table)
+ (let* ((cache-entry (assoc key lib-complete:cache))
+ (cache-records (cdr cache-entry))
+ (new-cache-records (list (list root modtimes table))))
+ (if (not cache-entry) nil
+ ;; Remove old cache entry
+ (setq lib-complete:cache (delete* cache-entry lib-complete:cache))
+ ;; Copy non-redundant entries from old cache entry
+ (while cache-records
+ (if (or (equal root (nth 0 (car cache-records)))
+ (lib-complete:better-root root
+ (nth 0 (car cache-records))))
+ nil
+ (setq new-cache-records
+ (cons (car cache-records) new-cache-records)))
+ (setq cache-records (cdr cache-records))))
+ ;; Add entry to front of cache
+ (setq lib-complete:cache
+ (cons (cons key (nreverse new-cache-records))
+ lib-complete:cache))
+ ;; Trim cache
+ (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
+ (if tail (setcdr tail nil))))))
(let ((completion-table
(lib-complete:get-completion-table
FILE read-library-internal-search-path FILTER)))
＠＠ -212,7 +212,7 ＠＠
((eq FLAG nil) (try-completion FILE completion-table nil))
((eq FLAG t) (all-completions FILE completion-table nil))
((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
- )))
+ ))))
(defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH
FULL FILTER)
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/minibuf.el
--- a/lisp/minibuf.el
+++ b/lisp/minibuf.el
＠＠ -1479,8 +1479,7 ＠＠
default))
prompt))
(alist (mapcar #'(lambda (b) (cons (buffer-name b) b))
- (remove-if (lambda (elt) (member elt exclude))
- (buffer-list))))
+ (set-difference (buffer-list) exclude)))
result)
(while (progn
(setq result (completing-read prompt alist nil require-match
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/newcomment.el
--- a/lisp/newcomment.el
+++ b/lisp/newcomment.el
＠＠ -577,12 +577,14 ＠＠
(concat lpad s (when multi (make-string n (aref str (1- (match-end 1))))) rpad)
;; construct a regexp that would match anything from just S
;; to any possible output of this function for any N.
- (concat (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?"))
- lpad "") ;padding is not required
- (regexp-quote s)
- (when multi "+") ;the last char of S might be repeated
- (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?"))
- rpad "")))))) ;padding is not required
+ (labels
+ ((regexp-quote-with-? (c) (concat (regexp-quote (string c)) "?")))
+ (concat (mapconcat #'regexp-quote-with-?
+ lpad "") ;padding is not required
+ (regexp-quote s)
+ (when multi "+") ;the last char of S might be repeated
+ (mapconcat #'regexp-quote-with-?
+ rpad ""))))))) ;padding is not required
(defun comment-padleft (str &optional n)
"Construct a string composed of `comment-padding' plus STR.
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/packages.el
--- a/lisp/packages.el
+++ b/lisp/packages.el
＠＠ -91,19 +91,9 ＠＠
`("site-packages" ,＠(when (featurep 'mule) '("mule-packages"))
"xemacs-packages"))
-(defun package-get-key-1 (info key)
- "Locate keyword `key' in list."
- (cond ((null info)
- nil)
- ((eq (car info) key)
- (nth 1 info))
- (t (package-get-key-1 (cddr info) key))))
-
(defun package-get-key (name key)
"Get info `key' from package `name'."
- (let ((info (assq name packages-package-list)))
- (when info
- (package-get-key-1 (cdr info) key))))
+ (getf (cdr (assq name packages-package-list)) key))
(defun package-provide (name &rest attributes)
(let ((info (if (and attributes (floatp (car attributes)))
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/simple.el
--- a/lisp/simple.el
+++ b/lisp/simple.el
＠＠ -407,12 +407,6 ＠＠
(if (eq arg '-) (setq arg -1))
(kill-region (point) (+ (point) arg)))
-;; Internal subroutine of backward-delete-char
-(defun kill-backward-chars (arg)
- (if (listp arg) (setq arg (car arg)))
- (if (eq arg '-) (setq arg -1))
- (kill-region (point) (- (point) arg)))
-
(defun backward-delete-char-untabify (arg &optional killp)
"Delete characters backward, changing tabs into spaces.
Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
＠＠ -824,8 +818,7 ＠＠
percent narrowed-details col hscroll)
(message "Char: %s (%s %s) point=%d of %d(%d%%)%s column %d %s"
(text-char-description char) unicode-string
- (mapconcat (lambda (arg) (format "%S" arg))
- (split-char char) " ")
+ (mapconcat #'prin1-to-string (split-char char) " ")
pos total
percent narrowed-details col hscroll)))))
＠＠ -4766,8 +4759,8 ＠＠
(cond ((featurep 'xemacs) "XEmacs")
(t "Emacs")))
-(defun debug-print-1 (&rest args)
- "Send a debugging-type string to standard output.
+(defun debug-print (&rest args)
+ "Send a string to the debugging output.
If the first argument is a string, it is considered to be a format
specifier if there are sufficient numbers of other args, and the string is
formatted using (apply #'format args). Otherwise, each argument is printed
＠＠ -4790,15 +4783,6 ＠＠
(incf i))
(terpri)))))
-(defun debug-print (&rest args)
- "Send a string to the debugging output.
-If the first argument is a string, it is considered to be a format
-specifier if there are sufficient numbers of other args, and the string is
-formatted using (apply #'format args). Otherwise, each argument is printed
-individually in a numbered list."
- (let ((standard-output 'external-debugging-output))
- (apply #'debug-print-1 args)))
-
(defun debug-backtrace ()
"Send a backtrace to the debugging output."
(let ((standard-output 'external-debugging-output))
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/subr.el
--- a/lisp/subr.el
+++ b/lisp/subr.el
＠＠ -975,9 +975,9 ＠＠
"Return INTEGER converted to a bit vector.
Optional argument MINLENGTH gives a minimum length for the returned vector.
If MINLENGTH is not given, zero high-order bits will be ignored."
- (check-argument-type #'integerp integer)
+ (check-type integer integer)
(setq minlength (or minlength 0))
- (check-nonnegative-number minlength)
+ (check-type minlength natnum)
(read (format (format "#*%%0%db" minlength) integer)))
;; XEmacs addition.
diff -r ddf56c45634e53e4b1cdfd4777a53c95f6501fb5 -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 lisp/widget.el
--- a/lisp/widget.el
+++ b/lisp/widget.el
＠＠ -34,19 +34,6 ＠＠
;;; Code:
-;; Neither XEmacs, nor latest GNU Emacs need this -- provided for
-;; compatibility.
-;; (defalias 'define-widget-keywords 'ignore)
-
-(defmacro define-widget-keywords (&rest keys)
- "This doesn't do anything in Emacs 20 or XEmacs."
- `(eval-and-compile
- (let ((keywords (quote ,keys)))
- (while keywords
- (or (boundp (car keywords))
- (set (car keywords) (car keywords)))
- (setq keywords (cdr keywords))))))
-
(defun define-widget (name class doc &rest args)
"Define a new widget type named NAME from CLASS.
Repository URL: https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Support predefined character classes in #'skip-chars-{forward, backward}, too
12 years, 8 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1336162322 -3600
# Node ID 3df910176b6abc7d66f691cc8cff97498bf5d419
# Parent d026b665014fda7a8d6148e8cc8fb9d046bff7f7
Support predefined character classes in #'skip-chars-{forward,backward}, too
src/ChangeLog addition:
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* regex.c:
Move various #defines and enums to regex.h, since we need them
when implementing #'skip-chars-{backward,forward}.
* regex.c (re_wctype):
* regex.c (re_iswctype):
Be more robust about case insensitivity here.
* regex.c (regex_compile):
* regex.h:
* regex.h (RE_ISWCTYPE_ARG_DECL):
* regex.h (CHAR_CLASS_MAX_LENGTH):
* search.c (skip_chars):
Implement support for the predefined character classes in this
function.
tests/ChangeLog addition:
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/regexp-tests.el (equal):
* automated/regexp-tests.el (Assert-char-class):
Correct a stray parenthesis; add tests for the predefined
character classes with #'skip-chars-{forward,backward}; update the
tests to reflect some changed design decisions on my part.
man/ChangeLog addition:
2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/searching.texi (Regular Expressions):
* lispref/searching.texi (Syntax of Regexps):
* lispref/searching.texi (Char Classes):
* lispref/searching.texi (Regexp Example):
Document the predefined character classes in this file.
diff -r d026b665014f -r 3df910176b6a man/ChangeLog
--- a/man/ChangeLog Wed Apr 25 20:25:33 2012 +0100
+++ b/man/ChangeLog Fri May 04 21:12:02 2012 +0100
＠＠ -1,3 +1,11 ＠＠
+2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lispref/searching.texi (Regular Expressions):
+ * lispref/searching.texi (Syntax of Regexps):
+ * lispref/searching.texi (Char Classes):
+ * lispref/searching.texi (Regexp Example):
+ Document the predefined character classes in this file.
+
2011-12-30 Aidan Kehoe <kehoea(a)parhasard.net>
* cl.texi (Top):
diff -r d026b665014f -r 3df910176b6a man/lispref/searching.texi
--- a/man/lispref/searching.texi Wed Apr 25 20:25:33 2012 +0100
+++ b/man/lispref/searching.texi Fri May 04 21:12:02 2012 +0100
＠＠ -180,6 +180,7 ＠＠
＠menu
* Syntax of Regexps:: Rules for writing regular expressions.
+* Char Classes:: Predefined character classes for searching.
* Regexp Example:: Illustrates regular expression syntax.
＠end menu
＠＠ -335,6 +336,11 ＠＠
To include ＠samp{^} in a set, put it anywhere but at the beginning of
the set.
+It is also possible to specify named character classes as part of your
+character set; for example, ＠samp{[:xdigit:]} will match hexadecimal
+digits, ＠samp{[:nonascii:]} will match characters outside the basic
+ASCII set. These are documented elsewhere, ＠pxref{Char Classes}.
+
＠item [^ ＠dots{} ]
＠cindex ＠samp{^} in regexp
＠samp{[^} begins a ＠dfn{complement character set}, which matches any
＠＠ -604,6 +610,61 ＠＠
＠end example
＠end defun
+＠node Char Classes
+＠subsection Char Classes
+
+These are the predefined character classes available within regular
+expression character sets, and within ＠samp{skip-chars-forward} and
+＠samp{skip-chars-backward}, ＠xref{Skipping Characters}.
+
+＠table ＠samp
+＠item [:alnum:]
+This matches any ASCII letter or digit, or any non-ASCII character
+with word syntax.
+＠item [:alpha:]
+This matches any ASCII letter, or any non-ASCII character with word syntax.
+＠item [:ascii:]
+This matches any character with a numeric value below ＠samp{?\x80}.
+＠item [:blank:]
+This matches space or tab.
+＠item [:cntrl:]
+This matches any character with a numeric value below ＠samp{?\x20},
+the code for space; these are the ASCII control characters.
+＠item [:digit:]
+This matches the characters ＠samp{?0} to ＠samp{?9}, inclusive.
+＠item [:graph:]
+This matches ``graphic'' characters, with numeric values greater than
+＠samp{?\x20}, exclusive of ＠samp{?\x7f}, the delete character.
+＠item [:lower:]
+This matches minuscule characters, or any character with case
+information if ＠samp{case-fold-search} is non-nil.
+＠item [:multibyte:]
+This matches non-ASCII characters, that is, any character with a
+numeric value above ＠samp{?\x7f}.
+＠item [:nonascii:]
+This is equivalent to ＠samp{[:multibyte:]}.
+＠item [:print:]
+This is equivalent to [:graph:], but also matches the space character,
+＠samp{?\x20}.
+＠item [:punct:]
+This matches non-control, non-alphanumeric ASCII characters, or any
+non-ASCII character without word syntax.
+＠item [:space:]
+This matches any character with whitespace syntax.
+＠item [:unibyte:]
+This is a GNU Emacs extension; in XEmacs it is equivalent to
+＠samp{[:ascii:]}. Note that this means it is not equivalent to
+＠samp{"\x00-\xff"}, which one might have assumed to be the case.
+＠item [:upper:]
+This matches majuscule characters, or any character with case
+information if ＠samp{case-fold-search} is non-nil.
+＠item [:word:]
+This matches any character with word syntax.
+＠item [:xdigit:]
+This matches hexadecimal digits, so the decimal digits ＠samp{0-9} and the
+letters ＠samp{a-F} and ＠samp{A-F}.
+＠end table
+
＠node Regexp Example
＠subsection Complex Regexp Example
diff -r d026b665014f -r 3df910176b6a src/ChangeLog
--- a/src/ChangeLog Wed Apr 25 20:25:33 2012 +0100
+++ b/src/ChangeLog Fri May 04 21:12:02 2012 +0100
＠＠ -1,3 +1,19 ＠＠
+2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * regex.c:
+ Move various #defines and enums to regex.h, since we need them
+ when implementing #'skip-chars-{backward,forward}.
+ * regex.c (re_wctype):
+ * regex.c (re_iswctype):
+ Be more robust about case insensitivity here.
+ * regex.c (regex_compile):
+ * regex.h:
+ * regex.h (RE_ISWCTYPE_ARG_DECL):
+ * regex.h (CHAR_CLASS_MAX_LENGTH):
+ * search.c (skip_chars):
+ Implement support for the predefined character classes in this
+ function.
+
2012-04-25 Aidan Kehoe <kehoea(a)parhasard.net>
* search.c (string_match_1): Actually use the POSIX argument here,
diff -r d026b665014f -r 3df910176b6a src/regex.c
--- a/src/regex.c Wed Apr 25 20:25:33 2012 +0100
+++ b/src/regex.c Fri May 04 21:12:02 2012 +0100
＠＠ -178,51 +178,7 ＠＠
/* isalpha etc. are used for the character classes. */
#include <ctype.h>
-#ifdef emacs
-
-/* 1 if C is an ASCII character. */
-#define ISASCII(c) ((c) < 0x80)
-
-/* 1 if C is a unibyte character. */
-#define ISUNIBYTE(c) 0
-
-/* The Emacs definitions should not be directly affected by locales. */
-
-/* In Emacs, these are only used for single-byte characters. */
-#define ISDIGIT(c) ((c) >= '0' && (c) <= '9')
-#define ISCNTRL(c) ((c) < ' ')
-#define ISXDIGIT(c) (ISDIGIT (c) || ((c) >= 'a' && (c) <= 'f') \
- || ((c) >= 'A' && (c) <= 'F'))
-
-/* This is only used for single-byte characters. */
-#define ISBLANK(c) ((c) == ' ' || (c) == '\t')
-
-/* The rest must handle multibyte characters. */
-
-#define ISGRAPH(c) ((c) > ' ' && (c) != 0x7f)
-#define ISPRINT(c) ((c) == ' ' || ISGRAPH (c))
-#define ISALPHA(c) (ISASCII (c) ? (((c) >= 'a' && (c) <= 'z') \
- || ((c) >= 'A' && (c) <= 'Z')) \
- : ISWORD (c))
-#define ISALNUM(c) (ISALPHA (c) || ISDIGIT (c))
-
-#define ISLOWER(c) LOWERCASEP (lispbuf, c)
-
-#define ISPUNCT(c) (ISASCII (c) \
- ? ((c) > ' ' && (c) < 0x7F \
- && !(((c) >= 'a' && (c) <= 'z') \
- || ((c) >= 'A' && (c) <= 'Z') \
- || ((c) >= '0' && (c) <= '9'))) \
- : !ISWORD (c))
-
-#define ISSPACE(c) \
- (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Swhitespace)
-
-#define ISUPPER(c) UPPERCASEP (lispbuf, c)
-
-#define ISWORD(c) (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Sword)
-
-#else /* not emacs */
+#ifndef emacs /* For the emacs build, we need these in the header. */
/* 1 if C is an ASCII character. */
#define ISASCII(c) ((c) < 0200)
＠＠ -2013,23 +1969,6 ＠＠
/* The next available element. */
#define COMPILE_STACK_TOP (compile_stack.stack[compile_stack.avail])
-/* Bits used to implement the multibyte-part of the various character
- classes such as [:alnum:] in a charset's range table. XEmacs; use an
- enum, so they're visible in the debugger. */
-enum
-{
- BIT_WORD = (1 << 0),
- BIT_LOWER = (1 << 1),
- BIT_PUNCT = (1 << 2),
- BIT_SPACE = (1 << 3),
- BIT_UPPER = (1 << 4),
- /* XEmacs; we need this, because we unify treatment of ASCII and non-ASCII
- (possible matches) in charset_mule. [:alpha:] matches all characters
- with word syntax, with the exception of [0-9]. We don't need
- BIT_MULTIBYTE. */
- BIT_ALPHA = (1 << 5)
-};
-
/* Set the bit for character C in a bit vector. */
#define SET_LIST_BIT(c) \
(buf_end[((unsigned char) (c)) / BYTEWIDTH] \
＠＠ -2059,10 +1998,8 ＠＠
} \
}
-#define CHAR_CLASS_MAX_LENGTH 9 /* Namely, `multibyte'. */
-
/* Map a string to the char class it names (if any). */
-static re_wctype_t
+re_wctype_t
re_wctype (const char *string)
{
if (STREQ (string, "alnum")) return RECC_ALNUM;
＠＠ -2086,17 +2023,10 ＠＠
}
/* True if CH is in the char class CC. */
-static re_bool
-re_iswctype (int ch, re_wctype_t cc)
+int
+re_iswctype (int ch, re_wctype_t cc
+ RE_ISWCTYPE_ARG_DECL)
{
-#ifdef emacs
- /* This is cheesy, lispbuf isn't available to us when compiling the
- pattern. It's effectively only called (on Mule builds) when the current
- buffer doesn't matter (e.g. for RECC_ASCII, RECC_CNTRL), so it's not a
- big deal. */
- struct buffer *lispbuf = current_buffer;
-#endif
-
switch (cc)
{
case RECC_ALNUM: return ISALNUM (ch) != 0;
＠＠ -2105,11 +2035,20 ＠＠
case RECC_CNTRL: return ISCNTRL (ch) != 0;
case RECC_DIGIT: return ISDIGIT (ch) != 0;
case RECC_GRAPH: return ISGRAPH (ch) != 0;
- case RECC_LOWER: return ISLOWER (ch) != 0;
case RECC_PRINT: return ISPRINT (ch) != 0;
case RECC_PUNCT: return ISPUNCT (ch) != 0;
case RECC_SPACE: return ISSPACE (ch) != 0;
+#ifdef emacs
+ case RECC_UPPER:
+ return NILP (lispbuf->case_fold_search) ? ISUPPER (ch) != 0
+: !NOCASEP (lispbuf, ch);
+ case RECC_LOWER:
+ return NILP (lispbuf->case_fold_search) ? ISLOWER (ch) != 0
+: !NOCASEP (lispbuf, ch);
+#else
case RECC_UPPER: return ISUPPER (ch) != 0;
+ case RECC_LOWER: return ISLOWER (ch) != 0;
+#endif
case RECC_XDIGIT: return ISXDIGIT (ch) != 0;
case RECC_ASCII: return ISASCII (ch) != 0;
case RECC_NONASCII: case RECC_MULTIBYTE: return !ISASCII (ch);
＠＠ -2140,6 +2079,10 ＠＠
}
}
+#endif /* MULE */
+
+#ifdef emacs
+
/* Return a bit-pattern to use in the range-table bits to match multibyte
chars of class CC. */
static unsigned char
＠＠ -2158,7 +2101,8 ＠＠
case RECC_ASCII: case RECC_DIGIT: case RECC_XDIGIT: case RECC_CNTRL:
case RECC_BLANK: case RECC_UNIBYTE: case RECC_ERROR: return 0;
default:
- abort ();
+ ABORT ();
+ return 0;
}
}
＠＠ -2185,9 +2129,12 ＠＠
RE_TRANSLATE_TYPE translate,
reg_syntax_t syntax,
Lisp_Object rtab);
-static reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab,
- Bitbyte *flags_out);
#endif /* MULE */
+#ifdef emacs
+reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab,
+ Bitbyte *flags_out);
+#endif
+
static re_bool group_match_null_string_p (unsigned char **p,
unsigned char *end,
register_info_type *reg_info);
＠＠ -2814,7 +2761,8 ＠＠
#endif /* MULE */
for (ch = 0; ch < (1 << BYTEWIDTH); ++ch)
{
- if (re_iswctype (ch, cc))
+ if (re_iswctype (ch, cc
+ RE_ISWCTYPE_ARG (current_buffer)))
{
SET_LIST_BIT (ch);
}
＠＠ -3938,7 +3886,11 ＠＠
return REG_NOERROR;
}
-static reg_errcode_t
+#endif /* MULE */
+
+#ifdef emacs
+
+reg_errcode_t
compile_char_class (re_wctype_t cc, Lisp_Object rtab, Bitbyte *flags_out)
{
*flags_out |= re_wctype_to_bit (cc);
diff -r d026b665014f -r 3df910176b6a src/regex.h
--- a/src/regex.h Wed Apr 25 20:25:33 2012 +0100
+++ b/src/regex.h Fri May 04 21:12:02 2012 +0100
＠＠ -30,6 +30,8 ＠＠
#define RE_LISP_CONTEXT_ARGS_DECL , Lisp_Object lispobj, struct buffer *lispbuf, struct syntax_cache *scache
#define RE_LISP_CONTEXT_ARGS_MULE_DECL , Lisp_Object lispobj, struct buffer *USED_IF_MULE (lispbuf), struct syntax_cache *scache
#define RE_LISP_CONTEXT_ARGS , lispobj, lispbuf, scache
+#define RE_ISWCTYPE_ARG_DECL , struct buffer *lispbuf
+#define RE_ISWCTYPE_ARG(varname) , varname
#else
#define RE_TRANSLATE_TYPE char *
#define RE_LISP_SHORT_CONTEXT_ARGS_DECL
＠＠ -37,6 +39,8 ＠＠
#define RE_LISP_CONTEXT_ARGS_DECL
#define RE_LISP_CONTEXT_ARGS_MULE_DECL
#define RE_LISP_CONTEXT_ARGS
+#define RE_ISWCTYPE_ARG_DECL
+#define RE_ISWCTYPE_ARG(varname)
#define Elemcount ssize_t
#define Bytecount ssize_t
#endif /* emacs */
＠＠ -559,6 +563,86 ＠＠
RECC_ASCII, RECC_UNIBYTE
} re_wctype_t;
+#define CHAR_CLASS_MAX_LENGTH 9 /* Namely, `multibyte'. */
+
+/* Map a string to the char class it names (if any). */
+re_wctype_t re_wctype (const char *);
+
+/* Is character CH a member of the character class CC? */
+int re_iswctype (int ch, re_wctype_t cc RE_ISWCTYPE_ARG_DECL);
+
+/* Bits used to implement the multibyte-part of the various character
+ classes such as [:alnum:] in a charset's range table. XEmacs; use an
+ enum, so they're visible in the debugger. */
+enum
+{
+ BIT_WORD = (1 << 0),
+ BIT_LOWER = (1 << 1),
+ BIT_PUNCT = (1 << 2),
+ BIT_SPACE = (1 << 3),
+ BIT_UPPER = (1 << 4),
+ /* XEmacs; we need this, because we unify treatment of ASCII and non-ASCII
+ (possible matches) in charset_mule. [:alpha:] matches all characters
+ with word syntax, with the exception of [0-9]. We don't need
+ BIT_MULTIBYTE. */
+ BIT_ALPHA = (1 << 5)
+};
+
+#ifdef emacs
+reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab,
+ Bitbyte *flags_out);
+
+#endif
+
+/* isalpha etc. are used for the character classes. */
+#include <ctype.h>
+
+#ifdef emacs
+
+/* 1 if C is an ASCII character. */
+#define ISASCII(c) ((c) < 0x80)
+
+/* 1 if C is a unibyte character. */
+#define ISUNIBYTE ISASCII
+
+/* The Emacs definitions should not be directly affected by locales. */
+
+/* In Emacs, these are only used for single-byte characters. */
+#define ISDIGIT(c) ((c) >= '0' && (c) <= '9')
+#define ISCNTRL(c) ((c) < ' ')
+#define ISXDIGIT(c) (ISDIGIT (c) || ((c) >= 'a' && (c) <= 'f') \
+ || ((c) >= 'A' && (c) <= 'F'))
+
+/* This is only used for single-byte characters. */
+#define ISBLANK(c) ((c) == ' ' || (c) == '\t')
+
+/* The rest must handle multibyte characters. */
+
+#define ISGRAPH(c) ((c) > ' ' && (c) != 0x7f)
+#define ISPRINT(c) ((c) == ' ' || ISGRAPH (c))
+#define ISALPHA(c) (ISASCII (c) ? (((c) >= 'a' && (c) <= 'z') \
+ || ((c) >= 'A' && (c) <= 'Z')) \
+ : ISWORD (c))
+#define ISALNUM(c) (ISALPHA (c) || ISDIGIT (c))
+
+#define ISLOWER(c) LOWERCASEP (lispbuf, c)
+
+#define ISPUNCT(c) (ISASCII (c) \
+ ? ((c) > ' ' && (c) < 0x7F \
+ && !(((c) >= 'a' && (c) <= 'z') \
+ || ((c) >= 'A' && (c) <= 'Z') \
+ || ((c) >= '0' && (c) <= '9'))) \
+ : !ISWORD (c))
+
+#define ISSPACE(c) \
+ (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Swhitespace)
+
+#define ISUPPER(c) UPPERCASEP (lispbuf, c)
+
+#define ISWORD(c) (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Sword)
+
+#endif
+
END_C_DECLS
#endif /* INCLUDED_regex_h_ */
diff -r d026b665014f -r 3df910176b6a src/search.c
--- a/src/search.c Wed Apr 25 20:25:33 2012 +0100
+++ b/src/search.c Fri May 04 21:12:02 2012 +0100
＠＠ -887,9 +887,9 ＠＠
a range table. */
unsigned char fastmap[0400];
int negate = 0;
- REGISTER int i;
Charbpos limit;
struct syntax_cache *scache;
+ Bitbyte class_bits = 0;
if (NILP (lim))
limit = forwardp ? BUF_ZV (buf) : BUF_BEGV (buf);
＠＠ -957,6 +957,51 ＠＠
Vskip_chars_range_table);
INC_IBYTEPTR (p);
}
+ else if ('[' == c && p != pend && *p == ':')
+ {
+ Ibyte *colonp;
+ Extbyte *classname;
+ int ch = 0;
+ re_wctype_t cc;
+
+ INC_IBYTEPTR (p);
+
+ if (p == pend)
+ {
+ fastmap ['['] = fastmap[':'] = 1;
+ break;
+ }
+
+ colonp = memchr (p, ':', pend - p);
+ if (NULL == colonp || (colonp + 1) == pend || colonp[1] != ']')
+ {
+ fastmap ['['] = fastmap[':'] = 1;
+ continue;
+ }
+
+ classname = alloca_extbytes (colonp - p + 1);
+ memmove (classname, p, colonp - p);
+ classname[colonp - p] = '\0';
+ cc = re_wctype (classname);
+
+ if (cc == RECC_ERROR)
+ {
+ invalid_argument ("Invalid character class",
+ build_extstring (classname, Qbinary));
+ }
+
+ for (ch = 0; ch < countof (fastmap); ++ch)
+ {
+ if (re_iswctype (ch, cc, buf))
+ {
+ fastmap[ch] = 1;
+ }
+ }
+
+ compile_char_class (cc, Vskip_chars_range_table, &class_bits);
+
+ p = colonp + 2;
+ }
else
{
if (c < 0400)
＠＠ -972,14 +1017,6 ＠＠
if (syntaxp && fastmap['-'] != 0)
fastmap[' '] = 1;
- /* If ^ was the first character, complement the fastmap.
- We don't complement the range table, however; we just use negate
- in the comparisons below. */
-
- if (negate)
- for (i = 0; i < (int) (sizeof (fastmap)); i++)
- fastmap[i] ^= 1;
-
{
Charbpos start_point = BUF_PT (buf);
Charbpos pos = start_point;
＠＠ -996,7 +1033,8 ＠＠
while (fastmap[(unsigned char)
syntax_code_spec
[(int) SYNTAX_FROM_CACHE
- (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]])
+ (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]]
+ != negate)
{
pos++;
INC_BYTEBPOS (buf, pos_byte);
＠＠ -1013,10 +1051,11 ＠＠
pos--;
DEC_BYTEBPOS (buf, pos_byte);
UPDATE_SYNTAX_CACHE_BACKWARD (scache, pos);
- if (!fastmap[(unsigned char)
- syntax_code_spec
- [(int) SYNTAX_FROM_CACHE
- (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]])
+ if (fastmap[(unsigned char)
+ syntax_code_spec
+ [(int) SYNTAX_FROM_CACHE
+ (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]]
+ == negate)
{
pos++;
pos_byte = savepos;
＠＠ -1027,16 +1066,30 ＠＠
}
else
{
+ struct buffer *lispbuf = buf;
+
+#define CLASS_BIT_CHECK(c) \
+ (class_bits && ((class_bits & BIT_ALPHA && ISALPHA (c)) \
+ || (class_bits & BIT_SPACE && ISSPACE (c)) \
+ || (class_bits & BIT_PUNCT && ISPUNCT (c)) \
+ || (class_bits & BIT_WORD && ISWORD (c)) \
+ || (NILP (buf->case_fold_search) ? \
+ ((class_bits & BIT_UPPER && ISUPPER (c)) \
+ || (class_bits & BIT_LOWER && ISLOWER (c))) \
+: (class_bits & (BIT_UPPER | BIT_LOWER) \
+ && !NOCASEP (buf, c)))))
if (forwardp)
{
while (pos < limit)
{
Ichar ch = BYTE_BUF_FETCH_CHAR (buf, pos_byte);
- if ((ch < 0400) ? fastmap[ch] :
- (NILP (Fget_range_table (make_fixnum (ch),
- Vskip_chars_range_table,
- Qnil))
- == negate))
+
+ if ((ch < countof (fastmap) ? fastmap[ch]
+: (CLASS_BIT_CHECK (ch) ||
+ (EQ (Qt, Fget_range_table (make_fixnum (ch),
+ Vskip_chars_range_table,
+ Qnil)))))
+ != negate)
{
pos++;
INC_BYTEBPOS (buf, pos_byte);
＠＠ -1054,11 +1107,12 ＠＠
DEC_BYTEBPOS (buf, prev_pos_byte);
ch = BYTE_BUF_FETCH_CHAR (buf, prev_pos_byte);
- if ((ch < 0400) ? fastmap[ch] :
- (NILP (Fget_range_table (make_fixnum (ch),
- Vskip_chars_range_table,
- Qnil))
- == negate))
+ if ((ch < countof (fastmap) ? fastmap[ch]
+: (CLASS_BIT_CHECK (ch) ||
+ (EQ (Qt, Fget_range_table (make_fixnum (ch),
+ Vskip_chars_range_table,
+ Qnil)))))
+ != negate)
{
pos--;
pos_byte = prev_pos_byte;
diff -r d026b665014f -r 3df910176b6a tests/ChangeLog
--- a/tests/ChangeLog Wed Apr 25 20:25:33 2012 +0100
+++ b/tests/ChangeLog Fri May 04 21:12:02 2012 +0100
＠＠ -1,3 +1,11 ＠＠
+2012-05-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/regexp-tests.el (equal):
+ * automated/regexp-tests.el (Assert-char-class):
+ Correct a stray parenthesis; add tests for the predefined
+ character classes with #'skip-chars-{forward,backward}; update the
+ tests to reflect some changed design decisions on my part.
+
2012-04-25 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/regexp-tests.el: Check that #'posix-string-match
diff -r d026b665014f -r 3df910176b6a tests/automated/regexp-tests.el
--- a/tests/automated/regexp-tests.el Wed Apr 25 20:25:33 2012 +0100
+++ b/tests/automated/regexp-tests.el Fri May 04 21:12:02 2012 +0100
＠＠ -76,7 +76,7 ＠＠
(save-match-data
(progn (posix-string-match "i\\|ii" "ii") (match-data)))
'(0 2))
- "checking #'posix-string-match actually returns the longest match"))
+ "checking #'posix-string-match actually returns the longest match")
;; looking-at
(with-temp-buffer
＠＠ -665,7 +665,25 ＠＠
(Assert (null (string-match ,(concat "[^" class
(string non-matching-char) "]")
,(concat (string matching-char)
- (string non-matching-char)))))))
+ (string non-matching-char)))))
+ (let ((old-case-fold-search case-fold-search))
+ (with-temp-buffer
+ (setq case-fold-search old-case-fold-search)
+ (insert-char ,matching-char 20)
+ (insert-char ,non-matching-char 20)
+ (goto-char (point-min))
+ (Assert (eql (skip-chars-forward ,class) 20)
+ ,(format "making sure %s skips %S forward"
+ class matching-char))
+ (Assert (eql (skip-chars-forward ,(concat "^" class)) 20)
+ ,(format "making sure ^%s skips %S forward"
+ class non-matching-char))
+ (Assert (eql (skip-chars-backward ,(concat "^" class)) -20)
+ ,(format "making sure ^%s skips %S backward"
+ class non-matching-char))
+ (Assert (eql (skip-chars-backward ,class) -20)
+ ,(format "making sure %s skips %S backward"
+ class matching-char))))))
(Assert-never-matching (class &rest characters)
(cons
'progn
＠＠ -706,7 +724,7 ＠＠
(Assert-char-class "[:alnum:]" ?A ?/)
(Assert-char-class "[:alnum:]" ?Z ?!)
(Assert-char-class "[:alnum:]" ?0 ?,)
- (Assert-char-class "[:alnum:]" ?9 ?$)
+ (Assert-char-class "[:alnum:]" ?9 ?\t)
(Assert-char-class "[:alnum:]" ?b ?\x00)
(Assert-char-class "[:alnum:]" ?c ?\x09)
(Assert-char-class "[:alnum:]" ?d ?\ )
＠＠ -724,13 +742,12 ＠＠
(decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA
(decode-char 'ucs #x0385)) ;; GREEK DIALYTIKA TONOS
- ;; Word is equivalent to alnum in this implementation.
(Assert-char-class "[:word:]" ?a ?.)
(Assert-char-class "[:word:]" ?z ?')
(Assert-char-class "[:word:]" ?A ?/)
(Assert-char-class "[:word:]" ?Z ?!)
(Assert-char-class "[:word:]" ?0 ?,)
- (Assert-char-class "[:word:]" ?9 ?$)
+ (Assert-char-class "[:word:]" ?9 ?\t)
(Assert-char-class "[:word:]" ?b ?\x00)
(Assert-char-class "[:word:]" ?c ?\x09)
(Assert-char-class "[:word:]" ?d ?\ )
＠＠ -1083,7 +1100,7 ＠＠
(Assert-never-matching
"[:unibyte:]"
- ?\x01 ?\t ?A ?B ?C ?\x7f
+ ?\x80 ?\xe4 ?\xdf ?\xf8
(decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA
(decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A
(decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments