diff options
75 files changed, 4684 insertions, 2497 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index f098f3e7460..86410cc8f40 100644 --- a/.dir-locals.el +++ b/.dir-locals.el | |||
| @@ -1,6 +1,6 @@ | |||
| 1 | ((nil . ((tab-width . 8) | 1 | ((nil . ((tab-width . 8) |
| 2 | (sentence-end-double-space . t) | 2 | (sentence-end-double-space . t) |
| 3 | (fill-column . 70))) | 3 | (fill-column . 79))) |
| 4 | (c-mode . ((c-file-style . "GNU"))) | 4 | (c-mode . ((c-file-style . "GNU"))) |
| 5 | ;; You must set bugtracker_debbugs_url in your bazaar.conf for this to work. | 5 | ;; You must set bugtracker_debbugs_url in your bazaar.conf for this to work. |
| 6 | ;; See admin/notes/bugtracker. | 6 | ;; See admin/notes/bugtracker. |
diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index 1eb3cfa2556..faa5fa44e46 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog | |||
| @@ -1,6 +1,14 @@ | |||
| 1 | 2011-04-01 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * variables.texi (Defining Variables): Mention the new meaning of `defvar'. | ||
| 4 | (Lexical Binding): New sub-section. | ||
| 5 | |||
| 6 | * eval.texi (Eval): Discourage the use of `eval'. | ||
| 7 | Document its new `lexical' argument. | ||
| 8 | |||
| 1 | 2011-03-28 Stefan Monnier <monnier@iro.umontreal.ca> | 9 | 2011-03-28 Stefan Monnier <monnier@iro.umontreal.ca> |
| 2 | 10 | ||
| 3 | * commands.texi (Command Overview): post-command-hook is not reset to | 11 | * commands.texi (Command Overview): `post-command-hook' is not reset to |
| 4 | nil any more. | 12 | nil any more. |
| 5 | 13 | ||
| 6 | 2011-03-19 Stefan Monnier <monnier@iro.umontreal.ca> | 14 | 2011-03-19 Stefan Monnier <monnier@iro.umontreal.ca> |
diff --git a/doc/lispref/eval.texi b/doc/lispref/eval.texi index d44fe5bb95b..74f3d9c48b9 100644 --- a/doc/lispref/eval.texi +++ b/doc/lispref/eval.texi | |||
| @@ -585,6 +585,11 @@ occurrence in a program being run. On rare occasions, you may need to | |||
| 585 | write code that evaluates a form that is computed at run time, such as | 585 | write code that evaluates a form that is computed at run time, such as |
| 586 | after reading a form from text being edited or getting one from a | 586 | after reading a form from text being edited or getting one from a |
| 587 | property list. On these occasions, use the @code{eval} function. | 587 | property list. On these occasions, use the @code{eval} function. |
| 588 | Often @code{eval} is not needed and something else should be used instead. | ||
| 589 | For example, to get the value of a variable, while @code{eval} works, | ||
| 590 | @code{symbol-value} is preferable; or rather than store expressions | ||
| 591 | in a property list that then need to go through @code{eval}, it is better to | ||
| 592 | store functions instead that are then passed to @code{funcall}. | ||
| 588 | 593 | ||
| 589 | The functions and variables described in this section evaluate forms, | 594 | The functions and variables described in this section evaluate forms, |
| 590 | specify limits to the evaluation process, or record recently returned | 595 | specify limits to the evaluation process, or record recently returned |
| @@ -596,10 +601,13 @@ to store an expression in the data structure and evaluate it. Using | |||
| 596 | functions provides the ability to pass information to them as | 601 | functions provides the ability to pass information to them as |
| 597 | arguments. | 602 | arguments. |
| 598 | 603 | ||
| 599 | @defun eval form | 604 | @defun eval form &optional lexical |
| 600 | This is the basic function evaluating an expression. It evaluates | 605 | This is the basic function evaluating an expression. It evaluates |
| 601 | @var{form} in the current environment and returns the result. How the | 606 | @var{form} in the current environment and returns the result. How the |
| 602 | evaluation proceeds depends on the type of the object (@pxref{Forms}). | 607 | evaluation proceeds depends on the type of the object (@pxref{Forms}). |
| 608 | @var{lexical} if non-nil means to evaluate @var{form} using lexical scoping | ||
| 609 | rules (@pxref{Lexical Binding}) instead of the default dynamic scoping used | ||
| 610 | historically in Emacs Lisp. | ||
| 603 | 611 | ||
| 604 | Since @code{eval} is a function, the argument expression that appears | 612 | Since @code{eval} is a function, the argument expression that appears |
| 605 | in a call to @code{eval} is evaluated twice: once as preparation before | 613 | in a call to @code{eval} is evaluated twice: once as preparation before |
diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index a68b2b6dd4e..7e2c32334a4 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi | |||
| @@ -25,22 +25,22 @@ textual Lisp program is written using the read syntax for the symbol | |||
| 25 | representing the variable. | 25 | representing the variable. |
| 26 | 26 | ||
| 27 | @menu | 27 | @menu |
| 28 | * Global Variables:: Variable values that exist permanently, everywhere. | 28 | * Global Variables:: Variable values that exist permanently, everywhere. |
| 29 | * Constant Variables:: Certain "variables" have values that never change. | 29 | * Constant Variables:: Certain "variables" have values that never change. |
| 30 | * Local Variables:: Variable values that exist only temporarily. | 30 | * Local Variables:: Variable values that exist only temporarily. |
| 31 | * Void Variables:: Symbols that lack values. | 31 | * Void Variables:: Symbols that lack values. |
| 32 | * Defining Variables:: A definition says a symbol is used as a variable. | 32 | * Defining Variables:: A definition says a symbol is used as a variable. |
| 33 | * Tips for Defining:: Things you should think about when you | 33 | * Tips for Defining:: Things you should think about when you |
| 34 | define a variable. | 34 | define a variable. |
| 35 | * Accessing Variables:: Examining values of variables whose names | 35 | * Accessing Variables:: Examining values of variables whose names |
| 36 | are known only at run time. | 36 | are known only at run time. |
| 37 | * Setting Variables:: Storing new values in variables. | 37 | * Setting Variables:: Storing new values in variables. |
| 38 | * Variable Scoping:: How Lisp chooses among local and global values. | 38 | * Variable Scoping:: How Lisp chooses among local and global values. |
| 39 | * Buffer-Local Variables:: Variable values in effect only in one buffer. | 39 | * Buffer-Local Variables:: Variable values in effect only in one buffer. |
| 40 | * File Local Variables:: Handling local variable lists in files. | 40 | * File Local Variables:: Handling local variable lists in files. |
| 41 | * Directory Local Variables:: Local variables common to all files in a directory. | 41 | * Directory Local Variables:: Local variables common to all files in a directory. |
| 42 | * Frame-Local Variables:: Frame-local bindings for variables. | 42 | * Frame-Local Variables:: Frame-local bindings for variables. |
| 43 | * Variable Aliases:: Variables that are aliases for other variables. | 43 | * Variable Aliases:: Variables that are aliases for other variables. |
| 44 | * Variables with Restricted Values:: Non-constant variables whose value can | 44 | * Variables with Restricted Values:: Non-constant variables whose value can |
| 45 | @emph{not} be an arbitrary Lisp object. | 45 | @emph{not} be an arbitrary Lisp object. |
| 46 | @end menu | 46 | @end menu |
| @@ -437,14 +437,18 @@ this reason, user options must be defined with @code{defvar}. | |||
| 437 | This special form defines @var{symbol} as a variable and can also | 437 | This special form defines @var{symbol} as a variable and can also |
| 438 | initialize and document it. The definition informs a person reading | 438 | initialize and document it. The definition informs a person reading |
| 439 | your code that @var{symbol} is used as a variable that might be set or | 439 | your code that @var{symbol} is used as a variable that might be set or |
| 440 | changed. Note that @var{symbol} is not evaluated; the symbol to be | 440 | changed. It also declares this variable as @dfn{special}, meaning that it |
| 441 | defined must appear explicitly in the @code{defvar}. | 441 | should always use dynamic scoping rules. Note that @var{symbol} is not |
| 442 | evaluated; the symbol to be defined must appear explicitly in the | ||
| 443 | @code{defvar}. | ||
| 442 | 444 | ||
| 443 | If @var{symbol} is void and @var{value} is specified, @code{defvar} | 445 | If @var{symbol} is void and @var{value} is specified, @code{defvar} |
| 444 | evaluates it and sets @var{symbol} to the result. But if @var{symbol} | 446 | evaluates it and sets @var{symbol} to the result. But if @var{symbol} |
| 445 | already has a value (i.e., it is not void), @var{value} is not even | 447 | already has a value (i.e., it is not void), @var{value} is not even |
| 446 | evaluated, and @var{symbol}'s value remains unchanged. If @var{value} | 448 | evaluated, and @var{symbol}'s value remains unchanged. |
| 447 | is omitted, the value of @var{symbol} is not changed in any case. | 449 | If @var{value} is omitted, the value of @var{symbol} is not changed in any |
| 450 | case; instead, the only effect of @code{defvar} is to declare locally that this | ||
| 451 | variable exists elsewhere and should hence always use dynamic scoping rules. | ||
| 448 | 452 | ||
| 449 | If @var{symbol} has a buffer-local binding in the current buffer, | 453 | If @var{symbol} has a buffer-local binding in the current buffer, |
| 450 | @code{defvar} operates on the default value, which is buffer-independent, | 454 | @code{defvar} operates on the default value, which is buffer-independent, |
| @@ -881,7 +885,7 @@ the others. | |||
| 881 | @cindex extent | 885 | @cindex extent |
| 882 | @cindex dynamic scoping | 886 | @cindex dynamic scoping |
| 883 | @cindex lexical scoping | 887 | @cindex lexical scoping |
| 884 | Local bindings in Emacs Lisp have @dfn{indefinite scope} and | 888 | By default, local bindings in Emacs Lisp have @dfn{indefinite scope} and |
| 885 | @dfn{dynamic extent}. @dfn{Scope} refers to @emph{where} textually in | 889 | @dfn{dynamic extent}. @dfn{Scope} refers to @emph{where} textually in |
| 886 | the source code the binding can be accessed. ``Indefinite scope'' means | 890 | the source code the binding can be accessed. ``Indefinite scope'' means |
| 887 | that any part of the program can potentially access the variable | 891 | that any part of the program can potentially access the variable |
| @@ -893,6 +897,8 @@ lasts as long as the activation of the construct that established it. | |||
| 893 | @dfn{dynamic scoping}. By contrast, most programming languages use | 897 | @dfn{dynamic scoping}. By contrast, most programming languages use |
| 894 | @dfn{lexical scoping}, in which references to a local variable must be | 898 | @dfn{lexical scoping}, in which references to a local variable must be |
| 895 | located textually within the function or block that binds the variable. | 899 | located textually within the function or block that binds the variable. |
| 900 | Emacs can also support lexical scoping, upon request (@pxref{Lexical | ||
| 901 | Binding}). | ||
| 896 | 902 | ||
| 897 | @cindex CL note---special variables | 903 | @cindex CL note---special variables |
| 898 | @quotation | 904 | @quotation |
| @@ -901,11 +907,12 @@ dynamically scoped, like all variables in Emacs Lisp. | |||
| 901 | @end quotation | 907 | @end quotation |
| 902 | 908 | ||
| 903 | @menu | 909 | @menu |
| 904 | * Scope:: Scope means where in the program a value is visible. | 910 | * Scope:: Scope means where in the program a value is visible. |
| 905 | Comparison with other languages. | 911 | Comparison with other languages. |
| 906 | * Extent:: Extent means how long in time a value exists. | 912 | * Extent:: Extent means how long in time a value exists. |
| 907 | * Impl of Scope:: Two ways to implement dynamic scoping. | 913 | * Impl of Scope:: Two ways to implement dynamic scoping. |
| 908 | * Using Scoping:: How to use dynamic scoping carefully and avoid problems. | 914 | * Using Scoping:: How to use dynamic scoping carefully and avoid problems. |
| 915 | * Lexical Binding:: Use of lexical scoping. | ||
| 909 | @end menu | 916 | @end menu |
| 910 | 917 | ||
| 911 | @node Scope | 918 | @node Scope |
| @@ -969,12 +976,12 @@ Here, when @code{foo} is called by @code{binder}, it binds @code{x}. | |||
| 969 | by @code{foo} instead of the one bound by @code{binder}. | 976 | by @code{foo} instead of the one bound by @code{binder}. |
| 970 | @end itemize | 977 | @end itemize |
| 971 | 978 | ||
| 972 | Emacs Lisp uses dynamic scoping because simple implementations of | 979 | Emacs Lisp used dynamic scoping by default because simple implementations of |
| 973 | lexical scoping are slow. In addition, every Lisp system needs to offer | 980 | lexical scoping are slow. In addition, every Lisp system needs to offer |
| 974 | dynamic scoping at least as an option; if lexical scoping is the norm, | 981 | dynamic scoping at least as an option; if lexical scoping is the norm, there |
| 975 | there must be a way to specify dynamic scoping instead for a particular | 982 | must be a way to specify dynamic scoping instead for a particular variable. |
| 976 | variable. It might not be a bad thing for Emacs to offer both, but | 983 | Nowadays, Emacs offers both, but the default is still to use exclusively |
| 977 | implementing it with dynamic scoping only was much easier. | 984 | dynamic scoping. |
| 978 | 985 | ||
| 979 | @node Extent | 986 | @node Extent |
| 980 | @subsection Extent | 987 | @subsection Extent |
| @@ -1088,6 +1095,86 @@ for inter-function usage. It also avoids a warning from the byte | |||
| 1088 | compiler. Choose the variable's name to avoid name conflicts---don't | 1095 | compiler. Choose the variable's name to avoid name conflicts---don't |
| 1089 | use short names like @code{x}. | 1096 | use short names like @code{x}. |
| 1090 | 1097 | ||
| 1098 | |||
| 1099 | @node Lexical Binding | ||
| 1100 | @subsection Use of Lexical Scoping | ||
| 1101 | |||
| 1102 | Emacs Lisp can be evaluated in two different modes: in dynamic binding mode or | ||
| 1103 | lexical binding mode. In dynamic binding mode, all local variables use dynamic | ||
| 1104 | scoping, whereas in lexical binding mode variables that have been declared | ||
| 1105 | @dfn{special} (i.e., declared with @code{defvar} or @code{defconst}) use | ||
| 1106 | dynamic scoping and all others use lexical scoping. | ||
| 1107 | |||
| 1108 | @defvar lexical-binding | ||
| 1109 | When non-nil, evaluation of Lisp code uses lexical scoping for non-special | ||
| 1110 | local variables instead of dynamic scoping. If nil, dynamic scoping is used | ||
| 1111 | for all local variables. This variable is typically set for a whole Elisp file | ||
| 1112 | via file local variables (@pxref{File Local Variables}). | ||
| 1113 | @end defvar | ||
| 1114 | |||
| 1115 | @defun special-variable-p SYMBOL | ||
| 1116 | Return whether SYMBOL has been declared as a special variable, via | ||
| 1117 | @code{defvar} or @code{defconst}. | ||
| 1118 | @end defun | ||
| 1119 | |||
| 1120 | The use of a special variable as a formal argument in a function is generally | ||
| 1121 | discouraged and its behavior in lexical binding mode is unspecified (it may use | ||
| 1122 | lexical scoping sometimes and dynamic scoping other times). | ||
| 1123 | |||
| 1124 | Functions like @code{symbol-value}, @code{boundp}, or @code{set} only know | ||
| 1125 | about dynamically scoped variables, so you cannot get the value of a lexical | ||
| 1126 | variable via @code{symbol-value} and neither can you change it via @code{set}. | ||
| 1127 | Another particularity is that code in the body of a @code{defun} or | ||
| 1128 | @code{defmacro} cannot refer to surrounding lexical variables. | ||
| 1129 | |||
| 1130 | Evaluation of a @code{lambda} expression in lexical binding mode will not just | ||
| 1131 | return that lambda expression unchanged, as in the dynamic binding case, but | ||
| 1132 | will instead construct a new object that remembers the current lexical | ||
| 1133 | environment in which that lambda expression was defined, so that the function | ||
| 1134 | body can later be evaluated in the proper context. Those objects are called | ||
| 1135 | @dfn{closures}. They are also functions, in the sense that they are accepted | ||
| 1136 | by @code{funcall}, and they are represented by a cons cell whose @code{car} is | ||
| 1137 | the symbol @code{closure}. | ||
| 1138 | |||
| 1139 | @menu | ||
| 1140 | * Converting to Lexical Binding:: How to start using lexical scoping | ||
| 1141 | @end menu | ||
| 1142 | |||
| 1143 | @node Converting to Lexical Binding | ||
| 1144 | @subsubsection Converting a package to use lexical scoping | ||
| 1145 | |||
| 1146 | Lexical scoping, as currently implemented, does not bring many significant | ||
| 1147 | benefits, unless you are a seasoned functional programmer addicted to | ||
| 1148 | higher-order functions. But its importance will increase in the future: | ||
| 1149 | lexical scoping opens up a lot more opportunities for optimization, so | ||
| 1150 | lexically scoped code is likely to run faster in future Emacs versions, and it | ||
| 1151 | is much more friendly to concurrency, which we want to add in the near future. | ||
| 1152 | |||
| 1153 | Converting a package to lexical binding is usually pretty easy and should not | ||
| 1154 | break backward compatibility: just add a file-local variable setting | ||
| 1155 | @code{lexical-binding} to @code{t} and add declarations of the form | ||
| 1156 | @code{(defvar @var{VAR})} for every variable which still needs to use | ||
| 1157 | dynamic scoping. | ||
| 1158 | |||
| 1159 | To find which variables need this declaration, the simplest solution is to | ||
| 1160 | check the byte-compiler's warnings. The byte-compiler will usually find those | ||
| 1161 | variables either because they are used outside of a let-binding (leading to | ||
| 1162 | warnings about reference or assignment to ``free variable @var{VAR}'') or | ||
| 1163 | because they are let-bound but not used within the let-binding (leading to | ||
| 1164 | warnings about ``unused lexical variable @var{VAR}''). | ||
| 1165 | |||
| 1166 | In cases where a dynamically scoped variable was bound as a function argument, | ||
| 1167 | you will also need to move this binding to a @code{let}. These cases are also | ||
| 1168 | flagged by the byte-compiler. | ||
| 1169 | |||
| 1170 | To silence byte-compiler warnings about unused variables, just use a variable | ||
| 1171 | name that start with an underscore, which the byte-compiler interpret as an | ||
| 1172 | indication that this is a variable known not to be used. | ||
| 1173 | |||
| 1174 | In most cases, the resulting code will then work with either setting of | ||
| 1175 | @code{lexical-binding}, so it can still be used with older Emacsen (which will | ||
| 1176 | simply ignore the @code{lexical-binding} variable setting). | ||
| 1177 | |||
| 1091 | @node Buffer-Local Variables | 1178 | @node Buffer-Local Variables |
| 1092 | @section Buffer-Local Variables | 1179 | @section Buffer-Local Variables |
| 1093 | @cindex variable, buffer-local | 1180 | @cindex variable, buffer-local |
| @@ -1103,9 +1190,9 @@ local to each terminal, or to each frame. @xref{Multiple Terminals}, | |||
| 1103 | and @xref{Frame-Local Variables}.) | 1190 | and @xref{Frame-Local Variables}.) |
| 1104 | 1191 | ||
| 1105 | @menu | 1192 | @menu |
| 1106 | * Intro to Buffer-Local:: Introduction and concepts. | 1193 | * Intro to Buffer-Local:: Introduction and concepts. |
| 1107 | * Creating Buffer-Local:: Creating and destroying buffer-local bindings. | 1194 | * Creating Buffer-Local:: Creating and destroying buffer-local bindings. |
| 1108 | * Default Value:: The default value is seen in buffers | 1195 | * Default Value:: The default value is seen in buffers |
| 1109 | that don't have their own buffer-local values. | 1196 | that don't have their own buffer-local values. |
| 1110 | @end menu | 1197 | @end menu |
| 1111 | 1198 | ||
| @@ -676,6 +676,14 @@ binding `log-view-expanded-log-entry-function' to a suitable function. | |||
| 676 | 676 | ||
| 677 | *** New command `nato-region' converts text to NATO phonetic alphabet. | 677 | *** New command `nato-region' converts text to NATO phonetic alphabet. |
| 678 | 678 | ||
| 679 | *** The new command `info-display-manual' will display an Info manual | ||
| 680 | specified by its name. If that manual is already visited in some Info | ||
| 681 | buffer within the current session, the command will display that | ||
| 682 | buffer. Otherwise, it will load the manual and display it. This is | ||
| 683 | handy if you have many manuals in many Info buffers, and don't | ||
| 684 | remember the name of the buffer visiting the manual you want to | ||
| 685 | consult. | ||
| 686 | |||
| 679 | 687 | ||
| 680 | * New Modes and Packages in Emacs 24.1 | 688 | * New Modes and Packages in Emacs 24.1 |
| 681 | 689 | ||
| @@ -765,6 +773,22 @@ sc.el, x-menu.el, rnews.el, rnewspost.el | |||
| 765 | 773 | ||
| 766 | * Lisp changes in Emacs 24.1 | 774 | * Lisp changes in Emacs 24.1 |
| 767 | 775 | ||
| 776 | ** Code can now use lexical scoping by default instead of dynamic scoping. | ||
| 777 | The `lexical-binding' variable lets code use lexical scoping for local | ||
| 778 | variables. It is typically set via file-local variables, in which case it | ||
| 779 | applies to all the code in that file. | ||
| 780 | |||
| 781 | *** `eval' takes a new optional argument `lexical' to choose the new lexical | ||
| 782 | binding instead of the old dynamic binding mode. | ||
| 783 | |||
| 784 | *** Lexically scoped interpreted functions are represented with a new form | ||
| 785 | of function value which looks like (closure ENV ARGS &rest BODY). | ||
| 786 | |||
| 787 | *** New macro `letrec' to define recursive local functions. | ||
| 788 | |||
| 789 | *** New function `special-variable-p' to check whether a variable is | ||
| 790 | declared as dynamically bound. | ||
| 791 | |||
| 768 | ** pre/post-command-hook are not reset to nil upon error. | 792 | ** pre/post-command-hook are not reset to nil upon error. |
| 769 | Instead, the offending function is removed. | 793 | Instead, the offending function is removed. |
| 770 | 794 | ||
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 32e9c92a255..288199fd702 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,201 @@ | |||
| 1 | 2011-04-01 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | Add lexical binding. | ||
| 4 | |||
| 5 | * subr.el (apply-partially): Use new closures rather than CL. | ||
| 6 | (--dolist-tail--, --dotimes-limit--): Don't declare dynamic. | ||
| 7 | (dolist, dotimes): Use slightly different expansion for lexical code. | ||
| 8 | (functionp): Move to C. | ||
| 9 | (letrec): New macro. | ||
| 10 | (with-wrapper-hook): Use it and apply-partially instead of CL. | ||
| 11 | (eval-after-load): Preserve lexical-binding. | ||
| 12 | (save-window-excursion, with-output-to-temp-buffer): Turn them | ||
| 13 | into macros. | ||
| 14 | |||
| 15 | * simple.el (with-wrapper-hook, apply-partially): Move to subr.el. | ||
| 16 | |||
| 17 | * help-fns.el (help-split-fundoc): Return nil if there's nothing else | ||
| 18 | than the arglist. | ||
| 19 | (help-add-fundoc-usage): Don't add `Not documented'. | ||
| 20 | (help-function-arglist): Handle closures, subroutines, and new | ||
| 21 | byte-code-functions. | ||
| 22 | (help-make-usage): Remove leading underscores. | ||
| 23 | (describe-function-1): Handle closures. | ||
| 24 | (describe-variable): Use special-variable-p for completion. | ||
| 25 | |||
| 26 | * files.el (lexical-binding): Declare safe. | ||
| 27 | |||
| 28 | * emacs-lisp/pcase.el: Don't use destructuring-bind. | ||
| 29 | (pcase--memoize): Rename from pcase-memoize. Change weakness. | ||
| 30 | (pcase): Add `let' pattern. | ||
| 31 | Change memoization so it actually works. | ||
| 32 | (pcase-mutually-exclusive-predicates): Add byte-code-function-p. | ||
| 33 | (pcase--u1) <guard, pred>: Fix possible shadowing problem. | ||
| 34 | <let>: New case. | ||
| 35 | |||
| 36 | * emacs-lisp/macroexp.el: Use lexical binding. | ||
| 37 | (macroexpand-all-1): Check obsolete macros. Expand compiler-macros. | ||
| 38 | Don't convert ' to #' without checking that it's indeed quoting | ||
| 39 | a lambda. | ||
| 40 | |||
| 41 | * emacs-lisp/lisp-mode.el (eval-last-sexp-1): | ||
| 42 | Use eval-sexp-add-defvars. | ||
| 43 | (eval-sexp-add-defvars): New fun. | ||
| 44 | |||
| 45 | * emacs-lisp/float-sup.el (pi): Don't declare as dynamically bound. | ||
| 46 | |||
| 47 | * emacs-lisp/eieio.el (byte-compile-file-form-defmethod): | ||
| 48 | Don't autoload. | ||
| 49 | (eieio-defgeneric-form-primary-only-one): Use `byte-compile' rather | ||
| 50 | than the internal `byte-compile-lambda'. | ||
| 51 | (defmethod): Don't hide code under quotes. | ||
| 52 | (eieio-defmethod): New `code' argument. | ||
| 53 | |||
| 54 | * emacs-lisp/eieio-comp.el: Remove. | ||
| 55 | |||
| 56 | * emacs-lisp/edebug.el (edebug-eval-defun) | ||
| 57 | (edebug-eval-top-level-form): Use eval-sexp-add-defvars. | ||
| 58 | (edebug-toggle): Avoid `eval'. | ||
| 59 | |||
| 60 | * emacs-lisp/disass.el (disassemble-internal): Handle new | ||
| 61 | `closure' objects. | ||
| 62 | (disassemble-1): Handle new byte codes. | ||
| 63 | |||
| 64 | * emacs-lisp/cl.el (pushnew): Silence warning. | ||
| 65 | |||
| 66 | * emacs-lisp/cl-macs.el (cl-byte-compile-block) | ||
| 67 | (cl-byte-compile-throw): Remove. | ||
| 68 | (cl-block-wrapper, cl-block-throw): Use compiler-macros instead. | ||
| 69 | |||
| 70 | * emacs-lisp/cl-extra.el (cl-macroexpand-all): Properly quote CL | ||
| 71 | closures. | ||
| 72 | |||
| 73 | * emacs-lisp/cconv.el: New file. | ||
| 74 | |||
| 75 | * emacs-lisp/bytecomp.el: Use lexical binding instead of | ||
| 76 | a "bytecomp-" prefix. Macroexpand everything as a separate phase. | ||
| 77 | (byte-compile-initial-macro-environment): | ||
| 78 | Handle declare-function here. | ||
| 79 | (byte-compile--lexical-environment): New var. | ||
| 80 | (byte-stack-ref, byte-stack-set, byte-discardN) | ||
| 81 | (byte-discardN-preserve-tos): New lap codes. | ||
| 82 | (byte-interactive-p): Don't use any more. | ||
| 83 | (byte-compile-push-bytecodes, byte-compile-push-bytecode-const2): | ||
| 84 | New macros. | ||
| 85 | (byte-compile-lapcode): Use them and handle new lap codes. | ||
| 86 | (byte-compile-obsolete): Remove. | ||
| 87 | (byte-compile-arglist-signature): Handle new byte-code arg"lists". | ||
| 88 | (byte-compile-arglist-warn): Check late def of inlinable funs. | ||
| 89 | (byte-compile-cl-warn): Don't silence warnings for compiler-macros | ||
| 90 | since they should have been expanded by now. | ||
| 91 | (byte-compile--outbuffer): Rename from bytecomp-outbuffer. | ||
| 92 | (byte-compile-from-buffer): Remove unused second arg. | ||
| 93 | (byte-compile-preprocess): New function. | ||
| 94 | (byte-compile-toplevel-file-form): New function to distinguish | ||
| 95 | file-form calls from outside from file-form calls from hunk-handlers. | ||
| 96 | (byte-compile-file-form): Simplify. | ||
| 97 | (byte-compile-file-form-defsubst): Remove. | ||
| 98 | (byte-compile-file-form-defmumble): Simplify now that | ||
| 99 | byte-compile-lambda always returns a byte-code-function. | ||
| 100 | (byte-compile): Preprocess. | ||
| 101 | (byte-compile-byte-code-maker, byte-compile-byte-code-unmake): | ||
| 102 | Remove, not used any more. | ||
| 103 | (byte-compile-arglist-vars, byte-compile-make-lambda-lexenv) | ||
| 104 | (byte-compile-make-args-desc): New funs. | ||
| 105 | (byte-compile-lambda): Handle lexical functions. Always return | ||
| 106 | a byte-code-function. | ||
| 107 | (byte-compile-reserved-constants): New var, to make up room for | ||
| 108 | closed-over variables. | ||
| 109 | (byte-compile-constants-vector): Obey it. | ||
| 110 | (byte-compile-top-level): New args `lexenv' and `reserved-csts'. | ||
| 111 | (byte-compile-macroexpand-declare-function): New function. | ||
| 112 | (byte-compile-form): Call byte-compile-unfold-bcf to inline immediate | ||
| 113 | byte-code-functions. | ||
| 114 | (byte-compile-form): Check obsolescence here. | ||
| 115 | (byte-compile-inline-lapcode, byte-compile-unfold-bcf): New functions. | ||
| 116 | (byte-compile-variable-ref): Remove. | ||
| 117 | (byte-compile-dynamic-variable-op): New fun. | ||
| 118 | (byte-compile-dynamic-variable-bind, byte-compile-variable-ref) | ||
| 119 | (byte-compile-variable-set): New funs. | ||
| 120 | (byte-compile-discard): Add 2 args. | ||
| 121 | (byte-compile-stack-ref, byte-compile-stack-set) | ||
| 122 | (byte-compile-make-closure, byte-compile-get-closed-var): New funs. | ||
| 123 | (byte-compile-funarg, byte-compile-funarg-2): Remove, handled in | ||
| 124 | macroexpand-all instead. | ||
| 125 | (byte-compile-quote-form): Remove. | ||
| 126 | (byte-compile-push-binding-init, byte-compile-not-lexical-var-p) | ||
| 127 | (byte-compile-bind, byte-compile-unbind): New funs. | ||
| 128 | (byte-compile-let): Handle let* and lexical binding. | ||
| 129 | (byte-compile-let*): Remove. | ||
| 130 | (byte-compile-catch, byte-compile-unwind-protect) | ||
| 131 | (byte-compile-track-mouse, byte-compile-condition-case): | ||
| 132 | Handle a new :fun-body form, used for lexical scoping. | ||
| 133 | (byte-compile-save-window-excursion) | ||
| 134 | (byte-compile-with-output-to-temp-buffer): Remove. | ||
| 135 | (byte-compile-defun): Simplify. | ||
| 136 | (byte-compile-stack-adjustment): New fun. | ||
| 137 | (byte-compile-out): Use it. | ||
| 138 | (byte-compile-refresh-preloaded): Don't reload byte-compiler files. | ||
| 139 | |||
| 140 | * emacs-lisp/byte-run.el (make-obsolete): Don't set the `byte-compile' | ||
| 141 | handler any more. | ||
| 142 | |||
| 143 | * emacs-lisp/byte-opt.el: Use lexical binding. | ||
| 144 | (byte-inline-lapcode): Remove (to bytecomp). | ||
| 145 | (byte-compile-inline-expand): Pay attention to inlining to/from | ||
| 146 | lexically bound code. | ||
| 147 | (byte-compile-unfold-lambda): Don't handle byte-code-functions | ||
| 148 | any more. | ||
| 149 | (byte-optimize-form-code-walker): Don't handle save-window-excursion | ||
| 150 | any more and don't call compiler-macros. | ||
| 151 | (byte-compile-splice-in-already-compiled-code): Remove. | ||
| 152 | (byte-code): Don't inline any more. | ||
| 153 | (disassemble-offset): Receive `bytes' as argument rather than via | ||
| 154 | dynamic scoping. | ||
| 155 | (byte-compile-tag-number): Declare before first use. | ||
| 156 | (byte-decompile-bytecode-1): Handle new byte-codes, don't change | ||
| 157 | `return' even if make-spliceable. | ||
| 158 | (byte-compile-side-effect-and-error-free-ops): Add stack-ref, remove | ||
| 159 | obsolete interactive-p. | ||
| 160 | (byte-optimize-lapcode): Optimize new lap-codes. | ||
| 161 | Don't trip up on new form of `byte-constant' lap code. | ||
| 162 | |||
| 163 | * emacs-lisp/autoload.el (make-autoload): Don't burp on trivial macros. | ||
| 164 | |||
| 165 | * emacs-lisp/advice.el (ad-arglist): Use help-function-arglist. | ||
| 166 | |||
| 167 | * custom.el (custom-initialize-default, custom-declare-variable): | ||
| 168 | Use `defvar'. | ||
| 169 | |||
| 170 | * Makefile.in (BIG_STACK_DEPTH, BIG_STACK_OPTS, BYTE_COMPILE_FLAGS): | ||
| 171 | New variables. | ||
| 172 | (compile-onefile, .el.elc, compile-calc, recompile): Use them. | ||
| 173 | (COMPILE_FIRST): Add macroexp and cconv. | ||
| 174 | * makefile.w32-in: Mirror changes in Makefile.in. | ||
| 175 | |||
| 176 | * vc/cvs-status.el: | ||
| 177 | * vc/diff-mode.el: | ||
| 178 | * vc/log-edit.el: | ||
| 179 | * vc/log-view.el: | ||
| 180 | * vc/smerge-mode.el: | ||
| 181 | * textmodes/bibtex-style.el: | ||
| 182 | * textmodes/css.el: | ||
| 183 | * startup.el: | ||
| 184 | * uniquify.el: | ||
| 185 | * minibuffer.el: | ||
| 186 | * newcomment.el: | ||
| 187 | * reveal.el: | ||
| 188 | * server.el: | ||
| 189 | * mpc.el: | ||
| 190 | * emacs-lisp/smie.el: | ||
| 191 | * doc-view.el: | ||
| 192 | * dired.el: | ||
| 193 | * abbrev.el: Use lexical binding. | ||
| 194 | |||
| 195 | 2011-04-01 Eli Zaretskii <eliz@gnu.org> | ||
| 196 | |||
| 197 | * info.el (info-display-manual): New function. | ||
| 198 | |||
| 1 | 2011-03-31 Stefan Monnier <monnier@iro.umontreal.ca> | 199 | 2011-03-31 Stefan Monnier <monnier@iro.umontreal.ca> |
| 2 | 200 | ||
| 3 | * loadup.el: Load minibuffer after loaddefs, to use define-minor-mode. | 201 | * loadup.el: Load minibuffer after loaddefs, to use define-minor-mode. |
| @@ -69,8 +267,8 @@ | |||
| 69 | 267 | ||
| 70 | 2011-03-28 Brian T. Sniffen <bsniffen@akamai.com> (tiny change) | 268 | 2011-03-28 Brian T. Sniffen <bsniffen@akamai.com> (tiny change) |
| 71 | 269 | ||
| 72 | * net/imap.el (imap-shell-open, imap-process-connection-type): Use | 270 | * net/imap.el (imap-shell-open, imap-process-connection-type): |
| 73 | imap-process-connection-type for 'shell' streams as well as | 271 | Use imap-process-connection-type for 'shell' streams as well as |
| 74 | Kerberos, SSL, other subprocesses. | 272 | Kerberos, SSL, other subprocesses. |
| 75 | 273 | ||
| 76 | 2011-03-28 Leo Liu <sdl.web@gmail.com> | 274 | 2011-03-28 Leo Liu <sdl.web@gmail.com> |
diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 06c82181ea1..083f312d613 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in | |||
| @@ -70,12 +70,23 @@ AUTOGENEL = loaddefs.el \ | |||
| 70 | cedet/ede/loaddefs.el \ | 70 | cedet/ede/loaddefs.el \ |
| 71 | cedet/srecode/loaddefs.el | 71 | cedet/srecode/loaddefs.el |
| 72 | 72 | ||
| 73 | # Value of max-lisp-eval-depth when compiling initially. | ||
| 74 | # During bootstrapping the byte-compiler is run interpreted when compiling | ||
| 75 | # itself, and uses more stack than usual. | ||
| 76 | # | ||
| 77 | BIG_STACK_DEPTH = 1200 | ||
| 78 | BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))" | ||
| 79 | |||
| 80 | BYTE_COMPILE_FLAGS = $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) | ||
| 81 | |||
| 73 | # Files to compile before others during a bootstrap. This is done to | 82 | # Files to compile before others during a bootstrap. This is done to |
| 74 | # speed up the bootstrap process. | 83 | # speed up the bootstrap process. |
| 75 | 84 | ||
| 76 | COMPILE_FIRST = \ | 85 | COMPILE_FIRST = \ |
| 77 | $(lisp)/emacs-lisp/bytecomp.elc \ | 86 | $(lisp)/emacs-lisp/bytecomp.elc \ |
| 78 | $(lisp)/emacs-lisp/byte-opt.elc \ | 87 | $(lisp)/emacs-lisp/byte-opt.elc \ |
| 88 | $(lisp)/emacs-lisp/macroexp.elc \ | ||
| 89 | $(lisp)/emacs-lisp/cconv.elc \ | ||
| 79 | $(lisp)/emacs-lisp/autoload.elc | 90 | $(lisp)/emacs-lisp/autoload.elc |
| 80 | 91 | ||
| 81 | # The actual Emacs command run in the targets below. | 92 | # The actual Emacs command run in the targets below. |
| @@ -195,7 +206,9 @@ compile-onefile: | |||
| 195 | @echo Compiling $(THEFILE) | 206 | @echo Compiling $(THEFILE) |
| 196 | @# Use byte-compile-refresh-preloaded to try and work around some of | 207 | @# Use byte-compile-refresh-preloaded to try and work around some of |
| 197 | @# the most common bootstrapping problems. | 208 | @# the most common bootstrapping problems. |
| 198 | @$(emacs) -l bytecomp -f byte-compile-refresh-preloaded $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $(THEFILE) | 209 | @$(emacs) $(BYTE_COMPILE_FLAGS) \ |
| 210 | -l bytecomp -f byte-compile-refresh-preloaded \ | ||
| 211 | -f batch-byte-compile $(THEFILE) | ||
| 199 | 212 | ||
| 200 | # Files MUST be compiled one by one. If we compile several files in a | 213 | # Files MUST be compiled one by one. If we compile several files in a |
| 201 | # row (i.e., in the same instance of Emacs) we can't make sure that | 214 | # row (i.e., in the same instance of Emacs) we can't make sure that |
| @@ -210,7 +223,11 @@ compile-onefile: | |||
| 210 | # cannot have prerequisites. | 223 | # cannot have prerequisites. |
| 211 | .el.elc: | 224 | .el.elc: |
| 212 | @echo Compiling $< | 225 | @echo Compiling $< |
| 213 | @$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $< | 226 | @# The BIG_STACK_OPTS are only needed to byte-compile the byte-compiler |
| 227 | @# files, which is normally done in compile-first, but may also be | ||
| 228 | @# recompiled via this rule. | ||
| 229 | @$(emacs) $(BYTE_COMPILE_FLAGS) \ | ||
| 230 | -f batch-byte-compile $< | ||
| 214 | 231 | ||
| 215 | .PHONY: compile-first compile-main compile compile-always | 232 | .PHONY: compile-first compile-main compile compile-always |
| 216 | 233 | ||
| @@ -275,7 +292,7 @@ compile-always: doit | |||
| 275 | compile-calc: | 292 | compile-calc: |
| 276 | for el in $(lisp)/calc/*.el; do \ | 293 | for el in $(lisp)/calc/*.el; do \ |
| 277 | echo Compiling $$el; \ | 294 | echo Compiling $$el; \ |
| 278 | $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ | 295 | $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1;\ |
| 279 | done | 296 | done |
| 280 | 297 | ||
| 281 | # Backup compiled Lisp files in elc.tar.gz. If that file already | 298 | # Backup compiled Lisp files in elc.tar.gz. If that file already |
| @@ -302,7 +319,8 @@ compile-after-backup: backup-compiled-files compile-always | |||
| 302 | # since the environment of later files is affected by definitions in | 319 | # since the environment of later files is affected by definitions in |
| 303 | # earlier ones. | 320 | # earlier ones. |
| 304 | recompile: doit $(LOADDEFS) compile-first $(lisp)/progmodes/cc-mode.elc | 321 | recompile: doit $(LOADDEFS) compile-first $(lisp)/progmodes/cc-mode.elc |
| 305 | $(emacs) --eval "(batch-byte-recompile-directory 0)" $(lisp) | 322 | $(emacs) $(BYTE_COMPILE_FLAGS) \ |
| 323 | --eval "(batch-byte-recompile-directory 0)" $(lisp) | ||
| 306 | 324 | ||
| 307 | # Update MH-E internal autoloads. These are not to be confused with | 325 | # Update MH-E internal autoloads. These are not to be confused with |
| 308 | # the autoloads for the MH-E entry points, which are already in loaddefs.el. | 326 | # the autoloads for the MH-E entry points, which are already in loaddefs.el. |
diff --git a/lisp/abbrev.el b/lisp/abbrev.el index ddf37aff58f..b2cd2064da2 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; abbrev.el --- abbrev mode commands for Emacs | 1 | ;;; abbrev.el --- abbrev mode commands for Emacs -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -814,20 +814,19 @@ Returns the abbrev symbol, if expansion took place." | |||
| 814 | (destructuring-bind (&optional sym name wordstart wordend) | 814 | (destructuring-bind (&optional sym name wordstart wordend) |
| 815 | (abbrev--before-point) | 815 | (abbrev--before-point) |
| 816 | (when sym | 816 | (when sym |
| 817 | (let ((value sym)) | 817 | (unless (or ;; executing-kbd-macro |
| 818 | (unless (or ;; executing-kbd-macro | 818 | noninteractive |
| 819 | noninteractive | 819 | (window-minibuffer-p (selected-window))) |
| 820 | (window-minibuffer-p (selected-window))) | 820 | ;; Add an undo boundary, in case we are doing this for |
| 821 | ;; Add an undo boundary, in case we are doing this for | 821 | ;; a self-inserting command which has avoided making one so far. |
| 822 | ;; a self-inserting command which has avoided making one so far. | 822 | (undo-boundary)) |
| 823 | (undo-boundary)) | 823 | ;; Now sym is the abbrev symbol. |
| 824 | ;; Now sym is the abbrev symbol. | 824 | (setq last-abbrev-text name) |
| 825 | (setq last-abbrev-text name) | 825 | (setq last-abbrev sym) |
| 826 | (setq last-abbrev sym) | 826 | (setq last-abbrev-location wordstart) |
| 827 | (setq last-abbrev-location wordstart) | 827 | ;; If this abbrev has an expansion, delete the abbrev |
| 828 | ;; If this abbrev has an expansion, delete the abbrev | 828 | ;; and insert the expansion. |
| 829 | ;; and insert the expansion. | 829 | (abbrev-insert sym name wordstart wordend))))) |
| 830 | (abbrev-insert sym name wordstart wordend)))))) | ||
| 831 | 830 | ||
| 832 | (defun unexpand-abbrev () | 831 | (defun unexpand-abbrev () |
| 833 | "Undo the expansion of the last abbrev that expanded. | 832 | "Undo the expansion of the last abbrev that expanded. |
diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog index b6d5cff6b51..fa3f633d1ac 100644 --- a/lisp/cedet/ChangeLog +++ b/lisp/cedet/ChangeLog | |||
| @@ -1,3 +1,8 @@ | |||
| 1 | 2011-02-21 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * semantic/wisent/comp.el (wisent-byte-compile-grammar): | ||
| 4 | Macroexpand before passing to byte-compile-form. | ||
| 5 | |||
| 1 | 2011-01-13 Stefan Monnier <monnier@iro.umontreal.ca> | 6 | 2011-01-13 Stefan Monnier <monnier@iro.umontreal.ca> |
| 2 | 7 | ||
| 3 | * srecode/srt-mode.el (srecode-template-mode): Use define-derived-mode. | 8 | * srecode/srt-mode.el (srecode-template-mode): Use define-derived-mode. |
diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el index c3243c12923..f92ae88c14e 100644 --- a/lisp/cedet/semantic/wisent/comp.el +++ b/lisp/cedet/semantic/wisent/comp.el | |||
| @@ -3452,15 +3452,13 @@ where: | |||
| 3452 | (if (wisent-automaton-p grammar) | 3452 | (if (wisent-automaton-p grammar) |
| 3453 | grammar ;; Grammar already compiled just return it | 3453 | grammar ;; Grammar already compiled just return it |
| 3454 | (wisent-with-context compile-grammar | 3454 | (wisent-with-context compile-grammar |
| 3455 | (let* ((gc-cons-threshold 1000000) | 3455 | (let* ((gc-cons-threshold 1000000)) |
| 3456 | automaton) | ||
| 3457 | (garbage-collect) | 3456 | (garbage-collect) |
| 3458 | (setq wisent-new-log-flag t) | 3457 | (setq wisent-new-log-flag t) |
| 3459 | ;; Parse input grammar | 3458 | ;; Parse input grammar |
| 3460 | (wisent-parse-grammar grammar start-list) | 3459 | (wisent-parse-grammar grammar start-list) |
| 3461 | ;; Generate the LALR(1) automaton | 3460 | ;; Generate the LALR(1) automaton |
| 3462 | (setq automaton (wisent-parser-automaton)) | 3461 | (wisent-parser-automaton))))) |
| 3463 | automaton)))) | ||
| 3464 | 3462 | ||
| 3465 | ;;;; -------------------------- | 3463 | ;;;; -------------------------- |
| 3466 | ;;;; Byte compile input grammar | 3464 | ;;;; Byte compile input grammar |
| @@ -3476,8 +3474,19 @@ Automatically called by the Emacs Lisp byte compiler as a | |||
| 3476 | ;; automaton internal data structure. Then, because the internal | 3474 | ;; automaton internal data structure. Then, because the internal |
| 3477 | ;; data structure contains an obarray, convert it to a lisp form so | 3475 | ;; data structure contains an obarray, convert it to a lisp form so |
| 3478 | ;; it can be byte-compiled. | 3476 | ;; it can be byte-compiled. |
| 3479 | (byte-compile-form (wisent-automaton-lisp-form (eval form)))) | 3477 | (byte-compile-form |
| 3480 | 3478 | ;; FIXME: we macroexpand here since `byte-compile-form' expects | |
| 3479 | ;; macroexpanded code, but that's just a workaround: for lexical-binding | ||
| 3480 | ;; the lisp form should have to pass through closure-conversion and | ||
| 3481 | ;; `wisent-byte-compile-grammar' is called much too late for that. | ||
| 3482 | ;; Why isn't this `wisent-automaton-lisp-form' performed at | ||
| 3483 | ;; macroexpansion time? --Stef | ||
| 3484 | (macroexpand-all | ||
| 3485 | (wisent-automaton-lisp-form (eval form))))) | ||
| 3486 | |||
| 3487 | ;; FIXME: We shouldn't use a `byte-compile' handler. Maybe using a hash-table | ||
| 3488 | ;; instead of an obarray would work around the problem that obarrays | ||
| 3489 | ;; aren't printable. Then (put 'wisent-compile-grammar 'side-effect-free t). | ||
| 3481 | (put 'wisent-compile-grammar 'byte-compile 'wisent-byte-compile-grammar) | 3490 | (put 'wisent-compile-grammar 'byte-compile 'wisent-byte-compile-grammar) |
| 3482 | 3491 | ||
| 3483 | (defun wisent-automaton-lisp-form (automaton) | 3492 | (defun wisent-automaton-lisp-form (automaton) |
diff --git a/lisp/custom.el b/lisp/custom.el index e837c501438..5b5592698d8 100644 --- a/lisp/custom.el +++ b/lisp/custom.el | |||
| @@ -55,11 +55,9 @@ Otherwise, if symbol has a `saved-value' property, it will evaluate | |||
| 55 | the car of that and use it as the default binding for symbol. | 55 | the car of that and use it as the default binding for symbol. |
| 56 | Otherwise, VALUE will be evaluated and used as the default binding for | 56 | Otherwise, VALUE will be evaluated and used as the default binding for |
| 57 | symbol." | 57 | symbol." |
| 58 | (unless (default-boundp symbol) | 58 | (eval `(defvar ,symbol ,(if (get symbol 'saved-value) |
| 59 | ;; Use the saved value if it exists, otherwise the standard setting. | 59 | (car (get symbol 'saved-value)) |
| 60 | (set-default symbol (eval (if (get symbol 'saved-value) | 60 | value)))) |
| 61 | (car (get symbol 'saved-value)) | ||
| 62 | value))))) | ||
| 63 | 61 | ||
| 64 | (defun custom-initialize-set (symbol value) | 62 | (defun custom-initialize-set (symbol value) |
| 65 | "Initialize SYMBOL based on VALUE. | 63 | "Initialize SYMBOL based on VALUE. |
| @@ -81,15 +79,15 @@ The value is either the symbol's current value | |||
| 81 | \(as obtained using the `:get' function), if any, | 79 | \(as obtained using the `:get' function), if any, |
| 82 | or the value in the symbol's `saved-value' property if any, | 80 | or the value in the symbol's `saved-value' property if any, |
| 83 | or (last of all) VALUE." | 81 | or (last of all) VALUE." |
| 84 | (funcall (or (get symbol 'custom-set) 'set-default) | 82 | (funcall (or (get symbol 'custom-set) 'set-default) |
| 85 | symbol | 83 | symbol |
| 86 | (cond ((default-boundp symbol) | 84 | (cond ((default-boundp symbol) |
| 87 | (funcall (or (get symbol 'custom-get) 'default-value) | 85 | (funcall (or (get symbol 'custom-get) 'default-value) |
| 88 | symbol)) | 86 | symbol)) |
| 89 | ((get symbol 'saved-value) | 87 | ((get symbol 'saved-value) |
| 90 | (eval (car (get symbol 'saved-value)))) | 88 | (eval (car (get symbol 'saved-value)))) |
| 91 | (t | 89 | (t |
| 92 | (eval value))))) | 90 | (eval value))))) |
| 93 | 91 | ||
| 94 | (defun custom-initialize-changed (symbol value) | 92 | (defun custom-initialize-changed (symbol value) |
| 95 | "Initialize SYMBOL with VALUE. | 93 | "Initialize SYMBOL with VALUE. |
| @@ -142,10 +140,8 @@ set to nil, as the value is no longer rogue." | |||
| 142 | ;; Maybe this option was rogue in an earlier version. It no longer is. | 140 | ;; Maybe this option was rogue in an earlier version. It no longer is. |
| 143 | (when (get symbol 'force-value) | 141 | (when (get symbol 'force-value) |
| 144 | (put symbol 'force-value nil)) | 142 | (put symbol 'force-value nil)) |
| 145 | (when doc | 143 | (if (keywordp doc) |
| 146 | (if (keywordp doc) | 144 | (error "Doc string is missing")) |
| 147 | (error "Doc string is missing") | ||
| 148 | (put symbol 'variable-documentation doc))) | ||
| 149 | (let ((initialize 'custom-initialize-reset) | 145 | (let ((initialize 'custom-initialize-reset) |
| 150 | (requests nil)) | 146 | (requests nil)) |
| 151 | (unless (memq :group args) | 147 | (unless (memq :group args) |
| @@ -189,6 +185,13 @@ set to nil, as the value is no longer rogue." | |||
| 189 | ;; Do the actual initialization. | 185 | ;; Do the actual initialization. |
| 190 | (unless custom-dont-initialize | 186 | (unless custom-dont-initialize |
| 191 | (funcall initialize symbol default))) | 187 | (funcall initialize symbol default))) |
| 188 | ;; Use defvar to set the docstring as well as the special-variable-p flag. | ||
| 189 | ;; FIXME: We should reproduce more of `defvar's behavior, such as the warning | ||
| 190 | ;; when the var is currently let-bound. | ||
| 191 | (if (not (default-boundp symbol)) | ||
| 192 | ;; Don't use defvar to avoid setting a default-value when undesired. | ||
| 193 | (when doc (put symbol 'variable-documentation doc)) | ||
| 194 | (eval `(defvar ,symbol nil ,@(when doc (list doc))))) | ||
| 192 | (push symbol current-load-list) | 195 | (push symbol current-load-list) |
| 193 | (run-hooks 'custom-define-hook) | 196 | (run-hooks 'custom-define-hook) |
| 194 | symbol) | 197 | symbol) |
diff --git a/lisp/dired.el b/lisp/dired.el index 22470ea61e6..d72e0aad55f 100644 --- a/lisp/dired.el +++ b/lisp/dired.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; dired.el --- directory-browsing commands | 1 | ;;; dired.el --- directory-browsing commands -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1985-1986, 1992-1997, 2000-2011 | 3 | ;; Copyright (C) 1985-1986, 1992-1997, 2000-2011 |
| 4 | ;; Free Software Foundation, Inc. | 4 | ;; Free Software Foundation, Inc. |
| @@ -1181,7 +1181,7 @@ If HDR is non-nil, insert a header line with the directory name." | |||
| 1181 | 1181 | ||
| 1182 | ;; Reverting a dired buffer | 1182 | ;; Reverting a dired buffer |
| 1183 | 1183 | ||
| 1184 | (defun dired-revert (&optional arg noconfirm) | 1184 | (defun dired-revert (&optional _arg _noconfirm) |
| 1185 | "Reread the dired buffer. | 1185 | "Reread the dired buffer. |
| 1186 | Must also be called after `dired-actual-switches' have changed. | 1186 | Must also be called after `dired-actual-switches' have changed. |
| 1187 | Should not fail even on completely garbaged buffers. | 1187 | Should not fail even on completely garbaged buffers. |
| @@ -2143,7 +2143,7 @@ Optional arg GLOBAL means to replace all matches." | |||
| 2143 | ;; dired-get-filename. | 2143 | ;; dired-get-filename. |
| 2144 | (concat (or dir default-directory) file)) | 2144 | (concat (or dir default-directory) file)) |
| 2145 | 2145 | ||
| 2146 | (defun dired-make-relative (file &optional dir ignore) | 2146 | (defun dired-make-relative (file &optional dir _ignore) |
| 2147 | "Convert FILE (an absolute file name) to a name relative to DIR. | 2147 | "Convert FILE (an absolute file name) to a name relative to DIR. |
| 2148 | If this is impossible, return FILE unchanged. | 2148 | If this is impossible, return FILE unchanged. |
| 2149 | DIR must be a directory name, not a file name." | 2149 | DIR must be a directory name, not a file name." |
| @@ -3233,7 +3233,7 @@ Type \\[help-command] at that time for help." | |||
| 3233 | (interactive "cRemove marks (RET means all): \nP") | 3233 | (interactive "cRemove marks (RET means all): \nP") |
| 3234 | (save-excursion | 3234 | (save-excursion |
| 3235 | (let* ((count 0) | 3235 | (let* ((count 0) |
| 3236 | (inhibit-read-only t) case-fold-search query | 3236 | (inhibit-read-only t) case-fold-search |
| 3237 | (string (format "\n%c" mark)) | 3237 | (string (format "\n%c" mark)) |
| 3238 | (help-form "\ | 3238 | (help-form "\ |
| 3239 | Type SPC or `y' to unmark one file, DEL or `n' to skip to next, | 3239 | Type SPC or `y' to unmark one file, DEL or `n' to skip to next, |
| @@ -3508,6 +3508,8 @@ Anything else means ask for each directory." | |||
| 3508 | (declare-function dnd-get-local-file-name "dnd" (uri &optional must-exist)) | 3508 | (declare-function dnd-get-local-file-name "dnd" (uri &optional must-exist)) |
| 3509 | (declare-function dnd-get-local-file-uri "dnd" (uri)) | 3509 | (declare-function dnd-get-local-file-uri "dnd" (uri)) |
| 3510 | 3510 | ||
| 3511 | (defvar dired-overwrite-confirmed) ;Defined in dired-aux. | ||
| 3512 | |||
| 3511 | (defun dired-dnd-handle-local-file (uri action) | 3513 | (defun dired-dnd-handle-local-file (uri action) |
| 3512 | "Copy, move or link a file to the dired directory. | 3514 | "Copy, move or link a file to the dired directory. |
| 3513 | URI is the file to handle, ACTION is one of copy, move, link or ask. | 3515 | URI is the file to handle, ACTION is one of copy, move, link or ask. |
| @@ -3569,38 +3571,38 @@ Ask means pop up a menu for the user to select one of copy, move or link." | |||
| 3569 | 3571 | ||
| 3570 | (eval-when-compile (require 'desktop)) | 3572 | (eval-when-compile (require 'desktop)) |
| 3571 | 3573 | ||
| 3572 | (defun dired-desktop-buffer-misc-data (desktop-dirname) | 3574 | (defun dired-desktop-buffer-misc-data (dirname) |
| 3573 | "Auxiliary information to be saved in desktop file." | 3575 | "Auxiliary information to be saved in desktop file." |
| 3574 | (cons | 3576 | (cons |
| 3575 | ;; Value of `dired-directory'. | 3577 | ;; Value of `dired-directory'. |
| 3576 | (if (consp dired-directory) | 3578 | (if (consp dired-directory) |
| 3577 | ;; Directory name followed by list of files. | 3579 | ;; Directory name followed by list of files. |
| 3578 | (cons (desktop-file-name (car dired-directory) desktop-dirname) | 3580 | (cons (desktop-file-name (car dired-directory) dirname) |
| 3579 | (cdr dired-directory)) | 3581 | (cdr dired-directory)) |
| 3580 | ;; Directory name, optionally with shell wildcard. | 3582 | ;; Directory name, optionally with shell wildcard. |
| 3581 | (desktop-file-name dired-directory desktop-dirname)) | 3583 | (desktop-file-name dired-directory dirname)) |
| 3582 | ;; Subdirectories in `dired-subdir-alist'. | 3584 | ;; Subdirectories in `dired-subdir-alist'. |
| 3583 | (cdr | 3585 | (cdr |
| 3584 | (nreverse | 3586 | (nreverse |
| 3585 | (mapcar | 3587 | (mapcar |
| 3586 | (function (lambda (f) (desktop-file-name (car f) desktop-dirname))) | 3588 | (function (lambda (f) (desktop-file-name (car f) dirname))) |
| 3587 | dired-subdir-alist))))) | 3589 | dired-subdir-alist))))) |
| 3588 | 3590 | ||
| 3589 | (defun dired-restore-desktop-buffer (desktop-buffer-file-name | 3591 | (defun dired-restore-desktop-buffer (_file-name |
| 3590 | desktop-buffer-name | 3592 | _buffer-name |
| 3591 | desktop-buffer-misc) | 3593 | misc-data) |
| 3592 | "Restore a dired buffer specified in a desktop file." | 3594 | "Restore a dired buffer specified in a desktop file." |
| 3593 | ;; First element of `desktop-buffer-misc' is the value of `dired-directory'. | 3595 | ;; First element of `misc-data' is the value of `dired-directory'. |
| 3594 | ;; This value is a directory name, optionally with shell wildcard or | 3596 | ;; This value is a directory name, optionally with shell wildcard or |
| 3595 | ;; a directory name followed by list of files. | 3597 | ;; a directory name followed by list of files. |
| 3596 | (let* ((dired-dir (car desktop-buffer-misc)) | 3598 | (let* ((dired-dir (car misc-data)) |
| 3597 | (dir (if (consp dired-dir) (car dired-dir) dired-dir))) | 3599 | (dir (if (consp dired-dir) (car dired-dir) dired-dir))) |
| 3598 | (if (file-directory-p (file-name-directory dir)) | 3600 | (if (file-directory-p (file-name-directory dir)) |
| 3599 | (progn | 3601 | (progn |
| 3600 | (dired dired-dir) | 3602 | (dired dired-dir) |
| 3601 | ;; The following elements of `desktop-buffer-misc' are the keys | 3603 | ;; The following elements of `misc-data' are the keys |
| 3602 | ;; from `dired-subdir-alist'. | 3604 | ;; from `dired-subdir-alist'. |
| 3603 | (mapc 'dired-maybe-insert-subdir (cdr desktop-buffer-misc)) | 3605 | (mapc 'dired-maybe-insert-subdir (cdr misc-data)) |
| 3604 | (current-buffer)) | 3606 | (current-buffer)) |
| 3605 | (message "Desktop: Directory %s no longer exists." dir) | 3607 | (message "Desktop: Directory %s no longer exists." dir) |
| 3606 | (when desktop-missing-file-warning (sit-for 1)) | 3608 | (when desktop-missing-file-warning (sit-for 1)) |
diff --git a/lisp/doc-view.el b/lisp/doc-view.el index c67205fd52b..7bead624cc7 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el | |||
| @@ -1,4 +1,5 @@ | |||
| 1 | ;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs | 1 | ;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs -*- lexical-binding: t -*- |
| 2 | |||
| 2 | 3 | ||
| 3 | ;; Copyright (C) 2007-2011 Free Software Foundation, Inc. | 4 | ;; Copyright (C) 2007-2011 Free Software Foundation, Inc. |
| 4 | ;; | 5 | ;; |
| @@ -155,7 +156,7 @@ | |||
| 155 | 156 | ||
| 156 | (defcustom doc-view-ghostscript-options | 157 | (defcustom doc-view-ghostscript-options |
| 157 | '("-dSAFER" ;; Avoid security problems when rendering files from untrusted | 158 | '("-dSAFER" ;; Avoid security problems when rendering files from untrusted |
| 158 | ;; sources. | 159 | ;; sources. |
| 159 | "-dNOPAUSE" "-sDEVICE=png16m" "-dTextAlphaBits=4" | 160 | "-dNOPAUSE" "-sDEVICE=png16m" "-dTextAlphaBits=4" |
| 160 | "-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET") | 161 | "-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET") |
| 161 | "A list of options to give to ghostscript." | 162 | "A list of options to give to ghostscript." |
| @@ -442,9 +443,7 @@ Can be `dvi', `pdf', or `ps'.") | |||
| 442 | doc-view-current-converter-processes) | 443 | doc-view-current-converter-processes) |
| 443 | ;; The PNG file hasn't been generated yet. | 444 | ;; The PNG file hasn't been generated yet. |
| 444 | (doc-view-pdf->png-1 doc-view-buffer-file-name file page | 445 | (doc-view-pdf->png-1 doc-view-buffer-file-name file page |
| 445 | (lexical-let ((page page) | 446 | (let ((win (selected-window))) |
| 446 | (win (selected-window)) | ||
| 447 | (file file)) | ||
| 448 | (lambda () | 447 | (lambda () |
| 449 | (and (eq (current-buffer) (window-buffer win)) | 448 | (and (eq (current-buffer) (window-buffer win)) |
| 450 | ;; If we changed page in the mean | 449 | ;; If we changed page in the mean |
| @@ -453,7 +452,7 @@ Can be `dvi', `pdf', or `ps'.") | |||
| 453 | ;; Make sure we don't infloop. | 452 | ;; Make sure we don't infloop. |
| 454 | (file-readable-p file) | 453 | (file-readable-p file) |
| 455 | (with-selected-window win | 454 | (with-selected-window win |
| 456 | (doc-view-goto-page page)))))))) | 455 | (doc-view-goto-page page)))))))) |
| 457 | (overlay-put (doc-view-current-overlay) | 456 | (overlay-put (doc-view-current-overlay) |
| 458 | 'help-echo (doc-view-current-info)))) | 457 | 'help-echo (doc-view-current-info)))) |
| 459 | 458 | ||
| @@ -713,8 +712,8 @@ Should be invoked when the cached images aren't up-to-date." | |||
| 713 | (if (and doc-view-dvipdf-program | 712 | (if (and doc-view-dvipdf-program |
| 714 | (executable-find doc-view-dvipdf-program)) | 713 | (executable-find doc-view-dvipdf-program)) |
| 715 | (doc-view-start-process "dvi->pdf" doc-view-dvipdf-program | 714 | (doc-view-start-process "dvi->pdf" doc-view-dvipdf-program |
| 716 | (list dvi pdf) | 715 | (list dvi pdf) |
| 717 | callback) | 716 | callback) |
| 718 | (doc-view-start-process "dvi->pdf" doc-view-dvipdfm-program | 717 | (doc-view-start-process "dvi->pdf" doc-view-dvipdfm-program |
| 719 | (list "-o" pdf dvi) | 718 | (list "-o" pdf dvi) |
| 720 | callback))) | 719 | callback))) |
| @@ -735,7 +734,7 @@ is named like ODF with the extension turned to pdf." | |||
| 735 | (list (format "-r%d" (round doc-view-resolution)) | 734 | (list (format "-r%d" (round doc-view-resolution)) |
| 736 | (concat "-sOutputFile=" png) | 735 | (concat "-sOutputFile=" png) |
| 737 | pdf-ps)) | 736 | pdf-ps)) |
| 738 | (lexical-let ((resolution doc-view-resolution)) | 737 | (let ((resolution doc-view-resolution)) |
| 739 | (lambda () | 738 | (lambda () |
| 740 | ;; Only create the resolution file when it's all done, so it also | 739 | ;; Only create the resolution file when it's all done, so it also |
| 741 | ;; serves as a witness that the conversion is complete. | 740 | ;; serves as a witness that the conversion is complete. |
| @@ -780,7 +779,7 @@ Start by converting PAGES, and then the rest." | |||
| 780 | ;; (almost) consecutive, but since in 99% of the cases, there'll be only | 779 | ;; (almost) consecutive, but since in 99% of the cases, there'll be only |
| 781 | ;; a single page anyway, and of the remaining 1%, few cases will have | 780 | ;; a single page anyway, and of the remaining 1%, few cases will have |
| 782 | ;; consecutive pages, it's not worth the trouble. | 781 | ;; consecutive pages, it's not worth the trouble. |
| 783 | (lexical-let ((pdf pdf) (png png) (rest (cdr pages))) | 782 | (let ((rest (cdr pages))) |
| 784 | (doc-view-pdf->png-1 | 783 | (doc-view-pdf->png-1 |
| 785 | pdf (format png (car pages)) (car pages) | 784 | pdf (format png (car pages)) (car pages) |
| 786 | (lambda () | 785 | (lambda () |
| @@ -793,8 +792,8 @@ Start by converting PAGES, and then the rest." | |||
| 793 | ;; not sufficient. | 792 | ;; not sufficient. |
| 794 | (dolist (win (get-buffer-window-list (current-buffer) nil 'visible)) | 793 | (dolist (win (get-buffer-window-list (current-buffer) nil 'visible)) |
| 795 | (with-selected-window win | 794 | (with-selected-window win |
| 796 | (when (stringp (get-char-property (point-min) 'display)) | 795 | (when (stringp (get-char-property (point-min) 'display)) |
| 797 | (doc-view-goto-page (doc-view-current-page))))) | 796 | (doc-view-goto-page (doc-view-current-page))))) |
| 798 | ;; Convert the rest of the pages. | 797 | ;; Convert the rest of the pages. |
| 799 | (doc-view-pdf/ps->png pdf png))))))) | 798 | (doc-view-pdf/ps->png pdf png))))))) |
| 800 | 799 | ||
| @@ -816,10 +815,8 @@ Start by converting PAGES, and then the rest." | |||
| 816 | (ps | 815 | (ps |
| 817 | ;; Doc is a PS, so convert it to PDF (which will be converted to | 816 | ;; Doc is a PS, so convert it to PDF (which will be converted to |
| 818 | ;; TXT thereafter). | 817 | ;; TXT thereafter). |
| 819 | (lexical-let ((pdf (expand-file-name "doc.pdf" | 818 | (let ((pdf (expand-file-name "doc.pdf" |
| 820 | (doc-view-current-cache-dir))) | 819 | (doc-view-current-cache-dir)))) |
| 821 | (txt txt) | ||
| 822 | (callback callback)) | ||
| 823 | (doc-view-ps->pdf doc-view-buffer-file-name pdf | 820 | (doc-view-ps->pdf doc-view-buffer-file-name pdf |
| 824 | (lambda () (doc-view-pdf->txt pdf txt callback))))) | 821 | (lambda () (doc-view-pdf->txt pdf txt callback))))) |
| 825 | (dvi | 822 | (dvi |
| @@ -873,9 +870,7 @@ Those files are saved in the directory given by the function | |||
| 873 | (dvi | 870 | (dvi |
| 874 | ;; DVI files have to be converted to PDF before Ghostscript can process | 871 | ;; DVI files have to be converted to PDF before Ghostscript can process |
| 875 | ;; it. | 872 | ;; it. |
| 876 | (lexical-let | 873 | (let ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir))) |
| 877 | ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir)) | ||
| 878 | (png-file png-file)) | ||
| 879 | (doc-view-dvi->pdf doc-view-buffer-file-name pdf | 874 | (doc-view-dvi->pdf doc-view-buffer-file-name pdf |
| 880 | (lambda () (doc-view-pdf/ps->png pdf png-file))))) | 875 | (lambda () (doc-view-pdf/ps->png pdf png-file))))) |
| 881 | (odf | 876 | (odf |
| @@ -1026,8 +1021,8 @@ have the page we want to view." | |||
| 1026 | (and (not (member pagefile prev-pages)) | 1021 | (and (not (member pagefile prev-pages)) |
| 1027 | (member pagefile doc-view-current-files))) | 1022 | (member pagefile doc-view-current-files))) |
| 1028 | (with-selected-window win | 1023 | (with-selected-window win |
| 1029 | (assert (eq (current-buffer) buffer)) | 1024 | (assert (eq (current-buffer) buffer)) |
| 1030 | (doc-view-goto-page page)))))))) | 1025 | (doc-view-goto-page page)))))))) |
| 1031 | 1026 | ||
| 1032 | (defun doc-view-buffer-message () | 1027 | (defun doc-view-buffer-message () |
| 1033 | ;; Only show this message initially, not when refreshing the buffer (in which | 1028 | ;; Only show this message initially, not when refreshing the buffer (in which |
| @@ -1470,9 +1465,9 @@ See the command `doc-view-mode' for more information on this mode." | |||
| 1470 | (when (not (eq major-mode 'doc-view-mode)) | 1465 | (when (not (eq major-mode 'doc-view-mode)) |
| 1471 | (doc-view-toggle-display)) | 1466 | (doc-view-toggle-display)) |
| 1472 | (with-selected-window | 1467 | (with-selected-window |
| 1473 | (or (get-buffer-window (current-buffer) 0) | 1468 | (or (get-buffer-window (current-buffer) 0) |
| 1474 | (selected-window)) | 1469 | (selected-window)) |
| 1475 | (doc-view-goto-page page))))) | 1470 | (doc-view-goto-page page))))) |
| 1476 | 1471 | ||
| 1477 | 1472 | ||
| 1478 | (provide 'doc-view) | 1473 | (provide 'doc-view) |
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 915a726ae11..39ea97aa98e 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el | |||
| @@ -2535,17 +2535,11 @@ See Info node `(elisp)Computed Advice' for detailed documentation." | |||
| 2535 | "Return the argument list of DEFINITION. | 2535 | "Return the argument list of DEFINITION. |
| 2536 | If DEFINITION could be from a subr then its NAME should be | 2536 | If DEFINITION could be from a subr then its NAME should be |
| 2537 | supplied to make subr arglist lookup more efficient." | 2537 | supplied to make subr arglist lookup more efficient." |
| 2538 | (cond ((ad-compiled-p definition) | 2538 | (require 'help-fns) |
| 2539 | (aref (ad-compiled-code definition) 0)) | 2539 | (cond |
| 2540 | ((consp definition) | 2540 | ((or (ad-macro-p definition) (ad-advice-p definition)) |
| 2541 | (car (cdr (ad-lambda-expression definition)))) | 2541 | (help-function-arglist (cdr definition))) |
| 2542 | ((ad-subr-p definition) | 2542 | (t (help-function-arglist definition)))) |
| 2543 | (if name | ||
| 2544 | (ad-subr-arglist name) | ||
| 2545 | ;; otherwise get it from its printed representation: | ||
| 2546 | (setq name (format "%s" definition)) | ||
| 2547 | (string-match "^#<subr \\([^>]+\\)>$" name) | ||
| 2548 | (ad-subr-arglist (intern (match-string 1 name))))))) | ||
| 2549 | 2543 | ||
| 2550 | ;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish | 2544 | ;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish |
| 2551 | ;; a defined empty arglist `(nil)' from an undefined arglist: | 2545 | ;; a defined empty arglist `(nil)' from an undefined arglist: |
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index d6e7ee9e3cb..5a5d6b88a2d 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el | |||
| @@ -137,7 +137,7 @@ or macro definition or a defcustom)." | |||
| 137 | ;; Special case to autoload some of the macro's declarations. | 137 | ;; Special case to autoload some of the macro's declarations. |
| 138 | (let ((decls (nth (if (stringp (nth 3 form)) 4 3) form)) | 138 | (let ((decls (nth (if (stringp (nth 3 form)) 4 3) form)) |
| 139 | (exps '())) | 139 | (exps '())) |
| 140 | (when (eq (car decls) 'declare) | 140 | (when (eq (car-safe decls) 'declare) |
| 141 | ;; FIXME: We'd like to reuse macro-declaration-function, | 141 | ;; FIXME: We'd like to reuse macro-declaration-function, |
| 142 | ;; but we can't since it doesn't return anything. | 142 | ;; but we can't since it doesn't return anything. |
| 143 | (dolist (decl decls) | 143 | (dolist (decl decls) |
| @@ -471,7 +471,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE | |||
| 471 | (marker-buffer output-start))) | 471 | (marker-buffer output-start))) |
| 472 | (autoload-print-form autoload))) | 472 | (autoload-print-form autoload))) |
| 473 | (error | 473 | (error |
| 474 | (message "Error in %s: %S" file err))) | 474 | (message "Autoload cookie error in %s:%s %S" |
| 475 | file (count-lines (point-min) (point)) err))) | ||
| 475 | 476 | ||
| 476 | ;; Copy the rest of the line to the output. | 477 | ;; Copy the rest of the line to the output. |
| 477 | (princ (buffer-substring | 478 | (princ (buffer-substring |
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0f4018dc8da..548fcd133df 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler | 1 | ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1991, 1994, 2000-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1991, 1994, 2000-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -186,8 +186,10 @@ | |||
| 186 | (eval-when-compile (require 'cl)) | 186 | (eval-when-compile (require 'cl)) |
| 187 | 187 | ||
| 188 | (defun byte-compile-log-lap-1 (format &rest args) | 188 | (defun byte-compile-log-lap-1 (format &rest args) |
| 189 | (if (aref byte-code-vector 0) | 189 | ;; Newer byte codes for stack-ref make the slot 0 non-nil again. |
| 190 | (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) | 190 | ;; But the "old disassembler" is *really* ancient by now. |
| 191 | ;; (if (aref byte-code-vector 0) | ||
| 192 | ;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) | ||
| 191 | (byte-compile-log-1 | 193 | (byte-compile-log-1 |
| 192 | (apply 'format format | 194 | (apply 'format format |
| 193 | (let (c a) | 195 | (let (c a) |
| @@ -242,58 +244,72 @@ | |||
| 242 | sexp))) | 244 | sexp))) |
| 243 | (cdr form)))) | 245 | (cdr form)))) |
| 244 | 246 | ||
| 245 | |||
| 246 | ;; Splice the given lap code into the current instruction stream. | ||
| 247 | ;; If it has any labels in it, you're responsible for making sure there | ||
| 248 | ;; are no collisions, and that byte-compile-tag-number is reasonable | ||
| 249 | ;; after this is spliced in. The provided list is destroyed. | ||
| 250 | (defun byte-inline-lapcode (lap) | ||
| 251 | (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))) | ||
| 252 | |||
| 253 | (defun byte-compile-inline-expand (form) | 247 | (defun byte-compile-inline-expand (form) |
| 254 | (let* ((name (car form)) | 248 | (let* ((name (car form)) |
| 255 | (fn (or (cdr (assq name byte-compile-function-environment)) | 249 | (localfn (cdr (assq name byte-compile-function-environment))) |
| 256 | (and (fboundp name) (symbol-function name))))) | 250 | (fn (or localfn (and (fboundp name) (symbol-function name))))) |
| 257 | (if (null fn) | 251 | (when (and (consp fn) (eq (car fn) 'autoload)) |
| 258 | (progn | 252 | (load (nth 1 fn)) |
| 259 | (byte-compile-warn "attempt to inline `%s' before it was defined" | 253 | (setq fn (or (and (fboundp name) (symbol-function name)) |
| 260 | name) | 254 | (cdr (assq name byte-compile-function-environment))))) |
| 261 | form) | 255 | (pcase fn |
| 262 | ;; else | 256 | (`nil |
| 263 | (when (and (consp fn) (eq (car fn) 'autoload)) | 257 | (byte-compile-warn "attempt to inline `%s' before it was defined" |
| 264 | (load (nth 1 fn)) | 258 | name) |
| 265 | (setq fn (or (and (fboundp name) (symbol-function name)) | 259 | form) |
| 266 | (cdr (assq name byte-compile-function-environment))))) | 260 | (`(autoload . ,_) |
| 267 | (if (and (consp fn) (eq (car fn) 'autoload)) | 261 | (error "File `%s' didn't define `%s'" (nth 1 fn) name)) |
| 268 | (error "File `%s' didn't define `%s'" (nth 1 fn) name)) | 262 | ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias. |
| 269 | (if (and (symbolp fn) (not (eq fn t))) | 263 | (byte-compile-inline-expand (cons fn (cdr form)))) |
| 270 | (byte-compile-inline-expand (cons fn (cdr form))) | 264 | ((pred byte-code-function-p) |
| 271 | (if (byte-code-function-p fn) | 265 | ;; (message "Inlining byte-code for %S!" name) |
| 272 | (let (string) | 266 | ;; The byte-code will be really inlined in byte-compile-unfold-bcf. |
| 273 | (fetch-bytecode fn) | 267 | `(,fn ,@(cdr form))) |
| 274 | (setq string (aref fn 1)) | 268 | ((or (and `(lambda ,args . ,body) (let env nil)) |
| 275 | ;; Isn't it an error for `string' not to be unibyte?? --stef | 269 | `(closure ,env ,args . ,body)) |
| 276 | (if (fboundp 'string-as-unibyte) | 270 | (if (not (or (eq fn localfn) ;From the same file => same mode. |
| 277 | (setq string (string-as-unibyte string))) | 271 | (eq (not lexical-binding) (not env)))) ;Same mode. |
| 278 | ;; `byte-compile-splice-in-already-compiled-code' | 272 | ;; While byte-compile-unfold-bcf can inline dynbind byte-code into |
| 279 | ;; takes care of inlining the body. | 273 | ;; letbind byte-code (or any other combination for that matter), we |
| 280 | (cons `(lambda ,(aref fn 0) | 274 | ;; can only inline dynbind source into dynbind source or letbind |
| 281 | (byte-code ,string ,(aref fn 2) ,(aref fn 3))) | 275 | ;; source into letbind source. |
| 282 | (cdr form))) | 276 | ;; FIXME: we could of course byte-compile the inlined function |
| 283 | (if (eq (car-safe fn) 'lambda) | 277 | ;; first, and then inline its byte-code. |
| 284 | (cons fn (cdr form)) | 278 | form |
| 285 | ;; Give up on inlining. | 279 | (let ((renv ())) |
| 286 | form)))))) | 280 | ;; Turn the function's closed vars (if any) into local let bindings. |
| 281 | (dolist (binding env) | ||
| 282 | (cond | ||
| 283 | ((consp binding) | ||
| 284 | ;; We check shadowing by the args, so that the `let' can be | ||
| 285 | ;; moved within the lambda, which can then be unfolded. | ||
| 286 | ;; FIXME: Some of those bindings might be unused in `body'. | ||
| 287 | (unless (memq (car binding) args) ;Shadowed. | ||
| 288 | (push `(,(car binding) ',(cdr binding)) renv))) | ||
| 289 | ((eq binding t)) | ||
| 290 | (t (push `(defvar ,binding) body)))) | ||
| 291 | (let ((newfn (byte-compile-preprocess | ||
| 292 | (if (null renv) | ||
| 293 | `(lambda ,args ,@body) | ||
| 294 | `(lambda ,args (let ,(nreverse renv) ,@body)))))) | ||
| 295 | (if (eq (car-safe newfn) 'function) | ||
| 296 | (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) | ||
| 297 | (byte-compile-log-warning | ||
| 298 | (format "Inlining closure %S failed" name)) | ||
| 299 | form))))) | ||
| 300 | |||
| 301 | (t ;; Give up on inlining. | ||
| 302 | form)))) | ||
| 287 | 303 | ||
| 288 | ;; ((lambda ...) ...) | 304 | ;; ((lambda ...) ...) |
| 289 | (defun byte-compile-unfold-lambda (form &optional name) | 305 | (defun byte-compile-unfold-lambda (form &optional name) |
| 306 | ;; In lexical-binding mode, let and functions don't bind vars in the same way | ||
| 307 | ;; (let obey special-variable-p, but functions don't). But luckily, this | ||
| 308 | ;; doesn't matter here, because function's behavior is underspecified so it | ||
| 309 | ;; can safely be turned into a `let', even though the reverse is not true. | ||
| 290 | (or name (setq name "anonymous lambda")) | 310 | (or name (setq name "anonymous lambda")) |
| 291 | (let ((lambda (car form)) | 311 | (let ((lambda (car form)) |
| 292 | (values (cdr form))) | 312 | (values (cdr form))) |
| 293 | (if (byte-code-function-p lambda) | ||
| 294 | (setq lambda (list 'lambda (aref lambda 0) | ||
| 295 | (list 'byte-code (aref lambda 1) | ||
| 296 | (aref lambda 2) (aref lambda 3))))) | ||
| 297 | (let ((arglist (nth 1 lambda)) | 313 | (let ((arglist (nth 1 lambda)) |
| 298 | (body (cdr (cdr lambda))) | 314 | (body (cdr (cdr lambda))) |
| 299 | optionalp restp | 315 | optionalp restp |
| @@ -302,6 +318,7 @@ | |||
| 302 | (setq body (cdr body))) | 318 | (setq body (cdr body))) |
| 303 | (if (and (consp (car body)) (eq 'interactive (car (car body)))) | 319 | (if (and (consp (car body)) (eq 'interactive (car (car body)))) |
| 304 | (setq body (cdr body))) | 320 | (setq body (cdr body))) |
| 321 | ;; FIXME: The checks below do not belong in an optimization phase. | ||
| 305 | (while arglist | 322 | (while arglist |
| 306 | (cond ((eq (car arglist) '&optional) | 323 | (cond ((eq (car arglist) '&optional) |
| 307 | ;; ok, I'll let this slide because funcall_lambda() does... | 324 | ;; ok, I'll let this slide because funcall_lambda() does... |
| @@ -379,8 +396,7 @@ | |||
| 379 | (and (nth 1 form) | 396 | (and (nth 1 form) |
| 380 | (not for-effect) | 397 | (not for-effect) |
| 381 | form)) | 398 | form)) |
| 382 | ((or (byte-code-function-p fn) | 399 | ((eq 'lambda (car-safe fn)) |
| 383 | (eq 'lambda (car-safe fn))) | ||
| 384 | (let ((newform (byte-compile-unfold-lambda form))) | 400 | (let ((newform (byte-compile-unfold-lambda form))) |
| 385 | (if (eq newform form) | 401 | (if (eq newform form) |
| 386 | ;; Some error occurred, avoid infinite recursion | 402 | ;; Some error occurred, avoid infinite recursion |
| @@ -455,8 +471,8 @@ | |||
| 455 | (byte-optimize-form (nth 2 form) for-effect) | 471 | (byte-optimize-form (nth 2 form) for-effect) |
| 456 | (byte-optimize-body (nthcdr 3 form) for-effect))))) | 472 | (byte-optimize-body (nthcdr 3 form) for-effect))))) |
| 457 | 473 | ||
| 458 | ((memq fn '(and or)) ; remember, and/or are control structures. | 474 | ((memq fn '(and or)) ; Remember, and/or are control structures. |
| 459 | ;; take forms off the back until we can't any more. | 475 | ;; Take forms off the back until we can't any more. |
| 460 | ;; In the future it could conceivably be a problem that the | 476 | ;; In the future it could conceivably be a problem that the |
| 461 | ;; subexpressions of these forms are optimized in the reverse | 477 | ;; subexpressions of these forms are optimized in the reverse |
| 462 | ;; order, but it's ok for now. | 478 | ;; order, but it's ok for now. |
| @@ -471,7 +487,8 @@ | |||
| 471 | (byte-compile-log | 487 | (byte-compile-log |
| 472 | " all subforms of %s called for effect; deleted" form)) | 488 | " all subforms of %s called for effect; deleted" form)) |
| 473 | (and backwards | 489 | (and backwards |
| 474 | (cons fn (nreverse (mapcar 'byte-optimize-form backwards))))) | 490 | (cons fn (nreverse (mapcar 'byte-optimize-form |
| 491 | backwards))))) | ||
| 475 | (cons fn (mapcar 'byte-optimize-form (cdr form))))) | 492 | (cons fn (mapcar 'byte-optimize-form (cdr form))))) |
| 476 | 493 | ||
| 477 | ((eq fn 'interactive) | 494 | ((eq fn 'interactive) |
| @@ -479,8 +496,7 @@ | |||
| 479 | (prin1-to-string form)) | 496 | (prin1-to-string form)) |
| 480 | nil) | 497 | nil) |
| 481 | 498 | ||
| 482 | ((memq fn '(defun defmacro function | 499 | ((memq fn '(defun defmacro function condition-case)) |
| 483 | condition-case save-window-excursion)) | ||
| 484 | ;; These forms are compiled as constants or by breaking out | 500 | ;; These forms are compiled as constants or by breaking out |
| 485 | ;; all the subexpressions and compiling them separately. | 501 | ;; all the subexpressions and compiling them separately. |
| 486 | form) | 502 | form) |
| @@ -511,23 +527,11 @@ | |||
| 511 | ;; However, don't actually bother calling `ignore'. | 527 | ;; However, don't actually bother calling `ignore'. |
| 512 | `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) | 528 | `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) |
| 513 | 529 | ||
| 514 | ;; If optimization is on, this is the only place that macros are | 530 | ;; Neeeded as long as we run byte-optimize-form after cconv. |
| 515 | ;; expanded. If optimization is off, then macroexpansion happens | 531 | ((eq fn 'internal-make-closure) form) |
| 516 | ;; in byte-compile-form. Otherwise, the macros are already expanded | 532 | |
| 517 | ;; by the time that is reached. | 533 | ((byte-code-function-p fn) |
| 518 | ((not (eq form | 534 | (cons fn (mapcar #'byte-optimize-form (cdr form)))) |
| 519 | (setq form (macroexpand form | ||
| 520 | byte-compile-macro-environment)))) | ||
| 521 | (byte-optimize-form form for-effect)) | ||
| 522 | |||
| 523 | ;; Support compiler macros as in cl.el. | ||
| 524 | ((and (fboundp 'compiler-macroexpand) | ||
| 525 | (symbolp (car-safe form)) | ||
| 526 | (get (car-safe form) 'cl-compiler-macro) | ||
| 527 | (not (eq form | ||
| 528 | (with-no-warnings | ||
| 529 | (setq form (compiler-macroexpand form)))))) | ||
| 530 | (byte-optimize-form form for-effect)) | ||
| 531 | 535 | ||
| 532 | ((not (symbolp fn)) | 536 | ((not (symbolp fn)) |
| 533 | (byte-compile-warn "`%s' is a malformed function" | 537 | (byte-compile-warn "`%s' is a malformed function" |
| @@ -605,7 +609,7 @@ | |||
| 605 | 609 | ||
| 606 | 610 | ||
| 607 | (defun byte-optimize-body (forms all-for-effect) | 611 | (defun byte-optimize-body (forms all-for-effect) |
| 608 | ;; optimize the cdr of a progn or implicit progn; all forms is a list of | 612 | ;; Optimize the cdr of a progn or implicit progn; all forms is a list of |
| 609 | ;; forms, all but the last of which are optimized with the assumption that | 613 | ;; forms, all but the last of which are optimized with the assumption that |
| 610 | ;; they are being called for effect. the last is for-effect as well if | 614 | ;; they are being called for effect. the last is for-effect as well if |
| 611 | ;; all-for-effect is true. returns a new list of forms. | 615 | ;; all-for-effect is true. returns a new list of forms. |
| @@ -1085,7 +1089,7 @@ | |||
| 1085 | (let ((fn (nth 1 form))) | 1089 | (let ((fn (nth 1 form))) |
| 1086 | (if (memq (car-safe fn) '(quote function)) | 1090 | (if (memq (car-safe fn) '(quote function)) |
| 1087 | (cons (nth 1 fn) (cdr (cdr form))) | 1091 | (cons (nth 1 fn) (cdr (cdr form))) |
| 1088 | form))) | 1092 | form))) |
| 1089 | 1093 | ||
| 1090 | (defun byte-optimize-apply (form) | 1094 | (defun byte-optimize-apply (form) |
| 1091 | ;; If the last arg is a literal constant, turn this into a funcall. | 1095 | ;; If the last arg is a literal constant, turn this into a funcall. |
| @@ -1291,63 +1295,51 @@ | |||
| 1291 | (put (car pure-fns) 'pure t) | 1295 | (put (car pure-fns) 'pure t) |
| 1292 | (setq pure-fns (cdr pure-fns))) | 1296 | (setq pure-fns (cdr pure-fns))) |
| 1293 | nil) | 1297 | nil) |
| 1294 | |||
| 1295 | (defun byte-compile-splice-in-already-compiled-code (form) | ||
| 1296 | ;; form is (byte-code "..." [...] n) | ||
| 1297 | (if (not (memq byte-optimize '(t lap))) | ||
| 1298 | (byte-compile-normal-call form) | ||
| 1299 | (byte-inline-lapcode | ||
| 1300 | (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t)) | ||
| 1301 | (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form)) | ||
| 1302 | byte-compile-maxdepth)) | ||
| 1303 | (setq byte-compile-depth (1+ byte-compile-depth)))) | ||
| 1304 | |||
| 1305 | (put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code) | ||
| 1306 | |||
| 1307 | 1298 | ||
| 1308 | (defconst byte-constref-ops | 1299 | (defconst byte-constref-ops |
| 1309 | '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) | 1300 | '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) |
| 1310 | 1301 | ||
| 1302 | ;; Used and set dynamically in byte-decompile-bytecode-1. | ||
| 1303 | (defvar bytedecomp-op) | ||
| 1304 | (defvar bytedecomp-ptr) | ||
| 1305 | |||
| 1311 | ;; This function extracts the bitfields from variable-length opcodes. | 1306 | ;; This function extracts the bitfields from variable-length opcodes. |
| 1312 | ;; Originally defined in disass.el (which no longer uses it.) | 1307 | ;; Originally defined in disass.el (which no longer uses it.) |
| 1313 | 1308 | (defun disassemble-offset (bytes) | |
| 1314 | (defun disassemble-offset () | ||
| 1315 | "Don't call this!" | 1309 | "Don't call this!" |
| 1316 | ;; fetch and return the offset for the current opcode. | 1310 | ;; Fetch and return the offset for the current opcode. |
| 1317 | ;; return nil if this opcode has no offset | 1311 | ;; Return nil if this opcode has no offset. |
| 1318 | ;; Used and set dynamically in byte-decompile-bytecode-1. | ||
| 1319 | (defvar bytedecomp-op) | ||
| 1320 | (defvar bytedecomp-ptr) | ||
| 1321 | (defvar bytedecomp-bytes) | ||
| 1322 | (cond ((< bytedecomp-op byte-nth) | 1312 | (cond ((< bytedecomp-op byte-nth) |
| 1323 | (let ((tem (logand bytedecomp-op 7))) | 1313 | (let ((tem (logand bytedecomp-op 7))) |
| 1324 | (setq bytedecomp-op (logand bytedecomp-op 248)) | 1314 | (setq bytedecomp-op (logand bytedecomp-op 248)) |
| 1325 | (cond ((eq tem 6) | 1315 | (cond ((eq tem 6) |
| 1326 | ;; Offset in next byte. | 1316 | ;; Offset in next byte. |
| 1327 | (setq bytedecomp-ptr (1+ bytedecomp-ptr)) | 1317 | (setq bytedecomp-ptr (1+ bytedecomp-ptr)) |
| 1328 | (aref bytedecomp-bytes bytedecomp-ptr)) | 1318 | (aref bytes bytedecomp-ptr)) |
| 1329 | ((eq tem 7) | 1319 | ((eq tem 7) |
| 1330 | ;; Offset in next 2 bytes. | 1320 | ;; Offset in next 2 bytes. |
| 1331 | (setq bytedecomp-ptr (1+ bytedecomp-ptr)) | 1321 | (setq bytedecomp-ptr (1+ bytedecomp-ptr)) |
| 1332 | (+ (aref bytedecomp-bytes bytedecomp-ptr) | 1322 | (+ (aref bytes bytedecomp-ptr) |
| 1333 | (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) | 1323 | (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) |
| 1334 | (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) | 1324 | (lsh (aref bytes bytedecomp-ptr) 8)))) |
| 1335 | (t tem)))) ;offset was in opcode | 1325 | (t tem)))) ;Offset was in opcode. |
| 1336 | ((>= bytedecomp-op byte-constant) | 1326 | ((>= bytedecomp-op byte-constant) |
| 1337 | (prog1 (- bytedecomp-op byte-constant) ;offset in opcode | 1327 | (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode. |
| 1338 | (setq bytedecomp-op byte-constant))) | 1328 | (setq bytedecomp-op byte-constant))) |
| 1339 | ((and (>= bytedecomp-op byte-constant2) | 1329 | ((or (and (>= bytedecomp-op byte-constant2) |
| 1340 | (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) | 1330 | (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) |
| 1331 | (= bytedecomp-op byte-stack-set2)) | ||
| 1341 | ;; Offset in next 2 bytes. | 1332 | ;; Offset in next 2 bytes. |
| 1342 | (setq bytedecomp-ptr (1+ bytedecomp-ptr)) | 1333 | (setq bytedecomp-ptr (1+ bytedecomp-ptr)) |
| 1343 | (+ (aref bytedecomp-bytes bytedecomp-ptr) | 1334 | (+ (aref bytes bytedecomp-ptr) |
| 1344 | (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) | 1335 | (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) |
| 1345 | (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) | 1336 | (lsh (aref bytes bytedecomp-ptr) 8)))) |
| 1346 | ((and (>= bytedecomp-op byte-listN) | 1337 | ((and (>= bytedecomp-op byte-listN) |
| 1347 | (<= bytedecomp-op byte-insertN)) | 1338 | (<= bytedecomp-op byte-discardN)) |
| 1348 | (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte | 1339 | (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte. |
| 1349 | (aref bytedecomp-bytes bytedecomp-ptr)))) | 1340 | (aref bytes bytedecomp-ptr)))) |
| 1350 | 1341 | ||
| 1342 | (defvar byte-compile-tag-number) | ||
| 1351 | 1343 | ||
| 1352 | ;; This de-compiler is used for inline expansion of compiled functions, | 1344 | ;; This de-compiler is used for inline expansion of compiled functions, |
| 1353 | ;; and by the disassembler. | 1345 | ;; and by the disassembler. |
| @@ -1369,27 +1361,26 @@ | |||
| 1369 | ;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler. | 1361 | ;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler. |
| 1370 | ;; In that case, we put a pc value into the list | 1362 | ;; In that case, we put a pc value into the list |
| 1371 | ;; before each insn (or its label). | 1363 | ;; before each insn (or its label). |
| 1372 | (defun byte-decompile-bytecode-1 (bytedecomp-bytes constvec | 1364 | (defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) |
| 1373 | &optional make-spliceable) | 1365 | (let ((length (length bytes)) |
| 1374 | (let ((length (length bytedecomp-bytes)) | 1366 | (bytedecomp-ptr 0) optr tags bytedecomp-op offset |
| 1375 | (bytedecomp-ptr 0) optr tags bytedecomp-op offset | ||
| 1376 | lap tmp | 1367 | lap tmp |
| 1377 | endtag) | 1368 | endtag) |
| 1378 | (while (not (= bytedecomp-ptr length)) | 1369 | (while (not (= bytedecomp-ptr length)) |
| 1379 | (or make-spliceable | 1370 | (or make-spliceable |
| 1380 | (setq lap (cons bytedecomp-ptr lap))) | 1371 | (push bytedecomp-ptr lap)) |
| 1381 | (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr) | 1372 | (setq bytedecomp-op (aref bytes bytedecomp-ptr) |
| 1382 | optr bytedecomp-ptr | 1373 | optr bytedecomp-ptr |
| 1383 | offset (disassemble-offset)) ; this does dynamic-scope magic | 1374 | ;; This uses dynamic-scope magic. |
| 1375 | offset (disassemble-offset bytes)) | ||
| 1384 | (setq bytedecomp-op (aref byte-code-vector bytedecomp-op)) | 1376 | (setq bytedecomp-op (aref byte-code-vector bytedecomp-op)) |
| 1385 | (cond ((memq bytedecomp-op byte-goto-ops) | 1377 | (cond ((memq bytedecomp-op byte-goto-ops) |
| 1386 | ;; it's a pc | 1378 | ;; It's a pc. |
| 1387 | (setq offset | 1379 | (setq offset |
| 1388 | (cdr (or (assq offset tags) | 1380 | (cdr (or (assq offset tags) |
| 1389 | (car (setq tags | 1381 | (let ((new (cons offset (byte-compile-make-tag)))) |
| 1390 | (cons (cons offset | 1382 | (push new tags) |
| 1391 | (byte-compile-make-tag)) | 1383 | new))))) |
| 1392 | tags))))))) | ||
| 1393 | ((cond ((eq bytedecomp-op 'byte-constant2) | 1384 | ((cond ((eq bytedecomp-op 'byte-constant2) |
| 1394 | (setq bytedecomp-op 'byte-constant) t) | 1385 | (setq bytedecomp-op 'byte-constant) t) |
| 1395 | ((memq bytedecomp-op byte-constref-ops))) | 1386 | ((memq bytedecomp-op byte-constref-ops))) |
| @@ -1399,36 +1390,36 @@ | |||
| 1399 | offset (if (eq bytedecomp-op 'byte-constant) | 1390 | offset (if (eq bytedecomp-op 'byte-constant) |
| 1400 | (byte-compile-get-constant tmp) | 1391 | (byte-compile-get-constant tmp) |
| 1401 | (or (assq tmp byte-compile-variables) | 1392 | (or (assq tmp byte-compile-variables) |
| 1402 | (car (setq byte-compile-variables | 1393 | (let ((new (list tmp))) |
| 1403 | (cons (list tmp) | 1394 | (push new byte-compile-variables) |
| 1404 | byte-compile-variables))))))) | 1395 | new))))) |
| 1405 | ((and make-spliceable | 1396 | ((eq bytedecomp-op 'byte-stack-set2) |
| 1406 | (eq bytedecomp-op 'byte-return)) | 1397 | (setq bytedecomp-op 'byte-stack-set)) |
| 1407 | (if (= bytedecomp-ptr (1- length)) | 1398 | ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80)) |
| 1408 | (setq bytedecomp-op nil) | 1399 | ;; The top bit of the operand for byte-discardN is a flag, |
| 1409 | (setq offset (or endtag (setq endtag (byte-compile-make-tag))) | 1400 | ;; saying whether the top-of-stack is preserved. In |
| 1410 | bytedecomp-op 'byte-goto)))) | 1401 | ;; lapcode, we represent this by using a different opcode |
| 1402 | ;; (with the flag removed from the operand). | ||
| 1403 | (setq bytedecomp-op 'byte-discardN-preserve-tos) | ||
| 1404 | (setq offset (- offset #x80)))) | ||
| 1411 | ;; lap = ( [ (pc . (op . arg)) ]* ) | 1405 | ;; lap = ( [ (pc . (op . arg)) ]* ) |
| 1412 | (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0))) | 1406 | (push (cons optr (cons bytedecomp-op (or offset 0))) |
| 1413 | lap)) | 1407 | lap) |
| 1414 | (setq bytedecomp-ptr (1+ bytedecomp-ptr))) | 1408 | (setq bytedecomp-ptr (1+ bytedecomp-ptr))) |
| 1415 | ;; take off the dummy nil op that we replaced a trailing "return" with. | ||
| 1416 | (let ((rest lap)) | 1409 | (let ((rest lap)) |
| 1417 | (while rest | 1410 | (while rest |
| 1418 | (cond ((numberp (car rest))) | 1411 | (cond ((numberp (car rest))) |
| 1419 | ((setq tmp (assq (car (car rest)) tags)) | 1412 | ((setq tmp (assq (car (car rest)) tags)) |
| 1420 | ;; this addr is jumped to | 1413 | ;; This addr is jumped to. |
| 1421 | (setcdr rest (cons (cons nil (cdr tmp)) | 1414 | (setcdr rest (cons (cons nil (cdr tmp)) |
| 1422 | (cdr rest))) | 1415 | (cdr rest))) |
| 1423 | (setq tags (delq tmp tags)) | 1416 | (setq tags (delq tmp tags)) |
| 1424 | (setq rest (cdr rest)))) | 1417 | (setq rest (cdr rest)))) |
| 1425 | (setq rest (cdr rest)))) | 1418 | (setq rest (cdr rest)))) |
| 1426 | (if tags (error "optimizer error: missed tags %s" tags)) | 1419 | (if tags (error "optimizer error: missed tags %s" tags)) |
| 1427 | (if (null (car (cdr (car lap)))) | ||
| 1428 | (setq lap (cdr lap))) | ||
| 1429 | (if endtag | 1420 | (if endtag |
| 1430 | (setq lap (cons (cons nil endtag) lap))) | 1421 | (setq lap (cons (cons nil endtag) lap))) |
| 1431 | ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) | 1422 | ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) |
| 1432 | (mapcar (function (lambda (elt) | 1423 | (mapcar (function (lambda (elt) |
| 1433 | (if (numberp elt) | 1424 | (if (numberp elt) |
| 1434 | elt | 1425 | elt |
| @@ -1463,7 +1454,7 @@ | |||
| 1463 | byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max | 1454 | byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max |
| 1464 | byte-point-min byte-following-char byte-preceding-char | 1455 | byte-point-min byte-following-char byte-preceding-char |
| 1465 | byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp | 1456 | byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp |
| 1466 | byte-current-buffer byte-interactive-p)) | 1457 | byte-current-buffer byte-stack-ref)) |
| 1467 | 1458 | ||
| 1468 | (defconst byte-compile-side-effect-free-ops | 1459 | (defconst byte-compile-side-effect-free-ops |
| 1469 | (nconc | 1460 | (nconc |
| @@ -1505,7 +1496,7 @@ | |||
| 1505 | ;; The variable `byte-boolean-vars' is now primitive and updated | 1496 | ;; The variable `byte-boolean-vars' is now primitive and updated |
| 1506 | ;; automatically by DEFVAR_BOOL. | 1497 | ;; automatically by DEFVAR_BOOL. |
| 1507 | 1498 | ||
| 1508 | (defun byte-optimize-lapcode (lap &optional for-effect) | 1499 | (defun byte-optimize-lapcode (lap &optional _for-effect) |
| 1509 | "Simple peephole optimizer. LAP is both modified and returned. | 1500 | "Simple peephole optimizer. LAP is both modified and returned. |
| 1510 | If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | 1501 | If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." |
| 1511 | (let (lap0 | 1502 | (let (lap0 |
| @@ -1580,9 +1571,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 1580 | ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup | 1571 | ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup |
| 1581 | ;; The latter two can enable other optimizations. | 1572 | ;; The latter two can enable other optimizations. |
| 1582 | ;; | 1573 | ;; |
| 1574 | ;; For lexical variables, we could do the same | ||
| 1575 | ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 | ||
| 1576 | ;; but this is a very minor gain, since dup is stack-ref-0, | ||
| 1577 | ;; i.e. it's only better if X>5, and even then it comes | ||
| 1578 | ;; at the cost cost of an extra stack slot. Let's not bother. | ||
| 1583 | ((and (eq 'byte-varref (car lap2)) | 1579 | ((and (eq 'byte-varref (car lap2)) |
| 1584 | (eq (cdr lap1) (cdr lap2)) | 1580 | (eq (cdr lap1) (cdr lap2)) |
| 1585 | (memq (car lap1) '(byte-varset byte-varbind))) | 1581 | (memq (car lap1) '(byte-varset byte-varbind))) |
| 1586 | (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) | 1582 | (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) |
| 1587 | (not (eq (car lap0) 'byte-constant))) | 1583 | (not (eq (car lap0) 'byte-constant))) |
| 1588 | nil | 1584 | nil |
| @@ -1611,14 +1607,17 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 1611 | ;; | 1607 | ;; |
| 1612 | ;; dup varset-X discard --> varset-X | 1608 | ;; dup varset-X discard --> varset-X |
| 1613 | ;; dup varbind-X discard --> varbind-X | 1609 | ;; dup varbind-X discard --> varbind-X |
| 1610 | ;; dup stack-set-X discard --> stack-set-X-1 | ||
| 1614 | ;; (the varbind variant can emerge from other optimizations) | 1611 | ;; (the varbind variant can emerge from other optimizations) |
| 1615 | ;; | 1612 | ;; |
| 1616 | ((and (eq 'byte-dup (car lap0)) | 1613 | ((and (eq 'byte-dup (car lap0)) |
| 1617 | (eq 'byte-discard (car lap2)) | 1614 | (eq 'byte-discard (car lap2)) |
| 1618 | (memq (car lap1) '(byte-varset byte-varbind))) | 1615 | (memq (car lap1) '(byte-varset byte-varbind |
| 1616 | byte-stack-set))) | ||
| 1619 | (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) | 1617 | (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) |
| 1620 | (setq keep-going t | 1618 | (setq keep-going t |
| 1621 | rest (cdr rest)) | 1619 | rest (cdr rest)) |
| 1620 | (if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1))) | ||
| 1622 | (setq lap (delq lap0 (delq lap2 lap)))) | 1621 | (setq lap (delq lap0 (delq lap2 lap)))) |
| 1623 | ;; | 1622 | ;; |
| 1624 | ;; not goto-X-if-nil --> goto-X-if-non-nil | 1623 | ;; not goto-X-if-nil --> goto-X-if-non-nil |
| @@ -1627,8 +1626,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 1627 | ;; it is wrong to do the same thing for the -else-pop variants. | 1626 | ;; it is wrong to do the same thing for the -else-pop variants. |
| 1628 | ;; | 1627 | ;; |
| 1629 | ((and (eq 'byte-not (car lap0)) | 1628 | ((and (eq 'byte-not (car lap0)) |
| 1630 | (or (eq 'byte-goto-if-nil (car lap1)) | 1629 | (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) |
| 1631 | (eq 'byte-goto-if-not-nil (car lap1)))) | ||
| 1632 | (byte-compile-log-lap " not %s\t-->\t%s" | 1630 | (byte-compile-log-lap " not %s\t-->\t%s" |
| 1633 | lap1 | 1631 | lap1 |
| 1634 | (cons | 1632 | (cons |
| @@ -1647,8 +1645,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 1647 | ;; | 1645 | ;; |
| 1648 | ;; it is wrong to do the same thing for the -else-pop variants. | 1646 | ;; it is wrong to do the same thing for the -else-pop variants. |
| 1649 | ;; | 1647 | ;; |
| 1650 | ((and (or (eq 'byte-goto-if-nil (car lap0)) | 1648 | ((and (memq (car lap0) |
| 1651 | (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX | 1649 | '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX |
| 1652 | (eq 'byte-goto (car lap1)) ; gotoY | 1650 | (eq 'byte-goto (car lap1)) ; gotoY |
| 1653 | (eq (cdr lap0) lap2)) ; TAG X | 1651 | (eq (cdr lap0) lap2)) ; TAG X |
| 1654 | (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) | 1652 | (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) |
| @@ -1663,40 +1661,51 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 1663 | ;; const goto-if-* --> whatever | 1661 | ;; const goto-if-* --> whatever |
| 1664 | ;; | 1662 | ;; |
| 1665 | ((and (eq 'byte-constant (car lap0)) | 1663 | ((and (eq 'byte-constant (car lap0)) |
| 1666 | (memq (car lap1) byte-conditional-ops)) | 1664 | (memq (car lap1) byte-conditional-ops) |
| 1667 | (cond ((if (or (eq (car lap1) 'byte-goto-if-nil) | 1665 | ;; If the `byte-constant's cdr is not a cons cell, it has |
| 1668 | (eq (car lap1) 'byte-goto-if-nil-else-pop)) | 1666 | ;; to be an index into the constant pool); even though |
| 1669 | (car (cdr lap0)) | 1667 | ;; it'll be a constant, that constant is not known yet |
| 1670 | (not (car (cdr lap0)))) | 1668 | ;; (it's typically a free variable of a closure, so will |
| 1669 | ;; only be known when the closure will be built at | ||
| 1670 | ;; run-time). | ||
| 1671 | (consp (cdr lap0))) | ||
| 1672 | (cond ((if (memq (car lap1) '(byte-goto-if-nil | ||
| 1673 | byte-goto-if-nil-else-pop)) | ||
| 1674 | (car (cdr lap0)) | ||
| 1675 | (not (car (cdr lap0)))) | ||
| 1671 | (byte-compile-log-lap " %s %s\t-->\t<deleted>" | 1676 | (byte-compile-log-lap " %s %s\t-->\t<deleted>" |
| 1672 | lap0 lap1) | 1677 | lap0 lap1) |
| 1673 | (setq rest (cdr rest) | 1678 | (setq rest (cdr rest) |
| 1674 | lap (delq lap0 (delq lap1 lap)))) | 1679 | lap (delq lap0 (delq lap1 lap)))) |
| 1675 | (t | 1680 | (t |
| 1676 | (if (memq (car lap1) byte-goto-always-pop-ops) | 1681 | (byte-compile-log-lap " %s %s\t-->\t%s" |
| 1677 | (progn | 1682 | lap0 lap1 |
| 1678 | (byte-compile-log-lap " %s %s\t-->\t%s" | 1683 | (cons 'byte-goto (cdr lap1))) |
| 1679 | lap0 lap1 (cons 'byte-goto (cdr lap1))) | 1684 | (when (memq (car lap1) byte-goto-always-pop-ops) |
| 1680 | (setq lap (delq lap0 lap))) | 1685 | (setq lap (delq lap0 lap))) |
| 1681 | (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 | ||
| 1682 | (cons 'byte-goto (cdr lap1)))) | ||
| 1683 | (setcar lap1 'byte-goto))) | 1686 | (setcar lap1 'byte-goto))) |
| 1684 | (setq keep-going t)) | 1687 | (setq keep-going t)) |
| 1685 | ;; | 1688 | ;; |
| 1686 | ;; varref-X varref-X --> varref-X dup | 1689 | ;; varref-X varref-X --> varref-X dup |
| 1687 | ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup | 1690 | ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup |
| 1691 | ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup | ||
| 1688 | ;; We don't optimize the const-X variations on this here, | 1692 | ;; We don't optimize the const-X variations on this here, |
| 1689 | ;; because that would inhibit some goto optimizations; we | 1693 | ;; because that would inhibit some goto optimizations; we |
| 1690 | ;; optimize the const-X case after all other optimizations. | 1694 | ;; optimize the const-X case after all other optimizations. |
| 1691 | ;; | 1695 | ;; |
| 1692 | ((and (eq 'byte-varref (car lap0)) | 1696 | ((and (memq (car lap0) '(byte-varref byte-stack-ref)) |
| 1693 | (progn | 1697 | (progn |
| 1694 | (setq tmp (cdr rest)) | 1698 | (setq tmp (cdr rest)) |
| 1699 | (setq tmp2 0) | ||
| 1695 | (while (eq (car (car tmp)) 'byte-dup) | 1700 | (while (eq (car (car tmp)) 'byte-dup) |
| 1696 | (setq tmp (cdr tmp))) | 1701 | (setq tmp2 (1+ tmp2)) |
| 1702 | (setq tmp (cdr tmp))) | ||
| 1697 | t) | 1703 | t) |
| 1698 | (eq (cdr lap0) (cdr (car tmp))) | 1704 | (eq (if (eq 'byte-stack-ref (car lap0)) |
| 1699 | (eq 'byte-varref (car (car tmp)))) | 1705 | (+ tmp2 1 (cdr lap0)) |
| 1706 | (cdr lap0)) | ||
| 1707 | (cdr (car tmp))) | ||
| 1708 | (eq (car lap0) (car (car tmp)))) | ||
| 1700 | (if (memq byte-optimize-log '(t byte)) | 1709 | (if (memq byte-optimize-log '(t byte)) |
| 1701 | (let ((str "")) | 1710 | (let ((str "")) |
| 1702 | (setq tmp2 (cdr rest)) | 1711 | (setq tmp2 (cdr rest)) |
| @@ -1856,18 +1865,21 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 1856 | (cons 'byte-discard byte-conditional-ops))) | 1865 | (cons 'byte-discard byte-conditional-ops))) |
| 1857 | (not (eq lap1 (car tmp)))) | 1866 | (not (eq lap1 (car tmp)))) |
| 1858 | (setq tmp2 (car tmp)) | 1867 | (setq tmp2 (car tmp)) |
| 1859 | (cond ((memq (car tmp2) | 1868 | (cond ((when (consp (cdr lap0)) |
| 1860 | (if (null (car (cdr lap0))) | 1869 | (memq (car tmp2) |
| 1861 | '(byte-goto-if-nil byte-goto-if-nil-else-pop) | 1870 | (if (null (car (cdr lap0))) |
| 1862 | '(byte-goto-if-not-nil | 1871 | '(byte-goto-if-nil byte-goto-if-nil-else-pop) |
| 1863 | byte-goto-if-not-nil-else-pop))) | 1872 | '(byte-goto-if-not-nil |
| 1873 | byte-goto-if-not-nil-else-pop)))) | ||
| 1864 | (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" | 1874 | (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" |
| 1865 | lap0 tmp2 lap0 tmp2) | 1875 | lap0 tmp2 lap0 tmp2) |
| 1866 | (setcar lap1 (car tmp2)) | 1876 | (setcar lap1 (car tmp2)) |
| 1867 | (setcdr lap1 (cdr tmp2)) | 1877 | (setcdr lap1 (cdr tmp2)) |
| 1868 | ;; Let next step fix the (const,goto-if*) sequence. | 1878 | ;; Let next step fix the (const,goto-if*) sequence. |
| 1869 | (setq rest (cons nil rest))) | 1879 | (setq rest (cons nil rest)) |
| 1870 | (t | 1880 | (setq keep-going t)) |
| 1881 | ((or (consp (cdr lap0)) | ||
| 1882 | (eq (car tmp2) 'byte-discard)) | ||
| 1871 | ;; Jump one step further | 1883 | ;; Jump one step further |
| 1872 | (byte-compile-log-lap | 1884 | (byte-compile-log-lap |
| 1873 | " %s goto [%s]\t-->\t<deleted> goto <skip>" | 1885 | " %s goto [%s]\t-->\t<deleted> goto <skip>" |
| @@ -1876,13 +1888,18 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 1876 | (setcdr tmp (cons (byte-compile-make-tag) | 1888 | (setcdr tmp (cons (byte-compile-make-tag) |
| 1877 | (cdr tmp)))) | 1889 | (cdr tmp)))) |
| 1878 | (setcdr lap1 (car (cdr tmp))) | 1890 | (setcdr lap1 (car (cdr tmp))) |
| 1879 | (setq lap (delq lap0 lap)))) | 1891 | (setq lap (delq lap0 lap)) |
| 1880 | (setq keep-going t)) | 1892 | (setq keep-going t)))) |
| 1881 | ;; | 1893 | ;; |
| 1882 | ;; X: varref-Y ... varset-Y goto-X --> | 1894 | ;; X: varref-Y ... varset-Y goto-X --> |
| 1883 | ;; X: varref-Y Z: ... dup varset-Y goto-Z | 1895 | ;; X: varref-Y Z: ... dup varset-Y goto-Z |
| 1884 | ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) | 1896 | ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) |
| 1885 | ;; (This is so usual for while loops that it is worth handling). | 1897 | ;; (This is so usual for while loops that it is worth handling). |
| 1898 | ;; | ||
| 1899 | ;; Here again, we could do it for stack-ref/stack-set, but | ||
| 1900 | ;; that's replacing a stack-ref-Y with a stack-ref-0, which | ||
| 1901 | ;; is a very minor improvement (if any), at the cost of | ||
| 1902 | ;; more stack use and more byte-code. Let's not do it. | ||
| 1886 | ;; | 1903 | ;; |
| 1887 | ((and (eq (car lap1) 'byte-varset) | 1904 | ((and (eq (car lap1) 'byte-varset) |
| 1888 | (eq (car lap2) 'byte-goto) | 1905 | (eq (car lap2) 'byte-goto) |
| @@ -1955,16 +1972,16 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 1955 | ;; Rebuild byte-compile-constants / byte-compile-variables. | 1972 | ;; Rebuild byte-compile-constants / byte-compile-variables. |
| 1956 | ;; Simple optimizations that would inhibit other optimizations if they | 1973 | ;; Simple optimizations that would inhibit other optimizations if they |
| 1957 | ;; were done in the optimizing loop, and optimizations which there is no | 1974 | ;; were done in the optimizing loop, and optimizations which there is no |
| 1958 | ;; need to do more than once. | 1975 | ;; need to do more than once. |
| 1959 | (setq byte-compile-constants nil | 1976 | (setq byte-compile-constants nil |
| 1960 | byte-compile-variables nil) | 1977 | byte-compile-variables nil) |
| 1961 | (setq rest lap) | 1978 | (setq rest lap) |
| 1979 | (byte-compile-log-lap " ---- final pass") | ||
| 1962 | (while rest | 1980 | (while rest |
| 1963 | (setq lap0 (car rest) | 1981 | (setq lap0 (car rest) |
| 1964 | lap1 (nth 1 rest)) | 1982 | lap1 (nth 1 rest)) |
| 1965 | (if (memq (car lap0) byte-constref-ops) | 1983 | (if (memq (car lap0) byte-constref-ops) |
| 1966 | (if (or (eq (car lap0) 'byte-constant) | 1984 | (if (memq (car lap0) '(byte-constant byte-constant2)) |
| 1967 | (eq (car lap0) 'byte-constant2)) | ||
| 1968 | (unless (memq (cdr lap0) byte-compile-constants) | 1985 | (unless (memq (cdr lap0) byte-compile-constants) |
| 1969 | (setq byte-compile-constants (cons (cdr lap0) | 1986 | (setq byte-compile-constants (cons (cdr lap0) |
| 1970 | byte-compile-constants))) | 1987 | byte-compile-constants))) |
| @@ -2008,10 +2025,86 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." | |||
| 2008 | (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 | 2025 | (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 |
| 2009 | (cons 'byte-unbind | 2026 | (cons 'byte-unbind |
| 2010 | (+ (cdr lap0) (cdr lap1)))) | 2027 | (+ (cdr lap0) (cdr lap1)))) |
| 2011 | (setq keep-going t) | ||
| 2012 | (setq lap (delq lap0 lap)) | 2028 | (setq lap (delq lap0 lap)) |
| 2013 | (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) | 2029 | (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) |
| 2014 | ) | 2030 | |
| 2031 | ;; | ||
| 2032 | ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos | ||
| 2033 | ;; stack-set-M [discard/discardN ...] --> discardN | ||
| 2034 | ;; | ||
| 2035 | ((and (eq (car lap0) 'byte-stack-set) | ||
| 2036 | (memq (car lap1) '(byte-discard byte-discardN)) | ||
| 2037 | (progn | ||
| 2038 | ;; See if enough discard operations follow to expose or | ||
| 2039 | ;; destroy the value stored by the stack-set. | ||
| 2040 | (setq tmp (cdr rest)) | ||
| 2041 | (setq tmp2 (1- (cdr lap0))) | ||
| 2042 | (setq tmp3 0) | ||
| 2043 | (while (memq (car (car tmp)) '(byte-discard byte-discardN)) | ||
| 2044 | (setq tmp3 | ||
| 2045 | (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) | ||
| 2046 | 1 | ||
| 2047 | (cdr (car tmp))))) | ||
| 2048 | (setq tmp (cdr tmp))) | ||
| 2049 | (>= tmp3 tmp2))) | ||
| 2050 | ;; Do the optimization. | ||
| 2051 | (setq lap (delq lap0 lap)) | ||
| 2052 | (setcar lap1 | ||
| 2053 | (if (= tmp2 tmp3) | ||
| 2054 | ;; The value stored is the new TOS, so pop one more | ||
| 2055 | ;; value (to get rid of the old value) using the | ||
| 2056 | ;; TOS-preserving discard operator. | ||
| 2057 | 'byte-discardN-preserve-tos | ||
| 2058 | ;; Otherwise, the value stored is lost, so just use a | ||
| 2059 | ;; normal discard. | ||
| 2060 | 'byte-discardN)) | ||
| 2061 | (setcdr lap1 (1+ tmp3)) | ||
| 2062 | (setcdr (cdr rest) tmp) | ||
| 2063 | (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" | ||
| 2064 | lap0 lap1)) | ||
| 2065 | |||
| 2066 | ;; | ||
| 2067 | ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> | ||
| 2068 | ;; discardN-(X+Y) | ||
| 2069 | ;; | ||
| 2070 | ((and (memq (car lap0) | ||
| 2071 | '(byte-discard byte-discardN | ||
| 2072 | byte-discardN-preserve-tos)) | ||
| 2073 | (memq (car lap1) '(byte-discard byte-discardN))) | ||
| 2074 | (setq lap (delq lap0 lap)) | ||
| 2075 | (byte-compile-log-lap | ||
| 2076 | " %s %s\t-->\t(discardN %s)" | ||
| 2077 | lap0 lap1 | ||
| 2078 | (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) | ||
| 2079 | (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) | ||
| 2080 | (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) | ||
| 2081 | (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) | ||
| 2082 | (setcar lap1 'byte-discardN)) | ||
| 2083 | |||
| 2084 | ;; | ||
| 2085 | ;; discardN-preserve-tos-X discardN-preserve-tos-Y --> | ||
| 2086 | ;; discardN-preserve-tos-(X+Y) | ||
| 2087 | ;; | ||
| 2088 | ((and (eq (car lap0) 'byte-discardN-preserve-tos) | ||
| 2089 | (eq (car lap1) 'byte-discardN-preserve-tos)) | ||
| 2090 | (setq lap (delq lap0 lap)) | ||
| 2091 | (setcdr lap1 (+ (cdr lap0) (cdr lap1))) | ||
| 2092 | (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) | ||
| 2093 | |||
| 2094 | ;; | ||
| 2095 | ;; discardN-preserve-tos return --> return | ||
| 2096 | ;; dup return --> return | ||
| 2097 | ;; stack-set-N return --> return ; where N is TOS-1 | ||
| 2098 | ;; | ||
| 2099 | ((and (eq (car lap1) 'byte-return) | ||
| 2100 | (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) | ||
| 2101 | (and (eq (car lap0) 'byte-stack-set) | ||
| 2102 | (= (cdr lap0) 1)))) | ||
| 2103 | ;; The byte-code interpreter will pop the stack for us, so | ||
| 2104 | ;; we can just leave stuff on it. | ||
| 2105 | (setq lap (delq lap0 lap)) | ||
| 2106 | (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) | ||
| 2107 | ) | ||
| 2015 | (setq rest (cdr rest))) | 2108 | (setq rest (cdr rest))) |
| 2016 | (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) | 2109 | (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) |
| 2017 | lap) | 2110 | lap) |
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 524f4f1b465..3fb3d841ed1 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el | |||
| @@ -123,12 +123,10 @@ If CURRENT-NAME is a string, that is the `use instead' message | |||
| 123 | If provided, WHEN should be a string indicating when the function | 123 | If provided, WHEN should be a string indicating when the function |
| 124 | was first made obsolete, for example a date or a release number." | 124 | was first made obsolete, for example a date or a release number." |
| 125 | (interactive "aMake function obsolete: \nxObsoletion replacement: ") | 125 | (interactive "aMake function obsolete: \nxObsoletion replacement: ") |
| 126 | (let ((handler (get obsolete-name 'byte-compile))) | 126 | (put obsolete-name 'byte-obsolete-info |
| 127 | (if (eq 'byte-compile-obsolete handler) | 127 | ;; The second entry used to hold the `byte-compile' handler, but |
| 128 | (setq handler (nth 1 (get obsolete-name 'byte-obsolete-info))) | 128 | ;; is not used any more nowadays. |
| 129 | (put obsolete-name 'byte-compile 'byte-compile-obsolete)) | 129 | (list (purecopy current-name) nil (purecopy when))) |
| 130 | (put obsolete-name 'byte-obsolete-info | ||
| 131 | (list (purecopy current-name) handler (purecopy when)))) | ||
| 132 | obsolete-name) | 130 | obsolete-name) |
| 133 | (set-advertised-calling-convention | 131 | (set-advertised-calling-convention |
| 134 | ;; New code should always provide the `when' argument. | 132 | ;; New code should always provide the `when' argument. |
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5c845e59c85..7c358a3830e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; bytecomp.el --- compilation of Lisp code into byte code | 1 | ;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2011 | 3 | ;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2011 |
| 4 | ;; Free Software Foundation, Inc. | 4 | ;; Free Software Foundation, Inc. |
| @@ -118,12 +118,16 @@ | |||
| 118 | ;; Some versions of `file' can be customized to recognize that. | 118 | ;; Some versions of `file' can be customized to recognize that. |
| 119 | 119 | ||
| 120 | (require 'backquote) | 120 | (require 'backquote) |
| 121 | (require 'macroexp) | ||
| 122 | (require 'cconv) | ||
| 121 | (eval-when-compile (require 'cl)) | 123 | (eval-when-compile (require 'cl)) |
| 122 | 124 | ||
| 123 | (or (fboundp 'defsubst) | 125 | (or (fboundp 'defsubst) |
| 124 | ;; This really ought to be loaded already! | 126 | ;; This really ought to be loaded already! |
| 125 | (load "byte-run")) | 127 | (load "byte-run")) |
| 126 | 128 | ||
| 129 | ;; The feature of compiling in a specific target Emacs version | ||
| 130 | ;; has been turned off because compile time options are a bad idea. | ||
| 127 | (defgroup bytecomp nil | 131 | (defgroup bytecomp nil |
| 128 | "Emacs Lisp byte-compiler." | 132 | "Emacs Lisp byte-compiler." |
| 129 | :group 'lisp) | 133 | :group 'lisp) |
| @@ -402,7 +406,7 @@ specify different fields to sort on." | |||
| 402 | (defvar byte-compile-variables nil | 406 | (defvar byte-compile-variables nil |
| 403 | "List of all variables encountered during compilation of this form.") | 407 | "List of all variables encountered during compilation of this form.") |
| 404 | (defvar byte-compile-bound-variables nil | 408 | (defvar byte-compile-bound-variables nil |
| 405 | "List of variables bound in the context of the current form. | 409 | "List of dynamic variables bound in the context of the current form. |
| 406 | This list lives partly on the stack.") | 410 | This list lives partly on the stack.") |
| 407 | (defvar byte-compile-const-variables nil | 411 | (defvar byte-compile-const-variables nil |
| 408 | "List of variables declared as constants during compilation of this file.") | 412 | "List of variables declared as constants during compilation of this file.") |
| @@ -415,10 +419,13 @@ This list lives partly on the stack.") | |||
| 415 | '( | 419 | '( |
| 416 | ;; (byte-compiler-options . (lambda (&rest forms) | 420 | ;; (byte-compiler-options . (lambda (&rest forms) |
| 417 | ;; (apply 'byte-compiler-options-handler forms))) | 421 | ;; (apply 'byte-compiler-options-handler forms))) |
| 422 | (declare-function . byte-compile-macroexpand-declare-function) | ||
| 418 | (eval-when-compile . (lambda (&rest body) | 423 | (eval-when-compile . (lambda (&rest body) |
| 419 | (list 'quote | 424 | (list |
| 420 | (byte-compile-eval (byte-compile-top-level | 425 | 'quote |
| 421 | (cons 'progn body)))))) | 426 | (byte-compile-eval |
| 427 | (byte-compile-top-level | ||
| 428 | (byte-compile-preprocess (cons 'progn body))))))) | ||
| 422 | (eval-and-compile . (lambda (&rest body) | 429 | (eval-and-compile . (lambda (&rest body) |
| 423 | (byte-compile-eval-before-compile (cons 'progn body)) | 430 | (byte-compile-eval-before-compile (cons 'progn body)) |
| 424 | (cons 'progn body)))) | 431 | (cons 'progn body)))) |
| @@ -451,6 +458,10 @@ defined with incorrect args.") | |||
| 451 | Used for warnings about calling a function that is defined during compilation | 458 | Used for warnings about calling a function that is defined during compilation |
| 452 | but won't necessarily be defined when the compiled file is loaded.") | 459 | but won't necessarily be defined when the compiled file is loaded.") |
| 453 | 460 | ||
| 461 | ;; Variables for lexical binding | ||
| 462 | (defvar byte-compile--lexical-environment nil | ||
| 463 | "The current lexical environment.") | ||
| 464 | |||
| 454 | (defvar byte-compile-tag-number 0) | 465 | (defvar byte-compile-tag-number 0) |
| 455 | (defvar byte-compile-output nil | 466 | (defvar byte-compile-output nil |
| 456 | "Alist describing contents to put in byte code string. | 467 | "Alist describing contents to put in byte code string. |
| @@ -496,11 +507,10 @@ Each element is (INDEX . VALUE)") | |||
| 496 | (put 'byte-stack+-info 'tmp-compile-time-value nil))) | 507 | (put 'byte-stack+-info 'tmp-compile-time-value nil))) |
| 497 | 508 | ||
| 498 | 509 | ||
| 499 | ;; unused: 0-7 | ||
| 500 | |||
| 501 | ;; These opcodes are special in that they pack their argument into the | 510 | ;; These opcodes are special in that they pack their argument into the |
| 502 | ;; opcode word. | 511 | ;; opcode word. |
| 503 | ;; | 512 | ;; |
| 513 | (byte-defop 0 1 byte-stack-ref "for stack reference") | ||
| 504 | (byte-defop 8 1 byte-varref "for variable reference") | 514 | (byte-defop 8 1 byte-varref "for variable reference") |
| 505 | (byte-defop 16 -1 byte-varset "for setting a variable") | 515 | (byte-defop 16 -1 byte-varset "for setting a variable") |
| 506 | (byte-defop 24 -1 byte-varbind "for binding a variable") | 516 | (byte-defop 24 -1 byte-varbind "for binding a variable") |
| @@ -570,7 +580,7 @@ Each element is (INDEX . VALUE)") | |||
| 570 | (byte-defop 114 0 byte-save-current-buffer | 580 | (byte-defop 114 0 byte-save-current-buffer |
| 571 | "To make a binding to record the current buffer") | 581 | "To make a binding to record the current buffer") |
| 572 | (byte-defop 115 0 byte-set-mark-OBSOLETE) | 582 | (byte-defop 115 0 byte-set-mark-OBSOLETE) |
| 573 | (byte-defop 116 1 byte-interactive-p) | 583 | ;; (byte-defop 116 1 byte-interactive-p) ;Let's not use it any more. |
| 574 | 584 | ||
| 575 | ;; These ops are new to v19 | 585 | ;; These ops are new to v19 |
| 576 | (byte-defop 117 0 byte-forward-char) | 586 | (byte-defop 117 0 byte-forward-char) |
| @@ -606,8 +616,8 @@ otherwise pop it") | |||
| 606 | 616 | ||
| 607 | (byte-defop 138 0 byte-save-excursion | 617 | (byte-defop 138 0 byte-save-excursion |
| 608 | "to make a binding to record the buffer, point and mark") | 618 | "to make a binding to record the buffer, point and mark") |
| 609 | (byte-defop 139 0 byte-save-window-excursion | 619 | ;; (byte-defop 139 0 byte-save-window-excursion ; Obsolete: It's a macro now. |
| 610 | "to make a binding to record entire window configuration") | 620 | ;; "to make a binding to record entire window configuration") |
| 611 | (byte-defop 140 0 byte-save-restriction | 621 | (byte-defop 140 0 byte-save-restriction |
| 612 | "to make a binding to record the current buffer clipping restrictions") | 622 | "to make a binding to record the current buffer clipping restrictions") |
| 613 | (byte-defop 141 -1 byte-catch | 623 | (byte-defop 141 -1 byte-catch |
| @@ -619,17 +629,9 @@ otherwise pop it") | |||
| 619 | ;; an expression for the body, and a list of clauses. | 629 | ;; an expression for the body, and a list of clauses. |
| 620 | (byte-defop 143 -2 byte-condition-case) | 630 | (byte-defop 143 -2 byte-condition-case) |
| 621 | 631 | ||
| 622 | ;; For entry to with-output-to-temp-buffer. | 632 | ;; Obsolete: `with-output-to-temp-buffer' is a macro now. |
| 623 | ;; Takes, on stack, the buffer name. | 633 | ;; (byte-defop 144 0 byte-temp-output-buffer-setup) |
| 624 | ;; Binds standard-output and does some other things. | 634 | ;; (byte-defop 145 -1 byte-temp-output-buffer-show) |
| 625 | ;; Returns with temp buffer on the stack in place of buffer name. | ||
| 626 | (byte-defop 144 0 byte-temp-output-buffer-setup) | ||
| 627 | |||
| 628 | ;; For exit from with-output-to-temp-buffer. | ||
| 629 | ;; Expects the temp buffer on the stack underneath value to return. | ||
| 630 | ;; Pops them both, then pushes the value back on. | ||
| 631 | ;; Unbinds standard-output and makes the temp buffer visible. | ||
| 632 | (byte-defop 145 -1 byte-temp-output-buffer-show) | ||
| 633 | 635 | ||
| 634 | ;; these ops are new to v19 | 636 | ;; these ops are new to v19 |
| 635 | 637 | ||
| @@ -666,7 +668,21 @@ otherwise pop it") | |||
| 666 | (byte-defop 176 nil byte-concatN) | 668 | (byte-defop 176 nil byte-concatN) |
| 667 | (byte-defop 177 nil byte-insertN) | 669 | (byte-defop 177 nil byte-insertN) |
| 668 | 670 | ||
| 669 | ;; unused: 178-191 | 671 | (byte-defop 178 -1 byte-stack-set) ; Stack offset in following one byte. |
| 672 | (byte-defop 179 -1 byte-stack-set2) ; Stack offset in following two bytes. | ||
| 673 | |||
| 674 | ;; If (following one byte & 0x80) == 0 | ||
| 675 | ;; discard (following one byte & 0x7F) stack entries | ||
| 676 | ;; else | ||
| 677 | ;; discard (following one byte & 0x7F) stack entries _underneath_ TOS | ||
| 678 | ;; (that is, if the operand = 0x83, ... X Y Z T => ... T) | ||
| 679 | (byte-defop 182 nil byte-discardN) | ||
| 680 | ;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into | ||
| 681 | ;; `byte-discardN' with the high bit in the operand set (by | ||
| 682 | ;; `byte-compile-lapcode'). | ||
| 683 | (defconst byte-discardN-preserve-tos byte-discardN) | ||
| 684 | |||
| 685 | ;; unused: 182-191 | ||
| 670 | 686 | ||
| 671 | (byte-defop 192 1 byte-constant "for reference to a constant") | 687 | (byte-defop 192 1 byte-constant "for reference to a constant") |
| 672 | ;; codes 193-255 are consumed by byte-constant. | 688 | ;; codes 193-255 are consumed by byte-constant. |
| @@ -713,71 +729,114 @@ otherwise pop it") | |||
| 713 | ;; front of the constants-vector than the constant-referencing instructions. | 729 | ;; front of the constants-vector than the constant-referencing instructions. |
| 714 | ;; Also, this lets us notice references to free variables. | 730 | ;; Also, this lets us notice references to free variables. |
| 715 | 731 | ||
| 732 | (defmacro byte-compile-push-bytecodes (&rest args) | ||
| 733 | "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed. | ||
| 734 | ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names. | ||
| 735 | BYTES and PC are updated after evaluating all the arguments." | ||
| 736 | (let ((byte-exprs (butlast args 2)) | ||
| 737 | (bytes-var (car (last args 2))) | ||
| 738 | (pc-var (car (last args)))) | ||
| 739 | `(setq ,bytes-var ,(if (null (cdr byte-exprs)) | ||
| 740 | `(progn (assert (<= 0 ,(car byte-exprs))) | ||
| 741 | (cons ,@byte-exprs ,bytes-var)) | ||
| 742 | `(nconc (list ,@(reverse byte-exprs)) ,bytes-var)) | ||
| 743 | ,pc-var (+ ,(length byte-exprs) ,pc-var)))) | ||
| 744 | |||
| 745 | (defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc) | ||
| 746 | "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC. | ||
| 747 | CONST2 may be evaulated multiple times." | ||
| 748 | `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8) | ||
| 749 | ,bytes ,pc)) | ||
| 750 | |||
| 716 | (defun byte-compile-lapcode (lap) | 751 | (defun byte-compile-lapcode (lap) |
| 717 | "Turns lapcode into bytecode. The lapcode is destroyed." | 752 | "Turns lapcode into bytecode. The lapcode is destroyed." |
| 718 | ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. | 753 | ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. |
| 719 | (let ((pc 0) ; Program counter | 754 | (let ((pc 0) ; Program counter |
| 720 | op off ; Operation & offset | 755 | op off ; Operation & offset |
| 756 | opcode ; numeric value of OP | ||
| 721 | (bytes '()) ; Put the output bytes here | 757 | (bytes '()) ; Put the output bytes here |
| 722 | (patchlist nil)) ; List of tags and goto's to patch | 758 | (patchlist nil)) ; List of gotos to patch |
| 723 | (while lap | 759 | (dolist (lap-entry lap) |
| 724 | (setq op (car (car lap)) | 760 | (setq op (car lap-entry) |
| 725 | off (cdr (car lap))) | 761 | off (cdr lap-entry)) |
| 726 | (cond ((not (symbolp op)) | 762 | (cond |
| 727 | (error "Non-symbolic opcode `%s'" op)) | 763 | ((not (symbolp op)) |
| 728 | ((eq op 'TAG) | 764 | (error "Non-symbolic opcode `%s'" op)) |
| 729 | (setcar off pc) | 765 | ((eq op 'TAG) |
| 730 | (setq patchlist (cons off patchlist))) | 766 | (setcar off pc)) |
| 731 | ((memq op byte-goto-ops) | 767 | (t |
| 732 | (setq pc (+ pc 3)) | 768 | (setq opcode |
| 733 | (setq bytes (cons (cons pc (cdr off)) | 769 | (if (eq op 'byte-discardN-preserve-tos) |
| 734 | (cons nil | 770 | ;; byte-discardN-preserve-tos is a pseudo op, which |
| 735 | (cons (symbol-value op) bytes)))) | 771 | ;; is actually the same as byte-discardN |
| 736 | (setq patchlist (cons bytes patchlist))) | 772 | ;; with a modified argument. |
| 737 | (t | 773 | byte-discardN |
| 738 | (setq bytes | 774 | (symbol-value op))) |
| 739 | (cond ((cond ((consp off) | 775 | (cond ((memq op byte-goto-ops) |
| 740 | ;; Variable or constant reference | 776 | ;; goto |
| 741 | (setq off (cdr off)) | 777 | (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) |
| 742 | (eq op 'byte-constant))) | 778 | (push bytes patchlist)) |
| 743 | (cond ((< off byte-constant-limit) | 779 | ((or (and (consp off) |
| 744 | (setq pc (1+ pc)) | 780 | ;; Variable or constant reference |
| 745 | (cons (+ byte-constant off) bytes)) | 781 | (progn |
| 746 | (t | 782 | (setq off (cdr off)) |
| 747 | (setq pc (+ 3 pc)) | 783 | (eq op 'byte-constant))) |
| 748 | (cons (lsh off -8) | 784 | (and (eq op 'byte-constant) |
| 749 | (cons (logand off 255) | 785 | (integerp off))) |
| 750 | (cons byte-constant2 bytes)))))) | 786 | ;; constant ref |
| 751 | ((<= byte-listN (symbol-value op)) | 787 | (if (< off byte-constant-limit) |
| 752 | (setq pc (+ 2 pc)) | 788 | (byte-compile-push-bytecodes (+ byte-constant off) |
| 753 | (cons off (cons (symbol-value op) bytes))) | 789 | bytes pc) |
| 754 | ((< off 6) | 790 | (byte-compile-push-bytecode-const2 byte-constant2 off |
| 755 | (setq pc (1+ pc)) | 791 | bytes pc))) |
| 756 | (cons (+ (symbol-value op) off) bytes)) | 792 | ((and (= opcode byte-stack-set) |
| 757 | ((< off 256) | 793 | (> off 255)) |
| 758 | (setq pc (+ 2 pc)) | 794 | ;; Use the two-byte version of byte-stack-set if the |
| 759 | (cons off (cons (+ (symbol-value op) 6) bytes))) | 795 | ;; offset is too large for the normal version. |
| 760 | (t | 796 | (byte-compile-push-bytecode-const2 byte-stack-set2 off |
| 761 | (setq pc (+ 3 pc)) | 797 | bytes pc)) |
| 762 | (cons (lsh off -8) | 798 | ((and (>= opcode byte-listN) |
| 763 | (cons (logand off 255) | 799 | (< opcode byte-discardN)) |
| 764 | (cons (+ (symbol-value op) 7) | 800 | ;; These insns all put their operand into one extra byte. |
| 765 | bytes)))))))) | 801 | (byte-compile-push-bytecodes opcode off bytes pc)) |
| 766 | (setq lap (cdr lap))) | 802 | ((= opcode byte-discardN) |
| 803 | ;; byte-discardN is weird in that it encodes a flag in the | ||
| 804 | ;; top bit of its one-byte argument. If the argument is | ||
| 805 | ;; too large to fit in 7 bits, the opcode can be repeated. | ||
| 806 | (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0))) | ||
| 807 | (while (> off #x7f) | ||
| 808 | (byte-compile-push-bytecodes opcode (logior #x7f flag) | ||
| 809 | bytes pc) | ||
| 810 | (setq off (- off #x7f))) | ||
| 811 | (byte-compile-push-bytecodes opcode (logior off flag) | ||
| 812 | bytes pc))) | ||
| 813 | ((null off) | ||
| 814 | ;; opcode that doesn't use OFF | ||
| 815 | (byte-compile-push-bytecodes opcode bytes pc)) | ||
| 816 | ((and (eq opcode byte-stack-ref) (eq off 0)) | ||
| 817 | ;; (stack-ref 0) is really just another name for `dup'. | ||
| 818 | (debug) ;FIXME: When would this happen? | ||
| 819 | (byte-compile-push-bytecodes byte-dup bytes pc)) | ||
| 820 | ;; The following three cases are for the special | ||
| 821 | ;; insns that encode their operand into 0, 1, or 2 | ||
| 822 | ;; extra bytes depending on its magnitude. | ||
| 823 | ((< off 6) | ||
| 824 | (byte-compile-push-bytecodes (+ opcode off) bytes pc)) | ||
| 825 | ((< off 256) | ||
| 826 | (byte-compile-push-bytecodes (+ opcode 6) off bytes pc)) | ||
| 827 | (t | ||
| 828 | (byte-compile-push-bytecode-const2 (+ opcode 7) off | ||
| 829 | bytes pc)))))) | ||
| 767 | ;;(if (not (= pc (length bytes))) | 830 | ;;(if (not (= pc (length bytes))) |
| 768 | ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) | 831 | ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) |
| 769 | ;; Patch PC into jumps | 832 | ;; Patch tag PCs into absolute jumps. |
| 770 | (let (bytes) | 833 | (dolist (bytes-tail patchlist) |
| 771 | (while patchlist | 834 | (setq pc (caar bytes-tail)) ; Pick PC from goto's tag. |
| 772 | (setq bytes (car patchlist)) | 835 | (setcar (cdr bytes-tail) (logand pc 255)) |
| 773 | (cond ((atom (car bytes))) ; Tag | 836 | (setcar bytes-tail (lsh pc -8)) |
| 774 | (t ; Absolute jump | 837 | ;; FIXME: Replace this by some workaround. |
| 775 | (setq pc (car (cdr (car bytes)))) ; Pick PC from tag | 838 | (if (> (car bytes) 255) (error "Bytecode overflow"))) |
| 776 | (setcar (cdr bytes) (logand pc 255)) | 839 | |
| 777 | (setcar bytes (lsh pc -8)) | ||
| 778 | ;; FIXME: Replace this by some workaround. | ||
| 779 | (if (> (car bytes) 255) (error "Bytecode overflow")))) | ||
| 780 | (setq patchlist (cdr patchlist)))) | ||
| 781 | (apply 'unibyte-string (nreverse bytes)))) | 840 | (apply 'unibyte-string (nreverse bytes)))) |
| 782 | 841 | ||
| 783 | 842 | ||
| @@ -793,7 +852,7 @@ otherwise pop it") | |||
| 793 | Each function's symbol gets added to `byte-compile-noruntime-functions'." | 852 | Each function's symbol gets added to `byte-compile-noruntime-functions'." |
| 794 | (let ((hist-orig load-history) | 853 | (let ((hist-orig load-history) |
| 795 | (hist-nil-orig current-load-list)) | 854 | (hist-nil-orig current-load-list)) |
| 796 | (prog1 (eval form) | 855 | (prog1 (eval form lexical-binding) |
| 797 | (when (byte-compile-warning-enabled-p 'noruntime) | 856 | (when (byte-compile-warning-enabled-p 'noruntime) |
| 798 | (let ((hist-new load-history) | 857 | (let ((hist-new load-history) |
| 799 | (hist-nil-new current-load-list)) | 858 | (hist-nil-new current-load-list)) |
| @@ -845,7 +904,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." | |||
| 845 | (defun byte-compile-eval-before-compile (form) | 904 | (defun byte-compile-eval-before-compile (form) |
| 846 | "Evaluate FORM for `eval-and-compile'." | 905 | "Evaluate FORM for `eval-and-compile'." |
| 847 | (let ((hist-nil-orig current-load-list)) | 906 | (let ((hist-nil-orig current-load-list)) |
| 848 | (prog1 (eval form) | 907 | (prog1 (eval form lexical-binding) |
| 849 | ;; (eval-and-compile (require 'cl) turns off warnings for cl functions. | 908 | ;; (eval-and-compile (require 'cl) turns off warnings for cl functions. |
| 850 | ;; FIXME Why does it do that - just as a hack? | 909 | ;; FIXME Why does it do that - just as a hack? |
| 851 | ;; There are other ways to do this nowadays. | 910 | ;; There are other ways to do this nowadays. |
| @@ -936,7 +995,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." | |||
| 936 | read-symbol-positions-list | 995 | read-symbol-positions-list |
| 937 | (byte-compile-delete-first | 996 | (byte-compile-delete-first |
| 938 | entry read-symbol-positions-list))) | 997 | entry read-symbol-positions-list))) |
| 939 | (or (and allow-previous (not (= last byte-compile-last-position))) | 998 | (or (and allow-previous |
| 999 | (not (= last byte-compile-last-position))) | ||
| 940 | (> last byte-compile-last-position))))))) | 1000 | (> last byte-compile-last-position))))))) |
| 941 | 1001 | ||
| 942 | (defvar byte-compile-last-warned-form nil) | 1002 | (defvar byte-compile-last-warned-form nil) |
| @@ -948,7 +1008,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." | |||
| 948 | (let* ((inhibit-read-only t) | 1008 | (let* ((inhibit-read-only t) |
| 949 | (dir default-directory) | 1009 | (dir default-directory) |
| 950 | (file (cond ((stringp byte-compile-current-file) | 1010 | (file (cond ((stringp byte-compile-current-file) |
| 951 | (format "%s:" (file-relative-name byte-compile-current-file dir))) | 1011 | (format "%s:" (file-relative-name |
| 1012 | byte-compile-current-file dir))) | ||
| 952 | ((bufferp byte-compile-current-file) | 1013 | ((bufferp byte-compile-current-file) |
| 953 | (format "Buffer %s:" | 1014 | (format "Buffer %s:" |
| 954 | (buffer-name byte-compile-current-file))) | 1015 | (buffer-name byte-compile-current-file))) |
| @@ -982,7 +1043,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." | |||
| 982 | ;; This no-op function is used as the value of warning-series | 1043 | ;; This no-op function is used as the value of warning-series |
| 983 | ;; to tell inner calls to displaying-byte-compile-warnings | 1044 | ;; to tell inner calls to displaying-byte-compile-warnings |
| 984 | ;; not to bind warning-series. | 1045 | ;; not to bind warning-series. |
| 985 | (defun byte-compile-warning-series (&rest ignore) | 1046 | (defun byte-compile-warning-series (&rest _ignore) |
| 986 | nil) | 1047 | nil) |
| 987 | 1048 | ||
| 988 | ;; (compile-mode) will cause this to be loaded. | 1049 | ;; (compile-mode) will cause this to be loaded. |
| @@ -1011,13 +1072,15 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." | |||
| 1011 | (insert "\f\nCompiling " | 1072 | (insert "\f\nCompiling " |
| 1012 | (if (stringp byte-compile-current-file) | 1073 | (if (stringp byte-compile-current-file) |
| 1013 | (concat "file " byte-compile-current-file) | 1074 | (concat "file " byte-compile-current-file) |
| 1014 | (concat "buffer " (buffer-name byte-compile-current-file))) | 1075 | (concat "buffer " |
| 1076 | (buffer-name byte-compile-current-file))) | ||
| 1015 | " at " (current-time-string) "\n") | 1077 | " at " (current-time-string) "\n") |
| 1016 | (insert "\f\nCompiling no file at " (current-time-string) "\n")) | 1078 | (insert "\f\nCompiling no file at " (current-time-string) "\n")) |
| 1017 | (when dir | 1079 | (when dir |
| 1018 | (setq default-directory dir) | 1080 | (setq default-directory dir) |
| 1019 | (unless was-same | 1081 | (unless was-same |
| 1020 | (insert (format "Entering directory `%s'\n" default-directory)))) | 1082 | (insert (format "Entering directory `%s'\n" |
| 1083 | default-directory)))) | ||
| 1021 | (setq byte-compile-last-logged-file byte-compile-current-file | 1084 | (setq byte-compile-last-logged-file byte-compile-current-file |
| 1022 | byte-compile-last-warned-form nil) | 1085 | byte-compile-last-warned-form nil) |
| 1023 | ;; Do this after setting default-directory. | 1086 | ;; Do this after setting default-directory. |
| @@ -1064,13 +1127,6 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." | |||
| 1064 | (byte-compile-log-warning | 1127 | (byte-compile-log-warning |
| 1065 | (error-message-string error-info) | 1128 | (error-message-string error-info) |
| 1066 | nil :error)) | 1129 | nil :error)) |
| 1067 | |||
| 1068 | ;;; Used by make-obsolete. | ||
| 1069 | (defun byte-compile-obsolete (form) | ||
| 1070 | (byte-compile-set-symbol-position (car form)) | ||
| 1071 | (byte-compile-warn-obsolete (car form)) | ||
| 1072 | (funcall (or (cadr (get (car form) 'byte-obsolete-info)) ; handler | ||
| 1073 | 'byte-compile-normal-call) form)) | ||
| 1074 | 1130 | ||
| 1075 | ;;; sanity-checking arglists | 1131 | ;;; sanity-checking arglists |
| 1076 | 1132 | ||
| @@ -1110,22 +1166,28 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." | |||
| 1110 | (t fn))))))) | 1166 | (t fn))))))) |
| 1111 | 1167 | ||
| 1112 | (defun byte-compile-arglist-signature (arglist) | 1168 | (defun byte-compile-arglist-signature (arglist) |
| 1113 | (let ((args 0) | 1169 | (if (integerp arglist) |
| 1114 | opts | 1170 | ;; New style byte-code arglist. |
| 1115 | restp) | 1171 | (cons (logand arglist 127) ;Mandatory. |
| 1116 | (while arglist | 1172 | (if (zerop (logand arglist 128)) ;No &rest. |
| 1117 | (cond ((eq (car arglist) '&optional) | 1173 | (lsh arglist -8))) ;Nonrest. |
| 1118 | (or opts (setq opts 0))) | 1174 | ;; Old style byte-code, or interpreted function. |
| 1119 | ((eq (car arglist) '&rest) | 1175 | (let ((args 0) |
| 1120 | (if (cdr arglist) | 1176 | opts |
| 1121 | (setq restp t | 1177 | restp) |
| 1122 | arglist nil))) | 1178 | (while arglist |
| 1123 | (t | 1179 | (cond ((eq (car arglist) '&optional) |
| 1124 | (if opts | 1180 | (or opts (setq opts 0))) |
| 1125 | (setq opts (1+ opts)) | 1181 | ((eq (car arglist) '&rest) |
| 1182 | (if (cdr arglist) | ||
| 1183 | (setq restp t | ||
| 1184 | arglist nil))) | ||
| 1185 | (t | ||
| 1186 | (if opts | ||
| 1187 | (setq opts (1+ opts)) | ||
| 1126 | (setq args (1+ args))))) | 1188 | (setq args (1+ args))))) |
| 1127 | (setq arglist (cdr arglist))) | 1189 | (setq arglist (cdr arglist))) |
| 1128 | (cons args (if restp nil (if opts (+ args opts) args))))) | 1190 | (cons args (if restp nil (if opts (+ args opts) args)))))) |
| 1129 | 1191 | ||
| 1130 | 1192 | ||
| 1131 | (defun byte-compile-arglist-signatures-congruent-p (old new) | 1193 | (defun byte-compile-arglist-signatures-congruent-p (old new) |
| @@ -1244,7 +1306,7 @@ extra args." | |||
| 1244 | (custom-declare-variable . defcustom)))) | 1306 | (custom-declare-variable . defcustom)))) |
| 1245 | (cadr name))) | 1307 | (cadr name))) |
| 1246 | ;; Update the current group, if needed. | 1308 | ;; Update the current group, if needed. |
| 1247 | (if (and byte-compile-current-file ;Only when byte-compiling a whole file. | 1309 | (if (and byte-compile-current-file ;Only when compiling a whole file. |
| 1248 | (eq (car form) 'custom-declare-group) | 1310 | (eq (car form) 'custom-declare-group) |
| 1249 | (eq (car-safe name) 'quote)) | 1311 | (eq (car-safe name) 'quote)) |
| 1250 | (setq byte-compile-current-group (cadr name)))))) | 1312 | (setq byte-compile-current-group (cadr name)))))) |
| @@ -1252,50 +1314,54 @@ extra args." | |||
| 1252 | ;; Warn if the function or macro is being redefined with a different | 1314 | ;; Warn if the function or macro is being redefined with a different |
| 1253 | ;; number of arguments. | 1315 | ;; number of arguments. |
| 1254 | (defun byte-compile-arglist-warn (form macrop) | 1316 | (defun byte-compile-arglist-warn (form macrop) |
| 1255 | (let ((old (byte-compile-fdefinition (nth 1 form) macrop))) | 1317 | (let* ((name (nth 1 form)) |
| 1318 | (old (byte-compile-fdefinition name macrop))) | ||
| 1256 | (if (and old (not (eq old t))) | 1319 | (if (and old (not (eq old t))) |
| 1257 | (progn | 1320 | (progn |
| 1258 | (and (eq 'macro (car-safe old)) | 1321 | (and (eq 'macro (car-safe old)) |
| 1259 | (eq 'lambda (car-safe (cdr-safe old))) | 1322 | (eq 'lambda (car-safe (cdr-safe old))) |
| 1260 | (setq old (cdr old))) | 1323 | (setq old (cdr old))) |
| 1261 | (let ((sig1 (byte-compile-arglist-signature | 1324 | (let ((sig1 (byte-compile-arglist-signature |
| 1262 | (if (eq 'lambda (car-safe old)) | 1325 | (pcase old |
| 1263 | (nth 1 old) | 1326 | (`(lambda ,args . ,_) args) |
| 1264 | (if (byte-code-function-p old) | 1327 | (`(closure ,_ ,args . ,_) args) |
| 1265 | (aref old 0) | 1328 | ((pred byte-code-function-p) (aref old 0)) |
| 1266 | '(&rest def))))) | 1329 | (t '(&rest def))))) |
| 1267 | (sig2 (byte-compile-arglist-signature (nth 2 form)))) | 1330 | (sig2 (byte-compile-arglist-signature (nth 2 form)))) |
| 1268 | (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) | 1331 | (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) |
| 1269 | (byte-compile-set-symbol-position (nth 1 form)) | 1332 | (byte-compile-set-symbol-position name) |
| 1270 | (byte-compile-warn | 1333 | (byte-compile-warn |
| 1271 | "%s %s used to take %s %s, now takes %s" | 1334 | "%s %s used to take %s %s, now takes %s" |
| 1272 | (if (eq (car form) 'defun) "function" "macro") | 1335 | (if (eq (car form) 'defun) "function" "macro") |
| 1273 | (nth 1 form) | 1336 | name |
| 1274 | (byte-compile-arglist-signature-string sig1) | 1337 | (byte-compile-arglist-signature-string sig1) |
| 1275 | (if (equal sig1 '(1 . 1)) "argument" "arguments") | 1338 | (if (equal sig1 '(1 . 1)) "argument" "arguments") |
| 1276 | (byte-compile-arglist-signature-string sig2))))) | 1339 | (byte-compile-arglist-signature-string sig2))))) |
| 1277 | ;; This is the first definition. See if previous calls are compatible. | 1340 | ;; This is the first definition. See if previous calls are compatible. |
| 1278 | (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions)) | 1341 | (let ((calls (assq name byte-compile-unresolved-functions)) |
| 1279 | nums sig min max) | 1342 | nums sig min max) |
| 1280 | (if calls | 1343 | (when calls |
| 1281 | (progn | 1344 | (when (and (symbolp name) |
| 1282 | (setq sig (byte-compile-arglist-signature (nth 2 form)) | 1345 | (eq (get name 'byte-optimizer) |
| 1283 | nums (sort (copy-sequence (cdr calls)) (function <)) | 1346 | 'byte-compile-inline-expand)) |
| 1284 | min (car nums) | 1347 | (byte-compile-warn "defsubst `%s' was used before it was defined" |
| 1285 | max (car (nreverse nums))) | 1348 | name)) |
| 1286 | (when (or (< min (car sig)) | 1349 | (setq sig (byte-compile-arglist-signature (nth 2 form)) |
| 1287 | (and (cdr sig) (> max (cdr sig)))) | 1350 | nums (sort (copy-sequence (cdr calls)) (function <)) |
| 1288 | (byte-compile-set-symbol-position (nth 1 form)) | 1351 | min (car nums) |
| 1289 | (byte-compile-warn | 1352 | max (car (nreverse nums))) |
| 1290 | "%s being defined to take %s%s, but was previously called with %s" | 1353 | (when (or (< min (car sig)) |
| 1291 | (nth 1 form) | 1354 | (and (cdr sig) (> max (cdr sig)))) |
| 1292 | (byte-compile-arglist-signature-string sig) | 1355 | (byte-compile-set-symbol-position name) |
| 1293 | (if (equal sig '(1 . 1)) " arg" " args") | 1356 | (byte-compile-warn |
| 1294 | (byte-compile-arglist-signature-string (cons min max)))) | 1357 | "%s being defined to take %s%s, but was previously called with %s" |
| 1295 | 1358 | name | |
| 1296 | (setq byte-compile-unresolved-functions | 1359 | (byte-compile-arglist-signature-string sig) |
| 1297 | (delq calls byte-compile-unresolved-functions))))) | 1360 | (if (equal sig '(1 . 1)) " arg" " args") |
| 1298 | ))) | 1361 | (byte-compile-arglist-signature-string (cons min max)))) |
| 1362 | |||
| 1363 | (setq byte-compile-unresolved-functions | ||
| 1364 | (delq calls byte-compile-unresolved-functions))))))) | ||
| 1299 | 1365 | ||
| 1300 | (defvar byte-compile-cl-functions nil | 1366 | (defvar byte-compile-cl-functions nil |
| 1301 | "List of functions defined in CL.") | 1367 | "List of functions defined in CL.") |
| @@ -1331,14 +1397,7 @@ extra args." | |||
| 1331 | ;; but such warnings are never useful, | 1397 | ;; but such warnings are never useful, |
| 1332 | ;; so don't warn about them. | 1398 | ;; so don't warn about them. |
| 1333 | macroexpand cl-macroexpand-all | 1399 | macroexpand cl-macroexpand-all |
| 1334 | cl-compiling-file))) | 1400 | cl-compiling-file)))) |
| 1335 | ;; Avoid warnings for things which are safe because they | ||
| 1336 | ;; have suitable compiler macros, but those aren't | ||
| 1337 | ;; expanded at this stage. There should probably be more | ||
| 1338 | ;; here than caaar and friends. | ||
| 1339 | (not (and (eq (get func 'byte-compile) | ||
| 1340 | 'cl-byte-compile-compiler-macro) | ||
| 1341 | (string-match "\\`c[ad]+r\\'" (symbol-name func))))) | ||
| 1342 | (byte-compile-warn "function `%s' from cl package called at runtime" | 1401 | (byte-compile-warn "function `%s' from cl package called at runtime" |
| 1343 | func))) | 1402 | func))) |
| 1344 | form) | 1403 | form) |
| @@ -1401,7 +1460,7 @@ symbol itself." | |||
| 1401 | (if any-value | 1460 | (if any-value |
| 1402 | (or (memq symbol byte-compile-const-variables) | 1461 | (or (memq symbol byte-compile-const-variables) |
| 1403 | ;; FIXME: We should provide a less intrusive way to find out | 1462 | ;; FIXME: We should provide a less intrusive way to find out |
| 1404 | ;; is a variable is "constant". | 1463 | ;; if a variable is "constant". |
| 1405 | (and (boundp symbol) | 1464 | (and (boundp symbol) |
| 1406 | (condition-case nil | 1465 | (condition-case nil |
| 1407 | (progn (set symbol (symbol-value symbol)) nil) | 1466 | (progn (set symbol (symbol-value symbol)) nil) |
| @@ -1414,6 +1473,7 @@ symbol itself." | |||
| 1414 | ((byte-compile-const-symbol-p ,form)))) | 1473 | ((byte-compile-const-symbol-p ,form)))) |
| 1415 | 1474 | ||
| 1416 | (defmacro byte-compile-close-variables (&rest body) | 1475 | (defmacro byte-compile-close-variables (&rest body) |
| 1476 | (declare (debug t)) | ||
| 1417 | (cons 'let | 1477 | (cons 'let |
| 1418 | (cons '(;; | 1478 | (cons '(;; |
| 1419 | ;; Close over these variables to encapsulate the | 1479 | ;; Close over these variables to encapsulate the |
| @@ -1444,6 +1504,7 @@ symbol itself." | |||
| 1444 | body))) | 1504 | body))) |
| 1445 | 1505 | ||
| 1446 | (defmacro displaying-byte-compile-warnings (&rest body) | 1506 | (defmacro displaying-byte-compile-warnings (&rest body) |
| 1507 | (declare (debug t)) | ||
| 1447 | `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) | 1508 | `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) |
| 1448 | (warning-series-started | 1509 | (warning-series-started |
| 1449 | (and (markerp warning-series) | 1510 | (and (markerp warning-series) |
| @@ -1481,41 +1542,33 @@ Files in subdirectories of DIRECTORY are processed also." | |||
| 1481 | (interactive "DByte force recompile (directory): ") | 1542 | (interactive "DByte force recompile (directory): ") |
| 1482 | (byte-recompile-directory directory nil t)) | 1543 | (byte-recompile-directory directory nil t)) |
| 1483 | 1544 | ||
| 1484 | ;; The `bytecomp-' prefix is applied to all local variables with | ||
| 1485 | ;; otherwise common names in this and similar functions for the sake | ||
| 1486 | ;; of the boundp test in byte-compile-variable-ref. | ||
| 1487 | ;; http://lists.gnu.org/archive/html/emacs-devel/2008-01/msg00237.html | ||
| 1488 | ;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2008-02/msg00134.html | ||
| 1489 | ;; Note that similar considerations apply to command-line-1 in startup.el. | ||
| 1490 | ;;;###autoload | 1545 | ;;;###autoload |
| 1491 | (defun byte-recompile-directory (bytecomp-directory &optional bytecomp-arg | 1546 | (defun byte-recompile-directory (directory &optional arg force) |
| 1492 | bytecomp-force) | 1547 | "Recompile every `.el' file in DIRECTORY that needs recompilation. |
| 1493 | "Recompile every `.el' file in BYTECOMP-DIRECTORY that needs recompilation. | ||
| 1494 | This happens when a `.elc' file exists but is older than the `.el' file. | 1548 | This happens when a `.elc' file exists but is older than the `.el' file. |
| 1495 | Files in subdirectories of BYTECOMP-DIRECTORY are processed also. | 1549 | Files in subdirectories of DIRECTORY are processed also. |
| 1496 | 1550 | ||
| 1497 | If the `.elc' file does not exist, normally this function *does not* | 1551 | If the `.elc' file does not exist, normally this function *does not* |
| 1498 | compile the corresponding `.el' file. However, if the prefix argument | 1552 | compile the corresponding `.el' file. However, if the prefix argument |
| 1499 | BYTECOMP-ARG is 0, that means do compile all those files. A nonzero | 1553 | ARG is 0, that means do compile all those files. A nonzero |
| 1500 | BYTECOMP-ARG means ask the user, for each such `.el' file, whether to | 1554 | ARG means ask the user, for each such `.el' file, whether to |
| 1501 | compile it. A nonzero BYTECOMP-ARG also means ask about each subdirectory | 1555 | compile it. A nonzero ARG also means ask about each subdirectory |
| 1502 | before scanning it. | 1556 | before scanning it. |
| 1503 | 1557 | ||
| 1504 | If the third argument BYTECOMP-FORCE is non-nil, recompile every `.el' file | 1558 | If the third argument FORCE is non-nil, recompile every `.el' file |
| 1505 | that already has a `.elc' file." | 1559 | that already has a `.elc' file." |
| 1506 | (interactive "DByte recompile directory: \nP") | 1560 | (interactive "DByte recompile directory: \nP") |
| 1507 | (if bytecomp-arg | 1561 | (if arg (setq arg (prefix-numeric-value arg))) |
| 1508 | (setq bytecomp-arg (prefix-numeric-value bytecomp-arg))) | ||
| 1509 | (if noninteractive | 1562 | (if noninteractive |
| 1510 | nil | 1563 | nil |
| 1511 | (save-some-buffers) | 1564 | (save-some-buffers) |
| 1512 | (force-mode-line-update)) | 1565 | (force-mode-line-update)) |
| 1513 | (with-current-buffer (get-buffer-create byte-compile-log-buffer) | 1566 | (with-current-buffer (get-buffer-create byte-compile-log-buffer) |
| 1514 | (setq default-directory (expand-file-name bytecomp-directory)) | 1567 | (setq default-directory (expand-file-name directory)) |
| 1515 | ;; compilation-mode copies value of default-directory. | 1568 | ;; compilation-mode copies value of default-directory. |
| 1516 | (unless (eq major-mode 'compilation-mode) | 1569 | (unless (eq major-mode 'compilation-mode) |
| 1517 | (compilation-mode)) | 1570 | (compilation-mode)) |
| 1518 | (let ((bytecomp-directories (list default-directory)) | 1571 | (let ((directories (list default-directory)) |
| 1519 | (default-directory default-directory) | 1572 | (default-directory default-directory) |
| 1520 | (skip-count 0) | 1573 | (skip-count 0) |
| 1521 | (fail-count 0) | 1574 | (fail-count 0) |
| @@ -1523,47 +1576,36 @@ that already has a `.elc' file." | |||
| 1523 | (dir-count 0) | 1576 | (dir-count 0) |
| 1524 | last-dir) | 1577 | last-dir) |
| 1525 | (displaying-byte-compile-warnings | 1578 | (displaying-byte-compile-warnings |
| 1526 | (while bytecomp-directories | 1579 | (while directories |
| 1527 | (setq bytecomp-directory (car bytecomp-directories)) | 1580 | (setq directory (car directories)) |
| 1528 | (message "Checking %s..." bytecomp-directory) | 1581 | (message "Checking %s..." directory) |
| 1529 | (let ((bytecomp-files (directory-files bytecomp-directory)) | 1582 | (dolist (file (directory-files directory)) |
| 1530 | bytecomp-source bytecomp-dest) | 1583 | (let ((source (expand-file-name file directory))) |
| 1531 | (dolist (bytecomp-file bytecomp-files) | 1584 | (if (and (not (member file '("RCS" "CVS"))) |
| 1532 | (setq bytecomp-source | 1585 | (not (eq ?\. (aref file 0))) |
| 1533 | (expand-file-name bytecomp-file bytecomp-directory)) | 1586 | (file-directory-p source) |
| 1534 | (if (and (not (member bytecomp-file '("RCS" "CVS"))) | 1587 | (not (file-symlink-p source))) |
| 1535 | (not (eq ?\. (aref bytecomp-file 0))) | 1588 | ;; This file is a subdirectory. Handle them differently. |
| 1536 | (file-directory-p bytecomp-source) | 1589 | (when (or (null arg) (eq 0 arg) |
| 1537 | (not (file-symlink-p bytecomp-source))) | 1590 | (y-or-n-p (concat "Check " source "? "))) |
| 1538 | ;; This file is a subdirectory. Handle them differently. | 1591 | (setq directories (nconc directories (list source)))) |
| 1539 | (when (or (null bytecomp-arg) | 1592 | ;; It is an ordinary file. Decide whether to compile it. |
| 1540 | (eq 0 bytecomp-arg) | 1593 | (if (and (string-match emacs-lisp-file-regexp source) |
| 1541 | (y-or-n-p (concat "Check " bytecomp-source "? "))) | 1594 | (file-readable-p source) |
| 1542 | (setq bytecomp-directories | 1595 | (not (auto-save-file-name-p source)) |
| 1543 | (nconc bytecomp-directories (list bytecomp-source)))) | 1596 | (not (string-equal dir-locals-file |
| 1544 | ;; It is an ordinary file. Decide whether to compile it. | 1597 | (file-name-nondirectory source)))) |
| 1545 | (if (and (string-match emacs-lisp-file-regexp bytecomp-source) | 1598 | (progn (case (byte-recompile-file source force arg) |
| 1546 | (file-readable-p bytecomp-source) | 1599 | (no-byte-compile (setq skip-count (1+ skip-count))) |
| 1547 | (not (auto-save-file-name-p bytecomp-source)) | 1600 | ((t) (setq file-count (1+ file-count))) |
| 1548 | (not (string-equal dir-locals-file | 1601 | ((nil) (setq fail-count (1+ fail-count)))) |
| 1549 | (file-name-nondirectory | 1602 | (or noninteractive |
| 1550 | bytecomp-source)))) | 1603 | (message "Checking %s..." directory)) |
| 1551 | (progn (let ((bytecomp-res (byte-recompile-file | 1604 | (if (not (eq last-dir directory)) |
| 1552 | bytecomp-source | 1605 | (setq last-dir directory |
| 1553 | bytecomp-force bytecomp-arg))) | 1606 | dir-count (1+ dir-count))) |
| 1554 | (cond ((eq bytecomp-res 'no-byte-compile) | 1607 | ))))) |
| 1555 | (setq skip-count (1+ skip-count))) | 1608 | (setq directories (cdr directories)))) |
| 1556 | ((eq bytecomp-res t) | ||
| 1557 | (setq file-count (1+ file-count))) | ||
| 1558 | ((eq bytecomp-res nil) | ||
| 1559 | (setq fail-count (1+ fail-count))))) | ||
| 1560 | (or noninteractive | ||
| 1561 | (message "Checking %s..." bytecomp-directory)) | ||
| 1562 | (if (not (eq last-dir bytecomp-directory)) | ||
| 1563 | (setq last-dir bytecomp-directory | ||
| 1564 | dir-count (1+ dir-count))) | ||
| 1565 | ))))) | ||
| 1566 | (setq bytecomp-directories (cdr bytecomp-directories)))) | ||
| 1567 | (message "Done (Total of %d file%s compiled%s%s%s)" | 1609 | (message "Done (Total of %d file%s compiled%s%s%s)" |
| 1568 | file-count (if (= file-count 1) "" "s") | 1610 | file-count (if (= file-count 1) "" "s") |
| 1569 | (if (> fail-count 0) (format ", %d failed" fail-count) "") | 1611 | (if (> fail-count 0) (format ", %d failed" fail-count) "") |
| @@ -1575,104 +1617,100 @@ that already has a `.elc' file." | |||
| 1575 | "Non-nil to prevent byte-compiling of Emacs Lisp code. | 1617 | "Non-nil to prevent byte-compiling of Emacs Lisp code. |
| 1576 | This is normally set in local file variables at the end of the elisp file: | 1618 | This is normally set in local file variables at the end of the elisp file: |
| 1577 | 1619 | ||
| 1578 | ;; Local Variables:\n;; no-byte-compile: t\n;; End: ") | 1620 | \;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;Backslash for compile-main. |
| 1579 | ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) | 1621 | ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) |
| 1580 | 1622 | ||
| 1581 | (defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load) | 1623 | (defun byte-recompile-file (filename &optional force arg load) |
| 1582 | "Recompile BYTECOMP-FILENAME file if it needs recompilation. | 1624 | "Recompile FILENAME file if it needs recompilation. |
| 1583 | This happens when its `.elc' file is older than itself. | 1625 | This happens when its `.elc' file is older than itself. |
| 1584 | 1626 | ||
| 1585 | If the `.elc' file exists and is up-to-date, normally this | 1627 | If the `.elc' file exists and is up-to-date, normally this |
| 1586 | function *does not* compile BYTECOMP-FILENAME. However, if the | 1628 | function *does not* compile FILENAME. However, if the |
| 1587 | prefix argument BYTECOMP-FORCE is set, that means do compile | 1629 | prefix argument FORCE is set, that means do compile |
| 1588 | BYTECOMP-FILENAME even if the destination already exists and is | 1630 | FILENAME even if the destination already exists and is |
| 1589 | up-to-date. | 1631 | up-to-date. |
| 1590 | 1632 | ||
| 1591 | If the `.elc' file does not exist, normally this function *does | 1633 | If the `.elc' file does not exist, normally this function *does |
| 1592 | not* compile BYTECOMP-FILENAME. If BYTECOMP-ARG is 0, that means | 1634 | not* compile FILENAME. If ARG is 0, that means |
| 1593 | compile the file even if it has never been compiled before. | 1635 | compile the file even if it has never been compiled before. |
| 1594 | A nonzero BYTECOMP-ARG means ask the user. | 1636 | A nonzero ARG means ask the user. |
| 1595 | 1637 | ||
| 1596 | If LOAD is set, `load' the file after compiling. | 1638 | If LOAD is set, `load' the file after compiling. |
| 1597 | 1639 | ||
| 1598 | The value returned is the value returned by `byte-compile-file', | 1640 | The value returned is the value returned by `byte-compile-file', |
| 1599 | or 'no-byte-compile if the file did not need recompilation." | 1641 | or 'no-byte-compile if the file did not need recompilation." |
| 1600 | (interactive | 1642 | (interactive |
| 1601 | (let ((bytecomp-file buffer-file-name) | 1643 | (let ((file buffer-file-name) |
| 1602 | (bytecomp-file-name nil) | 1644 | (file-name nil) |
| 1603 | (bytecomp-file-dir nil)) | 1645 | (file-dir nil)) |
| 1604 | (and bytecomp-file | 1646 | (and file |
| 1605 | (eq (cdr (assq 'major-mode (buffer-local-variables))) | 1647 | (derived-mode-p 'emacs-lisp-mode) |
| 1606 | 'emacs-lisp-mode) | 1648 | (setq file-name (file-name-nondirectory file) |
| 1607 | (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) | 1649 | file-dir (file-name-directory file))) |
| 1608 | bytecomp-file-dir (file-name-directory bytecomp-file))) | ||
| 1609 | (list (read-file-name (if current-prefix-arg | 1650 | (list (read-file-name (if current-prefix-arg |
| 1610 | "Byte compile file: " | 1651 | "Byte compile file: " |
| 1611 | "Byte recompile file: ") | 1652 | "Byte recompile file: ") |
| 1612 | bytecomp-file-dir bytecomp-file-name nil) | 1653 | file-dir file-name nil) |
| 1613 | current-prefix-arg))) | 1654 | current-prefix-arg))) |
| 1614 | (let ((bytecomp-dest | 1655 | (let ((dest (byte-compile-dest-file filename)) |
| 1615 | (byte-compile-dest-file bytecomp-filename)) | ||
| 1616 | ;; Expand now so we get the current buffer's defaults | 1656 | ;; Expand now so we get the current buffer's defaults |
| 1617 | (bytecomp-filename (expand-file-name bytecomp-filename))) | 1657 | (filename (expand-file-name filename))) |
| 1618 | (if (if (file-exists-p bytecomp-dest) | 1658 | (if (if (file-exists-p dest) |
| 1619 | ;; File was already compiled | 1659 | ;; File was already compiled |
| 1620 | ;; Compile if forced to, or filename newer | 1660 | ;; Compile if forced to, or filename newer |
| 1621 | (or bytecomp-force | 1661 | (or force |
| 1622 | (file-newer-than-file-p bytecomp-filename | 1662 | (file-newer-than-file-p filename dest)) |
| 1623 | bytecomp-dest)) | 1663 | (and arg |
| 1624 | (and bytecomp-arg | 1664 | (or (eq 0 arg) |
| 1625 | (or (eq 0 bytecomp-arg) | ||
| 1626 | (y-or-n-p (concat "Compile " | 1665 | (y-or-n-p (concat "Compile " |
| 1627 | bytecomp-filename "? "))))) | 1666 | filename "? "))))) |
| 1628 | (progn | 1667 | (progn |
| 1629 | (if (and noninteractive (not byte-compile-verbose)) | 1668 | (if (and noninteractive (not byte-compile-verbose)) |
| 1630 | (message "Compiling %s..." bytecomp-filename)) | 1669 | (message "Compiling %s..." filename)) |
| 1631 | (byte-compile-file bytecomp-filename load)) | 1670 | (byte-compile-file filename load)) |
| 1632 | (when load (load bytecomp-filename)) | 1671 | (when load (load filename)) |
| 1633 | 'no-byte-compile))) | 1672 | 'no-byte-compile))) |
| 1634 | 1673 | ||
| 1635 | ;;;###autoload | 1674 | ;;;###autoload |
| 1636 | (defun byte-compile-file (bytecomp-filename &optional load) | 1675 | (defun byte-compile-file (filename &optional load) |
| 1637 | "Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code. | 1676 | "Compile a file of Lisp code named FILENAME into a file of byte code. |
| 1638 | The output file's name is generated by passing BYTECOMP-FILENAME to the | 1677 | The output file's name is generated by passing FILENAME to the |
| 1639 | function `byte-compile-dest-file' (which see). | 1678 | function `byte-compile-dest-file' (which see). |
| 1640 | With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling. | 1679 | With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling. |
| 1641 | The value is non-nil if there were no errors, nil if errors." | 1680 | The value is non-nil if there were no errors, nil if errors." |
| 1642 | ;; (interactive "fByte compile file: \nP") | 1681 | ;; (interactive "fByte compile file: \nP") |
| 1643 | (interactive | 1682 | (interactive |
| 1644 | (let ((bytecomp-file buffer-file-name) | 1683 | (let ((file buffer-file-name) |
| 1645 | (bytecomp-file-name nil) | 1684 | (file-name nil) |
| 1646 | (bytecomp-file-dir nil)) | 1685 | (file-dir nil)) |
| 1647 | (and bytecomp-file | 1686 | (and file |
| 1648 | (eq (cdr (assq 'major-mode (buffer-local-variables))) | 1687 | (derived-mode-p 'emacs-lisp-mode) |
| 1649 | 'emacs-lisp-mode) | 1688 | (setq file-name (file-name-nondirectory file) |
| 1650 | (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) | 1689 | file-dir (file-name-directory file))) |
| 1651 | bytecomp-file-dir (file-name-directory bytecomp-file))) | ||
| 1652 | (list (read-file-name (if current-prefix-arg | 1690 | (list (read-file-name (if current-prefix-arg |
| 1653 | "Byte compile and load file: " | 1691 | "Byte compile and load file: " |
| 1654 | "Byte compile file: ") | 1692 | "Byte compile file: ") |
| 1655 | bytecomp-file-dir bytecomp-file-name nil) | 1693 | file-dir file-name nil) |
| 1656 | current-prefix-arg))) | 1694 | current-prefix-arg))) |
| 1657 | ;; Expand now so we get the current buffer's defaults | 1695 | ;; Expand now so we get the current buffer's defaults |
| 1658 | (setq bytecomp-filename (expand-file-name bytecomp-filename)) | 1696 | (setq filename (expand-file-name filename)) |
| 1659 | 1697 | ||
| 1660 | ;; If we're compiling a file that's in a buffer and is modified, offer | 1698 | ;; If we're compiling a file that's in a buffer and is modified, offer |
| 1661 | ;; to save it first. | 1699 | ;; to save it first. |
| 1662 | (or noninteractive | 1700 | (or noninteractive |
| 1663 | (let ((b (get-file-buffer (expand-file-name bytecomp-filename)))) | 1701 | (let ((b (get-file-buffer (expand-file-name filename)))) |
| 1664 | (if (and b (buffer-modified-p b) | 1702 | (if (and b (buffer-modified-p b) |
| 1665 | (y-or-n-p (format "Save buffer %s first? " (buffer-name b)))) | 1703 | (y-or-n-p (format "Save buffer %s first? " (buffer-name b)))) |
| 1666 | (with-current-buffer b (save-buffer))))) | 1704 | (with-current-buffer b (save-buffer))))) |
| 1667 | 1705 | ||
| 1668 | ;; Force logging of the file name for each file compiled. | 1706 | ;; Force logging of the file name for each file compiled. |
| 1669 | (setq byte-compile-last-logged-file nil) | 1707 | (setq byte-compile-last-logged-file nil) |
| 1670 | (let ((byte-compile-current-file bytecomp-filename) | 1708 | (let ((byte-compile-current-file filename) |
| 1671 | (byte-compile-current-group nil) | 1709 | (byte-compile-current-group nil) |
| 1672 | (set-auto-coding-for-load t) | 1710 | (set-auto-coding-for-load t) |
| 1673 | target-file input-buffer output-buffer | 1711 | target-file input-buffer output-buffer |
| 1674 | byte-compile-dest-file) | 1712 | byte-compile-dest-file) |
| 1675 | (setq target-file (byte-compile-dest-file bytecomp-filename)) | 1713 | (setq target-file (byte-compile-dest-file filename)) |
| 1676 | (setq byte-compile-dest-file target-file) | 1714 | (setq byte-compile-dest-file target-file) |
| 1677 | (with-current-buffer | 1715 | (with-current-buffer |
| 1678 | (setq input-buffer (get-buffer-create " *Compiler Input*")) | 1716 | (setq input-buffer (get-buffer-create " *Compiler Input*")) |
| @@ -1681,7 +1719,7 @@ The value is non-nil if there were no errors, nil if errors." | |||
| 1681 | ;; Always compile an Emacs Lisp file as multibyte | 1719 | ;; Always compile an Emacs Lisp file as multibyte |
| 1682 | ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- | 1720 | ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- |
| 1683 | (set-buffer-multibyte t) | 1721 | (set-buffer-multibyte t) |
| 1684 | (insert-file-contents bytecomp-filename) | 1722 | (insert-file-contents filename) |
| 1685 | ;; Mimic the way after-insert-file-set-coding can make the | 1723 | ;; Mimic the way after-insert-file-set-coding can make the |
| 1686 | ;; buffer unibyte when visiting this file. | 1724 | ;; buffer unibyte when visiting this file. |
| 1687 | (when (or (eq last-coding-system-used 'no-conversion) | 1725 | (when (or (eq last-coding-system-used 'no-conversion) |
| @@ -1691,7 +1729,7 @@ The value is non-nil if there were no errors, nil if errors." | |||
| 1691 | (set-buffer-multibyte nil)) | 1729 | (set-buffer-multibyte nil)) |
| 1692 | ;; Run hooks including the uncompression hook. | 1730 | ;; Run hooks including the uncompression hook. |
| 1693 | ;; If they change the file name, then change it for the output also. | 1731 | ;; If they change the file name, then change it for the output also. |
| 1694 | (letf ((buffer-file-name bytecomp-filename) | 1732 | (letf ((buffer-file-name filename) |
| 1695 | ((default-value 'major-mode) 'emacs-lisp-mode) | 1733 | ((default-value 'major-mode) 'emacs-lisp-mode) |
| 1696 | ;; Ignore unsafe local variables. | 1734 | ;; Ignore unsafe local variables. |
| 1697 | ;; We only care about a few of them for our purposes. | 1735 | ;; We only care about a few of them for our purposes. |
| @@ -1699,15 +1737,15 @@ The value is non-nil if there were no errors, nil if errors." | |||
| 1699 | (enable-local-eval nil)) | 1737 | (enable-local-eval nil)) |
| 1700 | ;; Arg of t means don't alter enable-local-variables. | 1738 | ;; Arg of t means don't alter enable-local-variables. |
| 1701 | (normal-mode t) | 1739 | (normal-mode t) |
| 1702 | (setq bytecomp-filename buffer-file-name)) | 1740 | (setq filename buffer-file-name)) |
| 1703 | ;; Set the default directory, in case an eval-when-compile uses it. | 1741 | ;; Set the default directory, in case an eval-when-compile uses it. |
| 1704 | (setq default-directory (file-name-directory bytecomp-filename))) | 1742 | (setq default-directory (file-name-directory filename))) |
| 1705 | ;; Check if the file's local variables explicitly specify not to | 1743 | ;; Check if the file's local variables explicitly specify not to |
| 1706 | ;; compile this file. | 1744 | ;; compile this file. |
| 1707 | (if (with-current-buffer input-buffer no-byte-compile) | 1745 | (if (with-current-buffer input-buffer no-byte-compile) |
| 1708 | (progn | 1746 | (progn |
| 1709 | ;; (message "%s not compiled because of `no-byte-compile: %s'" | 1747 | ;; (message "%s not compiled because of `no-byte-compile: %s'" |
| 1710 | ;; (file-relative-name bytecomp-filename) | 1748 | ;; (file-relative-name filename) |
| 1711 | ;; (with-current-buffer input-buffer no-byte-compile)) | 1749 | ;; (with-current-buffer input-buffer no-byte-compile)) |
| 1712 | (when (file-exists-p target-file) | 1750 | (when (file-exists-p target-file) |
| 1713 | (message "%s deleted because of `no-byte-compile: %s'" | 1751 | (message "%s deleted because of `no-byte-compile: %s'" |
| @@ -1717,18 +1755,18 @@ The value is non-nil if there were no errors, nil if errors." | |||
| 1717 | ;; We successfully didn't compile this file. | 1755 | ;; We successfully didn't compile this file. |
| 1718 | 'no-byte-compile) | 1756 | 'no-byte-compile) |
| 1719 | (when byte-compile-verbose | 1757 | (when byte-compile-verbose |
| 1720 | (message "Compiling %s..." bytecomp-filename)) | 1758 | (message "Compiling %s..." filename)) |
| 1721 | (setq byte-compiler-error-flag nil) | 1759 | (setq byte-compiler-error-flag nil) |
| 1722 | ;; It is important that input-buffer not be current at this call, | 1760 | ;; It is important that input-buffer not be current at this call, |
| 1723 | ;; so that the value of point set in input-buffer | 1761 | ;; so that the value of point set in input-buffer |
| 1724 | ;; within byte-compile-from-buffer lingers in that buffer. | 1762 | ;; within byte-compile-from-buffer lingers in that buffer. |
| 1725 | (setq output-buffer | 1763 | (setq output-buffer |
| 1726 | (save-current-buffer | 1764 | (save-current-buffer |
| 1727 | (byte-compile-from-buffer input-buffer bytecomp-filename))) | 1765 | (byte-compile-from-buffer input-buffer))) |
| 1728 | (if byte-compiler-error-flag | 1766 | (if byte-compiler-error-flag |
| 1729 | nil | 1767 | nil |
| 1730 | (when byte-compile-verbose | 1768 | (when byte-compile-verbose |
| 1731 | (message "Compiling %s...done" bytecomp-filename)) | 1769 | (message "Compiling %s...done" filename)) |
| 1732 | (kill-buffer input-buffer) | 1770 | (kill-buffer input-buffer) |
| 1733 | (with-current-buffer output-buffer | 1771 | (with-current-buffer output-buffer |
| 1734 | (goto-char (point-max)) | 1772 | (goto-char (point-max)) |
| @@ -1768,9 +1806,9 @@ The value is non-nil if there were no errors, nil if errors." | |||
| 1768 | (if (and byte-compile-generate-call-tree | 1806 | (if (and byte-compile-generate-call-tree |
| 1769 | (or (eq t byte-compile-generate-call-tree) | 1807 | (or (eq t byte-compile-generate-call-tree) |
| 1770 | (y-or-n-p (format "Report call tree for %s? " | 1808 | (y-or-n-p (format "Report call tree for %s? " |
| 1771 | bytecomp-filename)))) | 1809 | filename)))) |
| 1772 | (save-excursion | 1810 | (save-excursion |
| 1773 | (display-call-tree bytecomp-filename))) | 1811 | (display-call-tree filename))) |
| 1774 | (if load | 1812 | (if load |
| 1775 | (load target-file)) | 1813 | (load target-file)) |
| 1776 | t)))) | 1814 | t)))) |
| @@ -1794,18 +1832,21 @@ With argument ARG, insert value in current buffer after the form." | |||
| 1794 | (let ((read-with-symbol-positions (current-buffer)) | 1832 | (let ((read-with-symbol-positions (current-buffer)) |
| 1795 | (read-symbol-positions-list nil)) | 1833 | (read-symbol-positions-list nil)) |
| 1796 | (displaying-byte-compile-warnings | 1834 | (displaying-byte-compile-warnings |
| 1797 | (byte-compile-sexp (read (current-buffer)))))))) | 1835 | (byte-compile-sexp (read (current-buffer))))) |
| 1836 | lexical-binding))) | ||
| 1798 | (cond (arg | 1837 | (cond (arg |
| 1799 | (message "Compiling from buffer... done.") | 1838 | (message "Compiling from buffer... done.") |
| 1800 | (prin1 value (current-buffer)) | 1839 | (prin1 value (current-buffer)) |
| 1801 | (insert "\n")) | 1840 | (insert "\n")) |
| 1802 | ((message "%s" (prin1-to-string value))))))) | 1841 | ((message "%s" (prin1-to-string value))))))) |
| 1803 | 1842 | ||
| 1843 | ;; Dynamically bound in byte-compile-from-buffer. | ||
| 1844 | ;; NB also used in cl.el and cl-macs.el. | ||
| 1845 | (defvar byte-compile--outbuffer) | ||
| 1804 | 1846 | ||
| 1805 | (defun byte-compile-from-buffer (bytecomp-inbuffer &optional bytecomp-filename) | 1847 | (defun byte-compile-from-buffer (inbuffer) |
| 1806 | ;; Filename is used for the loading-into-Emacs-18 error message. | 1848 | (let (byte-compile--outbuffer |
| 1807 | (let (bytecomp-outbuffer | 1849 | (byte-compile-current-buffer inbuffer) |
| 1808 | (byte-compile-current-buffer bytecomp-inbuffer) | ||
| 1809 | (byte-compile-read-position nil) | 1850 | (byte-compile-read-position nil) |
| 1810 | (byte-compile-last-position nil) | 1851 | (byte-compile-last-position nil) |
| 1811 | ;; Prevent truncation of flonums and lists as we read and print them | 1852 | ;; Prevent truncation of flonums and lists as we read and print them |
| @@ -1826,22 +1867,24 @@ With argument ARG, insert value in current buffer after the form." | |||
| 1826 | (byte-compile-output nil) | 1867 | (byte-compile-output nil) |
| 1827 | ;; This allows us to get the positions of symbols read; it's | 1868 | ;; This allows us to get the positions of symbols read; it's |
| 1828 | ;; new in Emacs 22.1. | 1869 | ;; new in Emacs 22.1. |
| 1829 | (read-with-symbol-positions bytecomp-inbuffer) | 1870 | (read-with-symbol-positions inbuffer) |
| 1830 | (read-symbol-positions-list nil) | 1871 | (read-symbol-positions-list nil) |
| 1831 | ;; #### This is bound in b-c-close-variables. | 1872 | ;; #### This is bound in b-c-close-variables. |
| 1832 | ;; (byte-compile-warnings byte-compile-warnings) | 1873 | ;; (byte-compile-warnings byte-compile-warnings) |
| 1833 | ) | 1874 | ) |
| 1834 | (byte-compile-close-variables | 1875 | (byte-compile-close-variables |
| 1835 | (with-current-buffer | 1876 | (with-current-buffer |
| 1836 | (setq bytecomp-outbuffer (get-buffer-create " *Compiler Output*")) | 1877 | (setq byte-compile--outbuffer |
| 1878 | (get-buffer-create " *Compiler Output*")) | ||
| 1837 | (set-buffer-multibyte t) | 1879 | (set-buffer-multibyte t) |
| 1838 | (erase-buffer) | 1880 | (erase-buffer) |
| 1839 | ;; (emacs-lisp-mode) | 1881 | ;; (emacs-lisp-mode) |
| 1840 | (setq case-fold-search nil)) | 1882 | (setq case-fold-search nil)) |
| 1841 | (displaying-byte-compile-warnings | 1883 | (displaying-byte-compile-warnings |
| 1842 | (with-current-buffer bytecomp-inbuffer | 1884 | (with-current-buffer inbuffer |
| 1843 | (and bytecomp-filename | 1885 | (and byte-compile-current-file |
| 1844 | (byte-compile-insert-header bytecomp-filename bytecomp-outbuffer)) | 1886 | (byte-compile-insert-header byte-compile-current-file |
| 1887 | byte-compile--outbuffer)) | ||
| 1845 | (goto-char (point-min)) | 1888 | (goto-char (point-min)) |
| 1846 | ;; Should we always do this? When calling multiple files, it | 1889 | ;; Should we always do this? When calling multiple files, it |
| 1847 | ;; would be useful to delay this warning until all have been | 1890 | ;; would be useful to delay this warning until all have been |
| @@ -1858,13 +1901,13 @@ With argument ARG, insert value in current buffer after the form." | |||
| 1858 | (setq byte-compile-read-position (point) | 1901 | (setq byte-compile-read-position (point) |
| 1859 | byte-compile-last-position byte-compile-read-position) | 1902 | byte-compile-last-position byte-compile-read-position) |
| 1860 | (let* ((old-style-backquotes nil) | 1903 | (let* ((old-style-backquotes nil) |
| 1861 | (form (read bytecomp-inbuffer))) | 1904 | (form (read inbuffer))) |
| 1862 | ;; Warn about the use of old-style backquotes. | 1905 | ;; Warn about the use of old-style backquotes. |
| 1863 | (when old-style-backquotes | 1906 | (when old-style-backquotes |
| 1864 | (byte-compile-warn "!! The file uses old-style backquotes !! | 1907 | (byte-compile-warn "!! The file uses old-style backquotes !! |
| 1865 | This functionality has been obsolete for more than 10 years already | 1908 | This functionality has been obsolete for more than 10 years already |
| 1866 | and will be removed soon. See (elisp)Backquote in the manual.")) | 1909 | and will be removed soon. See (elisp)Backquote in the manual.")) |
| 1867 | (byte-compile-file-form form))) | 1910 | (byte-compile-toplevel-file-form form))) |
| 1868 | ;; Compile pending forms at end of file. | 1911 | ;; Compile pending forms at end of file. |
| 1869 | (byte-compile-flush-pending) | 1912 | (byte-compile-flush-pending) |
| 1870 | ;; Make warnings about unresolved functions | 1913 | ;; Make warnings about unresolved functions |
| @@ -1873,10 +1916,10 @@ and will be removed soon. See (elisp)Backquote in the manual.")) | |||
| 1873 | (byte-compile-warn-about-unresolved-functions)) | 1916 | (byte-compile-warn-about-unresolved-functions)) |
| 1874 | ;; Fix up the header at the front of the output | 1917 | ;; Fix up the header at the front of the output |
| 1875 | ;; if the buffer contains multibyte characters. | 1918 | ;; if the buffer contains multibyte characters. |
| 1876 | (and bytecomp-filename | 1919 | (and byte-compile-current-file |
| 1877 | (with-current-buffer bytecomp-outbuffer | 1920 | (with-current-buffer byte-compile--outbuffer |
| 1878 | (byte-compile-fix-header bytecomp-filename))))) | 1921 | (byte-compile-fix-header byte-compile-current-file))))) |
| 1879 | bytecomp-outbuffer)) | 1922 | byte-compile--outbuffer)) |
| 1880 | 1923 | ||
| 1881 | (defun byte-compile-fix-header (filename) | 1924 | (defun byte-compile-fix-header (filename) |
| 1882 | "If the current buffer has any multibyte characters, insert a version test." | 1925 | "If the current buffer has any multibyte characters, insert a version test." |
| @@ -1964,10 +2007,6 @@ Call from the source buffer." | |||
| 1964 | ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n" | 2007 | ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n" |
| 1965 | ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")))) | 2008 | ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")))) |
| 1966 | 2009 | ||
| 1967 | ;; Dynamically bound in byte-compile-from-buffer. | ||
| 1968 | ;; NB also used in cl.el and cl-macs.el. | ||
| 1969 | (defvar bytecomp-outbuffer) | ||
| 1970 | |||
| 1971 | (defun byte-compile-output-file-form (form) | 2010 | (defun byte-compile-output-file-form (form) |
| 1972 | ;; writes the given form to the output buffer, being careful of docstrings | 2011 | ;; writes the given form to the output buffer, being careful of docstrings |
| 1973 | ;; in defun, defmacro, defvar, defvaralias, defconst, autoload and | 2012 | ;; in defun, defmacro, defvar, defvaralias, defconst, autoload and |
| @@ -1975,8 +2014,8 @@ Call from the source buffer." | |||
| 1975 | ;; defalias calls are output directly by byte-compile-file-form-defmumble; | 2014 | ;; defalias calls are output directly by byte-compile-file-form-defmumble; |
| 1976 | ;; it does not pay to first build the defalias in defmumble and then parse | 2015 | ;; it does not pay to first build the defalias in defmumble and then parse |
| 1977 | ;; it here. | 2016 | ;; it here. |
| 1978 | (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst autoload | 2017 | (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst |
| 1979 | custom-declare-variable)) | 2018 | autoload custom-declare-variable)) |
| 1980 | (stringp (nth 3 form))) | 2019 | (stringp (nth 3 form))) |
| 1981 | (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil | 2020 | (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil |
| 1982 | (memq (car form) | 2021 | (memq (car form) |
| @@ -1989,11 +2028,12 @@ Call from the source buffer." | |||
| 1989 | (print-gensym t) | 2028 | (print-gensym t) |
| 1990 | (print-circle ; handle circular data structures | 2029 | (print-circle ; handle circular data structures |
| 1991 | (not byte-compile-disable-print-circle))) | 2030 | (not byte-compile-disable-print-circle))) |
| 1992 | (princ "\n" bytecomp-outbuffer) | 2031 | (princ "\n" byte-compile--outbuffer) |
| 1993 | (prin1 form bytecomp-outbuffer) | 2032 | (prin1 form byte-compile--outbuffer) |
| 1994 | nil))) | 2033 | nil))) |
| 1995 | 2034 | ||
| 1996 | (defvar print-gensym-alist) ;Used before print-circle existed. | 2035 | (defvar print-gensym-alist) ;Used before print-circle existed. |
| 2036 | (defvar byte-compile--for-effect) | ||
| 1997 | 2037 | ||
| 1998 | (defun byte-compile-output-docform (preface name info form specindex quoted) | 2038 | (defun byte-compile-output-docform (preface name info form specindex quoted) |
| 1999 | "Print a form with a doc string. INFO is (prefix doc-index postfix). | 2039 | "Print a form with a doc string. INFO is (prefix doc-index postfix). |
| @@ -2009,7 +2049,7 @@ list that represents a doc string reference. | |||
| 2009 | ;; We need to examine byte-compile-dynamic-docstrings | 2049 | ;; We need to examine byte-compile-dynamic-docstrings |
| 2010 | ;; in the input buffer (now current), not in the output buffer. | 2050 | ;; in the input buffer (now current), not in the output buffer. |
| 2011 | (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) | 2051 | (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) |
| 2012 | (with-current-buffer bytecomp-outbuffer | 2052 | (with-current-buffer byte-compile--outbuffer |
| 2013 | (let (position) | 2053 | (let (position) |
| 2014 | 2054 | ||
| 2015 | ;; Insert the doc string, and make it a comment with #@LENGTH. | 2055 | ;; Insert the doc string, and make it a comment with #@LENGTH. |
| @@ -2033,7 +2073,7 @@ list that represents a doc string reference. | |||
| 2033 | (if preface | 2073 | (if preface |
| 2034 | (progn | 2074 | (progn |
| 2035 | (insert preface) | 2075 | (insert preface) |
| 2036 | (prin1 name bytecomp-outbuffer))) | 2076 | (prin1 name byte-compile--outbuffer))) |
| 2037 | (insert (car info)) | 2077 | (insert (car info)) |
| 2038 | (let ((print-escape-newlines t) | 2078 | (let ((print-escape-newlines t) |
| 2039 | (print-quoted t) | 2079 | (print-quoted t) |
| @@ -2048,7 +2088,7 @@ list that represents a doc string reference. | |||
| 2048 | (print-continuous-numbering t) | 2088 | (print-continuous-numbering t) |
| 2049 | print-number-table | 2089 | print-number-table |
| 2050 | (index 0)) | 2090 | (index 0)) |
| 2051 | (prin1 (car form) bytecomp-outbuffer) | 2091 | (prin1 (car form) byte-compile--outbuffer) |
| 2052 | (while (setq form (cdr form)) | 2092 | (while (setq form (cdr form)) |
| 2053 | (setq index (1+ index)) | 2093 | (setq index (1+ index)) |
| 2054 | (insert " ") | 2094 | (insert " ") |
| @@ -2059,7 +2099,7 @@ list that represents a doc string reference. | |||
| 2059 | ;; (for instance, gensyms in the arg list). | 2099 | ;; (for instance, gensyms in the arg list). |
| 2060 | (let (non-nil) | 2100 | (let (non-nil) |
| 2061 | (when (hash-table-p print-number-table) | 2101 | (when (hash-table-p print-number-table) |
| 2062 | (maphash (lambda (k v) (if v (setq non-nil t))) | 2102 | (maphash (lambda (_k v) (if v (setq non-nil t))) |
| 2063 | print-number-table)) | 2103 | print-number-table)) |
| 2064 | (not non-nil))) | 2104 | (not non-nil))) |
| 2065 | ;; Output the byte code and constants specially | 2105 | ;; Output the byte code and constants specially |
| @@ -2068,37 +2108,40 @@ list that represents a doc string reference. | |||
| 2068 | (byte-compile-output-as-comment | 2108 | (byte-compile-output-as-comment |
| 2069 | (cons (car form) (nth 1 form)) | 2109 | (cons (car form) (nth 1 form)) |
| 2070 | t))) | 2110 | t))) |
| 2071 | (setq position (- (position-bytes position) (point-min) -1)) | 2111 | (setq position (- (position-bytes position) |
| 2072 | (princ (format "(#$ . %d) nil" position) bytecomp-outbuffer) | 2112 | (point-min) -1)) |
| 2113 | (princ (format "(#$ . %d) nil" position) | ||
| 2114 | byte-compile--outbuffer) | ||
| 2073 | (setq form (cdr form)) | 2115 | (setq form (cdr form)) |
| 2074 | (setq index (1+ index)))) | 2116 | (setq index (1+ index)))) |
| 2075 | ((= index (nth 1 info)) | 2117 | ((= index (nth 1 info)) |
| 2076 | (if position | 2118 | (if position |
| 2077 | (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") | 2119 | (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") |
| 2078 | position) | 2120 | position) |
| 2079 | bytecomp-outbuffer) | 2121 | byte-compile--outbuffer) |
| 2080 | (let ((print-escape-newlines nil)) | 2122 | (let ((print-escape-newlines nil)) |
| 2081 | (goto-char (prog1 (1+ (point)) | 2123 | (goto-char (prog1 (1+ (point)) |
| 2082 | (prin1 (car form) bytecomp-outbuffer))) | 2124 | (prin1 (car form) |
| 2125 | byte-compile--outbuffer))) | ||
| 2083 | (insert "\\\n") | 2126 | (insert "\\\n") |
| 2084 | (goto-char (point-max))))) | 2127 | (goto-char (point-max))))) |
| 2085 | (t | 2128 | (t |
| 2086 | (prin1 (car form) bytecomp-outbuffer))))) | 2129 | (prin1 (car form) byte-compile--outbuffer))))) |
| 2087 | (insert (nth 2 info))))) | 2130 | (insert (nth 2 info))))) |
| 2088 | nil) | 2131 | nil) |
| 2089 | 2132 | ||
| 2090 | (defun byte-compile-keep-pending (form &optional bytecomp-handler) | 2133 | (defun byte-compile-keep-pending (form &optional handler) |
| 2091 | (if (memq byte-optimize '(t source)) | 2134 | (if (memq byte-optimize '(t source)) |
| 2092 | (setq form (byte-optimize-form form t))) | 2135 | (setq form (byte-optimize-form form t))) |
| 2093 | (if bytecomp-handler | 2136 | (if handler |
| 2094 | (let ((for-effect t)) | 2137 | (let ((byte-compile--for-effect t)) |
| 2095 | ;; To avoid consing up monstrously large forms at load time, we split | 2138 | ;; To avoid consing up monstrously large forms at load time, we split |
| 2096 | ;; the output regularly. | 2139 | ;; the output regularly. |
| 2097 | (and (memq (car-safe form) '(fset defalias)) | 2140 | (and (memq (car-safe form) '(fset defalias)) |
| 2098 | (nthcdr 300 byte-compile-output) | 2141 | (nthcdr 300 byte-compile-output) |
| 2099 | (byte-compile-flush-pending)) | 2142 | (byte-compile-flush-pending)) |
| 2100 | (funcall bytecomp-handler form) | 2143 | (funcall handler form) |
| 2101 | (if for-effect | 2144 | (if byte-compile--for-effect |
| 2102 | (byte-compile-discard))) | 2145 | (byte-compile-discard))) |
| 2103 | (byte-compile-form form t)) | 2146 | (byte-compile-form form t)) |
| 2104 | nil) | 2147 | nil) |
| @@ -2116,37 +2159,39 @@ list that represents a doc string reference. | |||
| 2116 | byte-compile-maxdepth 0 | 2159 | byte-compile-maxdepth 0 |
| 2117 | byte-compile-output nil)))) | 2160 | byte-compile-output nil)))) |
| 2118 | 2161 | ||
| 2162 | (defun byte-compile-preprocess (form &optional _for-effect) | ||
| 2163 | (setq form (macroexpand-all form byte-compile-macro-environment)) | ||
| 2164 | ;; FIXME: We should run byte-optimize-form here, but it currently does not | ||
| 2165 | ;; recurse through all the code, so we'd have to fix this first. | ||
| 2166 | ;; Maybe a good fix would be to merge byte-optimize-form into | ||
| 2167 | ;; macroexpand-all. | ||
| 2168 | ;; (if (memq byte-optimize '(t source)) | ||
| 2169 | ;; (setq form (byte-optimize-form form for-effect))) | ||
| 2170 | (if lexical-binding | ||
| 2171 | (cconv-closure-convert form) | ||
| 2172 | form)) | ||
| 2173 | |||
| 2174 | ;; byte-hunk-handlers cannot call this! | ||
| 2175 | (defun byte-compile-toplevel-file-form (form) | ||
| 2176 | (let ((byte-compile-current-form nil)) ; close over this for warnings. | ||
| 2177 | (byte-compile-file-form (byte-compile-preprocess form t)))) | ||
| 2178 | |||
| 2179 | ;; byte-hunk-handlers can call this. | ||
| 2119 | (defun byte-compile-file-form (form) | 2180 | (defun byte-compile-file-form (form) |
| 2120 | (let ((byte-compile-current-form nil) ; close over this for warnings. | 2181 | (let (handler) |
| 2121 | bytecomp-handler) | 2182 | (cond ((and (consp form) |
| 2122 | (cond | 2183 | (symbolp (car form)) |
| 2123 | ((not (consp form)) | 2184 | (setq handler (get (car form) 'byte-hunk-handler))) |
| 2124 | (byte-compile-keep-pending form)) | 2185 | (cond ((setq form (funcall handler form)) |
| 2125 | ((and (symbolp (car form)) | 2186 | (byte-compile-flush-pending) |
| 2126 | (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) | 2187 | (byte-compile-output-file-form form)))) |
| 2127 | (cond ((setq form (funcall bytecomp-handler form)) | 2188 | (t |
| 2128 | (byte-compile-flush-pending) | 2189 | (byte-compile-keep-pending form))))) |
| 2129 | (byte-compile-output-file-form form)))) | ||
| 2130 | ((eq form (setq form (macroexpand form byte-compile-macro-environment))) | ||
| 2131 | (byte-compile-keep-pending form)) | ||
| 2132 | (t | ||
| 2133 | (byte-compile-file-form form))))) | ||
| 2134 | 2190 | ||
| 2135 | ;; Functions and variables with doc strings must be output separately, | 2191 | ;; Functions and variables with doc strings must be output separately, |
| 2136 | ;; so make-docfile can recognise them. Most other things can be output | 2192 | ;; so make-docfile can recognise them. Most other things can be output |
| 2137 | ;; as byte-code. | 2193 | ;; as byte-code. |
| 2138 | 2194 | ||
| 2139 | (put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) | ||
| 2140 | (defun byte-compile-file-form-defsubst (form) | ||
| 2141 | (when (assq (nth 1 form) byte-compile-unresolved-functions) | ||
| 2142 | (setq byte-compile-current-form (nth 1 form)) | ||
| 2143 | (byte-compile-warn "defsubst `%s' was used before it was defined" | ||
| 2144 | (nth 1 form))) | ||
| 2145 | (byte-compile-file-form | ||
| 2146 | (macroexpand form byte-compile-macro-environment)) | ||
| 2147 | ;; Return nil so the form is not output twice. | ||
| 2148 | nil) | ||
| 2149 | |||
| 2150 | (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) | 2195 | (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) |
| 2151 | (defun byte-compile-file-form-autoload (form) | 2196 | (defun byte-compile-file-form-autoload (form) |
| 2152 | (and (let ((form form)) | 2197 | (and (let ((form form)) |
| @@ -2200,7 +2245,8 @@ list that represents a doc string reference. | |||
| 2200 | (byte-compile-top-level (nth 2 form) nil 'file)))) | 2245 | (byte-compile-top-level (nth 2 form) nil 'file)))) |
| 2201 | form)) | 2246 | form)) |
| 2202 | 2247 | ||
| 2203 | (put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-define-abbrev-table) | 2248 | (put 'define-abbrev-table 'byte-hunk-handler |
| 2249 | 'byte-compile-file-form-define-abbrev-table) | ||
| 2204 | (defun byte-compile-file-form-define-abbrev-table (form) | 2250 | (defun byte-compile-file-form-define-abbrev-table (form) |
| 2205 | (if (eq 'quote (car-safe (car-safe (cdr form)))) | 2251 | (if (eq 'quote (car-safe (car-safe (cdr form)))) |
| 2206 | (push (car-safe (cdr (cadr form))) byte-compile-bound-variables)) | 2252 | (push (car-safe (cdr (cadr form))) byte-compile-bound-variables)) |
| @@ -2298,51 +2344,49 @@ by side-effects." | |||
| 2298 | res)) | 2344 | res)) |
| 2299 | 2345 | ||
| 2300 | (defun byte-compile-file-form-defmumble (form macrop) | 2346 | (defun byte-compile-file-form-defmumble (form macrop) |
| 2301 | (let* ((bytecomp-name (car (cdr form))) | 2347 | (let* ((name (car (cdr form))) |
| 2302 | (bytecomp-this-kind (if macrop 'byte-compile-macro-environment | 2348 | (this-kind (if macrop 'byte-compile-macro-environment |
| 2303 | 'byte-compile-function-environment)) | 2349 | 'byte-compile-function-environment)) |
| 2304 | (bytecomp-that-kind (if macrop 'byte-compile-function-environment | 2350 | (that-kind (if macrop 'byte-compile-function-environment |
| 2305 | 'byte-compile-macro-environment)) | 2351 | 'byte-compile-macro-environment)) |
| 2306 | (bytecomp-this-one (assq bytecomp-name | 2352 | (this-one (assq name (symbol-value this-kind))) |
| 2307 | (symbol-value bytecomp-this-kind))) | 2353 | (that-one (assq name (symbol-value that-kind))) |
| 2308 | (bytecomp-that-one (assq bytecomp-name | ||
| 2309 | (symbol-value bytecomp-that-kind))) | ||
| 2310 | (byte-compile-free-references nil) | 2354 | (byte-compile-free-references nil) |
| 2311 | (byte-compile-free-assignments nil)) | 2355 | (byte-compile-free-assignments nil)) |
| 2312 | (byte-compile-set-symbol-position bytecomp-name) | 2356 | (byte-compile-set-symbol-position name) |
| 2313 | ;; When a function or macro is defined, add it to the call tree so that | 2357 | ;; When a function or macro is defined, add it to the call tree so that |
| 2314 | ;; we can tell when functions are not used. | 2358 | ;; we can tell when functions are not used. |
| 2315 | (if byte-compile-generate-call-tree | 2359 | (if byte-compile-generate-call-tree |
| 2316 | (or (assq bytecomp-name byte-compile-call-tree) | 2360 | (or (assq name byte-compile-call-tree) |
| 2317 | (setq byte-compile-call-tree | 2361 | (setq byte-compile-call-tree |
| 2318 | (cons (list bytecomp-name nil nil) byte-compile-call-tree)))) | 2362 | (cons (list name nil nil) byte-compile-call-tree)))) |
| 2319 | 2363 | ||
| 2320 | (setq byte-compile-current-form bytecomp-name) ; for warnings | 2364 | (setq byte-compile-current-form name) ; for warnings |
| 2321 | (if (byte-compile-warning-enabled-p 'redefine) | 2365 | (if (byte-compile-warning-enabled-p 'redefine) |
| 2322 | (byte-compile-arglist-warn form macrop)) | 2366 | (byte-compile-arglist-warn form macrop)) |
| 2323 | (if byte-compile-verbose | 2367 | (if byte-compile-verbose |
| 2324 | ;; bytecomp-filename is from byte-compile-from-buffer. | 2368 | (message "Compiling %s... (%s)" |
| 2325 | (message "Compiling %s... (%s)" (or bytecomp-filename "") (nth 1 form))) | 2369 | (or byte-compile-current-file "") (nth 1 form))) |
| 2326 | (cond (bytecomp-that-one | 2370 | (cond (that-one |
| 2327 | (if (and (byte-compile-warning-enabled-p 'redefine) | 2371 | (if (and (byte-compile-warning-enabled-p 'redefine) |
| 2328 | ;; don't warn when compiling the stubs in byte-run... | 2372 | ;; don't warn when compiling the stubs in byte-run... |
| 2329 | (not (assq (nth 1 form) | 2373 | (not (assq (nth 1 form) |
| 2330 | byte-compile-initial-macro-environment))) | 2374 | byte-compile-initial-macro-environment))) |
| 2331 | (byte-compile-warn | 2375 | (byte-compile-warn |
| 2332 | "`%s' defined multiple times, as both function and macro" | 2376 | "`%s' defined multiple times, as both function and macro" |
| 2333 | (nth 1 form))) | 2377 | (nth 1 form))) |
| 2334 | (setcdr bytecomp-that-one nil)) | 2378 | (setcdr that-one nil)) |
| 2335 | (bytecomp-this-one | 2379 | (this-one |
| 2336 | (when (and (byte-compile-warning-enabled-p 'redefine) | 2380 | (when (and (byte-compile-warning-enabled-p 'redefine) |
| 2337 | ;; hack: don't warn when compiling the magic internal | 2381 | ;; hack: don't warn when compiling the magic internal |
| 2338 | ;; byte-compiler macros in byte-run.el... | 2382 | ;; byte-compiler macros in byte-run.el... |
| 2339 | (not (assq (nth 1 form) | 2383 | (not (assq (nth 1 form) |
| 2340 | byte-compile-initial-macro-environment))) | 2384 | byte-compile-initial-macro-environment))) |
| 2341 | (byte-compile-warn "%s `%s' defined multiple times in this file" | 2385 | (byte-compile-warn "%s `%s' defined multiple times in this file" |
| 2342 | (if macrop "macro" "function") | 2386 | (if macrop "macro" "function") |
| 2343 | (nth 1 form)))) | 2387 | (nth 1 form)))) |
| 2344 | ((and (fboundp bytecomp-name) | 2388 | ((and (fboundp name) |
| 2345 | (eq (car-safe (symbol-function bytecomp-name)) | 2389 | (eq (car-safe (symbol-function name)) |
| 2346 | (if macrop 'lambda 'macro))) | 2390 | (if macrop 'lambda 'macro))) |
| 2347 | (when (byte-compile-warning-enabled-p 'redefine) | 2391 | (when (byte-compile-warning-enabled-p 'redefine) |
| 2348 | (byte-compile-warn "%s `%s' being redefined as a %s" | 2392 | (byte-compile-warn "%s `%s' being redefined as a %s" |
| @@ -2350,9 +2394,9 @@ by side-effects." | |||
| 2350 | (nth 1 form) | 2394 | (nth 1 form) |
| 2351 | (if macrop "macro" "function"))) | 2395 | (if macrop "macro" "function"))) |
| 2352 | ;; shadow existing definition | 2396 | ;; shadow existing definition |
| 2353 | (set bytecomp-this-kind | 2397 | (set this-kind |
| 2354 | (cons (cons bytecomp-name nil) | 2398 | (cons (cons name nil) |
| 2355 | (symbol-value bytecomp-this-kind)))) | 2399 | (symbol-value this-kind)))) |
| 2356 | ) | 2400 | ) |
| 2357 | (let ((body (nthcdr 3 form))) | 2401 | (let ((body (nthcdr 3 form))) |
| 2358 | (when (and (stringp (car body)) | 2402 | (when (and (stringp (car body)) |
| @@ -2367,67 +2411,51 @@ by side-effects." | |||
| 2367 | ;; Remove declarations from the body of the macro definition. | 2411 | ;; Remove declarations from the body of the macro definition. |
| 2368 | (when macrop | 2412 | (when macrop |
| 2369 | (dolist (decl (byte-compile-defmacro-declaration form)) | 2413 | (dolist (decl (byte-compile-defmacro-declaration form)) |
| 2370 | (prin1 decl bytecomp-outbuffer))) | 2414 | (prin1 decl byte-compile--outbuffer))) |
| 2371 | 2415 | ||
| 2372 | (let* ((new-one (byte-compile-lambda (nthcdr 2 form) t)) | 2416 | (let* ((code (byte-compile-lambda (nthcdr 2 form) t))) |
| 2373 | (code (byte-compile-byte-code-maker new-one))) | 2417 | (if this-one |
| 2374 | (if bytecomp-this-one | 2418 | (setcdr this-one code) |
| 2375 | (setcdr bytecomp-this-one new-one) | 2419 | (set this-kind |
| 2376 | (set bytecomp-this-kind | 2420 | (cons (cons name code) |
| 2377 | (cons (cons bytecomp-name new-one) | 2421 | (symbol-value this-kind)))) |
| 2378 | (symbol-value bytecomp-this-kind)))) | 2422 | (byte-compile-flush-pending) |
| 2379 | (if (and (stringp (nth 3 form)) | 2423 | (if (not (stringp (nth 3 form))) |
| 2380 | (eq 'quote (car-safe code)) | 2424 | ;; No doc string. Provide -1 as the "doc string index" |
| 2381 | (eq 'lambda (car-safe (nth 1 code)))) | 2425 | ;; so that no element will be treated as a doc string. |
| 2382 | (cons (car form) | 2426 | (byte-compile-output-docform |
| 2383 | (cons bytecomp-name (cdr (nth 1 code)))) | 2427 | "\n(defalias '" |
| 2384 | (byte-compile-flush-pending) | 2428 | name |
| 2385 | (if (not (stringp (nth 3 form))) | 2429 | (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]")) |
| 2386 | ;; No doc string. Provide -1 as the "doc string index" | 2430 | (append code nil) ; Turn byte-code-function-p into list. |
| 2387 | ;; so that no element will be treated as a doc string. | 2431 | (and (atom code) byte-compile-dynamic |
| 2388 | (byte-compile-output-docform | 2432 | 1) |
| 2389 | "\n(defalias '" | 2433 | nil) |
| 2390 | bytecomp-name | 2434 | ;; Output the form by hand, that's much simpler than having |
| 2391 | (cond ((atom code) | 2435 | ;; b-c-output-file-form analyze the defalias. |
| 2392 | (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))) | 2436 | (byte-compile-output-docform |
| 2393 | ((eq (car code) 'quote) | 2437 | "\n(defalias '" |
| 2394 | (setq code new-one) | 2438 | name |
| 2395 | (if macrop '(" '(macro " -1 ")") '(" '(" -1 ")"))) | 2439 | (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]")) |
| 2396 | ((if macrop '(" (cons 'macro (" -1 "))") '(" (" -1 ")")))) | 2440 | (append code nil) ; Turn byte-code-function-p into list. |
| 2397 | (append code nil) | 2441 | (and (atom code) byte-compile-dynamic |
| 2398 | (and (atom code) byte-compile-dynamic | 2442 | 1) |
| 2399 | 1) | 2443 | nil)) |
| 2400 | nil) | 2444 | (princ ")" byte-compile--outbuffer) |
| 2401 | ;; Output the form by hand, that's much simpler than having | 2445 | nil))) |
| 2402 | ;; b-c-output-file-form analyze the defalias. | ||
| 2403 | (byte-compile-output-docform | ||
| 2404 | "\n(defalias '" | ||
| 2405 | bytecomp-name | ||
| 2406 | (cond ((atom code) | ||
| 2407 | (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) | ||
| 2408 | ((eq (car code) 'quote) | ||
| 2409 | (setq code new-one) | ||
| 2410 | (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) | ||
| 2411 | ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))) | ||
| 2412 | (append code nil) | ||
| 2413 | (and (atom code) byte-compile-dynamic | ||
| 2414 | 1) | ||
| 2415 | nil)) | ||
| 2416 | (princ ")" bytecomp-outbuffer) | ||
| 2417 | nil)))) | ||
| 2418 | 2446 | ||
| 2419 | ;; Print Lisp object EXP in the output file, inside a comment, | 2447 | ;; Print Lisp object EXP in the output file, inside a comment, |
| 2420 | ;; and return the file position it will have. | 2448 | ;; and return the file position it will have. |
| 2421 | ;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. | 2449 | ;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. |
| 2422 | (defun byte-compile-output-as-comment (exp quoted) | 2450 | (defun byte-compile-output-as-comment (exp quoted) |
| 2423 | (let ((position (point))) | 2451 | (let ((position (point))) |
| 2424 | (with-current-buffer bytecomp-outbuffer | 2452 | (with-current-buffer byte-compile--outbuffer |
| 2425 | 2453 | ||
| 2426 | ;; Insert EXP, and make it a comment with #@LENGTH. | 2454 | ;; Insert EXP, and make it a comment with #@LENGTH. |
| 2427 | (insert " ") | 2455 | (insert " ") |
| 2428 | (if quoted | 2456 | (if quoted |
| 2429 | (prin1 exp bytecomp-outbuffer) | 2457 | (prin1 exp byte-compile--outbuffer) |
| 2430 | (princ exp bytecomp-outbuffer)) | 2458 | (princ exp byte-compile--outbuffer)) |
| 2431 | (goto-char position) | 2459 | (goto-char position) |
| 2432 | ;; Quote certain special characters as needed. | 2460 | ;; Quote certain special characters as needed. |
| 2433 | ;; get_doc_string in doc.c does the unquoting. | 2461 | ;; get_doc_string in doc.c does the unquoting. |
| @@ -2469,6 +2497,10 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2469 | (if macro | 2497 | (if macro |
| 2470 | (setq fun (cdr fun))) | 2498 | (setq fun (cdr fun))) |
| 2471 | (cond ((eq (car-safe fun) 'lambda) | 2499 | (cond ((eq (car-safe fun) 'lambda) |
| 2500 | ;; Expand macros. | ||
| 2501 | (setq fun (byte-compile-preprocess fun)) | ||
| 2502 | ;; Get rid of the `function' quote added by the `lambda' macro. | ||
| 2503 | (if (eq (car-safe fun) 'function) (setq fun (cadr fun))) | ||
| 2472 | (setq fun (if macro | 2504 | (setq fun (if macro |
| 2473 | (cons 'macro (byte-compile-lambda fun)) | 2505 | (cons 'macro (byte-compile-lambda fun)) |
| 2474 | (byte-compile-lambda fun))) | 2506 | (byte-compile-lambda fun))) |
| @@ -2480,56 +2512,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2480 | "Compile and return SEXP." | 2512 | "Compile and return SEXP." |
| 2481 | (displaying-byte-compile-warnings | 2513 | (displaying-byte-compile-warnings |
| 2482 | (byte-compile-close-variables | 2514 | (byte-compile-close-variables |
| 2483 | (byte-compile-top-level sexp)))) | 2515 | (byte-compile-top-level (byte-compile-preprocess sexp))))) |
| 2484 | |||
| 2485 | ;; Given a function made by byte-compile-lambda, make a form which produces it. | ||
| 2486 | (defun byte-compile-byte-code-maker (fun) | ||
| 2487 | (cond | ||
| 2488 | ;; ## atom is faster than compiled-func-p. | ||
| 2489 | ((atom fun) ; compiled function. | ||
| 2490 | ;; generate-emacs19-bytecodes must be on, otherwise byte-compile-lambda | ||
| 2491 | ;; would have produced a lambda. | ||
| 2492 | fun) | ||
| 2493 | ;; b-c-lambda didn't produce a compiled-function, so it's either a trivial | ||
| 2494 | ;; function, or this is Emacs 18, or generate-emacs19-bytecodes is off. | ||
| 2495 | ((let (tmp) | ||
| 2496 | (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun)))) | ||
| 2497 | (null (cdr (memq tmp fun)))) | ||
| 2498 | ;; Generate a make-byte-code call. | ||
| 2499 | (let* ((interactive (assq 'interactive (cdr (cdr fun))))) | ||
| 2500 | (nconc (list 'make-byte-code | ||
| 2501 | (list 'quote (nth 1 fun)) ;arglist | ||
| 2502 | (nth 1 tmp) ;bytes | ||
| 2503 | (nth 2 tmp) ;consts | ||
| 2504 | (nth 3 tmp)) ;depth | ||
| 2505 | (cond ((stringp (nth 2 fun)) | ||
| 2506 | (list (nth 2 fun))) ;doc | ||
| 2507 | (interactive | ||
| 2508 | (list nil))) | ||
| 2509 | (cond (interactive | ||
| 2510 | (list (if (or (null (nth 1 interactive)) | ||
| 2511 | (stringp (nth 1 interactive))) | ||
| 2512 | (nth 1 interactive) | ||
| 2513 | ;; Interactive spec is a list or a variable | ||
| 2514 | ;; (if it is correct). | ||
| 2515 | (list 'quote (nth 1 interactive)))))))) | ||
| 2516 | ;; a non-compiled function (probably trivial) | ||
| 2517 | (list 'quote fun)))))) | ||
| 2518 | |||
| 2519 | ;; Turn a function into an ordinary lambda. Needed for v18 files. | ||
| 2520 | (defun byte-compile-byte-code-unmake (function) | ||
| 2521 | (if (consp function) | ||
| 2522 | function;;It already is a lambda. | ||
| 2523 | (setq function (append function nil)) ; turn it into a list | ||
| 2524 | (nconc (list 'lambda (nth 0 function)) | ||
| 2525 | (and (nth 4 function) (list (nth 4 function))) | ||
| 2526 | (if (nthcdr 5 function) | ||
| 2527 | (list (cons 'interactive (if (nth 5 function) | ||
| 2528 | (nthcdr 5 function))))) | ||
| 2529 | (list (list 'byte-code | ||
| 2530 | (nth 1 function) (nth 2 function) | ||
| 2531 | (nth 3 function)))))) | ||
| 2532 | |||
| 2533 | 2516 | ||
| 2534 | (defun byte-compile-check-lambda-list (list) | 2517 | (defun byte-compile-check-lambda-list (list) |
| 2535 | "Check lambda-list LIST for errors." | 2518 | "Check lambda-list LIST for errors." |
| @@ -2556,6 +2539,44 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2556 | (setq list (cdr list))))) | 2539 | (setq list (cdr list))))) |
| 2557 | 2540 | ||
| 2558 | 2541 | ||
| 2542 | (defun byte-compile-arglist-vars (arglist) | ||
| 2543 | "Return a list of the variables in the lambda argument list ARGLIST." | ||
| 2544 | (remq '&rest (remq '&optional arglist))) | ||
| 2545 | |||
| 2546 | (defun byte-compile-make-lambda-lexenv (form) | ||
| 2547 | "Return a new lexical environment for a lambda expression FORM." | ||
| 2548 | ;; See if this is a closure or not | ||
| 2549 | (let ((args (byte-compile-arglist-vars (cadr form)))) | ||
| 2550 | (let ((lexenv nil)) | ||
| 2551 | ;; Fill in the initial stack contents | ||
| 2552 | (let ((stackpos 0)) | ||
| 2553 | ;; Add entries for each argument | ||
| 2554 | (dolist (arg args) | ||
| 2555 | (push (cons arg stackpos) lexenv) | ||
| 2556 | (setq stackpos (1+ stackpos))) | ||
| 2557 | ;; Return the new lexical environment | ||
| 2558 | lexenv)))) | ||
| 2559 | |||
| 2560 | (defun byte-compile-make-args-desc (arglist) | ||
| 2561 | (let ((mandatory 0) | ||
| 2562 | nonrest (rest 0)) | ||
| 2563 | (while (and arglist (not (memq (car arglist) '(&optional &rest)))) | ||
| 2564 | (setq mandatory (1+ mandatory)) | ||
| 2565 | (setq arglist (cdr arglist))) | ||
| 2566 | (setq nonrest mandatory) | ||
| 2567 | (when (eq (car arglist) '&optional) | ||
| 2568 | (setq arglist (cdr arglist)) | ||
| 2569 | (while (and arglist (not (eq (car arglist) '&rest))) | ||
| 2570 | (setq nonrest (1+ nonrest)) | ||
| 2571 | (setq arglist (cdr arglist)))) | ||
| 2572 | (when arglist | ||
| 2573 | (setq rest 1)) | ||
| 2574 | (if (> mandatory 127) | ||
| 2575 | (byte-compile-report-error "Too many (>127) mandatory arguments") | ||
| 2576 | (logior mandatory | ||
| 2577 | (lsh nonrest 8) | ||
| 2578 | (lsh rest 7))))) | ||
| 2579 | |||
| 2559 | ;; Byte-compile a lambda-expression and return a valid function. | 2580 | ;; Byte-compile a lambda-expression and return a valid function. |
| 2560 | ;; The value is usually a compiled function but may be the original | 2581 | ;; The value is usually a compiled function but may be the original |
| 2561 | ;; lambda-expression. | 2582 | ;; lambda-expression. |
| @@ -2563,78 +2584,87 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2563 | ;; of the list FUN and `byte-compile-set-symbol-position' is not called. | 2584 | ;; of the list FUN and `byte-compile-set-symbol-position' is not called. |
| 2564 | ;; Use this feature to avoid calling `byte-compile-set-symbol-position' | 2585 | ;; Use this feature to avoid calling `byte-compile-set-symbol-position' |
| 2565 | ;; for symbols generated by the byte compiler itself. | 2586 | ;; for symbols generated by the byte compiler itself. |
| 2566 | (defun byte-compile-lambda (bytecomp-fun &optional add-lambda) | 2587 | (defun byte-compile-lambda (fun &optional add-lambda reserved-csts) |
| 2567 | (if add-lambda | 2588 | (if add-lambda |
| 2568 | (setq bytecomp-fun (cons 'lambda bytecomp-fun)) | 2589 | (setq fun (cons 'lambda fun)) |
| 2569 | (unless (eq 'lambda (car-safe bytecomp-fun)) | 2590 | (unless (eq 'lambda (car-safe fun)) |
| 2570 | (error "Not a lambda list: %S" bytecomp-fun)) | 2591 | (error "Not a lambda list: %S" fun)) |
| 2571 | (byte-compile-set-symbol-position 'lambda)) | 2592 | (byte-compile-set-symbol-position 'lambda)) |
| 2572 | (byte-compile-check-lambda-list (nth 1 bytecomp-fun)) | 2593 | (byte-compile-check-lambda-list (nth 1 fun)) |
| 2573 | (let* ((bytecomp-arglist (nth 1 bytecomp-fun)) | 2594 | (let* ((arglist (nth 1 fun)) |
| 2574 | (byte-compile-bound-variables | 2595 | (byte-compile-bound-variables |
| 2575 | (nconc (and (byte-compile-warning-enabled-p 'free-vars) | 2596 | (append (and (not lexical-binding) |
| 2576 | (delq '&rest | 2597 | (byte-compile-arglist-vars arglist)) |
| 2577 | (delq '&optional (copy-sequence bytecomp-arglist)))) | 2598 | byte-compile-bound-variables)) |
| 2578 | byte-compile-bound-variables)) | 2599 | (body (cdr (cdr fun))) |
| 2579 | (bytecomp-body (cdr (cdr bytecomp-fun))) | 2600 | (doc (if (stringp (car body)) |
| 2580 | (bytecomp-doc (if (stringp (car bytecomp-body)) | 2601 | (prog1 (car body) |
| 2581 | (prog1 (car bytecomp-body) | 2602 | ;; Discard the doc string |
| 2582 | ;; Discard the doc string | 2603 | ;; unless it is the last element of the body. |
| 2583 | ;; unless it is the last element of the body. | 2604 | (if (cdr body) |
| 2584 | (if (cdr bytecomp-body) | 2605 | (setq body (cdr body)))))) |
| 2585 | (setq bytecomp-body (cdr bytecomp-body)))))) | 2606 | (int (assq 'interactive body))) |
| 2586 | (bytecomp-int (assq 'interactive bytecomp-body))) | ||
| 2587 | ;; Process the interactive spec. | 2607 | ;; Process the interactive spec. |
| 2588 | (when bytecomp-int | 2608 | (when int |
| 2589 | (byte-compile-set-symbol-position 'interactive) | 2609 | (byte-compile-set-symbol-position 'interactive) |
| 2590 | ;; Skip (interactive) if it is in front (the most usual location). | 2610 | ;; Skip (interactive) if it is in front (the most usual location). |
| 2591 | (if (eq bytecomp-int (car bytecomp-body)) | 2611 | (if (eq int (car body)) |
| 2592 | (setq bytecomp-body (cdr bytecomp-body))) | 2612 | (setq body (cdr body))) |
| 2593 | (cond ((consp (cdr bytecomp-int)) | 2613 | (cond ((consp (cdr int)) |
| 2594 | (if (cdr (cdr bytecomp-int)) | 2614 | (if (cdr (cdr int)) |
| 2595 | (byte-compile-warn "malformed interactive spec: %s" | 2615 | (byte-compile-warn "malformed interactive spec: %s" |
| 2596 | (prin1-to-string bytecomp-int))) | 2616 | (prin1-to-string int))) |
| 2597 | ;; If the interactive spec is a call to `list', don't | 2617 | ;; If the interactive spec is a call to `list', don't |
| 2598 | ;; compile it, because `call-interactively' looks at the | 2618 | ;; compile it, because `call-interactively' looks at the |
| 2599 | ;; args of `list'. Actually, compile it to get warnings, | 2619 | ;; args of `list'. Actually, compile it to get warnings, |
| 2600 | ;; but don't use the result. | 2620 | ;; but don't use the result. |
| 2601 | (let ((form (nth 1 bytecomp-int))) | 2621 | (let* ((form (nth 1 int)) |
| 2622 | (newform (byte-compile-top-level form))) | ||
| 2602 | (while (memq (car-safe form) '(let let* progn save-excursion)) | 2623 | (while (memq (car-safe form) '(let let* progn save-excursion)) |
| 2603 | (while (consp (cdr form)) | 2624 | (while (consp (cdr form)) |
| 2604 | (setq form (cdr form))) | 2625 | (setq form (cdr form))) |
| 2605 | (setq form (car form))) | 2626 | (setq form (car form))) |
| 2606 | (if (eq (car-safe form) 'list) | 2627 | (if (and (eq (car-safe form) 'list) |
| 2607 | (byte-compile-top-level (nth 1 bytecomp-int)) | 2628 | ;; The spec is evaled in callint.c in dynamic-scoping |
| 2608 | (setq bytecomp-int (list 'interactive | 2629 | ;; mode, so just leaving the form unchanged would mean |
| 2609 | (byte-compile-top-level | 2630 | ;; it won't be eval'd in the right mode. |
| 2610 | (nth 1 bytecomp-int))))))) | 2631 | (not lexical-binding)) |
| 2611 | ((cdr bytecomp-int) | 2632 | nil |
| 2633 | (setq int `(interactive ,newform))))) | ||
| 2634 | ((cdr int) | ||
| 2612 | (byte-compile-warn "malformed interactive spec: %s" | 2635 | (byte-compile-warn "malformed interactive spec: %s" |
| 2613 | (prin1-to-string bytecomp-int))))) | 2636 | (prin1-to-string int))))) |
| 2614 | ;; Process the body. | 2637 | ;; Process the body. |
| 2615 | (let ((compiled (byte-compile-top-level | 2638 | (let ((compiled |
| 2616 | (cons 'progn bytecomp-body) nil 'lambda))) | 2639 | (byte-compile-top-level (cons 'progn body) nil 'lambda |
| 2640 | ;; If doing lexical binding, push a new | ||
| 2641 | ;; lexical environment containing just the | ||
| 2642 | ;; args (since lambda expressions should be | ||
| 2643 | ;; closed by now). | ||
| 2644 | (and lexical-binding | ||
| 2645 | (byte-compile-make-lambda-lexenv fun)) | ||
| 2646 | reserved-csts))) | ||
| 2617 | ;; Build the actual byte-coded function. | 2647 | ;; Build the actual byte-coded function. |
| 2618 | (if (eq 'byte-code (car-safe compiled)) | 2648 | (if (eq 'byte-code (car-safe compiled)) |
| 2619 | (apply 'make-byte-code | 2649 | (apply 'make-byte-code |
| 2620 | (append (list bytecomp-arglist) | 2650 | (if lexical-binding |
| 2621 | ;; byte-string, constants-vector, stack depth | 2651 | (byte-compile-make-args-desc arglist) |
| 2622 | (cdr compiled) | 2652 | arglist) |
| 2623 | ;; optionally, the doc string. | 2653 | (append |
| 2624 | (if (or bytecomp-doc bytecomp-int) | 2654 | ;; byte-string, constants-vector, stack depth |
| 2625 | (list bytecomp-doc)) | 2655 | (cdr compiled) |
| 2626 | ;; optionally, the interactive spec. | 2656 | ;; optionally, the doc string. |
| 2627 | (if bytecomp-int | 2657 | (cond (lexical-binding |
| 2628 | (list (nth 1 bytecomp-int))))) | 2658 | (require 'help-fns) |
| 2629 | (setq compiled | 2659 | (list (help-add-fundoc-usage doc arglist))) |
| 2630 | (nconc (if bytecomp-int (list bytecomp-int)) | 2660 | ((or doc int) |
| 2631 | (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) | 2661 | (list doc))) |
| 2632 | (compiled (list compiled))))) | 2662 | ;; optionally, the interactive spec. |
| 2633 | (nconc (list 'lambda bytecomp-arglist) | 2663 | (if int |
| 2634 | (if (or bytecomp-doc (stringp (car compiled))) | 2664 | (list (nth 1 int))))) |
| 2635 | (cons bytecomp-doc (cond (compiled) | 2665 | (error "byte-compile-top-level did not return byte-code"))))) |
| 2636 | (bytecomp-body (list nil)))) | 2666 | |
| 2637 | compiled)))))) | 2667 | (defvar byte-compile-reserved-constants 0) |
| 2638 | 2668 | ||
| 2639 | (defun byte-compile-constants-vector () | 2669 | (defun byte-compile-constants-vector () |
| 2640 | ;; Builds the constants-vector from the current variables and constants. | 2670 | ;; Builds the constants-vector from the current variables and constants. |
| @@ -2644,7 +2674,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2644 | ;; Next up to byte-constant-limit are constants, still with one-byte codes. | 2674 | ;; Next up to byte-constant-limit are constants, still with one-byte codes. |
| 2645 | ;; Next variables again, to get 2-byte codes for variable lookup. | 2675 | ;; Next variables again, to get 2-byte codes for variable lookup. |
| 2646 | ;; The rest of the constants and variables need 3-byte byte-codes. | 2676 | ;; The rest of the constants and variables need 3-byte byte-codes. |
| 2647 | (let* ((i -1) | 2677 | (let* ((i (1- byte-compile-reserved-constants)) |
| 2648 | (rest (nreverse byte-compile-variables)) ; nreverse because the first | 2678 | (rest (nreverse byte-compile-variables)) ; nreverse because the first |
| 2649 | (other (nreverse byte-compile-constants)) ; vars often are used most. | 2679 | (other (nreverse byte-compile-constants)) ; vars often are used most. |
| 2650 | ret tmp | 2680 | ret tmp |
| @@ -2655,11 +2685,15 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2655 | limit) | 2685 | limit) |
| 2656 | (while (or rest other) | 2686 | (while (or rest other) |
| 2657 | (setq limit (car limits)) | 2687 | (setq limit (car limits)) |
| 2658 | (while (and rest (not (eq i limit))) | 2688 | (while (and rest (< i limit)) |
| 2659 | (if (setq tmp (assq (car (car rest)) ret)) | 2689 | (cond |
| 2660 | (setcdr (car rest) (cdr tmp)) | 2690 | ((numberp (car rest)) |
| 2691 | (assert (< (car rest) byte-compile-reserved-constants))) | ||
| 2692 | ((setq tmp (assq (car (car rest)) ret)) | ||
| 2693 | (setcdr (car rest) (cdr tmp))) | ||
| 2694 | (t | ||
| 2661 | (setcdr (car rest) (setq i (1+ i))) | 2695 | (setcdr (car rest) (setq i (1+ i))) |
| 2662 | (setq ret (cons (car rest) ret))) | 2696 | (setq ret (cons (car rest) ret)))) |
| 2663 | (setq rest (cdr rest))) | 2697 | (setq rest (cdr rest))) |
| 2664 | (setq limits (cdr limits) | 2698 | (setq limits (cdr limits) |
| 2665 | rest (prog1 other | 2699 | rest (prog1 other |
| @@ -2668,29 +2702,38 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2668 | 2702 | ||
| 2669 | ;; Given an expression FORM, compile it and return an equivalent byte-code | 2703 | ;; Given an expression FORM, compile it and return an equivalent byte-code |
| 2670 | ;; expression (a call to the function byte-code). | 2704 | ;; expression (a call to the function byte-code). |
| 2671 | (defun byte-compile-top-level (form &optional for-effect output-type) | 2705 | (defun byte-compile-top-level (form &optional for-effect output-type |
| 2706 | lexenv reserved-csts) | ||
| 2672 | ;; OUTPUT-TYPE advises about how form is expected to be used: | 2707 | ;; OUTPUT-TYPE advises about how form is expected to be used: |
| 2673 | ;; 'eval or nil -> a single form, | 2708 | ;; 'eval or nil -> a single form, |
| 2674 | ;; 'progn or t -> a list of forms, | 2709 | ;; 'progn or t -> a list of forms, |
| 2675 | ;; 'lambda -> body of a lambda, | 2710 | ;; 'lambda -> body of a lambda, |
| 2676 | ;; 'file -> used at file-level. | 2711 | ;; 'file -> used at file-level. |
| 2677 | (let ((byte-compile-constants nil) | 2712 | (let ((byte-compile--for-effect for-effect) |
| 2713 | (byte-compile-constants nil) | ||
| 2678 | (byte-compile-variables nil) | 2714 | (byte-compile-variables nil) |
| 2679 | (byte-compile-tag-number 0) | 2715 | (byte-compile-tag-number 0) |
| 2680 | (byte-compile-depth 0) | 2716 | (byte-compile-depth 0) |
| 2681 | (byte-compile-maxdepth 0) | 2717 | (byte-compile-maxdepth 0) |
| 2718 | (byte-compile--lexical-environment lexenv) | ||
| 2719 | (byte-compile-reserved-constants (or reserved-csts 0)) | ||
| 2682 | (byte-compile-output nil)) | 2720 | (byte-compile-output nil)) |
| 2683 | (if (memq byte-optimize '(t source)) | 2721 | (if (memq byte-optimize '(t source)) |
| 2684 | (setq form (byte-optimize-form form for-effect))) | 2722 | (setq form (byte-optimize-form form byte-compile--for-effect))) |
| 2685 | (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) | 2723 | (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) |
| 2686 | (setq form (nth 1 form))) | 2724 | (setq form (nth 1 form))) |
| 2687 | (if (and (eq 'byte-code (car-safe form)) | 2725 | ;; Set up things for a lexically-bound function. |
| 2688 | (not (memq byte-optimize '(t byte))) | 2726 | (when (and lexical-binding (eq output-type 'lambda)) |
| 2689 | (stringp (nth 1 form)) (vectorp (nth 2 form)) | 2727 | ;; See how many arguments there are, and set the current stack depth |
| 2690 | (natnump (nth 3 form))) | 2728 | ;; accordingly. |
| 2691 | form | 2729 | (setq byte-compile-depth (length byte-compile--lexical-environment)) |
| 2692 | (byte-compile-form form for-effect) | 2730 | ;; If there are args, output a tag to record the initial |
| 2693 | (byte-compile-out-toplevel for-effect output-type)))) | 2731 | ;; stack-depth for the optimizer. |
| 2732 | (when (> byte-compile-depth 0) | ||
| 2733 | (byte-compile-out-tag (byte-compile-make-tag)))) | ||
| 2734 | ;; Now compile FORM | ||
| 2735 | (byte-compile-form form byte-compile--for-effect) | ||
| 2736 | (byte-compile-out-toplevel byte-compile--for-effect output-type))) | ||
| 2694 | 2737 | ||
| 2695 | (defun byte-compile-out-toplevel (&optional for-effect output-type) | 2738 | (defun byte-compile-out-toplevel (&optional for-effect output-type) |
| 2696 | (if for-effect | 2739 | (if for-effect |
| @@ -2712,7 +2755,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2712 | (setq byte-compile-output (nreverse byte-compile-output)) | 2755 | (setq byte-compile-output (nreverse byte-compile-output)) |
| 2713 | (if (memq byte-optimize '(t byte)) | 2756 | (if (memq byte-optimize '(t byte)) |
| 2714 | (setq byte-compile-output | 2757 | (setq byte-compile-output |
| 2715 | (byte-optimize-lapcode byte-compile-output for-effect))) | 2758 | (byte-optimize-lapcode byte-compile-output))) |
| 2716 | 2759 | ||
| 2717 | ;; Decompile trivial functions: | 2760 | ;; Decompile trivial functions: |
| 2718 | ;; only constants and variables, or a single funcall except in lambdas. | 2761 | ;; only constants and variables, or a single funcall except in lambdas. |
| @@ -2740,34 +2783,35 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2740 | (progn | 2783 | (progn |
| 2741 | (setq rest (nreverse | 2784 | (setq rest (nreverse |
| 2742 | (cdr (memq tmp (reverse byte-compile-output))))) | 2785 | (cdr (memq tmp (reverse byte-compile-output))))) |
| 2743 | (while (cond | 2786 | (while |
| 2744 | ((memq (car (car rest)) '(byte-varref byte-constant)) | 2787 | (cond |
| 2745 | (setq tmp (car (cdr (car rest)))) | 2788 | ((memq (car (car rest)) '(byte-varref byte-constant)) |
| 2746 | (if (if (eq (car (car rest)) 'byte-constant) | 2789 | (setq tmp (car (cdr (car rest)))) |
| 2747 | (or (consp tmp) | 2790 | (if (if (eq (car (car rest)) 'byte-constant) |
| 2748 | (and (symbolp tmp) | 2791 | (or (consp tmp) |
| 2749 | (not (byte-compile-const-symbol-p tmp))))) | 2792 | (and (symbolp tmp) |
| 2750 | (if maycall | 2793 | (not (byte-compile-const-symbol-p tmp))))) |
| 2751 | (setq body (cons (list 'quote tmp) body))) | 2794 | (if maycall |
| 2752 | (setq body (cons tmp body)))) | 2795 | (setq body (cons (list 'quote tmp) body))) |
| 2753 | ((and maycall | 2796 | (setq body (cons tmp body)))) |
| 2754 | ;; Allow a funcall if at most one atom follows it. | 2797 | ((and maycall |
| 2755 | (null (nthcdr 3 rest)) | 2798 | ;; Allow a funcall if at most one atom follows it. |
| 2756 | (setq tmp (get (car (car rest)) 'byte-opcode-invert)) | 2799 | (null (nthcdr 3 rest)) |
| 2757 | (or (null (cdr rest)) | 2800 | (setq tmp (get (car (car rest)) 'byte-opcode-invert)) |
| 2758 | (and (memq output-type '(file progn t)) | 2801 | (or (null (cdr rest)) |
| 2759 | (cdr (cdr rest)) | 2802 | (and (memq output-type '(file progn t)) |
| 2760 | (eq (car (nth 1 rest)) 'byte-discard) | 2803 | (cdr (cdr rest)) |
| 2761 | (progn (setq rest (cdr rest)) t)))) | 2804 | (eq (car (nth 1 rest)) 'byte-discard) |
| 2762 | (setq maycall nil) ; Only allow one real function call. | 2805 | (progn (setq rest (cdr rest)) t)))) |
| 2763 | (setq body (nreverse body)) | 2806 | (setq maycall nil) ; Only allow one real function call. |
| 2764 | (setq body (list | 2807 | (setq body (nreverse body)) |
| 2765 | (if (and (eq tmp 'funcall) | 2808 | (setq body (list |
| 2766 | (eq (car-safe (car body)) 'quote)) | 2809 | (if (and (eq tmp 'funcall) |
| 2767 | (cons (nth 1 (car body)) (cdr body)) | 2810 | (eq (car-safe (car body)) 'quote)) |
| 2768 | (cons tmp body)))) | 2811 | (cons (nth 1 (car body)) (cdr body)) |
| 2769 | (or (eq output-type 'file) | 2812 | (cons tmp body)))) |
| 2770 | (not (delq nil (mapcar 'consp (cdr (car body)))))))) | 2813 | (or (eq output-type 'file) |
| 2814 | (not (delq nil (mapcar 'consp (cdr (car body)))))))) | ||
| 2771 | (setq rest (cdr rest))) | 2815 | (setq rest (cdr rest))) |
| 2772 | rest)) | 2816 | rest)) |
| 2773 | (let ((byte-compile-vector (byte-compile-constants-vector))) | 2817 | (let ((byte-compile-vector (byte-compile-constants-vector))) |
| @@ -2777,94 +2821,108 @@ If FORM is a lambda or a macro, byte-compile it as a function." | |||
| 2777 | ((cdr body) (cons 'progn (nreverse body))) | 2821 | ((cdr body) (cons 'progn (nreverse body))) |
| 2778 | ((car body))))) | 2822 | ((car body))))) |
| 2779 | 2823 | ||
| 2780 | ;; Given BYTECOMP-BODY, compile it and return a new body. | 2824 | ;; Given BODY, compile it and return a new body. |
| 2781 | (defun byte-compile-top-level-body (bytecomp-body &optional for-effect) | 2825 | (defun byte-compile-top-level-body (body &optional for-effect) |
| 2782 | (setq bytecomp-body | 2826 | (setq body |
| 2783 | (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) | 2827 | (byte-compile-top-level (cons 'progn body) for-effect t)) |
| 2784 | (cond ((eq (car-safe bytecomp-body) 'progn) | 2828 | (cond ((eq (car-safe body) 'progn) |
| 2785 | (cdr bytecomp-body)) | 2829 | (cdr body)) |
| 2786 | (bytecomp-body | 2830 | (body |
| 2787 | (list bytecomp-body)))) | 2831 | (list body)))) |
| 2788 | 2832 | ||
| 2789 | (put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function) | 2833 | ;; Special macro-expander used during byte-compilation. |
| 2790 | (defun byte-compile-declare-function (form) | 2834 | (defun byte-compile-macroexpand-declare-function (fn file &rest args) |
| 2791 | (push (cons (nth 1 form) | 2835 | (push (cons fn |
| 2792 | (if (and (> (length form) 3) | 2836 | (if (and (consp args) (listp (car args))) |
| 2793 | (listp (nth 3 form))) | 2837 | (list 'declared (car args)) |
| 2794 | (list 'declared (nth 3 form)) | ||
| 2795 | t)) ; arglist not specified | 2838 | t)) ; arglist not specified |
| 2796 | byte-compile-function-environment) | 2839 | byte-compile-function-environment) |
| 2797 | ;; We are stating that it _will_ be defined at runtime. | 2840 | ;; We are stating that it _will_ be defined at runtime. |
| 2798 | (setq byte-compile-noruntime-functions | 2841 | (setq byte-compile-noruntime-functions |
| 2799 | (delq (nth 1 form) byte-compile-noruntime-functions)) | 2842 | (delq fn byte-compile-noruntime-functions)) |
| 2800 | nil) | 2843 | ;; Delegate the rest to the normal macro definition. |
| 2844 | (macroexpand `(declare-function ,fn ,file ,@args))) | ||
| 2801 | 2845 | ||
| 2802 | 2846 | ||
| 2803 | ;; This is the recursive entry point for compiling each subform of an | 2847 | ;; This is the recursive entry point for compiling each subform of an |
| 2804 | ;; expression. | 2848 | ;; expression. |
| 2805 | ;; If for-effect is non-nil, byte-compile-form will output a byte-discard | 2849 | ;; If for-effect is non-nil, byte-compile-form will output a byte-discard |
| 2806 | ;; before terminating (ie no value will be left on the stack). | 2850 | ;; before terminating (ie no value will be left on the stack). |
| 2807 | ;; A byte-compile handler may, when for-effect is non-nil, choose output code | 2851 | ;; A byte-compile handler may, when byte-compile--for-effect is non-nil, choose |
| 2808 | ;; which does not leave a value on the stack, and then set for-effect to nil | 2852 | ;; output code which does not leave a value on the stack, and then set |
| 2809 | ;; (to prevent byte-compile-form from outputting the byte-discard). | 2853 | ;; byte-compile--for-effect to nil (to prevent byte-compile-form from |
| 2854 | ;; outputting the byte-discard). | ||
| 2810 | ;; If a handler wants to call another handler, it should do so via | 2855 | ;; If a handler wants to call another handler, it should do so via |
| 2811 | ;; byte-compile-form, or take extreme care to handle for-effect correctly. | 2856 | ;; byte-compile-form, or take extreme care to handle byte-compile--for-effect |
| 2812 | ;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) | 2857 | ;; correctly. (Use byte-compile-form-do-effect to reset the |
| 2858 | ;; byte-compile--for-effect flag too.) | ||
| 2813 | ;; | 2859 | ;; |
| 2814 | (defun byte-compile-form (form &optional for-effect) | 2860 | (defun byte-compile-form (form &optional for-effect) |
| 2815 | (setq form (macroexpand form byte-compile-macro-environment)) | 2861 | (let ((byte-compile--for-effect for-effect)) |
| 2816 | (cond ((not (consp form)) | 2862 | (cond |
| 2817 | (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) | 2863 | ((not (consp form)) |
| 2818 | (when (symbolp form) | 2864 | (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) |
| 2819 | (byte-compile-set-symbol-position form)) | 2865 | (when (symbolp form) |
| 2820 | (byte-compile-constant form)) | 2866 | (byte-compile-set-symbol-position form)) |
| 2821 | ((and for-effect byte-compile-delete-errors) | 2867 | (byte-compile-constant form)) |
| 2822 | (when (symbolp form) | 2868 | ((and byte-compile--for-effect byte-compile-delete-errors) |
| 2823 | (byte-compile-set-symbol-position form)) | 2869 | (when (symbolp form) |
| 2824 | (setq for-effect nil)) | 2870 | (byte-compile-set-symbol-position form)) |
| 2825 | (t (byte-compile-variable-ref 'byte-varref form)))) | 2871 | (setq byte-compile--for-effect nil)) |
| 2826 | ((symbolp (car form)) | 2872 | (t |
| 2827 | (let* ((bytecomp-fn (car form)) | 2873 | (byte-compile-variable-ref form)))) |
| 2828 | (bytecomp-handler (get bytecomp-fn 'byte-compile))) | 2874 | ((symbolp (car form)) |
| 2829 | (when (byte-compile-const-symbol-p bytecomp-fn) | 2875 | (let* ((fn (car form)) |
| 2830 | (byte-compile-warn "`%s' called as a function" bytecomp-fn)) | 2876 | (handler (get fn 'byte-compile))) |
| 2831 | (and (byte-compile-warning-enabled-p 'interactive-only) | 2877 | (when (byte-compile-const-symbol-p fn) |
| 2832 | (memq bytecomp-fn byte-compile-interactive-only-functions) | 2878 | (byte-compile-warn "`%s' called as a function" fn)) |
| 2833 | (byte-compile-warn "`%s' used from Lisp code\n\ | 2879 | (and (byte-compile-warning-enabled-p 'interactive-only) |
| 2834 | That command is designed for interactive use only" bytecomp-fn)) | 2880 | (memq fn byte-compile-interactive-only-functions) |
| 2835 | (when (byte-compile-warning-enabled-p 'callargs) | 2881 | (byte-compile-warn "`%s' used from Lisp code\n\ |
| 2836 | (if (memq bytecomp-fn | 2882 | That command is designed for interactive use only" fn)) |
| 2837 | '(custom-declare-group custom-declare-variable | 2883 | (if (and (fboundp (car form)) |
| 2838 | custom-declare-face)) | 2884 | (eq (car-safe (symbol-function (car form))) 'macro)) |
| 2839 | (byte-compile-nogroup-warn form)) | 2885 | (byte-compile-report-error |
| 2840 | (byte-compile-callargs-warn form)) | 2886 | (format "Forgot to expand macro %s" (car form)))) |
| 2841 | (if (and bytecomp-handler | 2887 | (if (and handler |
| 2842 | ;; Make sure that function exists. This is important | 2888 | ;; Make sure that function exists. This is important |
| 2843 | ;; for CL compiler macros since the symbol may be | 2889 | ;; for CL compiler macros since the symbol may be |
| 2844 | ;; `cl-byte-compile-compiler-macro' but if CL isn't | 2890 | ;; `cl-byte-compile-compiler-macro' but if CL isn't |
| 2845 | ;; loaded, this function doesn't exist. | 2891 | ;; loaded, this function doesn't exist. |
| 2846 | (or (not (memq bytecomp-handler | 2892 | (and (not (eq handler |
| 2847 | '(cl-byte-compile-compiler-macro))) | 2893 | ;; Already handled by macroexpand-all. |
| 2848 | (functionp bytecomp-handler))) | 2894 | 'cl-byte-compile-compiler-macro)) |
| 2849 | (funcall bytecomp-handler form) | 2895 | (functionp handler))) |
| 2850 | (byte-compile-normal-call form)) | 2896 | (funcall handler form) |
| 2851 | (if (byte-compile-warning-enabled-p 'cl-functions) | 2897 | (byte-compile-normal-call form)) |
| 2852 | (byte-compile-cl-warn form)))) | 2898 | (if (byte-compile-warning-enabled-p 'cl-functions) |
| 2853 | ((and (or (byte-code-function-p (car form)) | 2899 | (byte-compile-cl-warn form)))) |
| 2854 | (eq (car-safe (car form)) 'lambda)) | 2900 | ((and (byte-code-function-p (car form)) |
| 2855 | ;; if the form comes out the same way it went in, that's | 2901 | (memq byte-optimize '(t lap))) |
| 2856 | ;; because it was malformed, and we couldn't unfold it. | 2902 | (byte-compile-unfold-bcf form)) |
| 2857 | (not (eq form (setq form (byte-compile-unfold-lambda form))))) | 2903 | ((and (eq (car-safe (car form)) 'lambda) |
| 2858 | (byte-compile-form form for-effect) | 2904 | ;; if the form comes out the same way it went in, that's |
| 2859 | (setq for-effect nil)) | 2905 | ;; because it was malformed, and we couldn't unfold it. |
| 2860 | ((byte-compile-normal-call form))) | 2906 | (not (eq form (setq form (byte-compile-unfold-lambda form))))) |
| 2861 | (if for-effect | 2907 | (byte-compile-form form byte-compile--for-effect) |
| 2862 | (byte-compile-discard))) | 2908 | (setq byte-compile--for-effect nil)) |
| 2909 | ((byte-compile-normal-call form))) | ||
| 2910 | (if byte-compile--for-effect | ||
| 2911 | (byte-compile-discard)))) | ||
| 2863 | 2912 | ||
| 2864 | (defun byte-compile-normal-call (form) | 2913 | (defun byte-compile-normal-call (form) |
| 2914 | (when (and (byte-compile-warning-enabled-p 'callargs) | ||
| 2915 | (symbolp (car form))) | ||
| 2916 | (if (memq (car form) | ||
| 2917 | '(custom-declare-group custom-declare-variable | ||
| 2918 | custom-declare-face)) | ||
| 2919 | (byte-compile-nogroup-warn form)) | ||
| 2920 | (when (get (car form) 'byte-obsolete-info) | ||
| 2921 | (byte-compile-warn-obsolete (car form))) | ||
| 2922 | (byte-compile-callargs-warn form)) | ||
| 2865 | (if byte-compile-generate-call-tree | 2923 | (if byte-compile-generate-call-tree |
| 2866 | (byte-compile-annotate-call-tree form)) | 2924 | (byte-compile-annotate-call-tree form)) |
| 2867 | (when (and for-effect (eq (car form) 'mapcar) | 2925 | (when (and byte-compile--for-effect (eq (car form) 'mapcar) |
| 2868 | (byte-compile-warning-enabled-p 'mapcar)) | 2926 | (byte-compile-warning-enabled-p 'mapcar)) |
| 2869 | (byte-compile-set-symbol-position 'mapcar) | 2927 | (byte-compile-set-symbol-position 'mapcar) |
| 2870 | (byte-compile-warn | 2928 | (byte-compile-warn |
| @@ -2873,44 +2931,142 @@ That command is designed for interactive use only" bytecomp-fn)) | |||
| 2873 | (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. | 2931 | (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. |
| 2874 | (byte-compile-out 'byte-call (length (cdr form)))) | 2932 | (byte-compile-out 'byte-call (length (cdr form)))) |
| 2875 | 2933 | ||
| 2876 | (defun byte-compile-variable-ref (base-op bytecomp-var) | 2934 | |
| 2877 | (when (symbolp bytecomp-var) | 2935 | ;; Splice the given lap code into the current instruction stream. |
| 2878 | (byte-compile-set-symbol-position bytecomp-var)) | 2936 | ;; If it has any labels in it, you're responsible for making sure there |
| 2879 | (if (or (not (symbolp bytecomp-var)) | 2937 | ;; are no collisions, and that byte-compile-tag-number is reasonable |
| 2880 | (byte-compile-const-symbol-p bytecomp-var | 2938 | ;; after this is spliced in. The provided list is destroyed. |
| 2881 | (not (eq base-op 'byte-varref)))) | 2939 | (defun byte-compile-inline-lapcode (lap end-depth) |
| 2882 | (if (byte-compile-warning-enabled-p 'constants) | 2940 | ;; "Replay" the operations: we used to just do |
| 2883 | (byte-compile-warn | 2941 | ;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output)) |
| 2884 | (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'") | 2942 | ;; but that fails to update byte-compile-depth, so we had to assume |
| 2885 | ((eq base-op 'byte-varset) "variable assignment to %s `%s'") | 2943 | ;; that `lap' ends up adding exactly 1 element to the stack. This |
| 2886 | (t "variable reference to %s `%s'")) | 2944 | ;; happens to be true for byte-code generated by bytecomp.el without |
| 2887 | (if (symbolp bytecomp-var) "constant" "nonvariable") | 2945 | ;; lexical-binding, but it's not true in general, and it's not true for |
| 2888 | (prin1-to-string bytecomp-var))) | 2946 | ;; code output by bytecomp.el with lexical-binding. |
| 2889 | (and (get bytecomp-var 'byte-obsolete-variable) | 2947 | (let ((endtag (byte-compile-make-tag))) |
| 2890 | (not (memq bytecomp-var byte-compile-not-obsolete-vars)) | 2948 | (dolist (op lap) |
| 2891 | (byte-compile-warn-obsolete bytecomp-var)) | 2949 | (cond |
| 2892 | (if (eq base-op 'byte-varbind) | 2950 | ((eq (car op) 'TAG) (byte-compile-out-tag op)) |
| 2893 | (push bytecomp-var byte-compile-bound-variables) | 2951 | ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op))) |
| 2894 | (or (not (byte-compile-warning-enabled-p 'free-vars)) | 2952 | ((eq (car op) 'byte-return) |
| 2895 | (boundp bytecomp-var) | 2953 | (byte-compile-discard (- byte-compile-depth end-depth) t) |
| 2896 | (memq bytecomp-var byte-compile-bound-variables) | 2954 | (byte-compile-goto 'byte-goto endtag)) |
| 2897 | (if (eq base-op 'byte-varset) | 2955 | (t (byte-compile-out (car op) (cdr op))))) |
| 2898 | (or (memq bytecomp-var byte-compile-free-assignments) | 2956 | (byte-compile-out-tag endtag))) |
| 2899 | (progn | 2957 | |
| 2900 | (byte-compile-warn "assignment to free variable `%s'" | 2958 | (defun byte-compile-unfold-bcf (form) |
| 2901 | bytecomp-var) | 2959 | "Inline call to byte-code-functions." |
| 2902 | (push bytecomp-var byte-compile-free-assignments))) | 2960 | (let* ((byte-compile-bound-variables byte-compile-bound-variables) |
| 2903 | (or (memq bytecomp-var byte-compile-free-references) | 2961 | (fun (car form)) |
| 2904 | (progn | 2962 | (fargs (aref fun 0)) |
| 2905 | (byte-compile-warn "reference to free variable `%s'" | 2963 | (start-depth byte-compile-depth) |
| 2906 | bytecomp-var) | 2964 | (fmax2 (if (numberp fargs) (lsh fargs -7))) ;2*max+rest. |
| 2907 | (push bytecomp-var byte-compile-free-references))))))) | 2965 | ;; (fmin (if (numberp fargs) (logand fargs 127))) |
| 2908 | (let ((tmp (assq bytecomp-var byte-compile-variables))) | 2966 | (alen (length (cdr form))) |
| 2967 | (dynbinds ())) | ||
| 2968 | (fetch-bytecode fun) | ||
| 2969 | (mapc 'byte-compile-form (cdr form)) | ||
| 2970 | (unless fmax2 | ||
| 2971 | ;; Old-style byte-code. | ||
| 2972 | (assert (listp fargs)) | ||
| 2973 | (while fargs | ||
| 2974 | (case (car fargs) | ||
| 2975 | (&optional (setq fargs (cdr fargs))) | ||
| 2976 | (&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1)) | ||
| 2977 | (push (cadr fargs) dynbinds) | ||
| 2978 | (setq fargs nil)) | ||
| 2979 | (t (push (pop fargs) dynbinds)))) | ||
| 2980 | (unless fmax2 (setq fmax2 (* 2 (length dynbinds))))) | ||
| 2981 | (cond | ||
| 2982 | ((<= (+ alen alen) fmax2) | ||
| 2983 | ;; Add missing &optional (or &rest) arguments. | ||
| 2984 | (dotimes (i (- (/ (1+ fmax2) 2) alen)) | ||
| 2985 | (byte-compile-push-constant nil))) | ||
| 2986 | ((zerop (logand fmax2 1)) | ||
| 2987 | (byte-compile-log-warning "Too many arguments for inlined function" | ||
| 2988 | nil :error) | ||
| 2989 | (byte-compile-discard (- alen (/ fmax2 2)))) | ||
| 2990 | (t | ||
| 2991 | ;; Turn &rest args into a list. | ||
| 2992 | (let ((n (- alen (/ (1- fmax2) 2)))) | ||
| 2993 | (assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n) | ||
| 2994 | (if (< n 5) | ||
| 2995 | (byte-compile-out | ||
| 2996 | (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n)) | ||
| 2997 | 0) | ||
| 2998 | (byte-compile-out 'byte-listN n))))) | ||
| 2999 | (mapc #'byte-compile-dynamic-variable-bind dynbinds) | ||
| 3000 | (byte-compile-inline-lapcode | ||
| 3001 | (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t) | ||
| 3002 | (1+ start-depth)) | ||
| 3003 | ;; Unbind dynamic variables. | ||
| 3004 | (when dynbinds | ||
| 3005 | (byte-compile-out 'byte-unbind (length dynbinds))) | ||
| 3006 | (assert (eq byte-compile-depth (1+ start-depth)) | ||
| 3007 | nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth))) | ||
| 3008 | |||
| 3009 | (defun byte-compile-check-variable (var &optional binding) | ||
| 3010 | "Do various error checks before a use of the variable VAR. | ||
| 3011 | If BINDING is non-nil, VAR is being bound." | ||
| 3012 | (when (symbolp var) | ||
| 3013 | (byte-compile-set-symbol-position var)) | ||
| 3014 | (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var)) | ||
| 3015 | (when (byte-compile-warning-enabled-p 'constants) | ||
| 3016 | (byte-compile-warn (if binding | ||
| 3017 | "attempt to let-bind %s `%s`" | ||
| 3018 | "variable reference to %s `%s'") | ||
| 3019 | (if (symbolp var) "constant" "nonvariable") | ||
| 3020 | (prin1-to-string var)))) | ||
| 3021 | ((and (get var 'byte-obsolete-variable) | ||
| 3022 | (not (memq var byte-compile-not-obsolete-vars))) | ||
| 3023 | (byte-compile-warn-obsolete var)))) | ||
| 3024 | |||
| 3025 | (defsubst byte-compile-dynamic-variable-op (base-op var) | ||
| 3026 | (let ((tmp (assq var byte-compile-variables))) | ||
| 2909 | (unless tmp | 3027 | (unless tmp |
| 2910 | (setq tmp (list bytecomp-var)) | 3028 | (setq tmp (list var)) |
| 2911 | (push tmp byte-compile-variables)) | 3029 | (push tmp byte-compile-variables)) |
| 2912 | (byte-compile-out base-op tmp))) | 3030 | (byte-compile-out base-op tmp))) |
| 2913 | 3031 | ||
| 3032 | (defun byte-compile-dynamic-variable-bind (var) | ||
| 3033 | "Generate code to bind the lexical variable VAR to the top-of-stack value." | ||
| 3034 | (byte-compile-check-variable var t) | ||
| 3035 | (push var byte-compile-bound-variables) | ||
| 3036 | (byte-compile-dynamic-variable-op 'byte-varbind var)) | ||
| 3037 | |||
| 3038 | (defun byte-compile-variable-ref (var) | ||
| 3039 | "Generate code to push the value of the variable VAR on the stack." | ||
| 3040 | (byte-compile-check-variable var) | ||
| 3041 | (let ((lex-binding (assq var byte-compile--lexical-environment))) | ||
| 3042 | (if lex-binding | ||
| 3043 | ;; VAR is lexically bound | ||
| 3044 | (byte-compile-stack-ref (cdr lex-binding)) | ||
| 3045 | ;; VAR is dynamically bound | ||
| 3046 | (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) | ||
| 3047 | (boundp var) | ||
| 3048 | (memq var byte-compile-bound-variables) | ||
| 3049 | (memq var byte-compile-free-references)) | ||
| 3050 | (byte-compile-warn "reference to free variable `%S'" var) | ||
| 3051 | (push var byte-compile-free-references)) | ||
| 3052 | (byte-compile-dynamic-variable-op 'byte-varref var)))) | ||
| 3053 | |||
| 3054 | (defun byte-compile-variable-set (var) | ||
| 3055 | "Generate code to set the variable VAR from the top-of-stack value." | ||
| 3056 | (byte-compile-check-variable var) | ||
| 3057 | (let ((lex-binding (assq var byte-compile--lexical-environment))) | ||
| 3058 | (if lex-binding | ||
| 3059 | ;; VAR is lexically bound | ||
| 3060 | (byte-compile-stack-set (cdr lex-binding)) | ||
| 3061 | ;; VAR is dynamically bound | ||
| 3062 | (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) | ||
| 3063 | (boundp var) | ||
| 3064 | (memq var byte-compile-bound-variables) | ||
| 3065 | (memq var byte-compile-free-assignments)) | ||
| 3066 | (byte-compile-warn "assignment to free variable `%s'" var) | ||
| 3067 | (push var byte-compile-free-assignments)) | ||
| 3068 | (byte-compile-dynamic-variable-op 'byte-varset var)))) | ||
| 3069 | |||
| 2914 | (defmacro byte-compile-get-constant (const) | 3070 | (defmacro byte-compile-get-constant (const) |
| 2915 | `(or (if (stringp ,const) | 3071 | `(or (if (stringp ,const) |
| 2916 | ;; In a string constant, treat properties as significant. | 3072 | ;; In a string constant, treat properties as significant. |
| @@ -2923,20 +3079,20 @@ That command is designed for interactive use only" bytecomp-fn)) | |||
| 2923 | (car (setq byte-compile-constants | 3079 | (car (setq byte-compile-constants |
| 2924 | (cons (list ,const) byte-compile-constants))))) | 3080 | (cons (list ,const) byte-compile-constants))))) |
| 2925 | 3081 | ||
| 2926 | ;; Use this when the value of a form is a constant. This obeys for-effect. | 3082 | ;; Use this when the value of a form is a constant. |
| 3083 | ;; This obeys byte-compile--for-effect. | ||
| 2927 | (defun byte-compile-constant (const) | 3084 | (defun byte-compile-constant (const) |
| 2928 | (if for-effect | 3085 | (if byte-compile--for-effect |
| 2929 | (setq for-effect nil) | 3086 | (setq byte-compile--for-effect nil) |
| 2930 | (when (symbolp const) | 3087 | (when (symbolp const) |
| 2931 | (byte-compile-set-symbol-position const)) | 3088 | (byte-compile-set-symbol-position const)) |
| 2932 | (byte-compile-out 'byte-constant (byte-compile-get-constant const)))) | 3089 | (byte-compile-out 'byte-constant (byte-compile-get-constant const)))) |
| 2933 | 3090 | ||
| 2934 | ;; Use this for a constant that is not the value of its containing form. | 3091 | ;; Use this for a constant that is not the value of its containing form. |
| 2935 | ;; This ignores for-effect. | 3092 | ;; This ignores byte-compile--for-effect. |
| 2936 | (defun byte-compile-push-constant (const) | 3093 | (defun byte-compile-push-constant (const) |
| 2937 | (let ((for-effect nil)) | 3094 | (let ((byte-compile--for-effect nil)) |
| 2938 | (inline (byte-compile-constant const)))) | 3095 | (inline (byte-compile-constant const)))) |
| 2939 | |||
| 2940 | 3096 | ||
| 2941 | ;; Compile those primitive ordinary functions | 3097 | ;; Compile those primitive ordinary functions |
| 2942 | ;; which have special byte codes just for speed. | 3098 | ;; which have special byte codes just for speed. |
| @@ -3007,7 +3163,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" | |||
| 3007 | (byte-defop-compiler bobp 0) | 3163 | (byte-defop-compiler bobp 0) |
| 3008 | (byte-defop-compiler current-buffer 0) | 3164 | (byte-defop-compiler current-buffer 0) |
| 3009 | ;;(byte-defop-compiler read-char 0) ;; obsolete | 3165 | ;;(byte-defop-compiler read-char 0) ;; obsolete |
| 3010 | (byte-defop-compiler interactive-p 0) | 3166 | ;; (byte-defop-compiler interactive-p 0) ;; Obsolete. |
| 3011 | (byte-defop-compiler widen 0) | 3167 | (byte-defop-compiler widen 0) |
| 3012 | (byte-defop-compiler end-of-line 0-1) | 3168 | (byte-defop-compiler end-of-line 0-1) |
| 3013 | (byte-defop-compiler forward-char 0-1) | 3169 | (byte-defop-compiler forward-char 0-1) |
| @@ -3090,7 +3246,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" | |||
| 3090 | (byte-compile-warn "`%s' called with %d arg%s, but requires %s" | 3246 | (byte-compile-warn "`%s' called with %d arg%s, but requires %s" |
| 3091 | (car form) (length (cdr form)) | 3247 | (car form) (length (cdr form)) |
| 3092 | (if (= 1 (length (cdr form))) "" "s") n) | 3248 | (if (= 1 (length (cdr form))) "" "s") n) |
| 3093 | ;; get run-time wrong-number-of-args error. | 3249 | ;; Get run-time wrong-number-of-args error. |
| 3094 | (byte-compile-normal-call form)) | 3250 | (byte-compile-normal-call form)) |
| 3095 | 3251 | ||
| 3096 | (defun byte-compile-no-args (form) | 3252 | (defun byte-compile-no-args (form) |
| @@ -3137,12 +3293,66 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" | |||
| 3137 | ((= len 4) (byte-compile-three-args form)) | 3293 | ((= len 4) (byte-compile-three-args form)) |
| 3138 | (t (byte-compile-subr-wrong-args form "2-3"))))) | 3294 | (t (byte-compile-subr-wrong-args form "2-3"))))) |
| 3139 | 3295 | ||
| 3140 | (defun byte-compile-noop (form) | 3296 | (defun byte-compile-noop (_form) |
| 3141 | (byte-compile-constant nil)) | 3297 | (byte-compile-constant nil)) |
| 3142 | 3298 | ||
| 3143 | (defun byte-compile-discard () | 3299 | (defun byte-compile-discard (&optional num preserve-tos) |
| 3144 | (byte-compile-out 'byte-discard 0)) | 3300 | "Output byte codes to discard the NUM entries at the top of the stack. |
| 3145 | 3301 | NUM defaults to 1. | |
| 3302 | If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were | ||
| 3303 | popped before discarding the num values, and then pushed back again after | ||
| 3304 | discarding." | ||
| 3305 | (if (and (null num) (not preserve-tos)) | ||
| 3306 | ;; common case | ||
| 3307 | (byte-compile-out 'byte-discard) | ||
| 3308 | ;; general case | ||
| 3309 | (unless num | ||
| 3310 | (setq num 1)) | ||
| 3311 | (when (and preserve-tos (> num 0)) | ||
| 3312 | ;; Preserve the top-of-stack value by writing it directly to the stack | ||
| 3313 | ;; location which will be at the top-of-stack after popping. | ||
| 3314 | (byte-compile-stack-set (1- (- byte-compile-depth num))) | ||
| 3315 | ;; Now we actually discard one less value, since we want to keep | ||
| 3316 | ;; the eventual TOS | ||
| 3317 | (setq num (1- num))) | ||
| 3318 | (while (> num 0) | ||
| 3319 | (byte-compile-out 'byte-discard) | ||
| 3320 | (setq num (1- num))))) | ||
| 3321 | |||
| 3322 | (defun byte-compile-stack-ref (stack-pos) | ||
| 3323 | "Output byte codes to push the value at stack position STACK-POS." | ||
| 3324 | (let ((dist (- byte-compile-depth (1+ stack-pos)))) | ||
| 3325 | (if (zerop dist) | ||
| 3326 | ;; A simple optimization | ||
| 3327 | (byte-compile-out 'byte-dup) | ||
| 3328 | ;; normal case | ||
| 3329 | (byte-compile-out 'byte-stack-ref dist)))) | ||
| 3330 | |||
| 3331 | (defun byte-compile-stack-set (stack-pos) | ||
| 3332 | "Output byte codes to store the TOS value at stack position STACK-POS." | ||
| 3333 | (byte-compile-out 'byte-stack-set (- byte-compile-depth (1+ stack-pos)))) | ||
| 3334 | |||
| 3335 | (byte-defop-compiler-1 internal-make-closure byte-compile-make-closure) | ||
| 3336 | (byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var) | ||
| 3337 | |||
| 3338 | (defun byte-compile-make-closure (form) | ||
| 3339 | "Byte-compile the special `internal-make-closure' form." | ||
| 3340 | (if byte-compile--for-effect (setq byte-compile--for-effect nil) | ||
| 3341 | (let* ((vars (nth 1 form)) | ||
| 3342 | (env (nth 2 form)) | ||
| 3343 | (body (nthcdr 3 form)) | ||
| 3344 | (fun | ||
| 3345 | (byte-compile-lambda `(lambda ,vars . ,body) nil (length env)))) | ||
| 3346 | (assert (byte-code-function-p fun)) | ||
| 3347 | (byte-compile-form `(make-byte-code | ||
| 3348 | ',(aref fun 0) ',(aref fun 1) | ||
| 3349 | (vconcat (vector . ,env) ',(aref fun 2)) | ||
| 3350 | ,@(nthcdr 3 (mapcar (lambda (x) `',x) fun))))))) | ||
| 3351 | |||
| 3352 | (defun byte-compile-get-closed-var (form) | ||
| 3353 | "Byte-compile the special `internal-get-closed-var' form." | ||
| 3354 | (if byte-compile--for-effect (setq byte-compile--for-effect nil) | ||
| 3355 | (byte-compile-out 'byte-constant (nth 1 form)))) | ||
| 3146 | 3356 | ||
| 3147 | ;; Compile a function that accepts one or more args and is right-associative. | 3357 | ;; Compile a function that accepts one or more args and is right-associative. |
| 3148 | ;; We do it by left-associativity so that the operations | 3358 | ;; We do it by left-associativity so that the operations |
| @@ -3297,43 +3507,17 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" | |||
| 3297 | (byte-compile-warn | 3507 | (byte-compile-warn |
| 3298 | "A quoted lambda form is the second argument of `fset'. This is probably | 3508 | "A quoted lambda form is the second argument of `fset'. This is probably |
| 3299 | not what you want, as that lambda cannot be compiled. Consider using | 3509 | not what you want, as that lambda cannot be compiled. Consider using |
| 3300 | the syntax (function (lambda (...) ...)) instead."))))) | 3510 | the syntax #'(lambda (...) ...) instead."))))) |
| 3301 | (byte-compile-two-args form)) | 3511 | (byte-compile-two-args form)) |
| 3302 | 3512 | ||
| 3303 | (defun byte-compile-funarg (form) | ||
| 3304 | ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) | ||
| 3305 | ;; for cases where it's guaranteed that first arg will be used as a lambda. | ||
| 3306 | (byte-compile-normal-call | ||
| 3307 | (let ((fn (nth 1 form))) | ||
| 3308 | (if (and (eq (car-safe fn) 'quote) | ||
| 3309 | (eq (car-safe (nth 1 fn)) 'lambda)) | ||
| 3310 | (cons (car form) | ||
| 3311 | (cons (cons 'function (cdr fn)) | ||
| 3312 | (cdr (cdr form)))) | ||
| 3313 | form)))) | ||
| 3314 | |||
| 3315 | (defun byte-compile-funarg-2 (form) | ||
| 3316 | ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..))) | ||
| 3317 | ;; for cases where it's guaranteed that second arg will be used as a lambda. | ||
| 3318 | (byte-compile-normal-call | ||
| 3319 | (let ((fn (nth 2 form))) | ||
| 3320 | (if (and (eq (car-safe fn) 'quote) | ||
| 3321 | (eq (car-safe (nth 1 fn)) 'lambda)) | ||
| 3322 | (cons (car form) | ||
| 3323 | (cons (nth 1 form) | ||
| 3324 | (cons (cons 'function (cdr fn)) | ||
| 3325 | (cdr (cdr (cdr form)))))) | ||
| 3326 | form)))) | ||
| 3327 | |||
| 3328 | ;; (function foo) must compile like 'foo, not like (symbol-function 'foo). | 3513 | ;; (function foo) must compile like 'foo, not like (symbol-function 'foo). |
| 3329 | ;; Otherwise it will be incompatible with the interpreter, | 3514 | ;; Otherwise it will be incompatible with the interpreter, |
| 3330 | ;; and (funcall (function foo)) will lose with autoloads. | 3515 | ;; and (funcall (function foo)) will lose with autoloads. |
| 3331 | 3516 | ||
| 3332 | (defun byte-compile-function-form (form) | 3517 | (defun byte-compile-function-form (form) |
| 3333 | (byte-compile-constant | 3518 | (byte-compile-constant (if (symbolp (nth 1 form)) |
| 3334 | (cond ((symbolp (nth 1 form)) | 3519 | (nth 1 form) |
| 3335 | (nth 1 form)) | 3520 | (byte-compile-lambda (nth 1 form))))) |
| 3336 | ((byte-compile-lambda (nth 1 form)))))) | ||
| 3337 | 3521 | ||
| 3338 | (defun byte-compile-indent-to (form) | 3522 | (defun byte-compile-indent-to (form) |
| 3339 | (let ((len (length form))) | 3523 | (let ((len (length form))) |
| @@ -3368,20 +3552,19 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" | |||
| 3368 | (byte-defop-compiler-1 setq) | 3552 | (byte-defop-compiler-1 setq) |
| 3369 | (byte-defop-compiler-1 setq-default) | 3553 | (byte-defop-compiler-1 setq-default) |
| 3370 | (byte-defop-compiler-1 quote) | 3554 | (byte-defop-compiler-1 quote) |
| 3371 | (byte-defop-compiler-1 quote-form) | ||
| 3372 | 3555 | ||
| 3373 | (defun byte-compile-setq (form) | 3556 | (defun byte-compile-setq (form) |
| 3374 | (let ((bytecomp-args (cdr form))) | 3557 | (let ((args (cdr form))) |
| 3375 | (if bytecomp-args | 3558 | (if args |
| 3376 | (while bytecomp-args | 3559 | (while args |
| 3377 | (byte-compile-form (car (cdr bytecomp-args))) | 3560 | (byte-compile-form (car (cdr args))) |
| 3378 | (or for-effect (cdr (cdr bytecomp-args)) | 3561 | (or byte-compile--for-effect (cdr (cdr args)) |
| 3379 | (byte-compile-out 'byte-dup 0)) | 3562 | (byte-compile-out 'byte-dup 0)) |
| 3380 | (byte-compile-variable-ref 'byte-varset (car bytecomp-args)) | 3563 | (byte-compile-variable-set (car args)) |
| 3381 | (setq bytecomp-args (cdr (cdr bytecomp-args)))) | 3564 | (setq args (cdr (cdr args)))) |
| 3382 | ;; (setq), with no arguments. | 3565 | ;; (setq), with no arguments. |
| 3383 | (byte-compile-form nil for-effect)) | 3566 | (byte-compile-form nil byte-compile--for-effect)) |
| 3384 | (setq for-effect nil))) | 3567 | (setq byte-compile--for-effect nil))) |
| 3385 | 3568 | ||
| 3386 | (defun byte-compile-setq-default (form) | 3569 | (defun byte-compile-setq-default (form) |
| 3387 | (setq form (cdr form)) | 3570 | (setq form (cdr form)) |
| @@ -3412,26 +3595,22 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" | |||
| 3412 | 3595 | ||
| 3413 | (defun byte-compile-quote (form) | 3596 | (defun byte-compile-quote (form) |
| 3414 | (byte-compile-constant (car (cdr form)))) | 3597 | (byte-compile-constant (car (cdr form)))) |
| 3415 | |||
| 3416 | (defun byte-compile-quote-form (form) | ||
| 3417 | (byte-compile-constant (byte-compile-top-level (nth 1 form)))) | ||
| 3418 | |||
| 3419 | 3598 | ||
| 3420 | ;;; control structures | 3599 | ;;; control structures |
| 3421 | 3600 | ||
| 3422 | (defun byte-compile-body (bytecomp-body &optional for-effect) | 3601 | (defun byte-compile-body (body &optional for-effect) |
| 3423 | (while (cdr bytecomp-body) | 3602 | (while (cdr body) |
| 3424 | (byte-compile-form (car bytecomp-body) t) | 3603 | (byte-compile-form (car body) t) |
| 3425 | (setq bytecomp-body (cdr bytecomp-body))) | 3604 | (setq body (cdr body))) |
| 3426 | (byte-compile-form (car bytecomp-body) for-effect)) | 3605 | (byte-compile-form (car body) for-effect)) |
| 3427 | 3606 | ||
| 3428 | (defsubst byte-compile-body-do-effect (bytecomp-body) | 3607 | (defsubst byte-compile-body-do-effect (body) |
| 3429 | (byte-compile-body bytecomp-body for-effect) | 3608 | (byte-compile-body body byte-compile--for-effect) |
| 3430 | (setq for-effect nil)) | 3609 | (setq byte-compile--for-effect nil)) |
| 3431 | 3610 | ||
| 3432 | (defsubst byte-compile-form-do-effect (form) | 3611 | (defsubst byte-compile-form-do-effect (form) |
| 3433 | (byte-compile-form form for-effect) | 3612 | (byte-compile-form form byte-compile--for-effect) |
| 3434 | (setq for-effect nil)) | 3613 | (setq byte-compile--for-effect nil)) |
| 3435 | 3614 | ||
| 3436 | (byte-defop-compiler-1 inline byte-compile-progn) | 3615 | (byte-defop-compiler-1 inline byte-compile-progn) |
| 3437 | (byte-defop-compiler-1 progn) | 3616 | (byte-defop-compiler-1 progn) |
| @@ -3443,18 +3622,8 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" | |||
| 3443 | (byte-defop-compiler-1 or) | 3622 | (byte-defop-compiler-1 or) |
| 3444 | (byte-defop-compiler-1 while) | 3623 | (byte-defop-compiler-1 while) |
| 3445 | (byte-defop-compiler-1 funcall) | 3624 | (byte-defop-compiler-1 funcall) |
| 3446 | (byte-defop-compiler-1 apply byte-compile-funarg) | ||
| 3447 | (byte-defop-compiler-1 mapcar byte-compile-funarg) | ||
| 3448 | (byte-defop-compiler-1 mapatoms byte-compile-funarg) | ||
| 3449 | (byte-defop-compiler-1 mapconcat byte-compile-funarg) | ||
| 3450 | (byte-defop-compiler-1 mapc byte-compile-funarg) | ||
| 3451 | (byte-defop-compiler-1 maphash byte-compile-funarg) | ||
| 3452 | (byte-defop-compiler-1 map-char-table byte-compile-funarg) | ||
| 3453 | (byte-defop-compiler-1 map-char-table byte-compile-funarg-2) | ||
| 3454 | ;; map-charset-chars should be funarg but has optional third arg | ||
| 3455 | (byte-defop-compiler-1 sort byte-compile-funarg-2) | ||
| 3456 | (byte-defop-compiler-1 let) | 3625 | (byte-defop-compiler-1 let) |
| 3457 | (byte-defop-compiler-1 let*) | 3626 | (byte-defop-compiler-1 let* byte-compile-let) |
| 3458 | 3627 | ||
| 3459 | (defun byte-compile-progn (form) | 3628 | (defun byte-compile-progn (form) |
| 3460 | (byte-compile-body-do-effect (cdr form))) | 3629 | (byte-compile-body-do-effect (cdr form))) |
| @@ -3519,13 +3688,11 @@ that suppresses all warnings during execution of BODY." | |||
| 3519 | ,condition (list 'boundp 'default-boundp))) | 3688 | ,condition (list 'boundp 'default-boundp))) |
| 3520 | ;; Maybe add to the bound list. | 3689 | ;; Maybe add to the bound list. |
| 3521 | (byte-compile-bound-variables | 3690 | (byte-compile-bound-variables |
| 3522 | (if bound-list | 3691 | (append bound-list byte-compile-bound-variables))) |
| 3523 | (append bound-list byte-compile-bound-variables) | ||
| 3524 | byte-compile-bound-variables))) | ||
| 3525 | (unwind-protect | 3692 | (unwind-protect |
| 3526 | ;; If things not being bound at all is ok, so must them being obsolete. | 3693 | ;; If things not being bound at all is ok, so must them being |
| 3527 | ;; Note that we add to the existing lists since Tramp (ab)uses | 3694 | ;; obsolete. Note that we add to the existing lists since Tramp |
| 3528 | ;; this feature. | 3695 | ;; (ab)uses this feature. |
| 3529 | (let ((byte-compile-not-obsolete-vars | 3696 | (let ((byte-compile-not-obsolete-vars |
| 3530 | (append byte-compile-not-obsolete-vars bound-list)) | 3697 | (append byte-compile-not-obsolete-vars bound-list)) |
| 3531 | (byte-compile-not-obsolete-funcs | 3698 | (byte-compile-not-obsolete-funcs |
| @@ -3547,20 +3714,20 @@ that suppresses all warnings during execution of BODY." | |||
| 3547 | (if (null (nthcdr 3 form)) | 3714 | (if (null (nthcdr 3 form)) |
| 3548 | ;; No else-forms | 3715 | ;; No else-forms |
| 3549 | (progn | 3716 | (progn |
| 3550 | (byte-compile-goto-if nil for-effect donetag) | 3717 | (byte-compile-goto-if nil byte-compile--for-effect donetag) |
| 3551 | (byte-compile-maybe-guarded clause | 3718 | (byte-compile-maybe-guarded clause |
| 3552 | (byte-compile-form (nth 2 form) for-effect)) | 3719 | (byte-compile-form (nth 2 form) byte-compile--for-effect)) |
| 3553 | (byte-compile-out-tag donetag)) | 3720 | (byte-compile-out-tag donetag)) |
| 3554 | (let ((elsetag (byte-compile-make-tag))) | 3721 | (let ((elsetag (byte-compile-make-tag))) |
| 3555 | (byte-compile-goto 'byte-goto-if-nil elsetag) | 3722 | (byte-compile-goto 'byte-goto-if-nil elsetag) |
| 3556 | (byte-compile-maybe-guarded clause | 3723 | (byte-compile-maybe-guarded clause |
| 3557 | (byte-compile-form (nth 2 form) for-effect)) | 3724 | (byte-compile-form (nth 2 form) byte-compile--for-effect)) |
| 3558 | (byte-compile-goto 'byte-goto donetag) | 3725 | (byte-compile-goto 'byte-goto donetag) |
| 3559 | (byte-compile-out-tag elsetag) | 3726 | (byte-compile-out-tag elsetag) |
| 3560 | (byte-compile-maybe-guarded (list 'not clause) | 3727 | (byte-compile-maybe-guarded (list 'not clause) |
| 3561 | (byte-compile-body (cdr (cdr (cdr form))) for-effect)) | 3728 | (byte-compile-body (cdr (cdr (cdr form))) byte-compile--for-effect)) |
| 3562 | (byte-compile-out-tag donetag)))) | 3729 | (byte-compile-out-tag donetag)))) |
| 3563 | (setq for-effect nil)) | 3730 | (setq byte-compile--for-effect nil)) |
| 3564 | 3731 | ||
| 3565 | (defun byte-compile-cond (clauses) | 3732 | (defun byte-compile-cond (clauses) |
| 3566 | (let ((donetag (byte-compile-make-tag)) | 3733 | (let ((donetag (byte-compile-make-tag)) |
| @@ -3577,18 +3744,18 @@ that suppresses all warnings during execution of BODY." | |||
| 3577 | (byte-compile-form (car clause)) | 3744 | (byte-compile-form (car clause)) |
| 3578 | (if (null (cdr clause)) | 3745 | (if (null (cdr clause)) |
| 3579 | ;; First clause is a singleton. | 3746 | ;; First clause is a singleton. |
| 3580 | (byte-compile-goto-if t for-effect donetag) | 3747 | (byte-compile-goto-if t byte-compile--for-effect donetag) |
| 3581 | (setq nexttag (byte-compile-make-tag)) | 3748 | (setq nexttag (byte-compile-make-tag)) |
| 3582 | (byte-compile-goto 'byte-goto-if-nil nexttag) | 3749 | (byte-compile-goto 'byte-goto-if-nil nexttag) |
| 3583 | (byte-compile-maybe-guarded (car clause) | 3750 | (byte-compile-maybe-guarded (car clause) |
| 3584 | (byte-compile-body (cdr clause) for-effect)) | 3751 | (byte-compile-body (cdr clause) byte-compile--for-effect)) |
| 3585 | (byte-compile-goto 'byte-goto donetag) | 3752 | (byte-compile-goto 'byte-goto donetag) |
| 3586 | (byte-compile-out-tag nexttag))))) | 3753 | (byte-compile-out-tag nexttag))))) |
| 3587 | ;; Last clause | 3754 | ;; Last clause |
| 3588 | (let ((guard (car clause))) | 3755 | (let ((guard (car clause))) |
| 3589 | (and (cdr clause) (not (eq guard t)) | 3756 | (and (cdr clause) (not (eq guard t)) |
| 3590 | (progn (byte-compile-form guard) | 3757 | (progn (byte-compile-form guard) |
| 3591 | (byte-compile-goto-if nil for-effect donetag) | 3758 | (byte-compile-goto-if nil byte-compile--for-effect donetag) |
| 3592 | (setq clause (cdr clause)))) | 3759 | (setq clause (cdr clause)))) |
| 3593 | (byte-compile-maybe-guarded guard | 3760 | (byte-compile-maybe-guarded guard |
| 3594 | (byte-compile-body-do-effect clause))) | 3761 | (byte-compile-body-do-effect clause))) |
| @@ -3596,10 +3763,10 @@ that suppresses all warnings during execution of BODY." | |||
| 3596 | 3763 | ||
| 3597 | (defun byte-compile-and (form) | 3764 | (defun byte-compile-and (form) |
| 3598 | (let ((failtag (byte-compile-make-tag)) | 3765 | (let ((failtag (byte-compile-make-tag)) |
| 3599 | (bytecomp-args (cdr form))) | 3766 | (args (cdr form))) |
| 3600 | (if (null bytecomp-args) | 3767 | (if (null args) |
| 3601 | (byte-compile-form-do-effect t) | 3768 | (byte-compile-form-do-effect t) |
| 3602 | (byte-compile-and-recursion bytecomp-args failtag)))) | 3769 | (byte-compile-and-recursion args failtag)))) |
| 3603 | 3770 | ||
| 3604 | ;; Handle compilation of a nontrivial `and' call. | 3771 | ;; Handle compilation of a nontrivial `and' call. |
| 3605 | ;; We use tail recursion so we can use byte-compile-maybe-guarded. | 3772 | ;; We use tail recursion so we can use byte-compile-maybe-guarded. |
| @@ -3607,7 +3774,7 @@ that suppresses all warnings during execution of BODY." | |||
| 3607 | (if (cdr rest) | 3774 | (if (cdr rest) |
| 3608 | (progn | 3775 | (progn |
| 3609 | (byte-compile-form (car rest)) | 3776 | (byte-compile-form (car rest)) |
| 3610 | (byte-compile-goto-if nil for-effect failtag) | 3777 | (byte-compile-goto-if nil byte-compile--for-effect failtag) |
| 3611 | (byte-compile-maybe-guarded (car rest) | 3778 | (byte-compile-maybe-guarded (car rest) |
| 3612 | (byte-compile-and-recursion (cdr rest) failtag))) | 3779 | (byte-compile-and-recursion (cdr rest) failtag))) |
| 3613 | (byte-compile-form-do-effect (car rest)) | 3780 | (byte-compile-form-do-effect (car rest)) |
| @@ -3615,10 +3782,10 @@ that suppresses all warnings during execution of BODY." | |||
| 3615 | 3782 | ||
| 3616 | (defun byte-compile-or (form) | 3783 | (defun byte-compile-or (form) |
| 3617 | (let ((wintag (byte-compile-make-tag)) | 3784 | (let ((wintag (byte-compile-make-tag)) |
| 3618 | (bytecomp-args (cdr form))) | 3785 | (args (cdr form))) |
| 3619 | (if (null bytecomp-args) | 3786 | (if (null args) |
| 3620 | (byte-compile-form-do-effect nil) | 3787 | (byte-compile-form-do-effect nil) |
| 3621 | (byte-compile-or-recursion bytecomp-args wintag)))) | 3788 | (byte-compile-or-recursion args wintag)))) |
| 3622 | 3789 | ||
| 3623 | ;; Handle compilation of a nontrivial `or' call. | 3790 | ;; Handle compilation of a nontrivial `or' call. |
| 3624 | ;; We use tail recursion so we can use byte-compile-maybe-guarded. | 3791 | ;; We use tail recursion so we can use byte-compile-maybe-guarded. |
| @@ -3626,7 +3793,7 @@ that suppresses all warnings during execution of BODY." | |||
| 3626 | (if (cdr rest) | 3793 | (if (cdr rest) |
| 3627 | (progn | 3794 | (progn |
| 3628 | (byte-compile-form (car rest)) | 3795 | (byte-compile-form (car rest)) |
| 3629 | (byte-compile-goto-if t for-effect wintag) | 3796 | (byte-compile-goto-if t byte-compile--for-effect wintag) |
| 3630 | (byte-compile-maybe-guarded (list 'not (car rest)) | 3797 | (byte-compile-maybe-guarded (list 'not (car rest)) |
| 3631 | (byte-compile-or-recursion (cdr rest) wintag))) | 3798 | (byte-compile-or-recursion (cdr rest) wintag))) |
| 3632 | (byte-compile-form-do-effect (car rest)) | 3799 | (byte-compile-form-do-effect (car rest)) |
| @@ -3637,44 +3804,131 @@ that suppresses all warnings during execution of BODY." | |||
| 3637 | (looptag (byte-compile-make-tag))) | 3804 | (looptag (byte-compile-make-tag))) |
| 3638 | (byte-compile-out-tag looptag) | 3805 | (byte-compile-out-tag looptag) |
| 3639 | (byte-compile-form (car (cdr form))) | 3806 | (byte-compile-form (car (cdr form))) |
| 3640 | (byte-compile-goto-if nil for-effect endtag) | 3807 | (byte-compile-goto-if nil byte-compile--for-effect endtag) |
| 3641 | (byte-compile-body (cdr (cdr form)) t) | 3808 | (byte-compile-body (cdr (cdr form)) t) |
| 3642 | (byte-compile-goto 'byte-goto looptag) | 3809 | (byte-compile-goto 'byte-goto looptag) |
| 3643 | (byte-compile-out-tag endtag) | 3810 | (byte-compile-out-tag endtag) |
| 3644 | (setq for-effect nil))) | 3811 | (setq byte-compile--for-effect nil))) |
| 3645 | 3812 | ||
| 3646 | (defun byte-compile-funcall (form) | 3813 | (defun byte-compile-funcall (form) |
| 3647 | (mapc 'byte-compile-form (cdr form)) | 3814 | (mapc 'byte-compile-form (cdr form)) |
| 3648 | (byte-compile-out 'byte-call (length (cdr (cdr form))))) | 3815 | (byte-compile-out 'byte-call (length (cdr (cdr form))))) |
| 3649 | 3816 | ||
| 3817 | |||
| 3818 | ;; let binding | ||
| 3819 | |||
| 3820 | (defun byte-compile-push-binding-init (clause) | ||
| 3821 | "Emit byte-codes to push the initialization value for CLAUSE on the stack. | ||
| 3822 | Return the offset in the form (VAR . OFFSET)." | ||
| 3823 | (let* ((var (if (consp clause) (car clause) clause))) | ||
| 3824 | ;; We record the stack position even of dynamic bindings and | ||
| 3825 | ;; variables in non-stack lexical environments; we'll put | ||
| 3826 | ;; them in the proper place below. | ||
| 3827 | (prog1 (cons var byte-compile-depth) | ||
| 3828 | (if (consp clause) | ||
| 3829 | (byte-compile-form (cadr clause)) | ||
| 3830 | (byte-compile-push-constant nil))))) | ||
| 3831 | |||
| 3832 | (defun byte-compile-not-lexical-var-p (var) | ||
| 3833 | (or (not (symbolp var)) | ||
| 3834 | (special-variable-p var) | ||
| 3835 | (memq var byte-compile-bound-variables) | ||
| 3836 | (memq var '(nil t)) | ||
| 3837 | (keywordp var))) | ||
| 3838 | |||
| 3839 | (defun byte-compile-bind (var init-lexenv) | ||
| 3840 | "Emit byte-codes to bind VAR and update `byte-compile--lexical-environment'. | ||
| 3841 | INIT-LEXENV should be a lexical-environment alist describing the | ||
| 3842 | positions of the init value that have been pushed on the stack. | ||
| 3843 | Return non-nil if the TOS value was popped." | ||
| 3844 | ;; The presence of lexical bindings mean that we may have to | ||
| 3845 | ;; juggle things on the stack, to move them to TOS for | ||
| 3846 | ;; dynamic binding. | ||
| 3847 | (cond ((not (byte-compile-not-lexical-var-p var)) | ||
| 3848 | ;; VAR is a simple stack-allocated lexical variable | ||
| 3849 | (push (assq var init-lexenv) | ||
| 3850 | byte-compile--lexical-environment) | ||
| 3851 | nil) | ||
| 3852 | ((eq var (caar init-lexenv)) | ||
| 3853 | ;; VAR is dynamic and is on the top of the | ||
| 3854 | ;; stack, so we can just bind it like usual | ||
| 3855 | (byte-compile-dynamic-variable-bind var) | ||
| 3856 | t) | ||
| 3857 | (t | ||
| 3858 | ;; VAR is dynamic, but we have to get its | ||
| 3859 | ;; value out of the middle of the stack | ||
| 3860 | (let ((stack-pos (cdr (assq var init-lexenv)))) | ||
| 3861 | (byte-compile-stack-ref stack-pos) | ||
| 3862 | (byte-compile-dynamic-variable-bind var) | ||
| 3863 | ;; Now we have to store nil into its temporary | ||
| 3864 | ;; stack position to avoid problems with GC | ||
| 3865 | (byte-compile-push-constant nil) | ||
| 3866 | (byte-compile-stack-set stack-pos)) | ||
| 3867 | nil))) | ||
| 3868 | |||
| 3869 | (defun byte-compile-unbind (clauses init-lexenv | ||
| 3870 | &optional preserve-body-value) | ||
| 3871 | "Emit byte-codes to unbind the variables bound by CLAUSES. | ||
| 3872 | CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a | ||
| 3873 | lexical-environment alist describing the positions of the init value that | ||
| 3874 | have been pushed on the stack. If PRESERVE-BODY-VALUE is true, | ||
| 3875 | then an additional value on the top of the stack, above any lexical binding | ||
| 3876 | slots, is preserved, so it will be on the top of the stack after all | ||
| 3877 | binding slots have been popped." | ||
| 3878 | ;; Unbind dynamic variables | ||
| 3879 | (let ((num-dynamic-bindings 0)) | ||
| 3880 | (dolist (clause clauses) | ||
| 3881 | (unless (assq (if (consp clause) (car clause) clause) | ||
| 3882 | byte-compile--lexical-environment) | ||
| 3883 | (setq num-dynamic-bindings (1+ num-dynamic-bindings)))) | ||
| 3884 | (unless (zerop num-dynamic-bindings) | ||
| 3885 | (byte-compile-out 'byte-unbind num-dynamic-bindings))) | ||
| 3886 | ;; Pop lexical variables off the stack, possibly preserving the | ||
| 3887 | ;; return value of the body. | ||
| 3888 | (when init-lexenv | ||
| 3889 | ;; INIT-LEXENV contains all init values left on the stack | ||
| 3890 | (byte-compile-discard (length init-lexenv) preserve-body-value))) | ||
| 3650 | 3891 | ||
| 3651 | (defun byte-compile-let (form) | 3892 | (defun byte-compile-let (form) |
| 3652 | ;; First compute the binding values in the old scope. | 3893 | "Generate code for the `let' form FORM." |
| 3653 | (let ((varlist (car (cdr form)))) | 3894 | (let ((clauses (cadr form)) |
| 3654 | (dolist (var varlist) | 3895 | (init-lexenv nil)) |
| 3655 | (if (consp var) | 3896 | (when (eq (car form) 'let) |
| 3656 | (byte-compile-form (car (cdr var))) | 3897 | ;; First compute the binding values in the old scope. |
| 3657 | (byte-compile-push-constant nil)))) | 3898 | (dolist (var clauses) |
| 3658 | (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope | 3899 | (push (byte-compile-push-binding-init var) init-lexenv))) |
| 3659 | (varlist (reverse (car (cdr form))))) | 3900 | ;; New scope. |
| 3660 | (dolist (var varlist) | 3901 | (let ((byte-compile-bound-variables byte-compile-bound-variables) |
| 3661 | (byte-compile-variable-ref 'byte-varbind | 3902 | (byte-compile--lexical-environment |
| 3662 | (if (consp var) (car var) var))) | 3903 | byte-compile--lexical-environment)) |
| 3663 | (byte-compile-body-do-effect (cdr (cdr form))) | 3904 | ;; Bind the variables. |
| 3664 | (byte-compile-out 'byte-unbind (length (car (cdr form)))))) | 3905 | ;; For `let', do it in reverse order, because it makes no |
| 3665 | 3906 | ;; semantic difference, but it is a lot more efficient since the | |
| 3666 | (defun byte-compile-let* (form) | 3907 | ;; values are now in reverse order on the stack. |
| 3667 | (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope | 3908 | (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses)) |
| 3668 | (varlist (copy-sequence (car (cdr form))))) | 3909 | (unless (eq (car form) 'let) |
| 3669 | (dolist (var varlist) | 3910 | (push (byte-compile-push-binding-init var) init-lexenv)) |
| 3670 | (if (atom var) | 3911 | (let ((var (if (consp var) (car var) var))) |
| 3671 | (byte-compile-push-constant nil) | 3912 | (cond ((null lexical-binding) |
| 3672 | (byte-compile-form (car (cdr var))) | 3913 | ;; If there are no lexical bindings, we can do things simply. |
| 3673 | (setq var (car var))) | 3914 | (byte-compile-dynamic-variable-bind var)) |
| 3674 | (byte-compile-variable-ref 'byte-varbind var)) | 3915 | ((byte-compile-bind var init-lexenv) |
| 3675 | (byte-compile-body-do-effect (cdr (cdr form))) | 3916 | (pop init-lexenv))))) |
| 3676 | (byte-compile-out 'byte-unbind (length (car (cdr form)))))) | 3917 | ;; Emit the body. |
| 3918 | (let ((init-stack-depth byte-compile-depth)) | ||
| 3919 | (byte-compile-body-do-effect (cdr (cdr form))) | ||
| 3920 | ;; Unbind the variables. | ||
| 3921 | (if lexical-binding | ||
| 3922 | ;; Unbind both lexical and dynamic variables. | ||
| 3923 | (progn | ||
| 3924 | (assert (or (eq byte-compile-depth init-stack-depth) | ||
| 3925 | (eq byte-compile-depth (1+ init-stack-depth)))) | ||
| 3926 | (byte-compile-unbind clauses init-lexenv (> byte-compile-depth | ||
| 3927 | init-stack-depth))) | ||
| 3928 | ;; Unbind dynamic variables. | ||
| 3929 | (byte-compile-out 'byte-unbind (length clauses))))))) | ||
| 3677 | 3930 | ||
| 3931 | |||
| 3678 | 3932 | ||
| 3679 | (byte-defop-compiler-1 /= byte-compile-negated) | 3933 | (byte-defop-compiler-1 /= byte-compile-negated) |
| 3680 | (byte-defop-compiler-1 atom byte-compile-negated) | 3934 | (byte-defop-compiler-1 atom byte-compile-negated) |
| @@ -3706,70 +3960,86 @@ that suppresses all warnings during execution of BODY." | |||
| 3706 | (byte-defop-compiler-1 save-excursion) | 3960 | (byte-defop-compiler-1 save-excursion) |
| 3707 | (byte-defop-compiler-1 save-current-buffer) | 3961 | (byte-defop-compiler-1 save-current-buffer) |
| 3708 | (byte-defop-compiler-1 save-restriction) | 3962 | (byte-defop-compiler-1 save-restriction) |
| 3709 | (byte-defop-compiler-1 save-window-excursion) | 3963 | ;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro. |
| 3710 | (byte-defop-compiler-1 with-output-to-temp-buffer) | 3964 | ;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. |
| 3711 | (byte-defop-compiler-1 track-mouse) | 3965 | (byte-defop-compiler-1 track-mouse) |
| 3712 | 3966 | ||
| 3713 | (defun byte-compile-catch (form) | 3967 | (defun byte-compile-catch (form) |
| 3714 | (byte-compile-form (car (cdr form))) | 3968 | (byte-compile-form (car (cdr form))) |
| 3715 | (byte-compile-push-constant | 3969 | (pcase (cddr form) |
| 3716 | (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) | 3970 | (`(:fun-body ,f) |
| 3971 | (byte-compile-form `(list 'funcall ,f))) | ||
| 3972 | (body | ||
| 3973 | (byte-compile-push-constant | ||
| 3974 | (byte-compile-top-level (cons 'progn body) byte-compile--for-effect)))) | ||
| 3717 | (byte-compile-out 'byte-catch 0)) | 3975 | (byte-compile-out 'byte-catch 0)) |
| 3718 | 3976 | ||
| 3719 | (defun byte-compile-unwind-protect (form) | 3977 | (defun byte-compile-unwind-protect (form) |
| 3720 | (byte-compile-push-constant | 3978 | (pcase (cddr form) |
| 3721 | (byte-compile-top-level-body (cdr (cdr form)) t)) | 3979 | (`(:fun-body ,f) |
| 3980 | (byte-compile-form `(list (list 'funcall ,f)))) | ||
| 3981 | (handlers | ||
| 3982 | (byte-compile-push-constant | ||
| 3983 | (byte-compile-top-level-body handlers t)))) | ||
| 3722 | (byte-compile-out 'byte-unwind-protect 0) | 3984 | (byte-compile-out 'byte-unwind-protect 0) |
| 3723 | (byte-compile-form-do-effect (car (cdr form))) | 3985 | (byte-compile-form-do-effect (car (cdr form))) |
| 3724 | (byte-compile-out 'byte-unbind 1)) | 3986 | (byte-compile-out 'byte-unbind 1)) |
| 3725 | 3987 | ||
| 3726 | (defun byte-compile-track-mouse (form) | 3988 | (defun byte-compile-track-mouse (form) |
| 3727 | (byte-compile-form | 3989 | (byte-compile-form |
| 3728 | `(funcall '(lambda nil | 3990 | (pcase form |
| 3729 | (track-mouse ,@(byte-compile-top-level-body (cdr form))))))) | 3991 | (`(,_ :fun-body ,f) `(eval (list 'track-mouse (list 'funcall ,f)))) |
| 3992 | (_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form)))))))) | ||
| 3730 | 3993 | ||
| 3731 | (defun byte-compile-condition-case (form) | 3994 | (defun byte-compile-condition-case (form) |
| 3732 | (let* ((var (nth 1 form)) | 3995 | (let* ((var (nth 1 form)) |
| 3733 | (byte-compile-bound-variables | 3996 | (fun-bodies (eq var :fun-body)) |
| 3734 | (if var (cons var byte-compile-bound-variables) | 3997 | (byte-compile-bound-variables |
| 3998 | (if (and var (not fun-bodies)) | ||
| 3999 | (cons var byte-compile-bound-variables) | ||
| 3735 | byte-compile-bound-variables))) | 4000 | byte-compile-bound-variables))) |
| 3736 | (byte-compile-set-symbol-position 'condition-case) | 4001 | (byte-compile-set-symbol-position 'condition-case) |
| 3737 | (unless (symbolp var) | 4002 | (unless (symbolp var) |
| 3738 | (byte-compile-warn | 4003 | (byte-compile-warn |
| 3739 | "`%s' is not a variable-name or nil (in condition-case)" var)) | 4004 | "`%s' is not a variable-name or nil (in condition-case)" var)) |
| 4005 | (if fun-bodies (setq var (make-symbol "err"))) | ||
| 3740 | (byte-compile-push-constant var) | 4006 | (byte-compile-push-constant var) |
| 3741 | (byte-compile-push-constant (byte-compile-top-level | 4007 | (if fun-bodies |
| 3742 | (nth 2 form) for-effect)) | 4008 | (byte-compile-form `(list 'funcall ,(nth 2 form))) |
| 3743 | (let ((clauses (cdr (cdr (cdr form)))) | 4009 | (byte-compile-push-constant |
| 3744 | compiled-clauses) | 4010 | (byte-compile-top-level (nth 2 form) byte-compile--for-effect))) |
| 3745 | (while clauses | 4011 | (let ((compiled-clauses |
| 3746 | (let* ((clause (car clauses)) | 4012 | (mapcar |
| 3747 | (condition (car clause))) | 4013 | (lambda (clause) |
| 3748 | (cond ((not (or (symbolp condition) | 4014 | (let ((condition (car clause))) |
| 3749 | (and (listp condition) | 4015 | (cond ((not (or (symbolp condition) |
| 3750 | (let ((syms condition) (ok t)) | 4016 | (and (listp condition) |
| 3751 | (while syms | 4017 | (let ((ok t)) |
| 3752 | (if (not (symbolp (car syms))) | 4018 | (dolist (sym condition) |
| 3753 | (setq ok nil)) | 4019 | (if (not (symbolp sym)) |
| 3754 | (setq syms (cdr syms))) | 4020 | (setq ok nil))) |
| 3755 | ok)))) | 4021 | ok)))) |
| 3756 | (byte-compile-warn | 4022 | (byte-compile-warn |
| 3757 | "`%s' is not a condition name or list of such (in condition-case)" | 4023 | "`%S' is not a condition name or list of such (in condition-case)" |
| 3758 | (prin1-to-string condition))) | 4024 | condition)) |
| 3759 | ;; ((not (or (eq condition 't) | 4025 | ;; (not (or (eq condition 't) |
| 3760 | ;; (and (stringp (get condition 'error-message)) | 4026 | ;; (and (stringp (get condition 'error-message)) |
| 3761 | ;; (consp (get condition 'error-conditions))))) | 4027 | ;; (consp (get condition |
| 3762 | ;; (byte-compile-warn | 4028 | ;; 'error-conditions))))) |
| 3763 | ;; "`%s' is not a known condition name (in condition-case)" | 4029 | ;; (byte-compile-warn |
| 3764 | ;; condition)) | 4030 | ;; "`%s' is not a known condition name |
| 3765 | ) | 4031 | ;; (in condition-case)" |
| 3766 | (setq compiled-clauses | 4032 | ;; condition)) |
| 3767 | (cons (cons condition | 4033 | ) |
| 3768 | (byte-compile-top-level-body | 4034 | (if fun-bodies |
| 3769 | (cdr clause) for-effect)) | 4035 | `(list ',condition (list 'funcall ,(cadr clause) ',var)) |
| 3770 | compiled-clauses))) | 4036 | (cons condition |
| 3771 | (setq clauses (cdr clauses))) | 4037 | (byte-compile-top-level-body |
| 3772 | (byte-compile-push-constant (nreverse compiled-clauses))) | 4038 | (cdr clause) byte-compile--for-effect))))) |
| 4039 | (cdr (cdr (cdr form)))))) | ||
| 4040 | (if fun-bodies | ||
| 4041 | (byte-compile-form `(list ,@compiled-clauses)) | ||
| 4042 | (byte-compile-push-constant compiled-clauses))) | ||
| 3773 | (byte-compile-out 'byte-condition-case 0))) | 4043 | (byte-compile-out 'byte-condition-case 0))) |
| 3774 | 4044 | ||
| 3775 | 4045 | ||
| @@ -3791,17 +4061,6 @@ that suppresses all warnings during execution of BODY." | |||
| 3791 | (byte-compile-out 'byte-save-current-buffer 0) | 4061 | (byte-compile-out 'byte-save-current-buffer 0) |
| 3792 | (byte-compile-body-do-effect (cdr form)) | 4062 | (byte-compile-body-do-effect (cdr form)) |
| 3793 | (byte-compile-out 'byte-unbind 1)) | 4063 | (byte-compile-out 'byte-unbind 1)) |
| 3794 | |||
| 3795 | (defun byte-compile-save-window-excursion (form) | ||
| 3796 | (byte-compile-push-constant | ||
| 3797 | (byte-compile-top-level-body (cdr form) for-effect)) | ||
| 3798 | (byte-compile-out 'byte-save-window-excursion 0)) | ||
| 3799 | |||
| 3800 | (defun byte-compile-with-output-to-temp-buffer (form) | ||
| 3801 | (byte-compile-form (car (cdr form))) | ||
| 3802 | (byte-compile-out 'byte-temp-output-buffer-setup 0) | ||
| 3803 | (byte-compile-body (cdr (cdr form))) | ||
| 3804 | (byte-compile-out 'byte-temp-output-buffer-show 0)) | ||
| 3805 | 4064 | ||
| 3806 | ;;; top-level forms elsewhere | 4065 | ;;; top-level forms elsewhere |
| 3807 | 4066 | ||
| @@ -3818,22 +4077,16 @@ that suppresses all warnings during execution of BODY." | |||
| 3818 | (byte-compile-set-symbol-position (car form)) | 4077 | (byte-compile-set-symbol-position (car form)) |
| 3819 | (byte-compile-set-symbol-position 'defun) | 4078 | (byte-compile-set-symbol-position 'defun) |
| 3820 | (error "defun name must be a symbol, not %s" (car form))) | 4079 | (error "defun name must be a symbol, not %s" (car form))) |
| 3821 | ;; We prefer to generate a defalias form so it will record the function | 4080 | (byte-compile-push-constant 'defalias) |
| 3822 | ;; definition just like interpreting a defun. | 4081 | (byte-compile-push-constant (nth 1 form)) |
| 3823 | (byte-compile-form | 4082 | (byte-compile-push-constant (byte-compile-lambda (cdr (cdr form)) t)) |
| 3824 | (list 'defalias | 4083 | (byte-compile-out 'byte-call 2)) |
| 3825 | (list 'quote (nth 1 form)) | ||
| 3826 | (byte-compile-byte-code-maker | ||
| 3827 | (byte-compile-lambda (cdr (cdr form)) t))) | ||
| 3828 | t) | ||
| 3829 | (byte-compile-constant (nth 1 form))) | ||
| 3830 | 4084 | ||
| 3831 | (defun byte-compile-defmacro (form) | 4085 | (defun byte-compile-defmacro (form) |
| 3832 | ;; This is not used for file-level defmacros with doc strings. | 4086 | ;; This is not used for file-level defmacros with doc strings. |
| 3833 | (byte-compile-body-do-effect | 4087 | (byte-compile-body-do-effect |
| 3834 | (let ((decls (byte-compile-defmacro-declaration form)) | 4088 | (let ((decls (byte-compile-defmacro-declaration form)) |
| 3835 | (code (byte-compile-byte-code-maker | 4089 | (code (byte-compile-lambda (cdr (cdr form)) t))) |
| 3836 | (byte-compile-lambda (cdr (cdr form)) t)))) | ||
| 3837 | `((defalias ',(nth 1 form) | 4090 | `((defalias ',(nth 1 form) |
| 3838 | ,(if (eq (car-safe code) 'make-byte-code) | 4091 | ,(if (eq (car-safe code) 'make-byte-code) |
| 3839 | `(cons 'macro ,code) | 4092 | `(cons 'macro ,code) |
| @@ -3881,7 +4134,7 @@ that suppresses all warnings during execution of BODY." | |||
| 3881 | ;; Put the defined variable in this library's load-history entry | 4134 | ;; Put the defined variable in this library's load-history entry |
| 3882 | ;; just as a real defvar would, but only in top-level forms. | 4135 | ;; just as a real defvar would, but only in top-level forms. |
| 3883 | (when (and (cddr form) (null byte-compile-current-form)) | 4136 | (when (and (cddr form) (null byte-compile-current-form)) |
| 3884 | `(push ',var current-load-list)) | 4137 | `(setq current-load-list (cons ',var current-load-list))) |
| 3885 | (when (> (length form) 3) | 4138 | (when (> (length form) 3) |
| 3886 | (when (and string (not (stringp string))) | 4139 | (when (and string (not (stringp string))) |
| 3887 | (byte-compile-warn "third arg to `%s %s' is not a string: %s" | 4140 | (byte-compile-warn "third arg to `%s %s' is not a string: %s" |
| @@ -3915,7 +4168,7 @@ that suppresses all warnings during execution of BODY." | |||
| 3915 | 4168 | ||
| 3916 | ;; Lambdas in valid places are handled as special cases by various code. | 4169 | ;; Lambdas in valid places are handled as special cases by various code. |
| 3917 | ;; The ones that remain are errors. | 4170 | ;; The ones that remain are errors. |
| 3918 | (defun byte-compile-lambda-form (form) | 4171 | (defun byte-compile-lambda-form (_form) |
| 3919 | (byte-compile-set-symbol-position 'lambda) | 4172 | (byte-compile-set-symbol-position 'lambda) |
| 3920 | (error "`lambda' used as function name is invalid")) | 4173 | (error "`lambda' used as function name is invalid")) |
| 3921 | 4174 | ||
| @@ -3990,8 +4243,8 @@ that suppresses all warnings during execution of BODY." | |||
| 3990 | (progn | 4243 | (progn |
| 3991 | ;; ## remove this someday | 4244 | ;; ## remove this someday |
| 3992 | (and byte-compile-depth | 4245 | (and byte-compile-depth |
| 3993 | (not (= (cdr (cdr tag)) byte-compile-depth)) | 4246 | (not (= (cdr (cdr tag)) byte-compile-depth)) |
| 3994 | (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) | 4247 | (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) |
| 3995 | (setq byte-compile-depth (cdr (cdr tag)))) | 4248 | (setq byte-compile-depth (cdr (cdr tag)))) |
| 3996 | (setcdr (cdr tag) byte-compile-depth))) | 4249 | (setcdr (cdr tag) byte-compile-depth))) |
| 3997 | 4250 | ||
| @@ -4003,24 +4256,31 @@ that suppresses all warnings during execution of BODY." | |||
| 4003 | (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) | 4256 | (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) |
| 4004 | (1- byte-compile-depth)))) | 4257 | (1- byte-compile-depth)))) |
| 4005 | 4258 | ||
| 4006 | (defun byte-compile-out (opcode offset) | 4259 | (defun byte-compile-stack-adjustment (op operand) |
| 4007 | (push (cons opcode offset) byte-compile-output) | 4260 | "Return the amount by which an operation adjusts the stack. |
| 4008 | (cond ((eq opcode 'byte-call) | 4261 | OP and OPERAND are as passed to `byte-compile-out'." |
| 4009 | (setq byte-compile-depth (- byte-compile-depth offset))) | 4262 | (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) |
| 4010 | ((eq opcode 'byte-return) | 4263 | ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 |
| 4011 | ;; This is actually an unnecessary case, because there should be | 4264 | ;; elements, and the push the result, for a total of -OPERAND. |
| 4012 | ;; no more opcodes behind byte-return. | 4265 | ;; For discardN*, of course, we just pop OPERAND elements. |
| 4013 | (setq byte-compile-depth nil)) | 4266 | (- operand) |
| 4014 | (t | 4267 | (or (aref byte-stack+-info (symbol-value op)) |
| 4015 | (setq byte-compile-depth (+ byte-compile-depth | 4268 | ;; Ops with a nil entry in `byte-stack+-info' are byte-codes |
| 4016 | (or (aref byte-stack+-info | 4269 | ;; that take OPERAND values off the stack and push a result, for |
| 4017 | (symbol-value opcode)) | 4270 | ;; a total of 1 - OPERAND |
| 4018 | (- (1- offset)))) | 4271 | (- 1 operand)))) |
| 4019 | byte-compile-maxdepth (max byte-compile-depth | 4272 | |
| 4020 | byte-compile-maxdepth)))) | 4273 | (defun byte-compile-out (op &optional operand) |
| 4021 | ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) | 4274 | (push (cons op operand) byte-compile-output) |
| 4022 | ) | 4275 | (if (eq op 'byte-return) |
| 4023 | 4276 | ;; This is actually an unnecessary case, because there should be no | |
| 4277 | ;; more ops behind byte-return. | ||
| 4278 | (setq byte-compile-depth nil) | ||
| 4279 | (setq byte-compile-depth | ||
| 4280 | (+ byte-compile-depth (byte-compile-stack-adjustment op operand))) | ||
| 4281 | (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth)) | ||
| 4282 | ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) | ||
| 4283 | )) | ||
| 4024 | 4284 | ||
| 4025 | ;;; call tree stuff | 4285 | ;;; call tree stuff |
| 4026 | 4286 | ||
| @@ -4079,22 +4339,22 @@ invoked interactively." | |||
| 4079 | (if byte-compile-call-tree-sort | 4339 | (if byte-compile-call-tree-sort |
| 4080 | (setq byte-compile-call-tree | 4340 | (setq byte-compile-call-tree |
| 4081 | (sort byte-compile-call-tree | 4341 | (sort byte-compile-call-tree |
| 4082 | (cond ((eq byte-compile-call-tree-sort 'callers) | 4342 | (case byte-compile-call-tree-sort |
| 4083 | (function (lambda (x y) (< (length (nth 1 x)) | 4343 | (callers |
| 4084 | (length (nth 1 y)))))) | 4344 | (lambda (x y) (< (length (nth 1 x)) |
| 4085 | ((eq byte-compile-call-tree-sort 'calls) | 4345 | (length (nth 1 y))))) |
| 4086 | (function (lambda (x y) (< (length (nth 2 x)) | 4346 | (calls |
| 4087 | (length (nth 2 y)))))) | 4347 | (lambda (x y) (< (length (nth 2 x)) |
| 4088 | ((eq byte-compile-call-tree-sort 'calls+callers) | 4348 | (length (nth 2 y))))) |
| 4089 | (function (lambda (x y) (< (+ (length (nth 1 x)) | 4349 | (calls+callers |
| 4090 | (length (nth 2 x))) | 4350 | (lambda (x y) (< (+ (length (nth 1 x)) |
| 4091 | (+ (length (nth 1 y)) | 4351 | (length (nth 2 x))) |
| 4092 | (length (nth 2 y))))))) | 4352 | (+ (length (nth 1 y)) |
| 4093 | ((eq byte-compile-call-tree-sort 'name) | 4353 | (length (nth 2 y)))))) |
| 4094 | (function (lambda (x y) (string< (car x) | 4354 | (name |
| 4095 | (car y))))) | 4355 | (lambda (x y) (string< (car x) (car y)))) |
| 4096 | (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" | 4356 | (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" |
| 4097 | byte-compile-call-tree-sort)))))) | 4357 | byte-compile-call-tree-sort)))))) |
| 4098 | (message "Generating call tree...") | 4358 | (message "Generating call tree...") |
| 4099 | (let ((rest byte-compile-call-tree) | 4359 | (let ((rest byte-compile-call-tree) |
| 4100 | (b (current-buffer)) | 4360 | (b (current-buffer)) |
| @@ -4202,60 +4462,59 @@ Each file is processed even if an error occurred previously. | |||
| 4202 | For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\". | 4462 | For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\". |
| 4203 | If NOFORCE is non-nil, don't recompile a file that seems to be | 4463 | If NOFORCE is non-nil, don't recompile a file that seems to be |
| 4204 | already up-to-date." | 4464 | already up-to-date." |
| 4205 | ;; command-line-args-left is what is left of the command line (from startup.el) | 4465 | ;; command-line-args-left is what is left of the command line, from |
| 4466 | ;; startup.el. | ||
| 4206 | (defvar command-line-args-left) ;Avoid 'free variable' warning | 4467 | (defvar command-line-args-left) ;Avoid 'free variable' warning |
| 4207 | (if (not noninteractive) | 4468 | (if (not noninteractive) |
| 4208 | (error "`batch-byte-compile' is to be used only with -batch")) | 4469 | (error "`batch-byte-compile' is to be used only with -batch")) |
| 4209 | (let ((bytecomp-error nil)) | 4470 | (let ((error nil)) |
| 4210 | (while command-line-args-left | 4471 | (while command-line-args-left |
| 4211 | (if (file-directory-p (expand-file-name (car command-line-args-left))) | 4472 | (if (file-directory-p (expand-file-name (car command-line-args-left))) |
| 4212 | ;; Directory as argument. | 4473 | ;; Directory as argument. |
| 4213 | (let ((bytecomp-files (directory-files (car command-line-args-left))) | 4474 | (let (source dest) |
| 4214 | bytecomp-source bytecomp-dest) | 4475 | (dolist (file (directory-files (car command-line-args-left))) |
| 4215 | (dolist (bytecomp-file bytecomp-files) | 4476 | (if (and (string-match emacs-lisp-file-regexp file) |
| 4216 | (if (and (string-match emacs-lisp-file-regexp bytecomp-file) | 4477 | (not (auto-save-file-name-p file)) |
| 4217 | (not (auto-save-file-name-p bytecomp-file)) | 4478 | (setq source |
| 4218 | (setq bytecomp-source | 4479 | (expand-file-name file |
| 4219 | (expand-file-name bytecomp-file | ||
| 4220 | (car command-line-args-left))) | 4480 | (car command-line-args-left))) |
| 4221 | (setq bytecomp-dest (byte-compile-dest-file | 4481 | (setq dest (byte-compile-dest-file source)) |
| 4222 | bytecomp-source)) | 4482 | (file-exists-p dest) |
| 4223 | (file-exists-p bytecomp-dest) | 4483 | (file-newer-than-file-p source dest)) |
| 4224 | (file-newer-than-file-p bytecomp-source bytecomp-dest)) | 4484 | (if (null (batch-byte-compile-file source)) |
| 4225 | (if (null (batch-byte-compile-file bytecomp-source)) | 4485 | (setq error t))))) |
| 4226 | (setq bytecomp-error t))))) | ||
| 4227 | ;; Specific file argument | 4486 | ;; Specific file argument |
| 4228 | (if (or (not noforce) | 4487 | (if (or (not noforce) |
| 4229 | (let* ((bytecomp-source (car command-line-args-left)) | 4488 | (let* ((source (car command-line-args-left)) |
| 4230 | (bytecomp-dest (byte-compile-dest-file bytecomp-source))) | 4489 | (dest (byte-compile-dest-file source))) |
| 4231 | (or (not (file-exists-p bytecomp-dest)) | 4490 | (or (not (file-exists-p dest)) |
| 4232 | (file-newer-than-file-p bytecomp-source bytecomp-dest)))) | 4491 | (file-newer-than-file-p source dest)))) |
| 4233 | (if (null (batch-byte-compile-file (car command-line-args-left))) | 4492 | (if (null (batch-byte-compile-file (car command-line-args-left))) |
| 4234 | (setq bytecomp-error t)))) | 4493 | (setq error t)))) |
| 4235 | (setq command-line-args-left (cdr command-line-args-left))) | 4494 | (setq command-line-args-left (cdr command-line-args-left))) |
| 4236 | (kill-emacs (if bytecomp-error 1 0)))) | 4495 | (kill-emacs (if error 1 0)))) |
| 4237 | 4496 | ||
| 4238 | (defun batch-byte-compile-file (bytecomp-file) | 4497 | (defun batch-byte-compile-file (file) |
| 4239 | (if debug-on-error | 4498 | (if debug-on-error |
| 4240 | (byte-compile-file bytecomp-file) | 4499 | (byte-compile-file file) |
| 4241 | (condition-case err | 4500 | (condition-case err |
| 4242 | (byte-compile-file bytecomp-file) | 4501 | (byte-compile-file file) |
| 4243 | (file-error | 4502 | (file-error |
| 4244 | (message (if (cdr err) | 4503 | (message (if (cdr err) |
| 4245 | ">>Error occurred processing %s: %s (%s)" | 4504 | ">>Error occurred processing %s: %s (%s)" |
| 4246 | ">>Error occurred processing %s: %s") | 4505 | ">>Error occurred processing %s: %s") |
| 4247 | bytecomp-file | 4506 | file |
| 4248 | (get (car err) 'error-message) | 4507 | (get (car err) 'error-message) |
| 4249 | (prin1-to-string (cdr err))) | 4508 | (prin1-to-string (cdr err))) |
| 4250 | (let ((bytecomp-destfile (byte-compile-dest-file bytecomp-file))) | 4509 | (let ((destfile (byte-compile-dest-file file))) |
| 4251 | (if (file-exists-p bytecomp-destfile) | 4510 | (if (file-exists-p destfile) |
| 4252 | (delete-file bytecomp-destfile))) | 4511 | (delete-file destfile))) |
| 4253 | nil) | 4512 | nil) |
| 4254 | (error | 4513 | (error |
| 4255 | (message (if (cdr err) | 4514 | (message (if (cdr err) |
| 4256 | ">>Error occurred processing %s: %s (%s)" | 4515 | ">>Error occurred processing %s: %s (%s)" |
| 4257 | ">>Error occurred processing %s: %s") | 4516 | ">>Error occurred processing %s: %s") |
| 4258 | bytecomp-file | 4517 | file |
| 4259 | (get (car err) 'error-message) | 4518 | (get (car err) 'error-message) |
| 4260 | (prin1-to-string (cdr err))) | 4519 | (prin1-to-string (cdr err))) |
| 4261 | nil)))) | 4520 | nil)))) |
| @@ -4271,7 +4530,14 @@ Use with caution." | |||
| 4271 | (setq f (car f)) | 4530 | (setq f (car f)) |
| 4272 | (if (string-match "elc\\'" f) (setq f (substring f 0 -1))) | 4531 | (if (string-match "elc\\'" f) (setq f (substring f 0 -1))) |
| 4273 | (when (and (file-readable-p f) | 4532 | (when (and (file-readable-p f) |
| 4274 | (file-newer-than-file-p f emacs-file)) | 4533 | (file-newer-than-file-p f emacs-file) |
| 4534 | ;; Don't reload the source version of the files below | ||
| 4535 | ;; because that causes subsequent byte-compilation to | ||
| 4536 | ;; be a lot slower and need a higher max-lisp-eval-depth, | ||
| 4537 | ;; so it can cause recompilation to fail. | ||
| 4538 | (not (member (file-name-nondirectory f) | ||
| 4539 | '("pcase.el" "bytecomp.el" "macroexp.el" | ||
| 4540 | "cconv.el" "byte-opt.el")))) | ||
| 4275 | (message "Reloading stale %s" (file-name-nondirectory f)) | 4541 | (message "Reloading stale %s" (file-name-nondirectory f)) |
| 4276 | (condition-case nil | 4542 | (condition-case nil |
| 4277 | (load f 'noerror nil 'nosuffix) | 4543 | (load f 'noerror nil 'nosuffix) |
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el new file mode 100644 index 00000000000..5cc9ecb4cf7 --- /dev/null +++ b/lisp/emacs-lisp/cconv.el | |||
| @@ -0,0 +1,713 @@ | |||
| 1 | ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*- | ||
| 2 | |||
| 3 | ;; Copyright (C) 2011 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> | ||
| 6 | ;; Maintainer: FSF | ||
| 7 | ;; Keywords: lisp | ||
| 8 | ;; Package: emacs | ||
| 9 | |||
| 10 | ;; This file is part of GNU Emacs. | ||
| 11 | |||
| 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 13 | ;; it under the terms of the GNU General Public License as published by | ||
| 14 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 15 | ;; (at your option) any later version. | ||
| 16 | |||
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 20 | ;; GNU General Public License for more details. | ||
| 21 | |||
| 22 | ;; You should have received a copy of the GNU General Public License | ||
| 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 24 | |||
| 25 | ;;; Commentary: | ||
| 26 | |||
| 27 | ;; This takes a piece of Elisp code, and eliminates all free variables from | ||
| 28 | ;; lambda expressions. The user entry points are cconv-closure-convert and | ||
| 29 | ;; cconv-closure-convert-toplevel(for toplevel forms). | ||
| 30 | ;; All macros should be expanded beforehand. | ||
| 31 | ;; | ||
| 32 | ;; Here is a brief explanation how this code works. | ||
| 33 | ;; Firstly, we analyse the tree by calling cconv-analyse-form. | ||
| 34 | ;; This function finds all mutated variables, all functions that are suitable | ||
| 35 | ;; for lambda lifting and all variables captured by closure. It passes the tree | ||
| 36 | ;; once, returning a list of three lists. | ||
| 37 | ;; | ||
| 38 | ;; Then we calculate the intersection of first and third lists returned by | ||
| 39 | ;; cconv-analyse form to find all mutated variables that are captured by | ||
| 40 | ;; closure. | ||
| 41 | |||
| 42 | ;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the | ||
| 43 | ;; tree recursivly, lifting lambdas where possible, building closures where it | ||
| 44 | ;; is needed and eliminating mutable variables used in closure. | ||
| 45 | ;; | ||
| 46 | ;; We do following replacements : | ||
| 47 | ;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .) | ||
| 48 | ;; if the function is suitable for lambda lifting (if all calls are known) | ||
| 49 | ;; | ||
| 50 | ;; (lambda (v0 ...) ... fv0 .. fv1 ...) => | ||
| 51 | ;; (internal-make-closure (v0 ...) (fv1 ...) | ||
| 52 | ;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...) | ||
| 53 | ;; | ||
| 54 | ;; If the function has no free variables, we don't do anything. | ||
| 55 | ;; | ||
| 56 | ;; If a variable is mutated (updated by setq), and it is used in a closure | ||
| 57 | ;; we wrap its definition with list: (list val) and we also replace | ||
| 58 | ;; var => (car var) wherever this variable is used, and also | ||
| 59 | ;; (setq var value) => (setcar var value) where it is updated. | ||
| 60 | ;; | ||
| 61 | ;; If defun argument is closure mutable, we letbind it and wrap it's | ||
| 62 | ;; definition with list. | ||
| 63 | ;; (defun foo (... mutable-arg ...) ...) => | ||
| 64 | ;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...)) | ||
| 65 | ;; | ||
| 66 | ;;; Code: | ||
| 67 | |||
| 68 | ;; TODO: (not just for cconv but also for the lexbind changes in general) | ||
| 69 | ;; - let (e)debug find the value of lexical variables from the stack. | ||
| 70 | ;; - make eval-region do the eval-sexp-add-defvars danse. | ||
| 71 | ;; - byte-optimize-form should be applied before cconv. | ||
| 72 | ;; OTOH, the warnings emitted by cconv-analyze need to come before optimize | ||
| 73 | ;; since afterwards they can because obnoxious (warnings about an "unused | ||
| 74 | ;; variable" should not be emitted when the variable use has simply been | ||
| 75 | ;; optimized away). | ||
| 76 | ;; - turn defun and defmacro into macros (and remove special handling of | ||
| 77 | ;; `declare' afterwards). | ||
| 78 | ;; - let macros specify that some let-bindings come from the same source, | ||
| 79 | ;; so the unused warning takes all uses into account. | ||
| 80 | ;; - let interactive specs return a function to build the args (to stash into | ||
| 81 | ;; command-history). | ||
| 82 | ;; - canonize code in macro-expand so we don't have to handle (let (var) body) | ||
| 83 | ;; and other oddities. | ||
| 84 | ;; - new byte codes for unwind-protect, catch, and condition-case so that | ||
| 85 | ;; closures aren't needed at all. | ||
| 86 | ;; - inline source code of different binding mode by first compiling it. | ||
| 87 | ;; - a reference to a var that is known statically to always hold a constant | ||
| 88 | ;; should be turned into a byte-constant rather than a byte-stack-ref. | ||
| 89 | ;; Hmm... right, that's called constant propagation and could be done here, | ||
| 90 | ;; but when that constant is a function, we have to be careful to make sure | ||
| 91 | ;; the bytecomp only compiles it once. | ||
| 92 | ;; - Since we know here when a variable is not mutated, we could pass that | ||
| 93 | ;; info to the byte-compiler, e.g. by using a new `immutable-let'. | ||
| 94 | ;; - add tail-calls to bytecode.c and the byte compiler. | ||
| 95 | ;; - call known non-escaping functions with `goto' rather than `call'. | ||
| 96 | ;; - optimize mapcar to a while loop. | ||
| 97 | |||
| 98 | ;; (defmacro dlet (binders &rest body) | ||
| 99 | ;; ;; Works in both lexical and non-lexical mode. | ||
| 100 | ;; `(progn | ||
| 101 | ;; ,@(mapcar (lambda (binder) | ||
| 102 | ;; `(defvar ,(if (consp binder) (car binder) binder))) | ||
| 103 | ;; binders) | ||
| 104 | ;; (let ,binders ,@body))) | ||
| 105 | |||
| 106 | ;; (defmacro llet (binders &rest body) | ||
| 107 | ;; ;; Only works in lexical-binding mode. | ||
| 108 | ;; `(funcall | ||
| 109 | ;; (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder)) | ||
| 110 | ;; binders) | ||
| 111 | ;; ,@body) | ||
| 112 | ;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder))) | ||
| 113 | ;; binders))) | ||
| 114 | |||
| 115 | ;; (defmacro letrec (binders &rest body) | ||
| 116 | ;; ;; Only useful in lexical-binding mode. | ||
| 117 | ;; ;; As a special-form, we could implement it more efficiently (and cleanly, | ||
| 118 | ;; ;; making the vars actually unbound during evaluation of the binders). | ||
| 119 | ;; `(let ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder)) | ||
| 120 | ;; binders) | ||
| 121 | ;; ,@(delq nil (mapcar (lambda (binder) (if (consp binder) `(setq ,@binder))) | ||
| 122 | ;; binders)) | ||
| 123 | ;; ,@body)) | ||
| 124 | |||
| 125 | (eval-when-compile (require 'cl)) | ||
| 126 | |||
| 127 | (defconst cconv-liftwhen 6 | ||
| 128 | "Try to do lambda lifting if the number of arguments + free variables | ||
| 129 | is less than this number.") | ||
| 130 | ;; List of all the variables that are both captured by a closure | ||
| 131 | ;; and mutated. Each entry in the list takes the form | ||
| 132 | ;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the | ||
| 133 | ;; variable (or is just (VAR) for variables not introduced by let). | ||
| 134 | (defvar cconv-captured+mutated) | ||
| 135 | |||
| 136 | ;; List of candidates for lambda lifting. | ||
| 137 | ;; Each candidate has the form (BINDER . PARENTFORM). A candidate | ||
| 138 | ;; is a variable that is only passed to `funcall' or `apply'. | ||
| 139 | (defvar cconv-lambda-candidates) | ||
| 140 | |||
| 141 | ;; Alist associating to each function body the list of its free variables. | ||
| 142 | (defvar cconv-freevars-alist) | ||
| 143 | |||
| 144 | ;;;###autoload | ||
| 145 | (defun cconv-closure-convert (form) | ||
| 146 | "Main entry point for closure conversion. | ||
| 147 | -- FORM is a piece of Elisp code after macroexpansion. | ||
| 148 | -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST | ||
| 149 | |||
| 150 | Returns a form where all lambdas don't have any free variables." | ||
| 151 | ;; (message "Entering cconv-closure-convert...") | ||
| 152 | (let ((cconv-freevars-alist '()) | ||
| 153 | (cconv-lambda-candidates '()) | ||
| 154 | (cconv-captured+mutated '())) | ||
| 155 | ;; Analyse form - fill these variables with new information. | ||
| 156 | (cconv-analyse-form form '()) | ||
| 157 | (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) | ||
| 158 | (cconv-convert form nil nil))) ; Env initially empty. | ||
| 159 | |||
| 160 | (defconst cconv--dummy-var (make-symbol "ignored")) | ||
| 161 | |||
| 162 | (defun cconv--set-diff (s1 s2) | ||
| 163 | "Return elements of set S1 that are not in set S2." | ||
| 164 | (let ((res '())) | ||
| 165 | (dolist (x s1) | ||
| 166 | (unless (memq x s2) (push x res))) | ||
| 167 | (nreverse res))) | ||
| 168 | |||
| 169 | (defun cconv--set-diff-map (s m) | ||
| 170 | "Return elements of set S that are not in Dom(M)." | ||
| 171 | (let ((res '())) | ||
| 172 | (dolist (x s) | ||
| 173 | (unless (assq x m) (push x res))) | ||
| 174 | (nreverse res))) | ||
| 175 | |||
| 176 | (defun cconv--map-diff (m1 m2) | ||
| 177 | "Return the submap of map M1 that has Dom(M2) removed." | ||
| 178 | (let ((res '())) | ||
| 179 | (dolist (x m1) | ||
| 180 | (unless (assq (car x) m2) (push x res))) | ||
| 181 | (nreverse res))) | ||
| 182 | |||
| 183 | (defun cconv--map-diff-elem (m x) | ||
| 184 | "Return the map M minus any mapping for X." | ||
| 185 | ;; Here we assume that X appears at most once in M. | ||
| 186 | (let* ((b (assq x m)) | ||
| 187 | (res (if b (remq b m) m))) | ||
| 188 | (assert (null (assq x res))) ;; Check the assumption was warranted. | ||
| 189 | res)) | ||
| 190 | |||
| 191 | (defun cconv--map-diff-set (m s) | ||
| 192 | "Return the map M minus any mapping for elements of S." | ||
| 193 | ;; Here we assume that X appears at most once in M. | ||
| 194 | (let ((res '())) | ||
| 195 | (dolist (b m) | ||
| 196 | (unless (memq (car b) s) (push b res))) | ||
| 197 | (nreverse res))) | ||
| 198 | |||
| 199 | (defun cconv--convert-function (args body env parentform) | ||
| 200 | (assert (equal body (caar cconv-freevars-alist))) | ||
| 201 | (let* ((fvs (cdr (pop cconv-freevars-alist))) | ||
| 202 | (body-new '()) | ||
| 203 | (letbind '()) | ||
| 204 | (envector ()) | ||
| 205 | (i 0) | ||
| 206 | (new-env ())) | ||
| 207 | ;; Build the "formal and actual envs" for the closure-converted function. | ||
| 208 | (dolist (fv fvs) | ||
| 209 | (let ((exp (or (cdr (assq fv env)) fv))) | ||
| 210 | (pcase exp | ||
| 211 | ;; If `fv' is a variable that's wrapped in a cons-cell, | ||
| 212 | ;; we want to put the cons-cell itself in the closure, | ||
| 213 | ;; rather than just a copy of its current content. | ||
| 214 | (`(car ,iexp . ,_) | ||
| 215 | (push iexp envector) | ||
| 216 | (push `(,fv . (car (internal-get-closed-var ,i))) new-env)) | ||
| 217 | (_ | ||
| 218 | (push exp envector) | ||
| 219 | (push `(,fv . (internal-get-closed-var ,i)) new-env)))) | ||
| 220 | (setq i (1+ i))) | ||
| 221 | (setq envector (nreverse envector)) | ||
| 222 | (setq new-env (nreverse new-env)) | ||
| 223 | |||
| 224 | (dolist (arg args) | ||
| 225 | (if (not (member (cons (list arg) parentform) cconv-captured+mutated)) | ||
| 226 | (if (assq arg new-env) (push `(,arg) new-env)) | ||
| 227 | (push `(,arg . (car ,arg)) new-env) | ||
| 228 | (push `(,arg (list ,arg)) letbind))) | ||
| 229 | |||
| 230 | (setq body-new (mapcar (lambda (form) | ||
| 231 | (cconv-convert form new-env nil)) | ||
| 232 | body)) | ||
| 233 | |||
| 234 | (when letbind | ||
| 235 | (let ((special-forms '())) | ||
| 236 | ;; Keep special forms at the beginning of the body. | ||
| 237 | (while (or (stringp (car body-new)) ;docstring. | ||
| 238 | (memq (car-safe (car body-new)) '(interactive declare))) | ||
| 239 | (push (pop body-new) special-forms)) | ||
| 240 | (setq body-new | ||
| 241 | `(,@(nreverse special-forms) (let ,letbind . ,body-new))))) | ||
| 242 | |||
| 243 | (cond | ||
| 244 | ((null envector) ;if no freevars - do nothing | ||
| 245 | `(function (lambda ,args . ,body-new))) | ||
| 246 | (t | ||
| 247 | `(internal-make-closure | ||
| 248 | ,args ,envector . ,body-new))))) | ||
| 249 | |||
| 250 | (defun cconv-convert (form env extend) | ||
| 251 | ;; This function actually rewrites the tree. | ||
| 252 | "Return FORM with all its lambdas changed so they are closed. | ||
| 253 | ENV is a lexical environment mapping variables to the expression | ||
| 254 | used to get its value. This is used for variables that are copied into | ||
| 255 | closures, moved into cons cells, ... | ||
| 256 | ENV is a list where each entry takes the shape either: | ||
| 257 | (VAR . (car EXP)): VAR has been moved into the car of a cons-cell, and EXP | ||
| 258 | is an expression that evaluates to this cons-cell. | ||
| 259 | (VAR . (internal-get-closed-var N)): VAR has been copied into the closure | ||
| 260 | environment's Nth slot. | ||
| 261 | (VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes | ||
| 262 | additional arguments ARGs. | ||
| 263 | EXTEND is a list of variables which might need to be accessed even from places | ||
| 264 | where they are shadowed, because some part of ENV causes them to be used at | ||
| 265 | places where they originally did not directly appear." | ||
| 266 | (assert (not (delq nil (mapcar (lambda (mapping) | ||
| 267 | (if (eq (cadr mapping) 'apply-partially) | ||
| 268 | (cconv--set-diff (cdr (cddr mapping)) | ||
| 269 | extend))) | ||
| 270 | env)))) | ||
| 271 | |||
| 272 | ;; What's the difference between fvrs and envs? | ||
| 273 | ;; Suppose that we have the code | ||
| 274 | ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) | ||
| 275 | ;; only the first occurrence of fvr should be replaced by | ||
| 276 | ;; (aref env ...). | ||
| 277 | ;; So initially envs and fvrs are the same thing, but when we descend to | ||
| 278 | ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs? | ||
| 279 | ;; Because in envs the order of variables is important. We use this list | ||
| 280 | ;; to find the number of a specific variable in the environment vector, | ||
| 281 | ;; so we never touch it(unless we enter to the other closure). | ||
| 282 | ;;(if (listp form) (print (car form)) form) | ||
| 283 | (pcase form | ||
| 284 | (`(,(and letsym (or `let* `let)) ,binders . ,body) | ||
| 285 | |||
| 286 | ; let and let* special forms | ||
| 287 | (let ((binders-new '()) | ||
| 288 | (new-env env) | ||
| 289 | (new-extend extend)) | ||
| 290 | |||
| 291 | (dolist (binder binders) | ||
| 292 | (let* ((value nil) | ||
| 293 | (var (if (not (consp binder)) | ||
| 294 | (prog1 binder (setq binder (list binder))) | ||
| 295 | (setq value (cadr binder)) | ||
| 296 | (car binder))) | ||
| 297 | (new-val | ||
| 298 | (cond | ||
| 299 | ;; Check if var is a candidate for lambda lifting. | ||
| 300 | ((and (member (cons binder form) cconv-lambda-candidates) | ||
| 301 | (progn | ||
| 302 | (assert (and (eq (car value) 'function) | ||
| 303 | (eq (car (cadr value)) 'lambda))) | ||
| 304 | (assert (equal (cddr (cadr value)) | ||
| 305 | (caar cconv-freevars-alist))) | ||
| 306 | ;; Peek at the freevars to decide whether to λ-lift. | ||
| 307 | (let* ((fvs (cdr (car cconv-freevars-alist))) | ||
| 308 | (fun (cadr value)) | ||
| 309 | (funargs (cadr fun)) | ||
| 310 | (funcvars (append fvs funargs))) | ||
| 311 | ; lambda lifting condition | ||
| 312 | (and fvs (>= cconv-liftwhen (length funcvars)))))) | ||
| 313 | ; Lift. | ||
| 314 | (let* ((fvs (cdr (pop cconv-freevars-alist))) | ||
| 315 | (fun (cadr value)) | ||
| 316 | (funargs (cadr fun)) | ||
| 317 | (funcvars (append fvs funargs)) | ||
| 318 | (funcbody (cddr fun)) | ||
| 319 | (funcbody-env ())) | ||
| 320 | (push `(,var . (apply-partially ,var . ,fvs)) new-env) | ||
| 321 | (dolist (fv fvs) | ||
| 322 | (pushnew fv new-extend) | ||
| 323 | (if (and (eq 'car (car-safe (cdr (assq fv env)))) | ||
| 324 | (not (memq fv funargs))) | ||
| 325 | (push `(,fv . (car ,fv)) funcbody-env))) | ||
| 326 | `(function (lambda ,funcvars . | ||
| 327 | ,(mapcar (lambda (form) | ||
| 328 | (cconv-convert | ||
| 329 | form funcbody-env nil)) | ||
| 330 | funcbody))))) | ||
| 331 | |||
| 332 | ;; Check if it needs to be turned into a "ref-cell". | ||
| 333 | ((member (cons binder form) cconv-captured+mutated) | ||
| 334 | ;; Declared variable is mutated and captured. | ||
| 335 | (push `(,var . (car ,var)) new-env) | ||
| 336 | `(list ,(cconv-convert value env extend))) | ||
| 337 | |||
| 338 | ;; Normal default case. | ||
| 339 | (t | ||
| 340 | (if (assq var new-env) (push `(,var) new-env)) | ||
| 341 | (cconv-convert value env extend))))) | ||
| 342 | |||
| 343 | ;; The piece of code below letbinds free variables of a λ-lifted | ||
| 344 | ;; function if they are redefined in this let, example: | ||
| 345 | ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) | ||
| 346 | ;; Here we can not pass y as parameter because it is redefined. | ||
| 347 | ;; So we add a (closed-y y) declaration. We do that even if the | ||
| 348 | ;; function is not used inside this let(*). The reason why we | ||
| 349 | ;; ignore this case is that we can't "look forward" to see if the | ||
| 350 | ;; function is called there or not. To treat this case better we'd | ||
| 351 | ;; need to traverse the tree one more time to collect this data, and | ||
| 352 | ;; I think that it's not worth it. | ||
| 353 | (when (memq var new-extend) | ||
| 354 | (let ((closedsym | ||
| 355 | (make-symbol (concat "closed-" (symbol-name var))))) | ||
| 356 | (setq new-env | ||
| 357 | (mapcar (lambda (mapping) | ||
| 358 | (if (not (eq (cadr mapping) 'apply-partially)) | ||
| 359 | mapping | ||
| 360 | (assert (eq (car mapping) (nth 2 mapping))) | ||
| 361 | (list* (car mapping) | ||
| 362 | 'apply-partially | ||
| 363 | (car mapping) | ||
| 364 | (mapcar (lambda (arg) | ||
| 365 | (if (eq var arg) | ||
| 366 | closedsym arg)) | ||
| 367 | (nthcdr 3 mapping))))) | ||
| 368 | new-env)) | ||
| 369 | (setq new-extend (remq var new-extend)) | ||
| 370 | (push closedsym new-extend) | ||
| 371 | (push `(,closedsym ,var) binders-new))) | ||
| 372 | |||
| 373 | ;; We push the element after redefined free variables are | ||
| 374 | ;; processed. This is important to avoid the bug when free | ||
| 375 | ;; variable and the function have the same name. | ||
| 376 | (push (list var new-val) binders-new) | ||
| 377 | |||
| 378 | (when (eq letsym 'let*) | ||
| 379 | (setq env new-env) | ||
| 380 | (setq extend new-extend)) | ||
| 381 | )) ; end of dolist over binders | ||
| 382 | |||
| 383 | `(,letsym ,(nreverse binders-new) | ||
| 384 | . ,(mapcar (lambda (form) | ||
| 385 | (cconv-convert | ||
| 386 | form new-env new-extend)) | ||
| 387 | body)))) | ||
| 388 | ;end of let let* forms | ||
| 389 | |||
| 390 | ; first element is lambda expression | ||
| 391 | (`(,(and `(lambda . ,_) fun) . ,args) | ||
| 392 | ;; FIXME: it's silly to create a closure just to call it. | ||
| 393 | ;; Running byte-optimize-form earlier will resolve this. | ||
| 394 | `(funcall | ||
| 395 | ,(cconv-convert `(function ,fun) env extend) | ||
| 396 | ,@(mapcar (lambda (form) | ||
| 397 | (cconv-convert form env extend)) | ||
| 398 | args))) | ||
| 399 | |||
| 400 | (`(cond . ,cond-forms) ; cond special form | ||
| 401 | `(cond . ,(mapcar (lambda (branch) | ||
| 402 | (mapcar (lambda (form) | ||
| 403 | (cconv-convert form env extend)) | ||
| 404 | branch)) | ||
| 405 | cond-forms))) | ||
| 406 | |||
| 407 | (`(function (lambda ,args . ,body) . ,_) | ||
| 408 | (cconv--convert-function args body env form)) | ||
| 409 | |||
| 410 | (`(internal-make-closure . ,_) | ||
| 411 | (byte-compile-report-error | ||
| 412 | "Internal error in compiler: cconv called twice?")) | ||
| 413 | |||
| 414 | (`(quote . ,_) form) | ||
| 415 | (`(function . ,_) form) | ||
| 416 | |||
| 417 | ;defconst, defvar | ||
| 418 | (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms) | ||
| 419 | `(,sym ,definedsymbol | ||
| 420 | . ,(mapcar (lambda (form) (cconv-convert form env extend)) | ||
| 421 | forms))) | ||
| 422 | |||
| 423 | ;defun, defmacro | ||
| 424 | (`(,(and sym (or `defun `defmacro)) | ||
| 425 | ,func ,args . ,body) | ||
| 426 | (assert (equal body (caar cconv-freevars-alist))) | ||
| 427 | (assert (null (cdar cconv-freevars-alist))) | ||
| 428 | |||
| 429 | (let ((new (cconv--convert-function args body env form))) | ||
| 430 | (pcase new | ||
| 431 | (`(function (lambda ,newargs . ,new-body)) | ||
| 432 | (assert (equal args newargs)) | ||
| 433 | `(,sym ,func ,args . ,new-body)) | ||
| 434 | (t (byte-compile-report-error | ||
| 435 | (format "Internal error in cconv of (%s %s ...)" sym func)))))) | ||
| 436 | |||
| 437 | ;condition-case | ||
| 438 | (`(condition-case ,var ,protected-form . ,handlers) | ||
| 439 | (let ((newform (cconv--convert-function | ||
| 440 | () (list protected-form) env form))) | ||
| 441 | `(condition-case :fun-body ,newform | ||
| 442 | ,@(mapcar (lambda (handler) | ||
| 443 | (list (car handler) | ||
| 444 | (cconv--convert-function | ||
| 445 | (list (or var cconv--dummy-var)) | ||
| 446 | (cdr handler) env form))) | ||
| 447 | handlers)))) | ||
| 448 | |||
| 449 | (`(,(and head (or `catch `unwind-protect)) ,form . ,body) | ||
| 450 | `(,head ,(cconv-convert form env extend) | ||
| 451 | :fun-body ,(cconv--convert-function () body env form))) | ||
| 452 | |||
| 453 | (`(track-mouse . ,body) | ||
| 454 | `(track-mouse | ||
| 455 | :fun-body ,(cconv--convert-function () body env form))) | ||
| 456 | |||
| 457 | (`(setq . ,forms) ; setq special form | ||
| 458 | (let ((prognlist ())) | ||
| 459 | (while forms | ||
| 460 | (let* ((sym (pop forms)) | ||
| 461 | (sym-new (or (cdr (assq sym env)) sym)) | ||
| 462 | (value (cconv-convert (pop forms) env extend))) | ||
| 463 | (push (pcase sym-new | ||
| 464 | ((pred symbolp) `(setq ,sym-new ,value)) | ||
| 465 | (`(car ,iexp) `(setcar ,iexp ,value)) | ||
| 466 | ;; This "should never happen", but for variables which are | ||
| 467 | ;; mutated+captured+unused, we may end up trying to `setq' | ||
| 468 | ;; on a closed-over variable, so just drop the setq. | ||
| 469 | (_ ;; (byte-compile-report-error | ||
| 470 | ;; (format "Internal error in cconv of (setq %s ..)" | ||
| 471 | ;; sym-new)) | ||
| 472 | value)) | ||
| 473 | prognlist))) | ||
| 474 | (if (cdr prognlist) | ||
| 475 | `(progn . ,(nreverse prognlist)) | ||
| 476 | (car prognlist)))) | ||
| 477 | |||
| 478 | (`(,(and (or `funcall `apply) callsym) ,fun . ,args) | ||
| 479 | ;; These are not special forms but we treat them separately for the needs | ||
| 480 | ;; of lambda lifting. | ||
| 481 | (let ((mapping (cdr (assq fun env)))) | ||
| 482 | (pcase mapping | ||
| 483 | (`(apply-partially ,_ . ,(and fvs `(,_ . ,_))) | ||
| 484 | (assert (eq (cadr mapping) fun)) | ||
| 485 | `(,callsym ,fun | ||
| 486 | ,@(mapcar (lambda (fv) | ||
| 487 | (let ((exp (or (cdr (assq fv env)) fv))) | ||
| 488 | (pcase exp | ||
| 489 | (`(car ,iexp . ,_) iexp) | ||
| 490 | (_ exp)))) | ||
| 491 | fvs) | ||
| 492 | ,@(mapcar (lambda (arg) | ||
| 493 | (cconv-convert arg env extend)) | ||
| 494 | args))) | ||
| 495 | (_ `(,callsym ,@(mapcar (lambda (arg) | ||
| 496 | (cconv-convert arg env extend)) | ||
| 497 | (cons fun args))))))) | ||
| 498 | |||
| 499 | (`(interactive . ,forms) | ||
| 500 | `(interactive . ,(mapcar (lambda (form) | ||
| 501 | (cconv-convert form nil nil)) | ||
| 502 | forms))) | ||
| 503 | |||
| 504 | (`(declare . ,_) form) ;The args don't contain code. | ||
| 505 | |||
| 506 | (`(,func . ,forms) | ||
| 507 | ;; First element is function or whatever function-like forms are: or, and, | ||
| 508 | ;; if, progn, prog1, prog2, while, until | ||
| 509 | `(,func . ,(mapcar (lambda (form) | ||
| 510 | (cconv-convert form env extend)) | ||
| 511 | forms))) | ||
| 512 | |||
| 513 | (_ (or (cdr (assq form env)) form)))) | ||
| 514 | |||
| 515 | (unless (fboundp 'byte-compile-not-lexical-var-p) | ||
| 516 | ;; Only used to test the code in non-lexbind Emacs. | ||
| 517 | (defalias 'byte-compile-not-lexical-var-p 'boundp)) | ||
| 518 | |||
| 519 | (defun cconv--analyse-use (vardata form varkind) | ||
| 520 | "Analyse the use of a variable. | ||
| 521 | VARDATA should be (BINDER READ MUTATED CAPTURED CALLED). | ||
| 522 | VARKIND is the name of the kind of variable. | ||
| 523 | FORM is the parent form that binds this var." | ||
| 524 | ;; use = `(,binder ,read ,mutated ,captured ,called) | ||
| 525 | (pcase vardata | ||
| 526 | (`(,_ nil nil nil nil) nil) | ||
| 527 | (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_) | ||
| 528 | ,_ ,_ ,_ ,_) | ||
| 529 | (byte-compile-log-warning | ||
| 530 | (format "%s `%S' not left unused" varkind var)))) | ||
| 531 | (pcase vardata | ||
| 532 | (`((,var . ,_) nil ,_ ,_ nil) | ||
| 533 | ;; FIXME: This gives warnings in the wrong order, with imprecise line | ||
| 534 | ;; numbers and without function name info. | ||
| 535 | (unless (or ;; Uninterned symbols typically come from macro-expansion, so | ||
| 536 | ;; it is often non-trivial for the programmer to avoid such | ||
| 537 | ;; unused vars. | ||
| 538 | (not (intern-soft var)) | ||
| 539 | (eq ?_ (aref (symbol-name var) 0))) | ||
| 540 | (byte-compile-log-warning (format "Unused lexical %s `%S'" | ||
| 541 | varkind var)))) | ||
| 542 | ;; If it's unused, there's no point converting it into a cons-cell, even if | ||
| 543 | ;; it's captured and mutated. | ||
| 544 | (`(,binder ,_ t t ,_) | ||
| 545 | (push (cons binder form) cconv-captured+mutated)) | ||
| 546 | (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) | ||
| 547 | (push (cons binder form) cconv-lambda-candidates)))) | ||
| 548 | |||
| 549 | (defun cconv--analyse-function (args body env parentform) | ||
| 550 | (let* ((newvars nil) | ||
| 551 | (freevars (list body)) | ||
| 552 | ;; We analyze the body within a new environment where all uses are | ||
| 553 | ;; nil, so we can distinguish uses within that function from uses | ||
| 554 | ;; outside of it. | ||
| 555 | (envcopy | ||
| 556 | (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env)) | ||
| 557 | (newenv envcopy)) | ||
| 558 | ;; Push it before recursing, so cconv-freevars-alist contains entries in | ||
| 559 | ;; the order they'll be used by closure-convert-rec. | ||
| 560 | (push freevars cconv-freevars-alist) | ||
| 561 | (dolist (arg args) | ||
| 562 | (cond | ||
| 563 | ((byte-compile-not-lexical-var-p arg) | ||
| 564 | (byte-compile-log-warning | ||
| 565 | (format "Argument %S is not a lexical variable" arg))) | ||
| 566 | ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... | ||
| 567 | (t (let ((varstruct (list arg nil nil nil nil))) | ||
| 568 | (push (cons (list arg) (cdr varstruct)) newvars) | ||
| 569 | (push varstruct newenv))))) | ||
| 570 | (dolist (form body) ;Analyse body forms. | ||
| 571 | (cconv-analyse-form form newenv)) | ||
| 572 | ;; Summarize resulting data about arguments. | ||
| 573 | (dolist (vardata newvars) | ||
| 574 | (cconv--analyse-use vardata parentform "argument")) | ||
| 575 | ;; Transfer uses collected in `envcopy' (via `newenv') back to `env'; | ||
| 576 | ;; and compute free variables. | ||
| 577 | (while env | ||
| 578 | (assert (and envcopy (eq (caar env) (caar envcopy)))) | ||
| 579 | (let ((free nil) | ||
| 580 | (x (cdr (car env))) | ||
| 581 | (y (cdr (car envcopy)))) | ||
| 582 | (while x | ||
| 583 | (when (car y) (setcar x t) (setq free t)) | ||
| 584 | (setq x (cdr x) y (cdr y))) | ||
| 585 | (when free | ||
| 586 | (push (caar env) (cdr freevars)) | ||
| 587 | (setf (nth 3 (car env)) t)) | ||
| 588 | (setq env (cdr env) envcopy (cdr envcopy)))))) | ||
| 589 | |||
| 590 | (defun cconv-analyse-form (form env) | ||
| 591 | "Find mutated variables and variables captured by closure. | ||
| 592 | Analyse lambdas if they are suitable for lambda lifting. | ||
| 593 | - FORM is a piece of Elisp code after macroexpansion. | ||
| 594 | - ENV is an alist mapping each enclosing lexical variable to its info. | ||
| 595 | I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)). | ||
| 596 | This function does not return anything but instead fills the | ||
| 597 | `cconv-captured+mutated' and `cconv-lambda-candidates' variables | ||
| 598 | and updates the data stored in ENV." | ||
| 599 | (pcase form | ||
| 600 | ; let special form | ||
| 601 | (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) | ||
| 602 | |||
| 603 | (let ((orig-env env) | ||
| 604 | (newvars nil) | ||
| 605 | (var nil) | ||
| 606 | (value nil)) | ||
| 607 | (dolist (binder binders) | ||
| 608 | (if (not (consp binder)) | ||
| 609 | (progn | ||
| 610 | (setq var binder) ; treat the form (let (x) ...) well | ||
| 611 | (setq binder (list binder)) | ||
| 612 | (setq value nil)) | ||
| 613 | (setq var (car binder)) | ||
| 614 | (setq value (cadr binder)) | ||
| 615 | |||
| 616 | (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) | ||
| 617 | |||
| 618 | (unless (byte-compile-not-lexical-var-p var) | ||
| 619 | (let ((varstruct (list var nil nil nil nil))) | ||
| 620 | (push (cons binder (cdr varstruct)) newvars) | ||
| 621 | (push varstruct env)))) | ||
| 622 | |||
| 623 | (dolist (form body-forms) ; Analyse body forms. | ||
| 624 | (cconv-analyse-form form env)) | ||
| 625 | |||
| 626 | (dolist (vardata newvars) | ||
| 627 | (cconv--analyse-use vardata form "variable")))) | ||
| 628 | |||
| 629 | ; defun special form | ||
| 630 | (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms) | ||
| 631 | (when env | ||
| 632 | (byte-compile-log-warning | ||
| 633 | (format "Function %S will ignore its context %S" | ||
| 634 | func (mapcar #'car env)) | ||
| 635 | t :warning)) | ||
| 636 | (cconv--analyse-function vrs body-forms nil form)) | ||
| 637 | |||
| 638 | (`(function (lambda ,vrs . ,body-forms)) | ||
| 639 | (cconv--analyse-function vrs body-forms env form)) | ||
| 640 | |||
| 641 | (`(setq . ,forms) | ||
| 642 | ;; If a local variable (member of env) is modified by setq then | ||
| 643 | ;; it is a mutated variable. | ||
| 644 | (while forms | ||
| 645 | (let ((v (assq (car forms) env))) ; v = non nil if visible | ||
| 646 | (when v (setf (nth 2 v) t))) | ||
| 647 | (cconv-analyse-form (cadr forms) env) | ||
| 648 | (setq forms (cddr forms)))) | ||
| 649 | |||
| 650 | (`((lambda . ,_) . ,_) ; first element is lambda expression | ||
| 651 | (dolist (exp `((function ,(car form)) . ,(cdr form))) | ||
| 652 | (cconv-analyse-form exp env))) | ||
| 653 | |||
| 654 | (`(cond . ,cond-forms) ; cond special form | ||
| 655 | (dolist (forms cond-forms) | ||
| 656 | (dolist (form forms) (cconv-analyse-form form env)))) | ||
| 657 | |||
| 658 | (`(quote . ,_) nil) ; quote form | ||
| 659 | (`(function . ,_) nil) ; same as quote | ||
| 660 | |||
| 661 | (`(condition-case ,var ,protected-form . ,handlers) | ||
| 662 | ;; FIXME: The bytecode for condition-case forces us to wrap the | ||
| 663 | ;; form and handlers in closures (for handlers, it's understandable | ||
| 664 | ;; but not for the protected form). | ||
| 665 | (cconv--analyse-function () (list protected-form) env form) | ||
| 666 | (dolist (handler handlers) | ||
| 667 | (cconv--analyse-function (if var (list var)) (cdr handler) env form))) | ||
| 668 | |||
| 669 | ;; FIXME: The bytecode for catch forces us to wrap the body. | ||
| 670 | (`(,(or `catch `unwind-protect) ,form . ,body) | ||
| 671 | (cconv-analyse-form form env) | ||
| 672 | (cconv--analyse-function () body env form)) | ||
| 673 | |||
| 674 | ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body. | ||
| 675 | ;; `track-mouse' really should be made into a macro. | ||
| 676 | (`(track-mouse . ,body) | ||
| 677 | (cconv--analyse-function () body env form)) | ||
| 678 | |||
| 679 | (`(,(or `defconst `defvar) ,var ,value . ,_) | ||
| 680 | (push var byte-compile-bound-variables) | ||
| 681 | (cconv-analyse-form value env)) | ||
| 682 | |||
| 683 | (`(,(or `funcall `apply) ,fun . ,args) | ||
| 684 | ;; Here we ignore fun because funcall and apply are the only two | ||
| 685 | ;; functions where we can pass a candidate for lambda lifting as | ||
| 686 | ;; argument. So, if we see fun elsewhere, we'll delete it from | ||
| 687 | ;; lambda candidate list. | ||
| 688 | (let ((fdata (and (symbolp fun) (assq fun env)))) | ||
| 689 | (if fdata | ||
| 690 | (setf (nth 4 fdata) t) | ||
| 691 | (cconv-analyse-form fun env))) | ||
| 692 | (dolist (form args) (cconv-analyse-form form env))) | ||
| 693 | |||
| 694 | (`(interactive . ,forms) | ||
| 695 | ;; These appear within the function body but they don't have access | ||
| 696 | ;; to the function's arguments. | ||
| 697 | ;; We could extend this to allow interactive specs to refer to | ||
| 698 | ;; variables in the function's enclosing environment, but it doesn't | ||
| 699 | ;; seem worth the trouble. | ||
| 700 | (dolist (form forms) (cconv-analyse-form form nil))) | ||
| 701 | |||
| 702 | (`(declare . ,_) nil) ;The args don't contain code. | ||
| 703 | |||
| 704 | (`(,_ . ,body-forms) ; First element is a function or whatever. | ||
| 705 | (dolist (form body-forms) (cconv-analyse-form form env))) | ||
| 706 | |||
| 707 | ((pred symbolp) | ||
| 708 | (let ((dv (assq form env))) ; dv = declared and visible | ||
| 709 | (when dv | ||
| 710 | (setf (nth 1 dv) t)))))) | ||
| 711 | |||
| 712 | (provide 'cconv) | ||
| 713 | ;;; cconv.el ends here | ||
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 885424ec726..7468a0237cf 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el | |||
| @@ -766,20 +766,15 @@ This also does some trivial optimizations to make the form prettier." | |||
| 766 | (eq (car-safe (car body)) 'interactive)) | 766 | (eq (car-safe (car body)) 'interactive)) |
| 767 | (push (list 'quote (pop body)) decls)) | 767 | (push (list 'quote (pop body)) decls)) |
| 768 | (put (car (last cl-closure-vars)) 'used t) | 768 | (put (car (last cl-closure-vars)) 'used t) |
| 769 | (append | 769 | `(list 'lambda '(&rest --cl-rest--) |
| 770 | (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) | 770 | ,@(sublis sub (nreverse decls)) |
| 771 | (sublis sub (nreverse decls)) | 771 | (list 'apply |
| 772 | (list | 772 | (list 'quote |
| 773 | (list* 'list '(quote apply) | 773 | #'(lambda ,(append new (cadadr form)) |
| 774 | (list 'function | 774 | ,@(sublis sub body))) |
| 775 | (list* 'lambda | 775 | ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) |
| 776 | (append new (cadadr form)) | 776 | cl-closure-vars) |
| 777 | (sublis sub body))) | 777 | '((quote --cl-rest--)))))) |
| 778 | (nconc (mapcar (function | ||
| 779 | (lambda (x) | ||
| 780 | (list 'list '(quote quote) x))) | ||
| 781 | cl-closure-vars) | ||
| 782 | '((quote --cl-rest--))))))) | ||
| 783 | (list (car form) (list* 'lambda (cadadr form) body)))) | 778 | (list (car form) (list* 'lambda (cadadr form) body)))) |
| 784 | (let ((found (assq (cadr form) env))) | 779 | (let ((found (assq (cadr form) env))) |
| 785 | (if (and found (ignore-errors | 780 | (if (and found (ignore-errors |
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 08001171ed1..4c824d4a6d4 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el | |||
| @@ -10,7 +10,7 @@ | |||
| 10 | ;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p | 10 | ;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p |
| 11 | ;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively | 11 | ;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively |
| 12 | ;;;;;; notevery notany every some mapcon mapcan mapl maplist map | 12 | ;;;;;; notevery notany every some mapcon mapcan mapl maplist map |
| 13 | ;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "60f6b85256416c5f2a0a3954a11523b6") | 13 | ;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "26339d9571f9485bf34fa6d2ae38fc84") |
| 14 | ;;; Generated autoloads from cl-extra.el | 14 | ;;; Generated autoloads from cl-extra.el |
| 15 | 15 | ||
| 16 | (autoload 'coerce "cl-extra" "\ | 16 | (autoload 'coerce "cl-extra" "\ |
| @@ -277,12 +277,12 @@ Not documented | |||
| 277 | ;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct | 277 | ;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct |
| 278 | ;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf | 278 | ;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf |
| 279 | ;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method | 279 | ;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method |
| 280 | ;;;;;; declare locally multiple-value-setq multiple-value-bind lexical-let* | 280 | ;;;;;; declare the locally multiple-value-setq multiple-value-bind |
| 281 | ;;;;;; lexical-let symbol-macrolet macrolet labels flet progv psetq | 281 | ;;;;;; lexical-let* lexical-let symbol-macrolet macrolet labels |
| 282 | ;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from | 282 | ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist |
| 283 | ;;;;;; return block etypecase typecase ecase case load-time-value | 283 | ;;;;;; do* do loop return-from return block etypecase typecase ecase |
| 284 | ;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp | 284 | ;;;;;; case load-time-value eval-when destructuring-bind function* |
| 285 | ;;;;;; gensym) "cl-macs" "cl-macs.el" "b3031039e82679e5b013ce1cbf174ee8") | 285 | ;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "fe8a5acbe14e32846a77578b2165fab5") |
| 286 | ;;; Generated autoloads from cl-macs.el | 286 | ;;; Generated autoloads from cl-macs.el |
| 287 | 287 | ||
| 288 | (autoload 'gensym "cl-macs" "\ | 288 | (autoload 'gensym "cl-macs" "\ |
| @@ -319,7 +319,7 @@ its argument list allows full Common Lisp conventions. | |||
| 319 | \(fn FUNC)" nil (quote macro)) | 319 | \(fn FUNC)" nil (quote macro)) |
| 320 | 320 | ||
| 321 | (autoload 'destructuring-bind "cl-macs" "\ | 321 | (autoload 'destructuring-bind "cl-macs" "\ |
| 322 | Not documented | 322 | |
| 323 | 323 | ||
| 324 | \(fn ARGS EXPR &rest BODY)" nil (quote macro)) | 324 | \(fn ARGS EXPR &rest BODY)" nil (quote macro)) |
| 325 | 325 | ||
| @@ -445,7 +445,7 @@ from OBARRAY. | |||
| 445 | \(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro)) | 445 | \(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro)) |
| 446 | 446 | ||
| 447 | (autoload 'do-all-symbols "cl-macs" "\ | 447 | (autoload 'do-all-symbols "cl-macs" "\ |
| 448 | Not documented | 448 | |
| 449 | 449 | ||
| 450 | \(fn SPEC &rest BODY)" nil (quote macro)) | 450 | \(fn SPEC &rest BODY)" nil (quote macro)) |
| 451 | 451 | ||
| @@ -500,16 +500,16 @@ Like `let', but lexically scoped. | |||
| 500 | The main visible difference is that lambdas inside BODY will create | 500 | The main visible difference is that lambdas inside BODY will create |
| 501 | lexical closures as in Common Lisp. | 501 | lexical closures as in Common Lisp. |
| 502 | 502 | ||
| 503 | \(fn VARLIST BODY)" nil (quote macro)) | 503 | \(fn BINDINGS BODY)" nil (quote macro)) |
| 504 | 504 | ||
| 505 | (autoload 'lexical-let* "cl-macs" "\ | 505 | (autoload 'lexical-let* "cl-macs" "\ |
| 506 | Like `let*', but lexically scoped. | 506 | Like `let*', but lexically scoped. |
| 507 | The main visible difference is that lambdas inside BODY, and in | 507 | The main visible difference is that lambdas inside BODY, and in |
| 508 | successive bindings within VARLIST, will create lexical closures | 508 | successive bindings within BINDINGS, will create lexical closures |
| 509 | as in Common Lisp. This is similar to the behavior of `let*' in | 509 | as in Common Lisp. This is similar to the behavior of `let*' in |
| 510 | Common Lisp. | 510 | Common Lisp. |
| 511 | 511 | ||
| 512 | \(fn VARLIST BODY)" nil (quote macro)) | 512 | \(fn BINDINGS BODY)" nil (quote macro)) |
| 513 | 513 | ||
| 514 | (autoload 'multiple-value-bind "cl-macs" "\ | 514 | (autoload 'multiple-value-bind "cl-macs" "\ |
| 515 | Collect multiple return values. | 515 | Collect multiple return values. |
| @@ -531,12 +531,17 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). | |||
| 531 | \(fn (SYM...) FORM)" nil (quote macro)) | 531 | \(fn (SYM...) FORM)" nil (quote macro)) |
| 532 | 532 | ||
| 533 | (autoload 'locally "cl-macs" "\ | 533 | (autoload 'locally "cl-macs" "\ |
| 534 | Not documented | 534 | |
| 535 | 535 | ||
| 536 | \(fn &rest BODY)" nil (quote macro)) | 536 | \(fn &rest BODY)" nil (quote macro)) |
| 537 | 537 | ||
| 538 | (autoload 'the "cl-macs" "\ | ||
| 539 | |||
| 540 | |||
| 541 | \(fn TYPE FORM)" nil (quote macro)) | ||
| 542 | |||
| 538 | (autoload 'declare "cl-macs" "\ | 543 | (autoload 'declare "cl-macs" "\ |
| 539 | Not documented | 544 | |
| 540 | 545 | ||
| 541 | \(fn &rest SPECS)" nil (quote macro)) | 546 | \(fn &rest SPECS)" nil (quote macro)) |
| 542 | 547 | ||
| @@ -596,7 +601,7 @@ before assigning any PLACEs to the corresponding values. | |||
| 596 | \(fn PLACE VAL PLACE VAL ...)" nil (quote macro)) | 601 | \(fn PLACE VAL PLACE VAL ...)" nil (quote macro)) |
| 597 | 602 | ||
| 598 | (autoload 'cl-do-pop "cl-macs" "\ | 603 | (autoload 'cl-do-pop "cl-macs" "\ |
| 599 | Not documented | 604 | |
| 600 | 605 | ||
| 601 | \(fn PLACE)" nil nil) | 606 | \(fn PLACE)" nil nil) |
| 602 | 607 | ||
| @@ -684,7 +689,7 @@ value, that slot cannot be set via `setf'. | |||
| 684 | \(fn NAME SLOTS...)" nil (quote macro)) | 689 | \(fn NAME SLOTS...)" nil (quote macro)) |
| 685 | 690 | ||
| 686 | (autoload 'cl-struct-setf-expander "cl-macs" "\ | 691 | (autoload 'cl-struct-setf-expander "cl-macs" "\ |
| 687 | Not documented | 692 | |
| 688 | 693 | ||
| 689 | \(fn X NAME ACCESSOR PRED-FORM POS)" nil nil) | 694 | \(fn X NAME ACCESSOR PRED-FORM POS)" nil nil) |
| 690 | 695 | ||
| @@ -730,7 +735,7 @@ and then returning foo. | |||
| 730 | \(fn FUNC ARGS &rest BODY)" nil (quote macro)) | 735 | \(fn FUNC ARGS &rest BODY)" nil (quote macro)) |
| 731 | 736 | ||
| 732 | (autoload 'compiler-macroexpand "cl-macs" "\ | 737 | (autoload 'compiler-macroexpand "cl-macs" "\ |
| 733 | Not documented | 738 | |
| 734 | 739 | ||
| 735 | \(fn FORM)" nil nil) | 740 | \(fn FORM)" nil nil) |
| 736 | 741 | ||
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c57d37703b0..9ce3dd6a7fe 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el | |||
| @@ -497,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant." | |||
| 497 | (symbol-function 'byte-compile-file-form))) | 497 | (symbol-function 'byte-compile-file-form))) |
| 498 | (list 'byte-compile-file-form (list 'quote set)) | 498 | (list 'byte-compile-file-form (list 'quote set)) |
| 499 | '(byte-compile-file-form form))) | 499 | '(byte-compile-file-form form))) |
| 500 | (print set (symbol-value 'bytecomp-outbuffer))) | 500 | (print set (symbol-value 'byte-compile--outbuffer))) |
| 501 | (list 'symbol-value (list 'quote temp))) | 501 | (list 'symbol-value (list 'quote temp))) |
| 502 | (list 'quote (eval form)))) | 502 | (list 'quote (eval form)))) |
| 503 | 503 | ||
| @@ -598,27 +598,6 @@ called from BODY." | |||
| 598 | (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) | 598 | (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) |
| 599 | body)))) | 599 | body)))) |
| 600 | 600 | ||
| 601 | (defvar cl-active-block-names nil) | ||
| 602 | |||
| 603 | (put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) | ||
| 604 | (defun cl-byte-compile-block (cl-form) | ||
| 605 | (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler | ||
| 606 | (progn | ||
| 607 | (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) | ||
| 608 | (cl-active-block-names (cons cl-entry cl-active-block-names)) | ||
| 609 | (cl-body (byte-compile-top-level | ||
| 610 | (cons 'progn (cddr (nth 1 cl-form)))))) | ||
| 611 | (if (cdr cl-entry) | ||
| 612 | (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body)) | ||
| 613 | (byte-compile-form cl-body)))) | ||
| 614 | (byte-compile-form (nth 1 cl-form)))) | ||
| 615 | |||
| 616 | (put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw) | ||
| 617 | (defun cl-byte-compile-throw (cl-form) | ||
| 618 | (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) | ||
| 619 | (if cl-found (setcdr cl-found t))) | ||
| 620 | (byte-compile-normal-call (cons 'throw (cdr cl-form)))) | ||
| 621 | |||
| 622 | ;;;###autoload | 601 | ;;;###autoload |
| 623 | (defmacro return (&optional result) | 602 | (defmacro return (&optional result) |
| 624 | "Return from the block named nil. | 603 | "Return from the block named nil. |
| @@ -1427,7 +1406,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). | |||
| 1427 | "Like `let', but lexically scoped. | 1406 | "Like `let', but lexically scoped. |
| 1428 | The main visible difference is that lambdas inside BODY will create | 1407 | The main visible difference is that lambdas inside BODY will create |
| 1429 | lexical closures as in Common Lisp. | 1408 | lexical closures as in Common Lisp. |
| 1430 | \n(fn VARLIST BODY)" | 1409 | \n(fn BINDINGS BODY)" |
| 1431 | (let* ((cl-closure-vars cl-closure-vars) | 1410 | (let* ((cl-closure-vars cl-closure-vars) |
| 1432 | (vars (mapcar (function | 1411 | (vars (mapcar (function |
| 1433 | (lambda (x) | 1412 | (lambda (x) |
| @@ -1470,10 +1449,10 @@ lexical closures as in Common Lisp. | |||
| 1470 | (defmacro lexical-let* (bindings &rest body) | 1449 | (defmacro lexical-let* (bindings &rest body) |
| 1471 | "Like `let*', but lexically scoped. | 1450 | "Like `let*', but lexically scoped. |
| 1472 | The main visible difference is that lambdas inside BODY, and in | 1451 | The main visible difference is that lambdas inside BODY, and in |
| 1473 | successive bindings within VARLIST, will create lexical closures | 1452 | successive bindings within BINDINGS, will create lexical closures |
| 1474 | as in Common Lisp. This is similar to the behavior of `let*' in | 1453 | as in Common Lisp. This is similar to the behavior of `let*' in |
| 1475 | Common Lisp. | 1454 | Common Lisp. |
| 1476 | \n(fn VARLIST BODY)" | 1455 | \n(fn BINDINGS BODY)" |
| 1477 | (if (null bindings) (cons 'progn body) | 1456 | (if (null bindings) (cons 'progn body) |
| 1478 | (setq bindings (reverse bindings)) | 1457 | (setq bindings (reverse bindings)) |
| 1479 | (while bindings | 1458 | (while bindings |
| @@ -2422,11 +2401,13 @@ value, that slot cannot be set via `setf'. | |||
| 2422 | (push (cons name t) side-eff)))) | 2401 | (push (cons name t) side-eff)))) |
| 2423 | (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) | 2402 | (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) |
| 2424 | (if print-func | 2403 | (if print-func |
| 2425 | (push (list 'push | 2404 | (push `(push |
| 2426 | (list 'function | 2405 | ;; The auto-generated function does not pay attention to |
| 2427 | (list 'lambda '(cl-x cl-s cl-n) | 2406 | ;; the depth argument cl-n. |
| 2428 | (list 'and pred-form print-func))) | 2407 | (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n)) |
| 2429 | 'custom-print-functions) forms)) | 2408 | (and ,pred-form ,print-func)) |
| 2409 | custom-print-functions) | ||
| 2410 | forms)) | ||
| 2430 | (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) | 2411 | (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) |
| 2431 | (push (list* 'eval-when '(compile load eval) | 2412 | (push (list* 'eval-when '(compile load eval) |
| 2432 | (list 'put (list 'quote name) '(quote cl-struct-slots) | 2413 | (list 'put (list 'quote name) '(quote cl-struct-slots) |
| @@ -2580,7 +2561,7 @@ and then returning foo." | |||
| 2580 | (cl-transform-function-property | 2561 | (cl-transform-function-property |
| 2581 | func 'cl-compiler-macro | 2562 | func 'cl-compiler-macro |
| 2582 | (cons (if (memq '&whole args) (delq '&whole args) | 2563 | (cons (if (memq '&whole args) (delq '&whole args) |
| 2583 | (cons '--cl-whole-arg-- args)) body)) | 2564 | (cons '_cl-whole-arg args)) body)) |
| 2584 | (list 'or (list 'get (list 'quote func) '(quote byte-compile)) | 2565 | (list 'or (list 'get (list 'quote func) '(quote byte-compile)) |
| 2585 | (list 'progn | 2566 | (list 'progn |
| 2586 | (list 'put (list 'quote func) '(quote byte-compile) | 2567 | (list 'put (list 'quote func) '(quote byte-compile) |
| @@ -2618,6 +2599,27 @@ and then returning foo." | |||
| 2618 | (byte-compile-normal-call form) | 2599 | (byte-compile-normal-call form) |
| 2619 | (byte-compile-form form))) | 2600 | (byte-compile-form form))) |
| 2620 | 2601 | ||
| 2602 | ;; Optimize away unused block-wrappers. | ||
| 2603 | |||
| 2604 | (defvar cl-active-block-names nil) | ||
| 2605 | |||
| 2606 | (define-compiler-macro cl-block-wrapper (cl-form) | ||
| 2607 | (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil)) | ||
| 2608 | (cl-active-block-names (cons cl-entry cl-active-block-names)) | ||
| 2609 | (cl-body (macroexpand-all ;Performs compiler-macro expansions. | ||
| 2610 | (cons 'progn (cddr cl-form)) | ||
| 2611 | macroexpand-all-environment))) | ||
| 2612 | ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able | ||
| 2613 | ;; to indicate that this return value is already fully expanded. | ||
| 2614 | (if (cdr cl-entry) | ||
| 2615 | `(catch ,(nth 1 cl-form) ,@(cdr cl-body)) | ||
| 2616 | cl-body))) | ||
| 2617 | |||
| 2618 | (define-compiler-macro cl-block-throw (cl-tag cl-value) | ||
| 2619 | (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names))) | ||
| 2620 | (if cl-found (setcdr cl-found t))) | ||
| 2621 | `(throw ,cl-tag ,cl-value)) | ||
| 2622 | |||
| 2621 | ;;;###autoload | 2623 | ;;;###autoload |
| 2622 | (defmacro defsubst* (name args &rest body) | 2624 | (defmacro defsubst* (name args &rest body) |
| 2623 | "Define NAME as a function. | 2625 | "Define NAME as a function. |
diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 1d2b82f82eb..526475eb1bd 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el | |||
| @@ -161,7 +161,14 @@ an element already on the list. | |||
| 161 | (if (symbolp place) | 161 | (if (symbolp place) |
| 162 | (if (null keys) | 162 | (if (null keys) |
| 163 | `(let ((x ,x)) | 163 | `(let ((x ,x)) |
| 164 | (if (memql x ,place) ,place (setq ,place (cons x ,place)))) | 164 | (if (memql x ,place) |
| 165 | ;; This symbol may later on expand to actual code which then | ||
| 166 | ;; trigger warnings like "value unused" since pushnew's return | ||
| 167 | ;; value is rarely used. It should not matter that other | ||
| 168 | ;; warnings may be silenced, since `place' is used earlier and | ||
| 169 | ;; should have triggered them already. | ||
| 170 | (with-no-warnings ,place) | ||
| 171 | (setq ,place (cons x ,place)))) | ||
| 165 | (list 'setq place (list* 'adjoin x place keys))) | 172 | (list 'setq place (list* 'adjoin x place keys))) |
| 166 | (list* 'callf2 'adjoin x place keys))) | 173 | (list* 'callf2 'adjoin x place keys))) |
| 167 | 174 | ||
| @@ -271,9 +278,9 @@ definitions to shadow the loaded ones for use in file byte-compilation. | |||
| 271 | (defvar cl-compiling-file nil) | 278 | (defvar cl-compiling-file nil) |
| 272 | (defun cl-compiling-file () | 279 | (defun cl-compiling-file () |
| 273 | (or cl-compiling-file | 280 | (or cl-compiling-file |
| 274 | (and (boundp 'bytecomp-outbuffer) | 281 | (and (boundp 'byte-compile--outbuffer) |
| 275 | (bufferp (symbol-value 'bytecomp-outbuffer)) | 282 | (bufferp (symbol-value 'byte-compile--outbuffer)) |
| 276 | (equal (buffer-name (symbol-value 'bytecomp-outbuffer)) | 283 | (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) |
| 277 | " *Compiler Output*")))) | 284 | " *Compiler Output*")))) |
| 278 | 285 | ||
| 279 | (defvar cl-proclaims-deferred nil) | 286 | (defvar cl-proclaims-deferred nil) |
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 9f4cca91676..4fd10185c17 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el | |||
| @@ -78,13 +78,14 @@ redefine OBJECT if it is a symbol." | |||
| 78 | obj (symbol-function obj))) | 78 | obj (symbol-function obj))) |
| 79 | (if (subrp obj) | 79 | (if (subrp obj) |
| 80 | (error "Can't disassemble #<subr %s>" name)) | 80 | (error "Can't disassemble #<subr %s>" name)) |
| 81 | (if (and (listp obj) (eq (car obj) 'autoload)) | 81 | (when (and (listp obj) (eq (car obj) 'autoload)) |
| 82 | (progn | 82 | (load (nth 1 obj)) |
| 83 | (load (nth 1 obj)) | 83 | (setq obj (symbol-function name))) |
| 84 | (setq obj (symbol-function name)))) | ||
| 85 | (if (eq (car-safe obj) 'macro) ;handle macros | 84 | (if (eq (car-safe obj) 'macro) ;handle macros |
| 86 | (setq macro t | 85 | (setq macro t |
| 87 | obj (cdr obj))) | 86 | obj (cdr obj))) |
| 87 | (when (and (listp obj) (eq (car obj) 'closure)) | ||
| 88 | (error "Don't know how to compile an interpreted closure")) | ||
| 88 | (if (and (listp obj) (eq (car obj) 'byte-code)) | 89 | (if (and (listp obj) (eq (car obj) 'byte-code)) |
| 89 | (setq obj (list 'lambda nil obj))) | 90 | (setq obj (list 'lambda nil obj))) |
| 90 | (if (and (listp obj) (not (eq (car obj) 'lambda))) | 91 | (if (and (listp obj) (not (eq (car obj) 'lambda))) |
| @@ -215,7 +216,9 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." | |||
| 215 | (cond ((memq op byte-goto-ops) | 216 | (cond ((memq op byte-goto-ops) |
| 216 | (insert (int-to-string (nth 1 arg)))) | 217 | (insert (int-to-string (nth 1 arg)))) |
| 217 | ((memq op '(byte-call byte-unbind | 218 | ((memq op '(byte-call byte-unbind |
| 218 | byte-listN byte-concatN byte-insertN)) | 219 | byte-listN byte-concatN byte-insertN |
| 220 | byte-stack-ref byte-stack-set byte-stack-set2 | ||
| 221 | byte-discardN byte-discardN-preserve-tos)) | ||
| 219 | (insert (int-to-string arg))) | 222 | (insert (int-to-string arg))) |
| 220 | ((memq op '(byte-varref byte-varset byte-varbind)) | 223 | ((memq op '(byte-varref byte-varset byte-varbind)) |
| 221 | (prin1 (car arg) (current-buffer))) | 224 | (prin1 (car arg) (current-buffer))) |
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 70a7983dbea..f84de0308bf 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el | |||
| @@ -519,7 +519,8 @@ the minibuffer." | |||
| 519 | ((and (eq (car form) 'defcustom) | 519 | ((and (eq (car form) 'defcustom) |
| 520 | (default-boundp (nth 1 form))) | 520 | (default-boundp (nth 1 form))) |
| 521 | ;; Force variable to be bound. | 521 | ;; Force variable to be bound. |
| 522 | (set-default (nth 1 form) (eval (nth 2 form)))) | 522 | ;; FIXME: Shouldn't this use the :setter or :initializer? |
| 523 | (set-default (nth 1 form) (eval (nth 2 form) lexical-binding))) | ||
| 523 | ((eq (car form) 'defface) | 524 | ((eq (car form) 'defface) |
| 524 | ;; Reset the face. | 525 | ;; Reset the face. |
| 525 | (setq face-new-frame-defaults | 526 | (setq face-new-frame-defaults |
| @@ -532,7 +533,7 @@ the minibuffer." | |||
| 532 | (put ',(nth 1 form) 'customized-face | 533 | (put ',(nth 1 form) 'customized-face |
| 533 | ,(nth 2 form))) | 534 | ,(nth 2 form))) |
| 534 | (put (nth 1 form) 'saved-face nil))))) | 535 | (put (nth 1 form) 'saved-face nil))))) |
| 535 | (setq edebug-result (eval form)) | 536 | (setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding)) |
| 536 | (if (not edebugging) | 537 | (if (not edebugging) |
| 537 | (princ edebug-result) | 538 | (princ edebug-result) |
| 538 | edebug-result))) | 539 | edebug-result))) |
| @@ -565,7 +566,8 @@ already is one.)" | |||
| 565 | ;; but this causes problems while edebugging edebug. | 566 | ;; but this causes problems while edebugging edebug. |
| 566 | (let ((edebug-all-forms t) | 567 | (let ((edebug-all-forms t) |
| 567 | (edebug-all-defs t)) | 568 | (edebug-all-defs t)) |
| 568 | (edebug-read-top-level-form)))) | 569 | (eval-sexp-add-defvars |
| 570 | (edebug-read-top-level-form))))) | ||
| 569 | 571 | ||
| 570 | 572 | ||
| 571 | (defun edebug-read-top-level-form () | 573 | (defun edebug-read-top-level-form () |
| @@ -2462,6 +2464,7 @@ MSG is printed after `::::} '." | |||
| 2462 | (if edebug-global-break-condition | 2464 | (if edebug-global-break-condition |
| 2463 | (condition-case nil | 2465 | (condition-case nil |
| 2464 | (setq edebug-global-break-result | 2466 | (setq edebug-global-break-result |
| 2467 | ;; FIXME: lexbind. | ||
| 2465 | (eval edebug-global-break-condition)) | 2468 | (eval edebug-global-break-condition)) |
| 2466 | (error nil)))) | 2469 | (error nil)))) |
| 2467 | (edebug-break)) | 2470 | (edebug-break)) |
| @@ -2473,6 +2476,7 @@ MSG is printed after `::::} '." | |||
| 2473 | (and edebug-break-data | 2476 | (and edebug-break-data |
| 2474 | (or (not edebug-break-condition) | 2477 | (or (not edebug-break-condition) |
| 2475 | (setq edebug-break-result | 2478 | (setq edebug-break-result |
| 2479 | ;; FIXME: lexbind. | ||
| 2476 | (eval edebug-break-condition)))))) | 2480 | (eval edebug-break-condition)))))) |
| 2477 | (if (and edebug-break | 2481 | (if (and edebug-break |
| 2478 | (nth 2 edebug-break-data)) ; is it temporary? | 2482 | (nth 2 edebug-break-data)) ; is it temporary? |
| @@ -3633,9 +3637,10 @@ Return the result of the last expression." | |||
| 3633 | 3637 | ||
| 3634 | (defun edebug-eval (edebug-expr) | 3638 | (defun edebug-eval (edebug-expr) |
| 3635 | ;; Are there cl lexical variables active? | 3639 | ;; Are there cl lexical variables active? |
| 3636 | (if (bound-and-true-p cl-debug-env) | 3640 | (eval (if (bound-and-true-p cl-debug-env) |
| 3637 | (eval (cl-macroexpand-all edebug-expr cl-debug-env)) | 3641 | (cl-macroexpand-all edebug-expr cl-debug-env) |
| 3638 | (eval edebug-expr))) | 3642 | edebug-expr) |
| 3643 | lexical-binding)) | ||
| 3639 | 3644 | ||
| 3640 | (defun edebug-safe-eval (edebug-expr) | 3645 | (defun edebug-safe-eval (edebug-expr) |
| 3641 | ;; Evaluate EXPR safely. | 3646 | ;; Evaluate EXPR safely. |
| @@ -4237,8 +4242,8 @@ It is removed when you hit any char." | |||
| 4237 | ;;; Menus | 4242 | ;;; Menus |
| 4238 | 4243 | ||
| 4239 | (defun edebug-toggle (variable) | 4244 | (defun edebug-toggle (variable) |
| 4240 | (set variable (not (eval variable))) | 4245 | (set variable (not (symbol-value variable))) |
| 4241 | (message "%s: %s" variable (eval variable))) | 4246 | (message "%s: %s" variable (symbol-value variable))) |
| 4242 | 4247 | ||
| 4243 | ;; We have to require easymenu (even for Emacs 18) just so | 4248 | ;; We have to require easymenu (even for Emacs 18) just so |
| 4244 | ;; the easy-menu-define macro call is compiled correctly. | 4249 | ;; the easy-menu-define macro call is compiled correctly. |
diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el deleted file mode 100644 index ed6fb6f1c41..00000000000 --- a/lisp/emacs-lisp/eieio-comp.el +++ /dev/null | |||
| @@ -1,142 +0,0 @@ | |||
| 1 | ;;; eieio-comp.el -- eieio routines to help with byte compilation | ||
| 2 | |||
| 3 | ;; Copyright (C) 1995-1996, 1998-2002, 2005, 2008-2011 | ||
| 4 | ;; Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 7 | ;; Version: 0.2 | ||
| 8 | ;; Keywords: lisp, tools | ||
| 9 | ;; Package: eieio | ||
| 10 | |||
| 11 | ;; This file is part of GNU Emacs. | ||
| 12 | |||
| 13 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 14 | ;; it under the terms of the GNU General Public License as published by | ||
| 15 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 16 | ;; (at your option) any later version. | ||
| 17 | |||
| 18 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 21 | ;; GNU General Public License for more details. | ||
| 22 | |||
| 23 | ;; You should have received a copy of the GNU General Public License | ||
| 24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 25 | |||
| 26 | ;;; Commentary: | ||
| 27 | |||
| 28 | ;; Byte compiler functions for defmethod. This will affect the new GNU | ||
| 29 | ;; byte compiler for Emacs 19 and better. This function will be called by | ||
| 30 | ;; the byte compiler whenever a `defmethod' is encountered in a file. | ||
| 31 | ;; It will output a function call to `eieio-defmethod' with the byte | ||
| 32 | ;; compiled function as a parameter. | ||
| 33 | |||
| 34 | ;;; Code: | ||
| 35 | |||
| 36 | (declare-function eieio-defgeneric-form "eieio" (method doc-string)) | ||
| 37 | |||
| 38 | ;; Some compatibility stuff | ||
| 39 | (eval-and-compile | ||
| 40 | (if (not (fboundp 'byte-compile-compiled-obj-to-list)) | ||
| 41 | (defun byte-compile-compiled-obj-to-list (moose) nil)) | ||
| 42 | |||
| 43 | (if (not (boundp 'byte-compile-outbuffer)) | ||
| 44 | (defvar byte-compile-outbuffer nil)) | ||
| 45 | ) | ||
| 46 | |||
| 47 | ;; This teaches the byte compiler how to do this sort of thing. | ||
| 48 | (put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) | ||
| 49 | |||
| 50 | (defun byte-compile-file-form-defmethod (form) | ||
| 51 | "Mumble about the method we are compiling. | ||
| 52 | This function is mostly ripped from `byte-compile-file-form-defun', | ||
| 53 | but it's been modified to handle the special syntax of the `defmethod' | ||
| 54 | command. There should probably be one for `defgeneric' as well, but | ||
| 55 | that is called but rarely. Argument FORM is the body of the method." | ||
| 56 | (setq form (cdr form)) | ||
| 57 | (let* ((meth (car form)) | ||
| 58 | (key (progn (setq form (cdr form)) | ||
| 59 | (cond ((or (eq ':BEFORE (car form)) | ||
| 60 | (eq ':before (car form))) | ||
| 61 | (setq form (cdr form)) | ||
| 62 | ":before ") | ||
| 63 | ((or (eq ':AFTER (car form)) | ||
| 64 | (eq ':after (car form))) | ||
| 65 | (setq form (cdr form)) | ||
| 66 | ":after ") | ||
| 67 | ((or (eq ':PRIMARY (car form)) | ||
| 68 | (eq ':primary (car form))) | ||
| 69 | (setq form (cdr form)) | ||
| 70 | ":primary ") | ||
| 71 | ((or (eq ':STATIC (car form)) | ||
| 72 | (eq ':static (car form))) | ||
| 73 | (setq form (cdr form)) | ||
| 74 | ":static ") | ||
| 75 | (t "")))) | ||
| 76 | (params (car form)) | ||
| 77 | (lamparams (byte-compile-defmethod-param-convert params)) | ||
| 78 | (arg1 (car params)) | ||
| 79 | (class (if (listp arg1) (nth 1 arg1) nil)) | ||
| 80 | (my-outbuffer (if (eval-when-compile (featurep 'xemacs)) | ||
| 81 | byte-compile-outbuffer | ||
| 82 | (cond ((boundp 'bytecomp-outbuffer) | ||
| 83 | bytecomp-outbuffer) ; Emacs >= 23.2 | ||
| 84 | ((boundp 'outbuffer) outbuffer) | ||
| 85 | (t (error "Unable to set outbuffer")))))) | ||
| 86 | (let ((name (format "%s::%s" (or class "#<generic>") meth))) | ||
| 87 | (if byte-compile-verbose | ||
| 88 | ;; #### filename used free | ||
| 89 | (message "Compiling %s... (%s)" | ||
| 90 | (cond ((boundp 'bytecomp-filename) bytecomp-filename) | ||
| 91 | ((boundp 'filename) filename) | ||
| 92 | (t "")) | ||
| 93 | name)) | ||
| 94 | (setq byte-compile-current-form name) ; for warnings | ||
| 95 | ) | ||
| 96 | ;; Flush any pending output | ||
| 97 | (byte-compile-flush-pending) | ||
| 98 | ;; Byte compile the body. For the byte compiled forms, add the | ||
| 99 | ;; rest arguments, which will get ignored by the engine which will | ||
| 100 | ;; add them later (I hope) | ||
| 101 | (let* ((new-one (byte-compile-lambda | ||
| 102 | (append (list 'lambda lamparams) | ||
| 103 | (cdr form)))) | ||
| 104 | (code (byte-compile-byte-code-maker new-one))) | ||
| 105 | (princ "\n(eieio-defmethod '" my-outbuffer) | ||
| 106 | (princ meth my-outbuffer) | ||
| 107 | (princ " '(" my-outbuffer) | ||
| 108 | (princ key my-outbuffer) | ||
| 109 | (prin1 params my-outbuffer) | ||
| 110 | (princ " " my-outbuffer) | ||
| 111 | (prin1 code my-outbuffer) | ||
| 112 | (princ "))" my-outbuffer) | ||
| 113 | ) | ||
| 114 | ;; Now add this function to the list of known functions. | ||
| 115 | ;; Don't bother with a doc string. Not relevant here. | ||
| 116 | (add-to-list 'byte-compile-function-environment | ||
| 117 | (cons meth | ||
| 118 | (eieio-defgeneric-form meth ""))) | ||
| 119 | |||
| 120 | ;; Remove it from the undefined list if it is there. | ||
| 121 | (let ((elt (assq meth byte-compile-unresolved-functions))) | ||
| 122 | (if elt (setq byte-compile-unresolved-functions | ||
| 123 | (delq elt byte-compile-unresolved-functions)))) | ||
| 124 | |||
| 125 | ;; nil prevents cruft from appearing in the output buffer. | ||
| 126 | nil)) | ||
| 127 | |||
| 128 | (defun byte-compile-defmethod-param-convert (paramlist) | ||
| 129 | "Convert method params into the params used by the `defmethod' thingy. | ||
| 130 | Argument PARAMLIST is the parameter list to convert." | ||
| 131 | (let ((argfix nil)) | ||
| 132 | (while paramlist | ||
| 133 | (setq argfix (cons (if (listp (car paramlist)) | ||
| 134 | (car (car paramlist)) | ||
| 135 | (car paramlist)) | ||
| 136 | argfix)) | ||
| 137 | (setq paramlist (cdr paramlist))) | ||
| 138 | (nreverse argfix))) | ||
| 139 | |||
| 140 | (provide 'eieio-comp) | ||
| 141 | |||
| 142 | ;;; eieio-comp.el ends here | ||
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 2fe33dfce2e..7a119e6bbc0 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el | |||
| @@ -45,8 +45,7 @@ | |||
| 45 | ;;; Code: | 45 | ;;; Code: |
| 46 | 46 | ||
| 47 | (eval-when-compile | 47 | (eval-when-compile |
| 48 | (require 'cl) | 48 | (require 'cl)) |
| 49 | (require 'eieio-comp)) | ||
| 50 | 49 | ||
| 51 | (defvar eieio-version "1.3" | 50 | (defvar eieio-version "1.3" |
| 52 | "Current version of EIEIO.") | 51 | "Current version of EIEIO.") |
| @@ -97,6 +96,7 @@ default setting for optimization purposes.") | |||
| 97 | "Non-nil means to optimize the method dispatch on primary methods.") | 96 | "Non-nil means to optimize the method dispatch on primary methods.") |
| 98 | 97 | ||
| 99 | ;; State Variables | 98 | ;; State Variables |
| 99 | ;; FIXME: These two constants below should have an `eieio-' prefix added!! | ||
| 100 | (defvar this nil | 100 | (defvar this nil |
| 101 | "Inside a method, this variable is the object in question. | 101 | "Inside a method, this variable is the object in question. |
| 102 | DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots. | 102 | DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots. |
| @@ -123,6 +123,7 @@ execute a `call-next-method'. DO NOT SET THIS YOURSELF!") | |||
| 123 | ;; while it is being built itself. | 123 | ;; while it is being built itself. |
| 124 | (defvar eieio-default-superclass nil) | 124 | (defvar eieio-default-superclass nil) |
| 125 | 125 | ||
| 126 | ;; FIXME: The constants below should have an `eieio-' prefix added!! | ||
| 126 | (defconst class-symbol 1 "Class's symbol (self-referencing.).") | 127 | (defconst class-symbol 1 "Class's symbol (self-referencing.).") |
| 127 | (defconst class-parent 2 "Class parent slot.") | 128 | (defconst class-parent 2 "Class parent slot.") |
| 128 | (defconst class-children 3 "Class children class slot.") | 129 | (defconst class-children 3 "Class children class slot.") |
| @@ -181,10 +182,6 @@ Stored outright without modifications or stripping.") | |||
| 181 | (t key) ;; already generic.. maybe. | 182 | (t key) ;; already generic.. maybe. |
| 182 | )) | 183 | )) |
| 183 | 184 | ||
| 184 | ;; How to specialty compile stuff. | ||
| 185 | (autoload 'byte-compile-file-form-defmethod "eieio-comp" | ||
| 186 | "This function is used to byte compile methods in a nice way.") | ||
| 187 | (put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) | ||
| 188 | 185 | ||
| 189 | ;;; Important macros used in eieio. | 186 | ;;; Important macros used in eieio. |
| 190 | ;; | 187 | ;; |
| @@ -1192,10 +1189,8 @@ IMPL is the symbol holding the method implementation." | |||
| 1192 | ;; is faster to execute this for not byte-compiled. ie, install this, | 1189 | ;; is faster to execute this for not byte-compiled. ie, install this, |
| 1193 | ;; then measure calls going through here. I wonder why. | 1190 | ;; then measure calls going through here. I wonder why. |
| 1194 | (require 'bytecomp) | 1191 | (require 'bytecomp) |
| 1195 | (let ((byte-compile-free-references nil) | 1192 | (let ((byte-compile-warnings nil)) |
| 1196 | (byte-compile-warnings nil) | 1193 | (byte-compile |
| 1197 | ) | ||
| 1198 | (byte-compile-lambda | ||
| 1199 | `(lambda (&rest local-args) | 1194 | `(lambda (&rest local-args) |
| 1200 | ,doc-string | 1195 | ,doc-string |
| 1201 | ;; This is a cool cheat. Usually we need to look up in the | 1196 | ;; This is a cool cheat. Usually we need to look up in the |
| @@ -1205,7 +1200,8 @@ IMPL is the symbol holding the method implementation." | |||
| 1205 | ;; of that one implementation, then clearly, there is no method def. | 1200 | ;; of that one implementation, then clearly, there is no method def. |
| 1206 | (if (not (eieio-object-p (car local-args))) | 1201 | (if (not (eieio-object-p (car local-args))) |
| 1207 | ;; Not an object. Just signal. | 1202 | ;; Not an object. Just signal. |
| 1208 | (signal 'no-method-definition (list ,(list 'quote method) local-args)) | 1203 | (signal 'no-method-definition |
| 1204 | (list ,(list 'quote method) local-args)) | ||
| 1209 | 1205 | ||
| 1210 | ;; We do have an object. Make sure it is the right type. | 1206 | ;; We do have an object. Make sure it is the right type. |
| 1211 | (if ,(if (eq class eieio-default-superclass) | 1207 | (if ,(if (eq class eieio-default-superclass) |
| @@ -1228,9 +1224,7 @@ IMPL is the symbol holding the method implementation." | |||
| 1228 | ) | 1224 | ) |
| 1229 | (apply ,(list 'quote impl) local-args) | 1225 | (apply ,(list 'quote impl) local-args) |
| 1230 | ;(,impl local-args) | 1226 | ;(,impl local-args) |
| 1231 | )))) | 1227 | ))))))) |
| 1232 | ) | ||
| 1233 | )) | ||
| 1234 | 1228 | ||
| 1235 | (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) | 1229 | (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) |
| 1236 | "Setup METHOD to call the generic form." | 1230 | "Setup METHOD to call the generic form." |
| @@ -1296,9 +1290,35 @@ Summary: | |||
| 1296 | ((typearg class-name) arg2 &optional opt &rest rest) | 1290 | ((typearg class-name) arg2 &optional opt &rest rest) |
| 1297 | \"doc-string\" | 1291 | \"doc-string\" |
| 1298 | body)" | 1292 | body)" |
| 1299 | `(eieio-defmethod (quote ,method) (quote ,args))) | 1293 | (let* ((key (cond ((or (eq ':BEFORE (car args)) |
| 1300 | 1294 | (eq ':before (car args))) | |
| 1301 | (defun eieio-defmethod (method args) | 1295 | (setq args (cdr args)) |
| 1296 | :before) | ||
| 1297 | ((or (eq ':AFTER (car args)) | ||
| 1298 | (eq ':after (car args))) | ||
| 1299 | (setq args (cdr args)) | ||
| 1300 | :after) | ||
| 1301 | ((or (eq ':PRIMARY (car args)) | ||
| 1302 | (eq ':primary (car args))) | ||
| 1303 | (setq args (cdr args)) | ||
| 1304 | :primary) | ||
| 1305 | ((or (eq ':STATIC (car args)) | ||
| 1306 | (eq ':static (car args))) | ||
| 1307 | (setq args (cdr args)) | ||
| 1308 | :static) | ||
| 1309 | (t nil))) | ||
| 1310 | (params (car args)) | ||
| 1311 | (lamparams | ||
| 1312 | (mapcar (lambda (param) (if (listp param) (car param) param)) | ||
| 1313 | params)) | ||
| 1314 | (arg1 (car params)) | ||
| 1315 | (class (if (listp arg1) (nth 1 arg1) nil))) | ||
| 1316 | `(eieio-defmethod ',method | ||
| 1317 | '(,@(if key (list key)) | ||
| 1318 | ,params) | ||
| 1319 | (lambda ,lamparams ,@(cdr args))))) | ||
| 1320 | |||
| 1321 | (defun eieio-defmethod (method args &optional code) | ||
| 1302 | "Work part of the `defmethod' macro defining METHOD with ARGS." | 1322 | "Work part of the `defmethod' macro defining METHOD with ARGS." |
| 1303 | (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) | 1323 | (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) |
| 1304 | ;; find optional keys | 1324 | ;; find optional keys |
| @@ -1352,10 +1372,7 @@ Summary: | |||
| 1352 | ;; generics are higher | 1372 | ;; generics are higher |
| 1353 | (setq key (eieio-specialized-key-to-generic-key key))) | 1373 | (setq key (eieio-specialized-key-to-generic-key key))) |
| 1354 | ;; Put this lambda into the symbol so we can find it | 1374 | ;; Put this lambda into the symbol so we can find it |
| 1355 | (if (byte-code-function-p (car-safe body)) | 1375 | (eieiomt-add method code key argclass) |
| 1356 | (eieiomt-add method (car-safe body) key argclass) | ||
| 1357 | (eieiomt-add method (append (list 'lambda (reverse argfix)) body) | ||
| 1358 | key argclass)) | ||
| 1359 | ) | 1376 | ) |
| 1360 | 1377 | ||
| 1361 | (when eieio-optimize-primary-methods-flag | 1378 | (when eieio-optimize-primary-methods-flag |
diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index ceb1eb3bafb..7e40fdad352 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el | |||
| @@ -28,7 +28,13 @@ | |||
| 28 | ;; Provide an easy hook to tell if we are running with floats or not. | 28 | ;; Provide an easy hook to tell if we are running with floats or not. |
| 29 | ;; Define pi and e via math-lib calls (much less prone to killer typos). | 29 | ;; Define pi and e via math-lib calls (much less prone to killer typos). |
| 30 | (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") | 30 | (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") |
| 31 | (defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.") | 31 | (progn |
| 32 | ;; Simulate a defconst that doesn't declare the variable dynamically bound. | ||
| 33 | (setq-default pi float-pi) | ||
| 34 | (put 'pi 'variable-documentation | ||
| 35 | "Obsolete since Emacs-23.3. Use `float-pi' instead.") | ||
| 36 | (put 'pi 'risky-local-variable t) | ||
| 37 | (push 'pi current-load-list)) | ||
| 32 | 38 | ||
| 33 | (defconst float-e (exp 1) "The value of e (2.7182818...).") | 39 | (defconst float-e (exp 1) "The value of e (2.7182818...).") |
| 34 | 40 | ||
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 15690023700..39bdb505039 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el | |||
| @@ -699,7 +699,9 @@ If CHAR is not a character, return nil." | |||
| 699 | "Evaluate sexp before point; print value in minibuffer. | 699 | "Evaluate sexp before point; print value in minibuffer. |
| 700 | With argument, print output into current buffer." | 700 | With argument, print output into current buffer." |
| 701 | (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) | 701 | (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) |
| 702 | (eval-last-sexp-print-value (eval (preceding-sexp))))) | 702 | ;; Setup the lexical environment if lexical-binding is enabled. |
| 703 | (eval-last-sexp-print-value | ||
| 704 | (eval (eval-sexp-add-defvars (preceding-sexp)) lexical-binding)))) | ||
| 703 | 705 | ||
| 704 | 706 | ||
| 705 | (defun eval-last-sexp-print-value (value) | 707 | (defun eval-last-sexp-print-value (value) |
| @@ -727,6 +729,23 @@ With argument, print output into current buffer." | |||
| 727 | 729 | ||
| 728 | (defvar eval-last-sexp-fake-value (make-symbol "t")) | 730 | (defvar eval-last-sexp-fake-value (make-symbol "t")) |
| 729 | 731 | ||
| 732 | (defun eval-sexp-add-defvars (exp &optional pos) | ||
| 733 | "Prepend EXP with all the `defvar's that precede it in the buffer. | ||
| 734 | POS specifies the starting position where EXP was found and defaults to point." | ||
| 735 | (if (not lexical-binding) | ||
| 736 | exp | ||
| 737 | (save-excursion | ||
| 738 | (unless pos (setq pos (point))) | ||
| 739 | (let ((vars ())) | ||
| 740 | (goto-char (point-min)) | ||
| 741 | (while (re-search-forward | ||
| 742 | "^(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)" | ||
| 743 | pos t) | ||
| 744 | (let ((var (intern (match-string 1)))) | ||
| 745 | (unless (special-variable-p var) | ||
| 746 | (push var vars)))) | ||
| 747 | `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp))))) | ||
| 748 | |||
| 730 | (defun eval-last-sexp (eval-last-sexp-arg-internal) | 749 | (defun eval-last-sexp (eval-last-sexp-arg-internal) |
| 731 | "Evaluate sexp before point; print value in minibuffer. | 750 | "Evaluate sexp before point; print value in minibuffer. |
| 732 | Interactively, with prefix argument, print output into current buffer. | 751 | Interactively, with prefix argument, print output into current buffer. |
| @@ -763,16 +782,18 @@ Reinitialize the face according to the `defface' specification." | |||
| 763 | ;; `defcustom' is now macroexpanded to | 782 | ;; `defcustom' is now macroexpanded to |
| 764 | ;; `custom-declare-variable' with a quoted value arg. | 783 | ;; `custom-declare-variable' with a quoted value arg. |
| 765 | ((and (eq (car form) 'custom-declare-variable) | 784 | ((and (eq (car form) 'custom-declare-variable) |
| 766 | (default-boundp (eval (nth 1 form)))) | 785 | (default-boundp (eval (nth 1 form) lexical-binding))) |
| 767 | ;; Force variable to be bound. | 786 | ;; Force variable to be bound. |
| 768 | (set-default (eval (nth 1 form)) (eval (nth 1 (nth 2 form)))) | 787 | (set-default (eval (nth 1 form) lexical-binding) |
| 788 | (eval (nth 1 (nth 2 form)) lexical-binding)) | ||
| 769 | form) | 789 | form) |
| 770 | ;; `defface' is macroexpanded to `custom-declare-face'. | 790 | ;; `defface' is macroexpanded to `custom-declare-face'. |
| 771 | ((eq (car form) 'custom-declare-face) | 791 | ((eq (car form) 'custom-declare-face) |
| 772 | ;; Reset the face. | 792 | ;; Reset the face. |
| 773 | (setq face-new-frame-defaults | 793 | (setq face-new-frame-defaults |
| 774 | (assq-delete-all (eval (nth 1 form)) face-new-frame-defaults)) | 794 | (assq-delete-all (eval (nth 1 form) lexical-binding) |
| 775 | (put (eval (nth 1 form)) 'face-defface-spec nil) | 795 | face-new-frame-defaults)) |
| 796 | (put (eval (nth 1 form) lexical-binding) 'face-defface-spec nil) | ||
| 776 | ;; Setting `customized-face' to the new spec after calling | 797 | ;; Setting `customized-face' to the new spec after calling |
| 777 | ;; the form, but preserving the old saved spec in `saved-face', | 798 | ;; the form, but preserving the old saved spec in `saved-face', |
| 778 | ;; imitates the situation when the new face spec is set | 799 | ;; imitates the situation when the new face spec is set |
| @@ -783,10 +804,11 @@ Reinitialize the face according to the `defface' specification." | |||
| 783 | ;; `defface' change the spec, regardless of a saved spec. | 804 | ;; `defface' change the spec, regardless of a saved spec. |
| 784 | (prog1 `(prog1 ,form | 805 | (prog1 `(prog1 ,form |
| 785 | (put ,(nth 1 form) 'saved-face | 806 | (put ,(nth 1 form) 'saved-face |
| 786 | ',(get (eval (nth 1 form)) 'saved-face)) | 807 | ',(get (eval (nth 1 form) lexical-binding) |
| 808 | 'saved-face)) | ||
| 787 | (put ,(nth 1 form) 'customized-face | 809 | (put ,(nth 1 form) 'customized-face |
| 788 | ,(nth 2 form))) | 810 | ,(nth 2 form))) |
| 789 | (put (eval (nth 1 form)) 'saved-face nil))) | 811 | (put (eval (nth 1 form) lexical-binding) 'saved-face nil))) |
| 790 | ((eq (car form) 'progn) | 812 | ((eq (car form) 'progn) |
| 791 | (cons 'progn (mapcar 'eval-defun-1 (cdr form)))) | 813 | (cons 'progn (mapcar 'eval-defun-1 (cdr form)))) |
| 792 | (t form))) | 814 | (t form))) |
| @@ -1205,7 +1227,6 @@ This function also returns nil meaning don't specify the indentation." | |||
| 1205 | (put 'prog1 'lisp-indent-function 1) | 1227 | (put 'prog1 'lisp-indent-function 1) |
| 1206 | (put 'prog2 'lisp-indent-function 2) | 1228 | (put 'prog2 'lisp-indent-function 2) |
| 1207 | (put 'save-excursion 'lisp-indent-function 0) | 1229 | (put 'save-excursion 'lisp-indent-function 0) |
| 1208 | (put 'save-window-excursion 'lisp-indent-function 0) | ||
| 1209 | (put 'save-restriction 'lisp-indent-function 0) | 1230 | (put 'save-restriction 'lisp-indent-function 0) |
| 1210 | (put 'save-match-data 'lisp-indent-function 0) | 1231 | (put 'save-match-data 'lisp-indent-function 0) |
| 1211 | (put 'save-current-buffer 'lisp-indent-function 0) | 1232 | (put 'save-current-buffer 'lisp-indent-function 0) |
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index af8047256e2..f0a075ace37 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; macroexp.el --- Additional macro-expansion support | 1 | ;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*- |
| 2 | ;; | 2 | ;; |
| 3 | ;; Copyright (C) 2004-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2004-2011 Free Software Foundation, Inc. |
| 4 | ;; | 4 | ;; |
| @@ -29,6 +29,8 @@ | |||
| 29 | 29 | ||
| 30 | ;;; Code: | 30 | ;;; Code: |
| 31 | 31 | ||
| 32 | (eval-when-compile (require 'cl)) | ||
| 33 | |||
| 32 | ;; Bound by the top-level `macroexpand-all', and modified to include any | 34 | ;; Bound by the top-level `macroexpand-all', and modified to include any |
| 33 | ;; macros defined by `defmacro'. | 35 | ;; macros defined by `defmacro'. |
| 34 | (defvar macroexpand-all-environment nil) | 36 | (defvar macroexpand-all-environment nil) |
| @@ -106,7 +108,14 @@ Assumes the caller has bound `macroexpand-all-environment'." | |||
| 106 | (macroexpand (macroexpand-all-forms form 1) | 108 | (macroexpand (macroexpand-all-forms form 1) |
| 107 | macroexpand-all-environment) | 109 | macroexpand-all-environment) |
| 108 | ;; Normal form; get its expansion, and then expand arguments. | 110 | ;; Normal form; get its expansion, and then expand arguments. |
| 109 | (setq form (macroexpand form macroexpand-all-environment)) | 111 | (let ((new-form (macroexpand form macroexpand-all-environment))) |
| 112 | (when (and (not (eq form new-form)) ;It was a macro call. | ||
| 113 | (car-safe form) | ||
| 114 | (symbolp (car form)) | ||
| 115 | (get (car form) 'byte-obsolete-info) | ||
| 116 | (fboundp 'byte-compile-warn-obsolete)) | ||
| 117 | (byte-compile-warn-obsolete (car form))) | ||
| 118 | (setq form new-form)) | ||
| 110 | (pcase form | 119 | (pcase form |
| 111 | (`(cond . ,clauses) | 120 | (`(cond . ,clauses) |
| 112 | (maybe-cons 'cond (macroexpand-all-clauses clauses) form)) | 121 | (maybe-cons 'cond (macroexpand-all-clauses clauses) form)) |
| @@ -122,7 +131,16 @@ Assumes the caller has bound `macroexpand-all-environment'." | |||
| 122 | (`(defmacro ,name . ,args-and-body) | 131 | (`(defmacro ,name . ,args-and-body) |
| 123 | (push (cons name (cons 'lambda args-and-body)) | 132 | (push (cons name (cons 'lambda args-and-body)) |
| 124 | macroexpand-all-environment) | 133 | macroexpand-all-environment) |
| 125 | (macroexpand-all-forms form 3)) | 134 | (let ((n 3)) |
| 135 | ;; Don't macroexpand `declare' since it should really be "expanded" | ||
| 136 | ;; away when `defmacro' is expanded, but currently defmacro is not | ||
| 137 | ;; itself a macro. So both `defmacro' and `declare' need to be | ||
| 138 | ;; handled directly in bytecomp.el. | ||
| 139 | ;; FIXME: Maybe a simpler solution is to (defalias 'declare 'quote). | ||
| 140 | (while (or (stringp (nth n form)) | ||
| 141 | (eq (car-safe (nth n form)) 'declare)) | ||
| 142 | (setq n (1+ n))) | ||
| 143 | (macroexpand-all-forms form n))) | ||
| 126 | (`(defun . ,_) (macroexpand-all-forms form 3)) | 144 | (`(defun . ,_) (macroexpand-all-forms form 3)) |
| 127 | (`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2)) | 145 | (`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2)) |
| 128 | (`(function ,(and f `(lambda . ,_))) | 146 | (`(function ,(and f `(lambda . ,_))) |
| @@ -151,19 +169,34 @@ Assumes the caller has bound `macroexpand-all-environment'." | |||
| 151 | ;; here, so that any code that cares about the difference will | 169 | ;; here, so that any code that cares about the difference will |
| 152 | ;; see the same transformation. | 170 | ;; see the same transformation. |
| 153 | ;; First arg is a function: | 171 | ;; First arg is a function: |
| 154 | (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) ',f . ,args) | 172 | (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) |
| 173 | ',(and f `(lambda . ,_)) . ,args) | ||
| 155 | ;; We don't use `maybe-cons' since there's clearly a change. | 174 | ;; We don't use `maybe-cons' since there's clearly a change. |
| 156 | (cons fun | 175 | (cons fun |
| 157 | (cons (macroexpand-all-1 (list 'function f)) | 176 | (cons (macroexpand-all-1 (list 'function f)) |
| 158 | (macroexpand-all-forms args)))) | 177 | (macroexpand-all-forms args)))) |
| 159 | ;; Second arg is a function: | 178 | ;; Second arg is a function: |
| 160 | (`(,(and fun (or `sort)) ,arg1 ',f . ,args) | 179 | (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) |
| 161 | ;; We don't use `maybe-cons' since there's clearly a change. | 180 | ;; We don't use `maybe-cons' since there's clearly a change. |
| 162 | (cons fun | 181 | (cons fun |
| 163 | (cons (macroexpand-all-1 arg1) | 182 | (cons (macroexpand-all-1 arg1) |
| 164 | (cons (macroexpand-all-1 | 183 | (cons (macroexpand-all-1 |
| 165 | (list 'function f)) | 184 | (list 'function f)) |
| 166 | (macroexpand-all-forms args))))) | 185 | (macroexpand-all-forms args))))) |
| 186 | ;; Macro expand compiler macros. This cannot be delayed to | ||
| 187 | ;; byte-optimize-form because the output of the compiler-macro can | ||
| 188 | ;; use macros. | ||
| 189 | ;; FIXME: Don't depend on CL. | ||
| 190 | (`(,(pred (lambda (fun) | ||
| 191 | (and (symbolp fun) | ||
| 192 | (eq (get fun 'byte-compile) | ||
| 193 | 'cl-byte-compile-compiler-macro) | ||
| 194 | (functionp 'compiler-macroexpand)))) | ||
| 195 | . ,_) | ||
| 196 | (let ((newform (with-no-warnings (compiler-macroexpand form)))) | ||
| 197 | (if (eq form newform) | ||
| 198 | (macroexpand-all-forms form 1) | ||
| 199 | (macroexpand-all-1 newform)))) | ||
| 167 | (`(,_ . ,_) | 200 | (`(,_ . ,_) |
| 168 | ;; For every other list, we just expand each argument (for | 201 | ;; For every other list, we just expand each argument (for |
| 169 | ;; setq/setq-default this works alright because the variable names | 202 | ;; setq/setq-default this works alright because the variable names |
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 916dcd4785c..e6c4ccbbc50 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; pcase.el --- ML-style pattern-matching macro for Elisp | 1 | ;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -27,16 +27,21 @@ | |||
| 27 | 27 | ||
| 28 | ;; Todo: | 28 | ;; Todo: |
| 29 | 29 | ||
| 30 | ;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't | ||
| 31 | ;; use x, because x is bound separately for the equality constraint | ||
| 32 | ;; (as well as any pred/guard) and for the body, so uses at one place don't | ||
| 33 | ;; count for the other. | ||
| 30 | ;; - provide ways to extend the set of primitives, with some kind of | 34 | ;; - provide ways to extend the set of primitives, with some kind of |
| 31 | ;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) | 35 | ;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) |
| 32 | ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). | 36 | ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). |
| 33 | ;; But better would be if we could define new ways to match by having the | 37 | ;; But better would be if we could define new ways to match by having the |
| 34 | ;; extension provide its own `pcase--split-<foo>' thingy. | 38 | ;; extension provide its own `pcase--split-<foo>' thingy. |
| 39 | ;; - along these lines, provide patterns to match CL structs. | ||
| 35 | ;; - provide something like (setq VAR) so a var can be set rather than | 40 | ;; - provide something like (setq VAR) so a var can be set rather than |
| 36 | ;; let-bound. | 41 | ;; let-bound. |
| 37 | ;; - provide a way to fallthrough to other cases. | 42 | ;; - provide a way to fallthrough to subsequent cases. |
| 38 | ;; - try and be more clever to reduce the size of the decision tree, and | 43 | ;; - try and be more clever to reduce the size of the decision tree, and |
| 39 | ;; to reduce the number of leafs that need to be turned into function: | 44 | ;; to reduce the number of leaves that need to be turned into function: |
| 40 | ;; - first, do the tests shared by all remaining branches (it will have | 45 | ;; - first, do the tests shared by all remaining branches (it will have |
| 41 | ;; to be performed anyway, so better so it first so it's shared). | 46 | ;; to be performed anyway, so better so it first so it's shared). |
| 42 | ;; - then choose the test that discriminates more (?). | 47 | ;; - then choose the test that discriminates more (?). |
| @@ -45,14 +50,12 @@ | |||
| 45 | 50 | ||
| 46 | ;;; Code: | 51 | ;;; Code: |
| 47 | 52 | ||
| 48 | (eval-when-compile (require 'cl)) | ||
| 49 | |||
| 50 | ;; Macro-expansion of pcase is reasonably fast, so it's not a problem | 53 | ;; Macro-expansion of pcase is reasonably fast, so it's not a problem |
| 51 | ;; when byte-compiling a file, but when interpreting the code, if the pcase | 54 | ;; when byte-compiling a file, but when interpreting the code, if the pcase |
| 52 | ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we | 55 | ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we |
| 53 | ;; memoize previous macro expansions to try and avoid recomputing them | 56 | ;; memoize previous macro expansions to try and avoid recomputing them |
| 54 | ;; over and over again. | 57 | ;; over and over again. |
| 55 | (defconst pcase-memoize (make-hash-table :weakness t :test 'equal)) | 58 | (defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq)) |
| 56 | 59 | ||
| 57 | (defconst pcase--dontcare-upats '(t _ dontcare)) | 60 | (defconst pcase--dontcare-upats '(t _ dontcare)) |
| 58 | 61 | ||
| @@ -69,6 +72,7 @@ UPatterns can take the following forms: | |||
| 69 | `QPAT matches if the QPattern QPAT matches. | 72 | `QPAT matches if the QPattern QPAT matches. |
| 70 | (pred PRED) matches if PRED applied to the object returns non-nil. | 73 | (pred PRED) matches if PRED applied to the object returns non-nil. |
| 71 | (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. | 74 | (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. |
| 75 | (let UPAT EXP) matches if EXP matches UPAT. | ||
| 72 | If a SYMBOL is used twice in the same pattern (i.e. the pattern is | 76 | If a SYMBOL is used twice in the same pattern (i.e. the pattern is |
| 73 | \"non-linear\"), then the second occurrence is turned into an `eq'uality test. | 77 | \"non-linear\"), then the second occurrence is turned into an `eq'uality test. |
| 74 | 78 | ||
| @@ -88,10 +92,21 @@ E.g. you can match pairs where the cdr is larger than the car with a pattern | |||
| 88 | like `(,a . ,(pred (< a))) or, with more checks: | 92 | like `(,a . ,(pred (< a))) or, with more checks: |
| 89 | `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" | 93 | `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" |
| 90 | (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars. | 94 | (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars. |
| 91 | (or (gethash (cons exp cases) pcase-memoize) | 95 | ;; We want to use a weak hash table as a cache, but the key will unavoidably |
| 92 | (puthash (cons exp cases) | 96 | ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time |
| 93 | (pcase--expand exp cases) | 97 | ;; we're called so it'll be immediately GC'd. So we use (car cases) as key |
| 94 | pcase-memoize))) | 98 | ;; which does come straight from the source code and should hence not be GC'd |
| 99 | ;; so easily. | ||
| 100 | (let ((data (gethash (car cases) pcase--memoize))) | ||
| 101 | ;; data = (EXP CASES . EXPANSION) | ||
| 102 | (if (and (equal exp (car data)) (equal cases (cadr data))) | ||
| 103 | ;; We have the right expansion. | ||
| 104 | (cddr data) | ||
| 105 | (when data | ||
| 106 | (message "pcase-memoize: equal first branch, yet different")) | ||
| 107 | (let ((expansion (pcase--expand exp cases))) | ||
| 108 | (puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize) | ||
| 109 | expansion)))) | ||
| 95 | 110 | ||
| 96 | ;;;###autoload | 111 | ;;;###autoload |
| 97 | (defmacro pcase-let* (bindings &rest body) | 112 | (defmacro pcase-let* (bindings &rest body) |
| @@ -145,6 +160,8 @@ of the form (UPAT EXP)." | |||
| 145 | (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) | 160 | (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) |
| 146 | 161 | ||
| 147 | (defun pcase--expand (exp cases) | 162 | (defun pcase--expand (exp cases) |
| 163 | ;; (message "pid=%S (pcase--expand %S ...hash=%S)" | ||
| 164 | ;; (emacs-pid) exp (sxhash cases)) | ||
| 148 | (let* ((defs (if (symbolp exp) '() | 165 | (let* ((defs (if (symbolp exp) '() |
| 149 | (let ((sym (make-symbol "x"))) | 166 | (let ((sym (make-symbol "x"))) |
| 150 | (prog1 `((,sym ,exp)) (setq exp sym))))) | 167 | (prog1 `((,sym ,exp)) (setq exp sym))))) |
| @@ -165,7 +182,9 @@ of the form (UPAT EXP)." | |||
| 165 | ;; to a separate function if that number is too high. | 182 | ;; to a separate function if that number is too high. |
| 166 | ;; | 183 | ;; |
| 167 | ;; We've already used this branch. So it is shared. | 184 | ;; We've already used this branch. So it is shared. |
| 168 | (destructuring-bind (code prevvars res) prev | 185 | (let* ((code (car prev)) (cdrprev (cdr prev)) |
| 186 | (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) | ||
| 187 | (res (car cddrprev))) | ||
| 169 | (unless (symbolp res) | 188 | (unless (symbolp res) |
| 170 | ;; This is the first repeat, so we have to move | 189 | ;; This is the first repeat, so we have to move |
| 171 | ;; the branch to a separate function. | 190 | ;; the branch to a separate function. |
| @@ -269,7 +288,10 @@ MATCH is the pattern that needs to be matched, of the form: | |||
| 269 | (and MATCH ...) | 288 | (and MATCH ...) |
| 270 | (or MATCH ...)" | 289 | (or MATCH ...)" |
| 271 | (when (setq branches (delq nil branches)) | 290 | (when (setq branches (delq nil branches)) |
| 272 | (destructuring-bind (match code &rest vars) (car branches) | 291 | (let* ((carbranch (car branches)) |
| 292 | (match (car carbranch)) (cdarbranch (cdr carbranch)) | ||
| 293 | (code (car cdarbranch)) | ||
| 294 | (vars (cdr cdarbranch))) | ||
| 273 | (pcase--u1 (list match) code vars (cdr branches))))) | 295 | (pcase--u1 (list match) code vars (cdr branches))))) |
| 274 | 296 | ||
| 275 | (defun pcase--and (match matches) | 297 | (defun pcase--and (match matches) |
| @@ -281,19 +303,25 @@ MATCH is the pattern that needs to be matched, of the form: | |||
| 281 | (symbolp . consp) | 303 | (symbolp . consp) |
| 282 | (symbolp . arrayp) | 304 | (symbolp . arrayp) |
| 283 | (symbolp . stringp) | 305 | (symbolp . stringp) |
| 306 | (symbolp . byte-code-function-p) | ||
| 284 | (integerp . consp) | 307 | (integerp . consp) |
| 285 | (integerp . arrayp) | 308 | (integerp . arrayp) |
| 286 | (integerp . stringp) | 309 | (integerp . stringp) |
| 310 | (integerp . byte-code-function-p) | ||
| 287 | (numberp . consp) | 311 | (numberp . consp) |
| 288 | (numberp . arrayp) | 312 | (numberp . arrayp) |
| 289 | (numberp . stringp) | 313 | (numberp . stringp) |
| 314 | (numberp . byte-code-function-p) | ||
| 290 | (consp . arrayp) | 315 | (consp . arrayp) |
| 291 | (consp . stringp) | 316 | (consp . stringp) |
| 292 | (arrayp . stringp))) | 317 | (consp . byte-code-function-p) |
| 318 | (arrayp . stringp) | ||
| 319 | (arrayp . byte-code-function-p) | ||
| 320 | (stringp . byte-code-function-p))) | ||
| 293 | 321 | ||
| 294 | (defun pcase--split-match (sym splitter match) | 322 | (defun pcase--split-match (sym splitter match) |
| 295 | (case (car match) | 323 | (cond |
| 296 | ((match) | 324 | ((eq (car match) 'match) |
| 297 | (if (not (eq sym (cadr match))) | 325 | (if (not (eq sym (cadr match))) |
| 298 | (cons match match) | 326 | (cons match match) |
| 299 | (let ((pat (cddr match))) | 327 | (let ((pat (cddr match))) |
| @@ -307,7 +335,7 @@ MATCH is the pattern that needs to be matched, of the form: | |||
| 307 | (cdr pat))))) | 335 | (cdr pat))))) |
| 308 | (t (let ((res (funcall splitter (cddr match)))) | 336 | (t (let ((res (funcall splitter (cddr match)))) |
| 309 | (cons (or (car res) match) (or (cdr res) match)))))))) | 337 | (cons (or (car res) match) (or (cdr res) match)))))))) |
| 310 | ((or and) | 338 | ((memq (car match) '(or and)) |
| 311 | (let ((then-alts '()) | 339 | (let ((then-alts '()) |
| 312 | (else-alts '()) | 340 | (else-alts '()) |
| 313 | (neutral-elem (if (eq 'or (car match)) | 341 | (neutral-elem (if (eq 'or (car match)) |
| @@ -474,53 +502,60 @@ Otherwise, it defers to REST which is a list of branches of the form | |||
| 474 | (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) | 502 | (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) |
| 475 | code vars | 503 | code vars |
| 476 | (if (null others) rest | 504 | (if (null others) rest |
| 477 | (cons (list* | 505 | (cons (cons |
| 478 | (pcase--and (if (cdr others) | 506 | (pcase--and (if (cdr others) |
| 479 | (cons 'or (nreverse others)) | 507 | (cons 'or (nreverse others)) |
| 480 | (car others)) | 508 | (car others)) |
| 481 | (cdr matches)) | 509 | (cdr matches)) |
| 482 | code vars) | 510 | (cons code vars)) |
| 483 | rest)))) | 511 | rest)))) |
| 484 | (t | 512 | (t |
| 485 | (pcase--u1 (cons (pop alts) (cdr matches)) code vars | 513 | (pcase--u1 (cons (pop alts) (cdr matches)) code vars |
| 486 | (if (null alts) (progn (error "Please avoid it") rest) | 514 | (if (null alts) (progn (error "Please avoid it") rest) |
| 487 | (cons (list* | 515 | (cons (cons |
| 488 | (pcase--and (if (cdr alts) | 516 | (pcase--and (if (cdr alts) |
| 489 | (cons 'or alts) (car alts)) | 517 | (cons 'or alts) (car alts)) |
| 490 | (cdr matches)) | 518 | (cdr matches)) |
| 491 | code vars) | 519 | (cons code vars)) |
| 492 | rest))))))) | 520 | rest))))))) |
| 493 | ((eq 'match (caar matches)) | 521 | ((eq 'match (caar matches)) |
| 494 | (destructuring-bind (op sym &rest upat) (pop matches) | 522 | (let* ((popmatches (pop matches)) |
| 523 | (_op (car popmatches)) (cdrpopmatches (cdr popmatches)) | ||
| 524 | (sym (car cdrpopmatches)) | ||
| 525 | (upat (cdr cdrpopmatches))) | ||
| 495 | (cond | 526 | (cond |
| 496 | ((memq upat '(t _)) (pcase--u1 matches code vars rest)) | 527 | ((memq upat '(t _)) (pcase--u1 matches code vars rest)) |
| 497 | ((eq upat 'dontcare) :pcase--dontcare) | 528 | ((eq upat 'dontcare) :pcase--dontcare) |
| 498 | ((functionp upat) (error "Feature removed, use (pred %s)" upat)) | ||
| 499 | ((memq (car-safe upat) '(guard pred)) | 529 | ((memq (car-safe upat) '(guard pred)) |
| 500 | (if (eq (car upat) 'pred) (put sym 'pcase-used t)) | 530 | (if (eq (car upat) 'pred) (put sym 'pcase-used t)) |
| 501 | (destructuring-bind (then-rest &rest else-rest) | 531 | (let* ((splitrest |
| 502 | (pcase--split-rest | 532 | (pcase--split-rest |
| 503 | sym (apply-partially #'pcase--split-pred upat) rest) | 533 | sym (apply-partially #'pcase--split-pred upat) rest)) |
| 534 | (then-rest (car splitrest)) | ||
| 535 | (else-rest (cdr splitrest))) | ||
| 504 | (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) | 536 | (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) |
| 505 | `(,(cadr upat) ,sym) | 537 | `(,(cadr upat) ,sym) |
| 506 | (let* ((exp (cadr upat)) | 538 | (let* ((exp (cadr upat)) |
| 507 | ;; `vs' is an upper bound on the vars we need. | 539 | ;; `vs' is an upper bound on the vars we need. |
| 508 | (vs (pcase--fgrep (mapcar #'car vars) exp)) | 540 | (vs (pcase--fgrep (mapcar #'car vars) exp)) |
| 509 | (call (cond | 541 | (env (mapcar (lambda (var) |
| 510 | ((eq 'guard (car upat)) exp) | 542 | (list var (cdr (assq var vars)))) |
| 511 | ((functionp exp) `(,exp ,sym)) | 543 | vs)) |
| 512 | (t `(,@exp ,sym))))) | 544 | (call (if (eq 'guard (car upat)) |
| 545 | exp | ||
| 546 | (when (memq sym vs) | ||
| 547 | ;; `sym' is shadowed by `env'. | ||
| 548 | (let ((newsym (make-symbol "x"))) | ||
| 549 | (push (list newsym sym) env) | ||
| 550 | (setq sym newsym))) | ||
| 551 | (if (functionp exp) `(,exp ,sym) | ||
| 552 | `(,@exp ,sym))))) | ||
| 513 | (if (null vs) | 553 | (if (null vs) |
| 514 | call | 554 | call |
| 515 | ;; Let's not replace `vars' in `exp' since it's | 555 | ;; Let's not replace `vars' in `exp' since it's |
| 516 | ;; too difficult to do it right, instead just | 556 | ;; too difficult to do it right, instead just |
| 517 | ;; let-bind `vars' around `exp'. | 557 | ;; let-bind `vars' around `exp'. |
| 518 | `(let ,(mapcar (lambda (var) | 558 | `(let* ,env ,call)))) |
| 519 | (list var (cdr (assq var vars)))) | ||
| 520 | vs) | ||
| 521 | ;; FIXME: `vars' can capture `sym'. E.g. | ||
| 522 | ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) | ||
| 523 | ,call)))) | ||
| 524 | (pcase--u1 matches code vars then-rest) | 559 | (pcase--u1 matches code vars then-rest) |
| 525 | (pcase--u else-rest)))) | 560 | (pcase--u else-rest)))) |
| 526 | ((symbolp upat) | 561 | ((symbolp upat) |
| @@ -531,6 +566,25 @@ Otherwise, it defers to REST which is a list of branches of the form | |||
| 531 | (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars))))) | 566 | (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars))))) |
| 532 | matches) | 567 | matches) |
| 533 | code vars rest))) | 568 | code vars rest))) |
| 569 | ((eq (car-safe upat) 'let) | ||
| 570 | ;; A upat of the form (let VAR EXP). | ||
| 571 | ;; (pcase--u1 matches code | ||
| 572 | ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) | ||
| 573 | (let* ((exp | ||
| 574 | (let* ((exp (nth 2 upat)) | ||
| 575 | (found (assq exp vars))) | ||
| 576 | (if found (cdr found) | ||
| 577 | (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) | ||
| 578 | (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) | ||
| 579 | vs))) | ||
| 580 | (if env `(let* ,env ,exp) exp))))) | ||
| 581 | (sym (if (symbolp exp) exp (make-symbol "x"))) | ||
| 582 | (body | ||
| 583 | (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) | ||
| 584 | code vars rest))) | ||
| 585 | (if (eq sym exp) | ||
| 586 | body | ||
| 587 | `(let* ((,sym ,exp)) ,body)))) | ||
| 534 | ((eq (car-safe upat) '\`) | 588 | ((eq (car-safe upat) '\`) |
| 535 | (put sym 'pcase-used t) | 589 | (put sym 'pcase-used t) |
| 536 | (pcase--q1 sym (cadr upat) matches code vars rest)) | 590 | (pcase--q1 sym (cadr upat) matches code vars rest)) |
| @@ -546,13 +600,15 @@ Otherwise, it defers to REST which is a list of branches of the form | |||
| 546 | (setq all nil)))) | 600 | (setq all nil)))) |
| 547 | (if all | 601 | (if all |
| 548 | ;; Use memq for (or `a `b `c `d) rather than a big tree. | 602 | ;; Use memq for (or `a `b `c `d) rather than a big tree. |
| 549 | (let ((elems (mapcar 'cadr (cdr upat)))) | 603 | (let* ((elems (mapcar 'cadr (cdr upat))) |
| 550 | (destructuring-bind (then-rest &rest else-rest) | 604 | (splitrest |
| 551 | (pcase--split-rest | 605 | (pcase--split-rest |
| 552 | sym (apply-partially #'pcase--split-member elems) rest) | 606 | sym (apply-partially #'pcase--split-member elems) rest)) |
| 553 | (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) | 607 | (then-rest (car splitrest)) |
| 554 | (pcase--u1 matches code vars then-rest) | 608 | (else-rest (cdr splitrest))) |
| 555 | (pcase--u else-rest)))) | 609 | (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) |
| 610 | (pcase--u1 matches code vars then-rest) | ||
| 611 | (pcase--u else-rest))) | ||
| 556 | (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars | 612 | (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars |
| 557 | (append (mapcar (lambda (upat) | 613 | (append (mapcar (lambda (upat) |
| 558 | `((and (match ,sym . ,upat) ,@matches) | 614 | `((and (match ,sym . ,upat) ,@matches) |
| @@ -575,15 +631,14 @@ Otherwise, it defers to REST which is a list of branches of the form | |||
| 575 | ;; `(PAT3 . PAT4)) which the programmer can easily rewrite | 631 | ;; `(PAT3 . PAT4)) which the programmer can easily rewrite |
| 576 | ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). | 632 | ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). |
| 577 | (pcase--u1 `((match ,sym . ,(cadr upat))) | 633 | (pcase--u1 `((match ,sym . ,(cadr upat))) |
| 578 | (lexical-let ((rest rest)) | 634 | ;; FIXME: This codegen is not careful to share its |
| 579 | ;; FIXME: This codegen is not careful to share its | 635 | ;; code if used several times: code blow up is likely. |
| 580 | ;; code if used several times: code blow up is likely. | 636 | (lambda (_vars) |
| 581 | (lambda (vars) | 637 | ;; `vars' will likely contain bindings which are |
| 582 | ;; `vars' will likely contain bindings which are | 638 | ;; not always available in other paths to |
| 583 | ;; not always available in other paths to | 639 | ;; `rest', so there' no point trying to pass |
| 584 | ;; `rest', so there' no point trying to pass | 640 | ;; them down. |
| 585 | ;; them down. | 641 | (pcase--u rest)) |
| 586 | (pcase--u rest))) | ||
| 587 | vars | 642 | vars |
| 588 | (list `((and . ,matches) ,code . ,vars)))) | 643 | (list `((and . ,matches) ,code . ,vars)))) |
| 589 | (t (error "Unknown upattern `%s'" upat))))) | 644 | (t (error "Unknown upattern `%s'" upat))))) |
| @@ -600,29 +655,33 @@ Otherwise, it defers to REST which is a list of branches of the form | |||
| 600 | ;; FIXME. | 655 | ;; FIXME. |
| 601 | (error "Vector QPatterns not implemented yet")) | 656 | (error "Vector QPatterns not implemented yet")) |
| 602 | ((consp qpat) | 657 | ((consp qpat) |
| 603 | (let ((syma (make-symbol "xcar")) | 658 | (let* ((syma (make-symbol "xcar")) |
| 604 | (symd (make-symbol "xcdr"))) | 659 | (symd (make-symbol "xcdr")) |
| 605 | (destructuring-bind (then-rest &rest else-rest) | 660 | (splitrest (pcase--split-rest |
| 606 | (pcase--split-rest sym | 661 | sym |
| 607 | (apply-partially #'pcase--split-consp syma symd) | 662 | (apply-partially #'pcase--split-consp syma symd) |
| 608 | rest) | 663 | rest)) |
| 609 | (let ((then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) | 664 | (then-rest (car splitrest)) |
| 610 | (match ,symd . ,(pcase--upat (cdr qpat))) | 665 | (else-rest (cdr splitrest)) |
| 611 | ,@matches) | 666 | (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) |
| 612 | code vars then-rest))) | 667 | (match ,symd . ,(pcase--upat (cdr qpat))) |
| 613 | (pcase--if | 668 | ,@matches) |
| 614 | `(consp ,sym) | 669 | code vars then-rest))) |
| 615 | ;; We want to be careful to only add bindings that are used. | 670 | (pcase--if |
| 616 | ;; The byte-compiler could do that for us, but it would have to pay | 671 | `(consp ,sym) |
| 617 | ;; attention to the `consp' test in order to figure out that car/cdr | 672 | ;; We want to be careful to only add bindings that are used. |
| 618 | ;; can't signal errors and our byte-compiler is not that clever. | 673 | ;; The byte-compiler could do that for us, but it would have to pay |
| 619 | `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) | 674 | ;; attention to the `consp' test in order to figure out that car/cdr |
| 620 | ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) | 675 | ;; can't signal errors and our byte-compiler is not that clever. |
| 621 | ,then-body) | 676 | `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) |
| 622 | (pcase--u else-rest)))))) | 677 | ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) |
| 678 | ,then-body) | ||
| 679 | (pcase--u else-rest)))) | ||
| 623 | ((or (integerp qpat) (symbolp qpat) (stringp qpat)) | 680 | ((or (integerp qpat) (symbolp qpat) (stringp qpat)) |
| 624 | (destructuring-bind (then-rest &rest else-rest) | 681 | (let* ((splitrest (pcase--split-rest |
| 625 | (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest) | 682 | sym (apply-partially 'pcase--split-equal qpat) rest)) |
| 683 | (then-rest (car splitrest)) | ||
| 684 | (else-rest (cdr splitrest))) | ||
| 626 | (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) | 685 | (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) |
| 627 | (pcase--u1 matches code vars then-rest) | 686 | (pcase--u1 matches code vars then-rest) |
| 628 | (pcase--u else-rest)))) | 687 | (pcase--u else-rest)))) |
diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index e81a8b37981..2701d6b940b 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; smie.el --- Simple Minded Indentation Engine | 1 | ;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -178,7 +178,7 @@ one of those elements share the same precedence level and associativity." | |||
| 178 | ;; Maybe also add (or <elem1> <elem2>...) for things like | 178 | ;; Maybe also add (or <elem1> <elem2>...) for things like |
| 179 | ;; (exp (exp (or "+" "*" "=" ..) exp)). | 179 | ;; (exp (exp (or "+" "*" "=" ..) exp)). |
| 180 | ;; Basically, make it EBNF (except for the specification of a separator in | 180 | ;; Basically, make it EBNF (except for the specification of a separator in |
| 181 | ;; the repetition). | 181 | ;; the repetition, maybe). |
| 182 | (let ((nts (mapcar 'car bnf)) ;Non-terminals | 182 | (let ((nts (mapcar 'car bnf)) ;Non-terminals |
| 183 | (first-ops-table ()) | 183 | (first-ops-table ()) |
| 184 | (last-ops-table ()) | 184 | (last-ops-table ()) |
diff --git a/lisp/files.el b/lisp/files.el index 198d5ca87de..38047f2fa43 100644 --- a/lisp/files.el +++ b/lisp/files.el | |||
| @@ -2869,18 +2869,19 @@ asking you for confirmation." | |||
| 2869 | ;; | 2869 | ;; |
| 2870 | ;; For variables defined in the C source code the declaration should go here: | 2870 | ;; For variables defined in the C source code the declaration should go here: |
| 2871 | 2871 | ||
| 2872 | (mapc (lambda (pair) | 2872 | (dolist (pair |
| 2873 | (put (car pair) 'safe-local-variable (cdr pair))) | 2873 | '((buffer-read-only . booleanp) ;; C source code |
| 2874 | '((buffer-read-only . booleanp) ;; C source code | 2874 | (default-directory . stringp) ;; C source code |
| 2875 | (default-directory . stringp) ;; C source code | 2875 | (fill-column . integerp) ;; C source code |
| 2876 | (fill-column . integerp) ;; C source code | 2876 | (indent-tabs-mode . booleanp) ;; C source code |
| 2877 | (indent-tabs-mode . booleanp) ;; C source code | 2877 | (left-margin . integerp) ;; C source code |
| 2878 | (left-margin . integerp) ;; C source code | 2878 | (no-update-autoloads . booleanp) |
| 2879 | (no-update-autoloads . booleanp) | 2879 | (lexical-binding . booleanp) ;; C source code |
| 2880 | (tab-width . integerp) ;; C source code | 2880 | (tab-width . integerp) ;; C source code |
| 2881 | (truncate-lines . booleanp) ;; C source code | 2881 | (truncate-lines . booleanp) ;; C source code |
| 2882 | (word-wrap . booleanp) ;; C source code | 2882 | (word-wrap . booleanp) ;; C source code |
| 2883 | (bidi-display-reordering . booleanp))) ;; C source code | 2883 | (bidi-display-reordering . booleanp))) ;; C source code |
| 2884 | (put (car pair) 'safe-local-variable (cdr pair))) | ||
| 2884 | 2885 | ||
| 2885 | (put 'bidi-paragraph-direction 'safe-local-variable | 2886 | (put 'bidi-paragraph-direction 'safe-local-variable |
| 2886 | (lambda (v) (memq v '(nil right-to-left left-to-right)))) | 2887 | (lambda (v) (memq v '(nil right-to-left left-to-right)))) |
diff --git a/lisp/follow.el b/lisp/follow.el index 7e6d4e7ee35..7f4093dd442 100644 --- a/lisp/follow.el +++ b/lisp/follow.el | |||
| @@ -871,8 +871,7 @@ Returns (end-pos end-of-buffer-p)" | |||
| 871 | ;; XEmacs can calculate the end of the window by using | 871 | ;; XEmacs can calculate the end of the window by using |
| 872 | ;; the 'guarantee options. GOOD! | 872 | ;; the 'guarantee options. GOOD! |
| 873 | (let ((end (window-end win t))) | 873 | (let ((end (window-end win t))) |
| 874 | (if (= end (funcall (symbol-function 'point-max) | 874 | (if (= end (point-max (window-buffer win))) |
| 875 | (window-buffer win))) | ||
| 876 | (list end t) | 875 | (list end t) |
| 877 | (list (+ end 1) nil))) | 876 | (list (+ end 1) nil))) |
| 878 | ;; Emacs: We have to calculate the end by ourselves. | 877 | ;; Emacs: We have to calculate the end by ourselves. |
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 2496453dd89..37faf83fd12 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog | |||
| @@ -1,3 +1,8 @@ | |||
| 1 | 2011-04-01 Julien Danjou <julien@danjou.info> | ||
| 2 | |||
| 3 | * mm-view.el (mm-display-inline-fontify): Do not fontify with | ||
| 4 | fundamental-mode. | ||
| 5 | |||
| 1 | 2011-03-30 Lars Magne Ingebrigtsen <larsi@gnus.org> | 6 | 2011-03-30 Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 2 | 7 | ||
| 3 | * gnus-sum.el (gnus-update-marks): Revert intersection change, which | 8 | * gnus-sum.el (gnus-update-marks): Revert intersection change, which |
diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index abd78b8de02..5a90f015aed 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el | |||
| @@ -608,7 +608,9 @@ If MODE is not set, try to find mode automatically." | |||
| 608 | (funcall mode) | 608 | (funcall mode) |
| 609 | (set-auto-mode)) | 609 | (set-auto-mode)) |
| 610 | ;; The mode function might have already turned on font-lock. | 610 | ;; The mode function might have already turned on font-lock. |
| 611 | (unless (symbol-value 'font-lock-mode) | 611 | ;; Do not fontify if the guess mode is fundamental. |
| 612 | (unless (or (symbol-value 'font-lock-mode) | ||
| 613 | (eq major-mode 'fundamental-mode)) | ||
| 612 | (font-lock-fontify-buffer))) | 614 | (font-lock-fontify-buffer))) |
| 613 | ;; By default, XEmacs font-lock uses non-duplicable text | 615 | ;; By default, XEmacs font-lock uses non-duplicable text |
| 614 | ;; properties. This code forces all the text properties | 616 | ;; properties. This code forces all the text properties |
diff --git a/lisp/help-fns.el b/lisp/help-fns.el index ede80f858bf..392e894965c 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el | |||
| @@ -76,15 +76,18 @@ DEF is the function whose usage we're looking for in DOCSTRING." | |||
| 76 | ;; Replace `fn' with the actual function name. | 76 | ;; Replace `fn' with the actual function name. |
| 77 | (if (consp def) "anonymous" def) | 77 | (if (consp def) "anonymous" def) |
| 78 | (match-string 1 docstring)) | 78 | (match-string 1 docstring)) |
| 79 | (substring docstring 0 (match-beginning 0))))) | 79 | (unless (zerop (match-beginning 0)) |
| 80 | (substring docstring 0 (match-beginning 0)))))) | ||
| 80 | 81 | ||
| 82 | ;; FIXME: Move to subr.el? | ||
| 81 | (defun help-add-fundoc-usage (docstring arglist) | 83 | (defun help-add-fundoc-usage (docstring arglist) |
| 82 | "Add the usage info to DOCSTRING. | 84 | "Add the usage info to DOCSTRING. |
| 83 | If DOCSTRING already has a usage info, then just return it unchanged. | 85 | If DOCSTRING already has a usage info, then just return it unchanged. |
| 84 | The usage info is built from ARGLIST. DOCSTRING can be nil. | 86 | The usage info is built from ARGLIST. DOCSTRING can be nil. |
| 85 | ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." | 87 | ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." |
| 86 | (unless (stringp docstring) (setq docstring "Not documented")) | 88 | (unless (stringp docstring) (setq docstring "")) |
| 87 | (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t)) | 89 | (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) |
| 90 | (eq arglist t)) | ||
| 88 | docstring | 91 | docstring |
| 89 | (concat docstring | 92 | (concat docstring |
| 90 | (if (string-match "\n?\n\\'" docstring) | 93 | (if (string-match "\n?\n\\'" docstring) |
| @@ -95,18 +98,52 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." | |||
| 95 | (concat "(fn" (match-string 1 arglist) ")") | 98 | (concat "(fn" (match-string 1 arglist) ")") |
| 96 | (format "%S" (help-make-usage 'fn arglist)))))) | 99 | (format "%S" (help-make-usage 'fn arglist)))))) |
| 97 | 100 | ||
| 101 | ;; FIXME: Move to subr.el? | ||
| 98 | (defun help-function-arglist (def) | 102 | (defun help-function-arglist (def) |
| 99 | ;; Handle symbols aliased to other symbols. | 103 | ;; Handle symbols aliased to other symbols. |
| 100 | (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) | 104 | (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) |
| 101 | ;; If definition is a macro, find the function inside it. | 105 | ;; If definition is a macro, find the function inside it. |
| 102 | (if (eq (car-safe def) 'macro) (setq def (cdr def))) | 106 | (if (eq (car-safe def) 'macro) (setq def (cdr def))) |
| 103 | (cond | 107 | (cond |
| 108 | ((and (byte-code-function-p def) (integerp (aref def 0))) | ||
| 109 | (let* ((args-desc (aref def 0)) | ||
| 110 | (max (lsh args-desc -8)) | ||
| 111 | (min (logand args-desc 127)) | ||
| 112 | (rest (logand args-desc 128)) | ||
| 113 | (arglist ())) | ||
| 114 | (dotimes (i min) | ||
| 115 | (push (intern (concat "arg" (number-to-string (1+ i)))) arglist)) | ||
| 116 | (when (> max min) | ||
| 117 | (push '&optional arglist) | ||
| 118 | (dotimes (i (- max min)) | ||
| 119 | (push (intern (concat "arg" (number-to-string (+ 1 i min)))) | ||
| 120 | arglist))) | ||
| 121 | (unless (zerop rest) (push '&rest arglist) (push 'rest arglist)) | ||
| 122 | (nreverse arglist))) | ||
| 104 | ((byte-code-function-p def) (aref def 0)) | 123 | ((byte-code-function-p def) (aref def 0)) |
| 105 | ((eq (car-safe def) 'lambda) (nth 1 def)) | 124 | ((eq (car-safe def) 'lambda) (nth 1 def)) |
| 125 | ((eq (car-safe def) 'closure) (nth 2 def)) | ||
| 126 | ((subrp def) | ||
| 127 | (let ((arity (subr-arity def)) | ||
| 128 | (arglist ())) | ||
| 129 | (dotimes (i (car arity)) | ||
| 130 | (push (intern (concat "arg" (number-to-string (1+ i)))) arglist)) | ||
| 131 | (cond | ||
| 132 | ((not (numberp (cdr arglist))) | ||
| 133 | (push '&rest arglist) | ||
| 134 | (push 'rest arglist)) | ||
| 135 | ((< (car arity) (cdr arity)) | ||
| 136 | (push '&optional arglist) | ||
| 137 | (dotimes (i (- (cdr arity) (car arity))) | ||
| 138 | (push (intern (concat "arg" (number-to-string | ||
| 139 | (+ 1 i (car arity))))) | ||
| 140 | arglist)))) | ||
| 141 | (nreverse arglist))) | ||
| 106 | ((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap))) | 142 | ((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap))) |
| 107 | "[Arg list not available until function definition is loaded.]") | 143 | "[Arg list not available until function definition is loaded.]") |
| 108 | (t t))) | 144 | (t t))) |
| 109 | 145 | ||
| 146 | ;; FIXME: Move to subr.el? | ||
| 110 | (defun help-make-usage (function arglist) | 147 | (defun help-make-usage (function arglist) |
| 111 | (cons (if (symbolp function) function 'anonymous) | 148 | (cons (if (symbolp function) function 'anonymous) |
| 112 | (mapcar (lambda (arg) | 149 | (mapcar (lambda (arg) |
| @@ -117,8 +154,11 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." | |||
| 117 | (cdr arg)) | 154 | (cdr arg)) |
| 118 | arg) | 155 | arg) |
| 119 | (let ((name (symbol-name arg))) | 156 | (let ((name (symbol-name arg))) |
| 120 | (if (string-match "\\`&" name) arg | 157 | (cond |
| 121 | (intern (upcase name)))))) | 158 | ((string-match "\\`&" name) arg) |
| 159 | ((string-match "\\`_" name) | ||
| 160 | (intern (upcase (substring name 1)))) | ||
| 161 | (t (intern (upcase name))))))) | ||
| 122 | arglist))) | 162 | arglist))) |
| 123 | 163 | ||
| 124 | ;; Could be this, if we make symbol-file do the work below. | 164 | ;; Could be this, if we make symbol-file do the work below. |
| @@ -190,7 +230,7 @@ if the variable `help-downcase-arguments' is non-nil." | |||
| 190 | doc t t 1))))) | 230 | doc t t 1))))) |
| 191 | 231 | ||
| 192 | (defun help-highlight-arguments (usage doc &rest args) | 232 | (defun help-highlight-arguments (usage doc &rest args) |
| 193 | (when usage | 233 | (when (and usage (string-match "^(" usage)) |
| 194 | (with-temp-buffer | 234 | (with-temp-buffer |
| 195 | (insert usage) | 235 | (insert usage) |
| 196 | (goto-char (point-min)) | 236 | (goto-char (point-min)) |
| @@ -353,8 +393,7 @@ suitable file is found, return nil." | |||
| 353 | (pt1 (with-current-buffer (help-buffer) (point))) | 393 | (pt1 (with-current-buffer (help-buffer) (point))) |
| 354 | errtype) | 394 | errtype) |
| 355 | (setq string | 395 | (setq string |
| 356 | (cond ((or (stringp def) | 396 | (cond ((or (stringp def) (vectorp def)) |
| 357 | (vectorp def)) | ||
| 358 | "a keyboard macro") | 397 | "a keyboard macro") |
| 359 | ((subrp def) | 398 | ((subrp def) |
| 360 | (if (eq 'unevalled (cdr (subr-arity def))) | 399 | (if (eq 'unevalled (cdr (subr-arity def))) |
| @@ -373,6 +412,8 @@ suitable file is found, return nil." | |||
| 373 | (concat beg "Lisp function")) | 412 | (concat beg "Lisp function")) |
| 374 | ((eq (car-safe def) 'macro) | 413 | ((eq (car-safe def) 'macro) |
| 375 | "a Lisp macro") | 414 | "a Lisp macro") |
| 415 | ((eq (car-safe def) 'closure) | ||
| 416 | (concat beg "Lisp closure")) | ||
| 376 | ((eq (car-safe def) 'autoload) | 417 | ((eq (car-safe def) 'autoload) |
| 377 | (format "%s autoloaded %s" | 418 | (format "%s autoloaded %s" |
| 378 | (if (commandp def) "an interactive" "an") | 419 | (if (commandp def) "an interactive" "an") |
| @@ -593,10 +634,9 @@ it is displayed along with the global value." | |||
| 593 | "Describe variable (default %s): " v) | 634 | "Describe variable (default %s): " v) |
| 594 | "Describe variable: ") | 635 | "Describe variable: ") |
| 595 | obarray | 636 | obarray |
| 596 | (lambda (vv) | 637 | (lambda (vv) |
| 597 | (and (not (keywordp vv)) | 638 | (or (special-variable-p vv) |
| 598 | (or (boundp vv) | 639 | (get vv 'variable-documentation))) |
| 599 | (get vv 'variable-documentation)))) | ||
| 600 | t nil nil | 640 | t nil nil |
| 601 | (if (symbolp v) (symbol-name v)))) | 641 | (if (symbolp v) (symbol-name v)))) |
| 602 | (list (if (equal val "") | 642 | (list (if (equal val "") |
diff --git a/lisp/ielm.el b/lisp/ielm.el index a5731eb09e2..a1057303743 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el | |||
| @@ -371,7 +371,8 @@ simply inserts a newline." | |||
| 371 | (*** *3)) | 371 | (*** *3)) |
| 372 | (kill-buffer (current-buffer)) | 372 | (kill-buffer (current-buffer)) |
| 373 | (set-buffer ielm-wbuf) | 373 | (set-buffer ielm-wbuf) |
| 374 | (setq ielm-result (eval ielm-form)) | 374 | (setq ielm-result |
| 375 | (eval ielm-form lexical-binding)) | ||
| 375 | (setq ielm-wbuf (current-buffer)) | 376 | (setq ielm-wbuf (current-buffer)) |
| 376 | (setq | 377 | (setq |
| 377 | ielm-temp-buffer | 378 | ielm-temp-buffer |
diff --git a/lisp/info.el b/lisp/info.el index fb753659737..34c486d3754 100644 --- a/lisp/info.el +++ b/lisp/info.el | |||
| @@ -4930,6 +4930,27 @@ type returned by `Info-bookmark-make-record', which see." | |||
| 4930 | (bookmark-default-handler | 4930 | (bookmark-default-handler |
| 4931 | `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk))))) | 4931 | `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk))))) |
| 4932 | 4932 | ||
| 4933 | |||
| 4934 | ;;;###autoload | ||
| 4935 | (defun info-display-manual (manual) | ||
| 4936 | "Go to Info buffer that displays MANUAL, creating it if none already exists." | ||
| 4937 | (interactive "sManual name: ") | ||
| 4938 | (let ((blist (buffer-list)) | ||
| 4939 | (manual-re (concat "\\(/\\|\\`\\)" manual "\\(\\.\\|\\'\\)")) | ||
| 4940 | (case-fold-search t) | ||
| 4941 | found) | ||
| 4942 | (dolist (buffer blist) | ||
| 4943 | (with-current-buffer buffer | ||
| 4944 | (when (and (eq major-mode 'Info-mode) | ||
| 4945 | (stringp Info-current-file) | ||
| 4946 | (string-match manual-re Info-current-file)) | ||
| 4947 | (setq found buffer | ||
| 4948 | blist nil)))) | ||
| 4949 | (if found | ||
| 4950 | (pop-to-buffer found) | ||
| 4951 | (info-initialize) | ||
| 4952 | (info (Info-find-file manual))))) | ||
| 4953 | |||
| 4933 | (provide 'info) | 4954 | (provide 'info) |
| 4934 | 4955 | ||
| 4935 | ;;; info.el ends here | 4956 | ;;; info.el ends here |
diff --git a/lisp/makefile.w32-in b/lisp/makefile.w32-in index 0e3d54408fd..ed2fe4031b7 100644 --- a/lisp/makefile.w32-in +++ b/lisp/makefile.w32-in | |||
| @@ -66,6 +66,15 @@ AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \ | |||
| 66 | $(lisp)/cedet/semantic/loaddefs.el $(lisp)/cedet/ede/loaddefs.el \ | 66 | $(lisp)/cedet/semantic/loaddefs.el $(lisp)/cedet/ede/loaddefs.el \ |
| 67 | $(lisp)/cedet/srecode/loaddefs.el | 67 | $(lisp)/cedet/srecode/loaddefs.el |
| 68 | 68 | ||
| 69 | # Value of max-lisp-eval-depth when compiling initially. | ||
| 70 | # During bootstrapping the byte-compiler is run interpreted when compiling | ||
| 71 | # itself, and uses more stack than usual. | ||
| 72 | # | ||
| 73 | BIG_STACK_DEPTH = 1200 | ||
| 74 | BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))" | ||
| 75 | |||
| 76 | BYTE_COMPILE_FLAGS = $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) | ||
| 77 | |||
| 69 | # Files to compile before others during a bootstrap. This is done to | 78 | # Files to compile before others during a bootstrap. This is done to |
| 70 | # speed up the bootstrap process. The CC files are compiled first | 79 | # speed up the bootstrap process. The CC files are compiled first |
| 71 | # because CC mode tweaks the compilation process, and requiring | 80 | # because CC mode tweaks the compilation process, and requiring |
| @@ -75,6 +84,8 @@ AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \ | |||
| 75 | COMPILE_FIRST = \ | 84 | COMPILE_FIRST = \ |
| 76 | $(lisp)/emacs-lisp/byte-opt.el \ | 85 | $(lisp)/emacs-lisp/byte-opt.el \ |
| 77 | $(lisp)/emacs-lisp/bytecomp.el \ | 86 | $(lisp)/emacs-lisp/bytecomp.el \ |
| 87 | $(lisp)/emacs-lisp/macroexp.el \ | ||
| 88 | $(lisp)/emacs-lisp/cconv.el \ | ||
| 78 | $(lisp)/subr.el \ | 89 | $(lisp)/subr.el \ |
| 79 | $(lisp)/progmodes/cc-mode.el \ | 90 | $(lisp)/progmodes/cc-mode.el \ |
| 80 | $(lisp)/progmodes/cc-vars.el | 91 | $(lisp)/progmodes/cc-vars.el |
| @@ -287,7 +298,7 @@ TAGS-LISP-CMD: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsf | |||
| 287 | .SUFFIXES: .elc .el | 298 | .SUFFIXES: .elc .el |
| 288 | 299 | ||
| 289 | .el.elc: | 300 | .el.elc: |
| 290 | -$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $< | 301 | -$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< |
| 291 | 302 | ||
| 292 | # Compile all Lisp files, but don't recompile those that are up to | 303 | # Compile all Lisp files, but don't recompile those that are up to |
| 293 | # date. Some files don't actually get compiled because they set the | 304 | # date. Some files don't actually get compiled because they set the |
| @@ -307,22 +318,22 @@ compile: $(lisp)/subdirs.el mh-autoloads compile-$(SHELLTYPE) doit | |||
| 307 | compile-CMD: | 318 | compile-CMD: |
| 308 | # -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g | 319 | # -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g |
| 309 | for %%f in ($(COMPILE_FIRST)) do \ | 320 | for %%f in ($(COMPILE_FIRST)) do \ |
| 310 | $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done %%f | 321 | $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done %%f |
| 311 | for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do \ | 322 | for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do \ |
| 312 | $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done %%f/%%g | 323 | $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done %%f/%%g |
| 313 | 324 | ||
| 314 | compile-SH: | 325 | compile-SH: |
| 315 | # for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done | 326 | # for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done |
| 316 | for el in $(COMPILE_FIRST); do \ | 327 | for el in $(COMPILE_FIRST); do \ |
| 317 | echo Compiling $$el; \ | 328 | echo Compiling $$el; \ |
| 318 | $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el; \ | 329 | $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done $$el; \ |
| 319 | done | 330 | done |
| 320 | for dir in $(lisp) $(WINS); do \ | 331 | for dir in $(lisp) $(WINS); do \ |
| 321 | for el in $$dir/*.el; do \ | 332 | for el in $$dir/*.el; do \ |
| 322 | if test -f $$el; \ | 333 | if test -f $$el; \ |
| 323 | then \ | 334 | then \ |
| 324 | echo Compiling $$el; \ | 335 | echo Compiling $$el; \ |
| 325 | $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el; \ | 336 | $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done $$el; \ |
| 326 | fi \ | 337 | fi \ |
| 327 | done; \ | 338 | done; \ |
| 328 | done | 339 | done |
| @@ -335,31 +346,31 @@ compile-always: $(lisp)/subdirs.el compile-always-$(SHELLTYPE) doit | |||
| 335 | 346 | ||
| 336 | compile-always-CMD: | 347 | compile-always-CMD: |
| 337 | # -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g | 348 | # -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g |
| 338 | for %%f in ($(COMPILE_FIRST)) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f | 349 | for %%f in ($(COMPILE_FIRST)) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f |
| 339 | for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f/%%g | 350 | for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f/%%g |
| 340 | 351 | ||
| 341 | compile-always-SH: | 352 | compile-always-SH: |
| 342 | # for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done | 353 | # for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done |
| 343 | for el in $(COMPILE_FIRST); do \ | 354 | for el in $(COMPILE_FIRST); do \ |
| 344 | echo Compiling $$el; \ | 355 | echo Compiling $$el; \ |
| 345 | $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ | 356 | $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \ |
| 346 | done | 357 | done |
| 347 | for dir in $(lisp) $(WINS); do \ | 358 | for dir in $(lisp) $(WINS); do \ |
| 348 | for el in $$dir/*.el; do \ | 359 | for el in $$dir/*.el; do \ |
| 349 | echo Compiling $$el; \ | 360 | echo Compiling $$el; \ |
| 350 | $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ | 361 | $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \ |
| 351 | done; \ | 362 | done; \ |
| 352 | done | 363 | done |
| 353 | 364 | ||
| 354 | compile-calc: compile-calc-$(SHELLTYPE) | 365 | compile-calc: compile-calc-$(SHELLTYPE) |
| 355 | 366 | ||
| 356 | compile-calc-CMD: | 367 | compile-calc-CMD: |
| 357 | for %%f in ($(lisp)/calc/*.el) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f | 368 | for %%f in ($(lisp)/calc/*.el) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f |
| 358 | 369 | ||
| 359 | compile-calc-SH: | 370 | compile-calc-SH: |
| 360 | for el in $(lisp)/calc/*.el; do \ | 371 | for el in $(lisp)/calc/*.el; do \ |
| 361 | echo Compiling $$el; \ | 372 | echo Compiling $$el; \ |
| 362 | $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ | 373 | $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \ |
| 363 | done | 374 | done |
| 364 | 375 | ||
| 365 | # Backup compiled Lisp files in elc.tar.gz. If that file already | 376 | # Backup compiled Lisp files in elc.tar.gz. If that file already |
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 4aa34698809..83358ba2f01 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; minibuffer.el --- Minibuffer completion functions | 1 | ;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2008-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2008-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -133,8 +133,8 @@ the closest directory separators." | |||
| 133 | "Apply FUN to each element of XS in turn. | 133 | "Apply FUN to each element of XS in turn. |
| 134 | Return the first non-nil returned value. | 134 | Return the first non-nil returned value. |
| 135 | Like CL's `some'." | 135 | Like CL's `some'." |
| 136 | (lexical-let ((firsterror nil) | 136 | (let ((firsterror nil) |
| 137 | res) | 137 | res) |
| 138 | (while (and (not res) xs) | 138 | (while (and (not res) xs) |
| 139 | (condition-case err | 139 | (condition-case err |
| 140 | (setq res (funcall fun (pop xs))) | 140 | (setq res (funcall fun (pop xs))) |
| @@ -171,16 +171,15 @@ FUN will be called in the buffer from which the minibuffer was entered. | |||
| 171 | The result of the `completion-table-dynamic' form is a function | 171 | The result of the `completion-table-dynamic' form is a function |
| 172 | that can be used as the COLLECTION argument to `try-completion' and | 172 | that can be used as the COLLECTION argument to `try-completion' and |
| 173 | `all-completions'. See Info node `(elisp)Programmed Completion'." | 173 | `all-completions'. See Info node `(elisp)Programmed Completion'." |
| 174 | (lexical-let ((fun fun)) | 174 | (lambda (string pred action) |
| 175 | (lambda (string pred action) | 175 | (if (eq (car-safe action) 'boundaries) |
| 176 | (if (eq (car-safe action) 'boundaries) | 176 | ;; `fun' is not supposed to return another function but a plain old |
| 177 | ;; `fun' is not supposed to return another function but a plain old | 177 | ;; completion table, whose boundaries are always trivial. |
| 178 | ;; completion table, whose boundaries are always trivial. | 178 | nil |
| 179 | nil | 179 | (with-current-buffer (let ((win (minibuffer-selected-window))) |
| 180 | (with-current-buffer (let ((win (minibuffer-selected-window))) | 180 | (if (window-live-p win) (window-buffer win) |
| 181 | (if (window-live-p win) (window-buffer win) | 181 | (current-buffer))) |
| 182 | (current-buffer))) | 182 | (complete-with-action action (funcall fun string) string pred))))) |
| 183 | (complete-with-action action (funcall fun string) string pred)))))) | ||
| 184 | 183 | ||
| 185 | (defmacro lazy-completion-table (var fun) | 184 | (defmacro lazy-completion-table (var fun) |
| 186 | "Initialize variable VAR as a lazy completion table. | 185 | "Initialize variable VAR as a lazy completion table. |
| @@ -209,19 +208,18 @@ You should give VAR a non-nil `risky-local-variable' property." | |||
| 209 | ;; Notice that `pred' may not be a function in some abusive cases. | 208 | ;; Notice that `pred' may not be a function in some abusive cases. |
| 210 | (when (functionp pred) | 209 | (when (functionp pred) |
| 211 | (setq pred | 210 | (setq pred |
| 212 | (lexical-let ((pred pred)) | 211 | ;; Predicates are called differently depending on the nature of |
| 213 | ;; Predicates are called differently depending on the nature of | 212 | ;; the completion table :-( |
| 214 | ;; the completion table :-( | 213 | (cond |
| 215 | (cond | 214 | ((vectorp table) ;Obarray. |
| 216 | ((vectorp table) ;Obarray. | 215 | (lambda (sym) (funcall pred (concat prefix (symbol-name sym))))) |
| 217 | (lambda (sym) (funcall pred (concat prefix (symbol-name sym))))) | 216 | ((hash-table-p table) |
| 218 | ((hash-table-p table) | 217 | (lambda (s _v) (funcall pred (concat prefix s)))) |
| 219 | (lambda (s v) (funcall pred (concat prefix s)))) | 218 | ((functionp table) |
| 220 | ((functionp table) | 219 | (lambda (s) (funcall pred (concat prefix s)))) |
| 221 | (lambda (s) (funcall pred (concat prefix s)))) | 220 | (t ;Lists and alists. |
| 222 | (t ;Lists and alists. | 221 | (lambda (s) |
| 223 | (lambda (s) | 222 | (funcall pred (concat prefix (if (consp s) (car s) s)))))))) |
| 224 | (funcall pred (concat prefix (if (consp s) (car s) s))))))))) | ||
| 225 | (if (eq (car-safe action) 'boundaries) | 223 | (if (eq (car-safe action) 'boundaries) |
| 226 | (let* ((len (length prefix)) | 224 | (let* ((len (length prefix)) |
| 227 | (bound (completion-boundaries string table pred (cdr action)))) | 225 | (bound (completion-boundaries string table pred (cdr action)))) |
| @@ -300,11 +298,10 @@ Note: TABLE needs to be a proper completion table which obeys predicates." | |||
| 300 | (t | 298 | (t |
| 301 | (or (complete-with-action action table string | 299 | (or (complete-with-action action table string |
| 302 | (if (null pred2) pred1 | 300 | (if (null pred2) pred1 |
| 303 | (lexical-let ((pred1 pred2) (pred2 pred2)) | 301 | (lambda (x) |
| 304 | (lambda (x) | 302 | ;; Call `pred1' first, so that `pred2' |
| 305 | ;; Call `pred1' first, so that `pred2' | 303 | ;; really can't tell that `x' is in table. |
| 306 | ;; really can't tell that `x' is in table. | 304 | (if (funcall pred1 x) (funcall pred2 x))))) |
| 307 | (if (funcall pred1 x) (funcall pred2 x)))))) | ||
| 308 | ;; If completion failed and we're not applying pred1 strictly, try | 305 | ;; If completion failed and we're not applying pred1 strictly, try |
| 309 | ;; again without pred1. | 306 | ;; again without pred1. |
| 310 | (and (not strict) | 307 | (and (not strict) |
| @@ -314,11 +311,10 @@ Note: TABLE needs to be a proper completion table which obeys predicates." | |||
| 314 | "Create a completion table that tries each table in TABLES in turn." | 311 | "Create a completion table that tries each table in TABLES in turn." |
| 315 | ;; FIXME: the boundaries may come from TABLE1 even when the completion list | 312 | ;; FIXME: the boundaries may come from TABLE1 even when the completion list |
| 316 | ;; is returned by TABLE2 (because TABLE1 returned an empty list). | 313 | ;; is returned by TABLE2 (because TABLE1 returned an empty list). |
| 317 | (lexical-let ((tables tables)) | 314 | (lambda (string pred action) |
| 318 | (lambda (string pred action) | 315 | (completion--some (lambda (table) |
| 319 | (completion--some (lambda (table) | 316 | (complete-with-action action table string pred)) |
| 320 | (complete-with-action action table string pred)) | 317 | tables))) |
| 321 | tables)))) | ||
| 322 | 318 | ||
| 323 | ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) | 319 | ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) |
| 324 | ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) | 320 | ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) |
| @@ -560,16 +556,15 @@ E = after completion we now have an Exact match. | |||
| 560 | 101 5 ??? impossible | 556 | 101 5 ??? impossible |
| 561 | 110 6 some completion happened | 557 | 110 6 some completion happened |
| 562 | 111 7 completed to an exact completion" | 558 | 111 7 completed to an exact completion" |
| 563 | (lexical-let* | 559 | (let* ((beg (field-beginning)) |
| 564 | ((beg (field-beginning)) | 560 | (end (field-end)) |
| 565 | (end (field-end)) | 561 | (string (buffer-substring beg end)) |
| 566 | (string (buffer-substring beg end)) | 562 | (comp (funcall (or try-completion-function |
| 567 | (comp (funcall (or try-completion-function | 563 | 'completion-try-completion) |
| 568 | 'completion-try-completion) | 564 | string |
| 569 | string | 565 | minibuffer-completion-table |
| 570 | minibuffer-completion-table | 566 | minibuffer-completion-predicate |
| 571 | minibuffer-completion-predicate | 567 | (- (point) beg)))) |
| 572 | (- (point) beg)))) | ||
| 573 | (cond | 568 | (cond |
| 574 | ((null comp) | 569 | ((null comp) |
| 575 | (minibuffer-hide-completions) | 570 | (minibuffer-hide-completions) |
| @@ -584,13 +579,12 @@ E = after completion we now have an Exact match. | |||
| 584 | ;; `completed' should be t if some completion was done, which doesn't | 579 | ;; `completed' should be t if some completion was done, which doesn't |
| 585 | ;; include simply changing the case of the entered string. However, | 580 | ;; include simply changing the case of the entered string. However, |
| 586 | ;; for appearance, the string is rewritten if the case changes. | 581 | ;; for appearance, the string is rewritten if the case changes. |
| 587 | (lexical-let* | 582 | (let* ((comp-pos (cdr comp)) |
| 588 | ((comp-pos (cdr comp)) | 583 | (completion (car comp)) |
| 589 | (completion (car comp)) | 584 | (completed (not (eq t (compare-strings completion nil nil |
| 590 | (completed (not (eq t (compare-strings completion nil nil | 585 | string nil nil t)))) |
| 591 | string nil nil t)))) | 586 | (unchanged (eq t (compare-strings completion nil nil |
| 592 | (unchanged (eq t (compare-strings completion nil nil | 587 | string nil nil nil)))) |
| 593 | string nil nil nil)))) | ||
| 594 | (if unchanged | 588 | (if unchanged |
| 595 | (goto-char end) | 589 | (goto-char end) |
| 596 | ;; Insert in minibuffer the chars we got. | 590 | ;; Insert in minibuffer the chars we got. |
| @@ -672,16 +666,16 @@ scroll the window of possible completions." | |||
| 672 | (setq minibuffer-scroll-window nil)) | 666 | (setq minibuffer-scroll-window nil)) |
| 673 | 667 | ||
| 674 | (cond | 668 | (cond |
| 675 | ;; If there's a fresh completion window with a live buffer, | 669 | ;; If there's a fresh completion window with a live buffer, |
| 676 | ;; and this command is repeated, scroll that window. | 670 | ;; and this command is repeated, scroll that window. |
| 677 | ((window-live-p minibuffer-scroll-window) | 671 | ((window-live-p minibuffer-scroll-window) |
| 678 | (let ((window minibuffer-scroll-window)) | 672 | (let ((window minibuffer-scroll-window)) |
| 679 | (with-current-buffer (window-buffer window) | 673 | (with-current-buffer (window-buffer window) |
| 680 | (if (pos-visible-in-window-p (point-max) window) | 674 | (if (pos-visible-in-window-p (point-max) window) |
| 681 | ;; If end is in view, scroll up to the beginning. | 675 | ;; If end is in view, scroll up to the beginning. |
| 682 | (set-window-start window (point-min) nil) | 676 | (set-window-start window (point-min) nil) |
| 683 | ;; Else scroll down one screen. | 677 | ;; Else scroll down one screen. |
| 684 | (scroll-other-window)) | 678 | (scroll-other-window)) |
| 685 | nil))) | 679 | nil))) |
| 686 | ;; If we're cycling, keep on cycling. | 680 | ;; If we're cycling, keep on cycling. |
| 687 | ((and completion-cycling completion-all-sorted-completions) | 681 | ((and completion-cycling completion-all-sorted-completions) |
| @@ -695,7 +689,7 @@ scroll the window of possible completions." | |||
| 695 | t) | 689 | t) |
| 696 | (t t))))) | 690 | (t t))))) |
| 697 | 691 | ||
| 698 | (defun completion--flush-all-sorted-completions (&rest ignore) | 692 | (defun completion--flush-all-sorted-completions (&rest _ignore) |
| 699 | (remove-hook 'after-change-functions | 693 | (remove-hook 'after-change-functions |
| 700 | 'completion--flush-all-sorted-completions t) | 694 | 'completion--flush-all-sorted-completions t) |
| 701 | (setq completion-cycling nil) | 695 | (setq completion-cycling nil) |
| @@ -783,8 +777,8 @@ If `minibuffer-completion-confirm' is `confirm-after-completion', | |||
| 783 | `minibuffer-confirm-exit-commands', and accept the input | 777 | `minibuffer-confirm-exit-commands', and accept the input |
| 784 | otherwise." | 778 | otherwise." |
| 785 | (interactive) | 779 | (interactive) |
| 786 | (lexical-let ((beg (field-beginning)) | 780 | (let ((beg (field-beginning)) |
| 787 | (end (field-end))) | 781 | (end (field-end))) |
| 788 | (cond | 782 | (cond |
| 789 | ;; Allow user to specify null string | 783 | ;; Allow user to specify null string |
| 790 | ((= beg end) (exit-minibuffer)) | 784 | ((= beg end) (exit-minibuffer)) |
| @@ -1029,7 +1023,7 @@ It also eliminates runs of equal strings." | |||
| 1029 | 'mouse-face 'highlight) | 1023 | 'mouse-face 'highlight) |
| 1030 | (add-text-properties (point) (progn (insert (cadr str)) (point)) | 1024 | (add-text-properties (point) (progn (insert (cadr str)) (point)) |
| 1031 | '(mouse-face nil | 1025 | '(mouse-face nil |
| 1032 | face completions-annotations))) | 1026 | face completions-annotations))) |
| 1033 | (cond | 1027 | (cond |
| 1034 | ((eq completions-format 'vertical) | 1028 | ((eq completions-format 'vertical) |
| 1035 | ;; Vertical format | 1029 | ;; Vertical format |
| @@ -1161,14 +1155,14 @@ variables.") | |||
| 1161 | "Display a list of possible completions of the current minibuffer contents." | 1155 | "Display a list of possible completions of the current minibuffer contents." |
| 1162 | (interactive) | 1156 | (interactive) |
| 1163 | (message "Making completion list...") | 1157 | (message "Making completion list...") |
| 1164 | (lexical-let* ((start (field-beginning)) | 1158 | (let* ((start (field-beginning)) |
| 1165 | (end (field-end)) | 1159 | (end (field-end)) |
| 1166 | (string (field-string)) | 1160 | (string (field-string)) |
| 1167 | (completions (completion-all-completions | 1161 | (completions (completion-all-completions |
| 1168 | string | 1162 | string |
| 1169 | minibuffer-completion-table | 1163 | minibuffer-completion-table |
| 1170 | minibuffer-completion-predicate | 1164 | minibuffer-completion-predicate |
| 1171 | (- (point) (field-beginning))))) | 1165 | (- (point) (field-beginning))))) |
| 1172 | (message nil) | 1166 | (message nil) |
| 1173 | (if (and completions | 1167 | (if (and completions |
| 1174 | (or (consp (cdr completions)) | 1168 | (or (consp (cdr completions)) |
| @@ -1462,7 +1456,7 @@ The completion method is determined by `completion-at-point-functions'." | |||
| 1462 | (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" | 1456 | (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" |
| 1463 | "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) | 1457 | "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) |
| 1464 | 1458 | ||
| 1465 | (defun completion--embedded-envvar-table (string pred action) | 1459 | (defun completion--embedded-envvar-table (string _pred action) |
| 1466 | "Completion table for envvars embedded in a string. | 1460 | "Completion table for envvars embedded in a string. |
| 1467 | The envvar syntax (and escaping) rules followed by this table are the | 1461 | The envvar syntax (and escaping) rules followed by this table are the |
| 1468 | same as `substitute-in-file-name'." | 1462 | same as `substitute-in-file-name'." |
| @@ -1482,20 +1476,20 @@ same as `substitute-in-file-name'." | |||
| 1482 | ;; other table handle the test-completion case. | 1476 | ;; other table handle the test-completion case. |
| 1483 | nil) | 1477 | nil) |
| 1484 | ((eq (car-safe action) 'boundaries) | 1478 | ((eq (car-safe action) 'boundaries) |
| 1485 | ;; Only return boundaries if there's something to complete, | 1479 | ;; Only return boundaries if there's something to complete, |
| 1486 | ;; since otherwise when we're used in | 1480 | ;; since otherwise when we're used in |
| 1487 | ;; completion-table-in-turn, we could return boundaries and | 1481 | ;; completion-table-in-turn, we could return boundaries and |
| 1488 | ;; let some subsequent table return a list of completions. | 1482 | ;; let some subsequent table return a list of completions. |
| 1489 | ;; FIXME: Maybe it should rather be fixed in | 1483 | ;; FIXME: Maybe it should rather be fixed in |
| 1490 | ;; completion-table-in-turn instead, but it's difficult to | 1484 | ;; completion-table-in-turn instead, but it's difficult to |
| 1491 | ;; do it efficiently there. | 1485 | ;; do it efficiently there. |
| 1492 | (when (try-completion (substring string beg) table nil) | 1486 | (when (try-completion (substring string beg) table nil) |
| 1493 | ;; Compute the boundaries of the subfield to which this | 1487 | ;; Compute the boundaries of the subfield to which this |
| 1494 | ;; completion applies. | 1488 | ;; completion applies. |
| 1495 | (let ((suffix (cdr action))) | 1489 | (let ((suffix (cdr action))) |
| 1496 | (list* 'boundaries | 1490 | (list* 'boundaries |
| 1497 | (or (match-beginning 2) (match-beginning 1)) | 1491 | (or (match-beginning 2) (match-beginning 1)) |
| 1498 | (when (string-match "[^[:alnum:]_]" suffix) | 1492 | (when (string-match "[^[:alnum:]_]" suffix) |
| 1499 | (match-beginning 0)))))) | 1493 | (match-beginning 0)))))) |
| 1500 | (t | 1494 | (t |
| 1501 | (if (eq (aref string (1- beg)) ?{) | 1495 | (if (eq (aref string (1- beg)) ?{) |
| @@ -1510,55 +1504,55 @@ same as `substitute-in-file-name'." | |||
| 1510 | (defun completion-file-name-table (string pred action) | 1504 | (defun completion-file-name-table (string pred action) |
| 1511 | "Completion table for file names." | 1505 | "Completion table for file names." |
| 1512 | (ignore-errors | 1506 | (ignore-errors |
| 1513 | (cond | 1507 | (cond |
| 1514 | ((eq (car-safe action) 'boundaries) | 1508 | ((eq (car-safe action) 'boundaries) |
| 1515 | (let ((start (length (file-name-directory string))) | 1509 | (let ((start (length (file-name-directory string))) |
| 1516 | (end (string-match-p "/" (cdr action)))) | 1510 | (end (string-match-p "/" (cdr action)))) |
| 1517 | (list* 'boundaries | 1511 | (list* 'boundaries |
| 1518 | ;; if `string' is "C:" in w32, (file-name-directory string) | 1512 | ;; if `string' is "C:" in w32, (file-name-directory string) |
| 1519 | ;; returns "C:/", so `start' is 3 rather than 2. | 1513 | ;; returns "C:/", so `start' is 3 rather than 2. |
| 1520 | ;; Not quite sure what is The Right Fix, but clipping it | 1514 | ;; Not quite sure what is The Right Fix, but clipping it |
| 1521 | ;; back to 2 will work for this particular case. We'll | 1515 | ;; back to 2 will work for this particular case. We'll |
| 1522 | ;; see if we can come up with a better fix when we bump | 1516 | ;; see if we can come up with a better fix when we bump |
| 1523 | ;; into more such problematic cases. | 1517 | ;; into more such problematic cases. |
| 1524 | (min start (length string)) end))) | 1518 | (min start (length string)) end))) |
| 1525 | 1519 | ||
| 1526 | ((eq action 'lambda) | 1520 | ((eq action 'lambda) |
| 1527 | (if (zerop (length string)) | 1521 | (if (zerop (length string)) |
| 1528 | nil ;Not sure why it's here, but it probably doesn't harm. | 1522 | nil ;Not sure why it's here, but it probably doesn't harm. |
| 1529 | (funcall (or pred 'file-exists-p) string))) | 1523 | (funcall (or pred 'file-exists-p) string))) |
| 1530 | 1524 | ||
| 1531 | (t | 1525 | (t |
| 1532 | (let* ((name (file-name-nondirectory string)) | 1526 | (let* ((name (file-name-nondirectory string)) |
| 1533 | (specdir (file-name-directory string)) | 1527 | (specdir (file-name-directory string)) |
| 1534 | (realdir (or specdir default-directory))) | 1528 | (realdir (or specdir default-directory))) |
| 1535 | 1529 | ||
| 1536 | (cond | 1530 | (cond |
| 1537 | ((null action) | 1531 | ((null action) |
| 1538 | (let ((comp (file-name-completion name realdir pred))) | 1532 | (let ((comp (file-name-completion name realdir pred))) |
| 1539 | (if (stringp comp) | 1533 | (if (stringp comp) |
| 1540 | (concat specdir comp) | 1534 | (concat specdir comp) |
| 1541 | comp))) | 1535 | comp))) |
| 1542 | 1536 | ||
| 1543 | ((eq action t) | 1537 | ((eq action t) |
| 1544 | (let ((all (file-name-all-completions name realdir))) | 1538 | (let ((all (file-name-all-completions name realdir))) |
| 1545 | 1539 | ||
| 1546 | ;; Check the predicate, if necessary. | 1540 | ;; Check the predicate, if necessary. |
| 1547 | (unless (memq pred '(nil file-exists-p)) | 1541 | (unless (memq pred '(nil file-exists-p)) |
| 1548 | (let ((comp ()) | 1542 | (let ((comp ()) |
| 1549 | (pred | 1543 | (pred |
| 1550 | (if (eq pred 'file-directory-p) | 1544 | (if (eq pred 'file-directory-p) |
| 1551 | ;; Brute-force speed up for directory checking: | 1545 | ;; Brute-force speed up for directory checking: |
| 1552 | ;; Discard strings which don't end in a slash. | 1546 | ;; Discard strings which don't end in a slash. |
| 1553 | (lambda (s) | 1547 | (lambda (s) |
| 1554 | (let ((len (length s))) | 1548 | (let ((len (length s))) |
| 1555 | (and (> len 0) (eq (aref s (1- len)) ?/)))) | 1549 | (and (> len 0) (eq (aref s (1- len)) ?/)))) |
| 1556 | ;; Must do it the hard (and slow) way. | 1550 | ;; Must do it the hard (and slow) way. |
| 1557 | pred))) | 1551 | pred))) |
| 1558 | (let ((default-directory (expand-file-name realdir))) | 1552 | (let ((default-directory (expand-file-name realdir))) |
| 1559 | (dolist (tem all) | 1553 | (dolist (tem all) |
| 1560 | (if (funcall pred tem) (push tem comp)))) | 1554 | (if (funcall pred tem) (push tem comp)))) |
| 1561 | (setq all (nreverse comp)))) | 1555 | (setq all (nreverse comp)))) |
| 1562 | 1556 | ||
| 1563 | all)))))))) | 1557 | all)))))))) |
| 1564 | 1558 | ||
| @@ -1755,122 +1749,122 @@ See `read-file-name' for the meaning of the arguments." | |||
| 1755 | (minibuffer--double-dollars dir))) | 1749 | (minibuffer--double-dollars dir))) |
| 1756 | (initial (cons (minibuffer--double-dollars initial) 0))))) | 1750 | (initial (cons (minibuffer--double-dollars initial) 0))))) |
| 1757 | 1751 | ||
| 1758 | (let ((completion-ignore-case read-file-name-completion-ignore-case) | 1752 | (let ((completion-ignore-case read-file-name-completion-ignore-case) |
| 1759 | (minibuffer-completing-file-name t) | 1753 | (minibuffer-completing-file-name t) |
| 1760 | (pred (or predicate 'file-exists-p)) | 1754 | (pred (or predicate 'file-exists-p)) |
| 1761 | (add-to-history nil)) | 1755 | (add-to-history nil)) |
| 1762 | 1756 | ||
| 1763 | (let* ((val | 1757 | (let* ((val |
| 1764 | (if (or (not (next-read-file-uses-dialog-p)) | 1758 | (if (or (not (next-read-file-uses-dialog-p)) |
| 1765 | ;; Graphical file dialogs can't handle remote | 1759 | ;; Graphical file dialogs can't handle remote |
| 1766 | ;; files (Bug#99). | 1760 | ;; files (Bug#99). |
| 1767 | (file-remote-p dir)) | 1761 | (file-remote-p dir)) |
| 1768 | ;; We used to pass `dir' to `read-file-name-internal' by | 1762 | ;; We used to pass `dir' to `read-file-name-internal' by |
| 1769 | ;; abusing the `predicate' argument. It's better to | 1763 | ;; abusing the `predicate' argument. It's better to |
| 1770 | ;; just use `default-directory', but in order to avoid | 1764 | ;; just use `default-directory', but in order to avoid |
| 1771 | ;; changing `default-directory' in the current buffer, | 1765 | ;; changing `default-directory' in the current buffer, |
| 1772 | ;; we don't let-bind it. | 1766 | ;; we don't let-bind it. |
| 1773 | (lexical-let ((dir (file-name-as-directory | 1767 | (let ((dir (file-name-as-directory |
| 1774 | (expand-file-name dir)))) | 1768 | (expand-file-name dir)))) |
| 1775 | (minibuffer-with-setup-hook | 1769 | (minibuffer-with-setup-hook |
| 1776 | (lambda () | 1770 | (lambda () |
| 1777 | (setq default-directory dir) | 1771 | (setq default-directory dir) |
| 1778 | ;; When the first default in `minibuffer-default' | 1772 | ;; When the first default in `minibuffer-default' |
| 1779 | ;; duplicates initial input `insdef', | 1773 | ;; duplicates initial input `insdef', |
| 1780 | ;; reset `minibuffer-default' to nil. | 1774 | ;; reset `minibuffer-default' to nil. |
| 1781 | (when (equal (or (car-safe insdef) insdef) | 1775 | (when (equal (or (car-safe insdef) insdef) |
| 1782 | (or (car-safe minibuffer-default) | 1776 | (or (car-safe minibuffer-default) |
| 1783 | minibuffer-default)) | 1777 | minibuffer-default)) |
| 1784 | (setq minibuffer-default | 1778 | (setq minibuffer-default |
| 1785 | (cdr-safe minibuffer-default))) | 1779 | (cdr-safe minibuffer-default))) |
| 1786 | ;; On the first request on `M-n' fill | 1780 | ;; On the first request on `M-n' fill |
| 1787 | ;; `minibuffer-default' with a list of defaults | 1781 | ;; `minibuffer-default' with a list of defaults |
| 1788 | ;; relevant for file-name reading. | 1782 | ;; relevant for file-name reading. |
| 1789 | (set (make-local-variable 'minibuffer-default-add-function) | 1783 | (set (make-local-variable 'minibuffer-default-add-function) |
| 1790 | (lambda () | 1784 | (lambda () |
| 1791 | (with-current-buffer | 1785 | (with-current-buffer |
| 1792 | (window-buffer (minibuffer-selected-window)) | 1786 | (window-buffer (minibuffer-selected-window)) |
| 1793 | (read-file-name--defaults dir initial))))) | 1787 | (read-file-name--defaults dir initial))))) |
| 1794 | (completing-read prompt 'read-file-name-internal | 1788 | (completing-read prompt 'read-file-name-internal |
| 1795 | pred mustmatch insdef | 1789 | pred mustmatch insdef |
| 1796 | 'file-name-history default-filename))) | 1790 | 'file-name-history default-filename))) |
| 1797 | ;; If DEFAULT-FILENAME not supplied and DIR contains | 1791 | ;; If DEFAULT-FILENAME not supplied and DIR contains |
| 1798 | ;; a file name, split it. | 1792 | ;; a file name, split it. |
| 1799 | (let ((file (file-name-nondirectory dir)) | 1793 | (let ((file (file-name-nondirectory dir)) |
| 1800 | ;; When using a dialog, revert to nil and non-nil | 1794 | ;; When using a dialog, revert to nil and non-nil |
| 1801 | ;; interpretation of mustmatch. confirm options | 1795 | ;; interpretation of mustmatch. confirm options |
| 1802 | ;; need to be interpreted as nil, otherwise | 1796 | ;; need to be interpreted as nil, otherwise |
| 1803 | ;; it is impossible to create new files using | 1797 | ;; it is impossible to create new files using |
| 1804 | ;; dialogs with the default settings. | 1798 | ;; dialogs with the default settings. |
| 1805 | (dialog-mustmatch | 1799 | (dialog-mustmatch |
| 1806 | (not (memq mustmatch | 1800 | (not (memq mustmatch |
| 1807 | '(nil confirm confirm-after-completion))))) | 1801 | '(nil confirm confirm-after-completion))))) |
| 1808 | (when (and (not default-filename) | 1802 | (when (and (not default-filename) |
| 1809 | (not (zerop (length file)))) | 1803 | (not (zerop (length file)))) |
| 1810 | (setq default-filename file) | 1804 | (setq default-filename file) |
| 1811 | (setq dir (file-name-directory dir))) | 1805 | (setq dir (file-name-directory dir))) |
| 1812 | (when default-filename | 1806 | (when default-filename |
| 1813 | (setq default-filename | 1807 | (setq default-filename |
| 1814 | (expand-file-name (if (consp default-filename) | 1808 | (expand-file-name (if (consp default-filename) |
| 1815 | (car default-filename) | 1809 | (car default-filename) |
| 1816 | default-filename) | 1810 | default-filename) |
| 1817 | dir))) | 1811 | dir))) |
| 1818 | (setq add-to-history t) | 1812 | (setq add-to-history t) |
| 1819 | (x-file-dialog prompt dir default-filename | 1813 | (x-file-dialog prompt dir default-filename |
| 1820 | dialog-mustmatch | 1814 | dialog-mustmatch |
| 1821 | (eq predicate 'file-directory-p))))) | 1815 | (eq predicate 'file-directory-p))))) |
| 1822 | 1816 | ||
| 1823 | (replace-in-history (eq (car-safe file-name-history) val))) | 1817 | (replace-in-history (eq (car-safe file-name-history) val))) |
| 1824 | ;; If completing-read returned the inserted default string itself | 1818 | ;; If completing-read returned the inserted default string itself |
| 1825 | ;; (rather than a new string with the same contents), | 1819 | ;; (rather than a new string with the same contents), |
| 1826 | ;; it has to mean that the user typed RET with the minibuffer empty. | 1820 | ;; it has to mean that the user typed RET with the minibuffer empty. |
| 1827 | ;; In that case, we really want to return "" | 1821 | ;; In that case, we really want to return "" |
| 1828 | ;; so that commands such as set-visited-file-name can distinguish. | 1822 | ;; so that commands such as set-visited-file-name can distinguish. |
| 1829 | (when (consp default-filename) | 1823 | (when (consp default-filename) |
| 1830 | (setq default-filename (car default-filename))) | 1824 | (setq default-filename (car default-filename))) |
| 1831 | (when (eq val default-filename) | 1825 | (when (eq val default-filename) |
| 1832 | ;; In this case, completing-read has not added an element | 1826 | ;; In this case, completing-read has not added an element |
| 1833 | ;; to the history. Maybe we should. | 1827 | ;; to the history. Maybe we should. |
| 1834 | (if (not replace-in-history) | 1828 | (if (not replace-in-history) |
| 1835 | (setq add-to-history t)) | 1829 | (setq add-to-history t)) |
| 1836 | (setq val "")) | 1830 | (setq val "")) |
| 1837 | (unless val (error "No file name specified")) | 1831 | (unless val (error "No file name specified")) |
| 1838 | 1832 | ||
| 1839 | (if (and default-filename | 1833 | (if (and default-filename |
| 1840 | (string-equal val (if (consp insdef) (car insdef) insdef))) | 1834 | (string-equal val (if (consp insdef) (car insdef) insdef))) |
| 1841 | (setq val default-filename)) | 1835 | (setq val default-filename)) |
| 1842 | (setq val (substitute-in-file-name val)) | 1836 | (setq val (substitute-in-file-name val)) |
| 1843 | 1837 | ||
| 1844 | (if replace-in-history | 1838 | (if replace-in-history |
| 1845 | ;; Replace what Fcompleting_read added to the history | 1839 | ;; Replace what Fcompleting_read added to the history |
| 1846 | ;; with what we will actually return. As an exception, | 1840 | ;; with what we will actually return. As an exception, |
| 1847 | ;; if that's the same as the second item in | 1841 | ;; if that's the same as the second item in |
| 1848 | ;; file-name-history, it's really a repeat (Bug#4657). | 1842 | ;; file-name-history, it's really a repeat (Bug#4657). |
| 1843 | (let ((val1 (minibuffer--double-dollars val))) | ||
| 1844 | (if history-delete-duplicates | ||
| 1845 | (setcdr file-name-history | ||
| 1846 | (delete val1 (cdr file-name-history)))) | ||
| 1847 | (if (string= val1 (cadr file-name-history)) | ||
| 1848 | (pop file-name-history) | ||
| 1849 | (setcar file-name-history val1))) | ||
| 1850 | (if add-to-history | ||
| 1851 | ;; Add the value to the history--but not if it matches | ||
| 1852 | ;; the last value already there. | ||
| 1849 | (let ((val1 (minibuffer--double-dollars val))) | 1853 | (let ((val1 (minibuffer--double-dollars val))) |
| 1850 | (if history-delete-duplicates | 1854 | (unless (and (consp file-name-history) |
| 1851 | (setcdr file-name-history | 1855 | (equal (car file-name-history) val1)) |
| 1852 | (delete val1 (cdr file-name-history)))) | 1856 | (setq file-name-history |
| 1853 | (if (string= val1 (cadr file-name-history)) | 1857 | (cons val1 |
| 1854 | (pop file-name-history) | 1858 | (if history-delete-duplicates |
| 1855 | (setcar file-name-history val1))) | 1859 | (delete val1 file-name-history) |
| 1856 | (if add-to-history | 1860 | file-name-history))))))) |
| 1857 | ;; Add the value to the history--but not if it matches | ||
| 1858 | ;; the last value already there. | ||
| 1859 | (let ((val1 (minibuffer--double-dollars val))) | ||
| 1860 | (unless (and (consp file-name-history) | ||
| 1861 | (equal (car file-name-history) val1)) | ||
| 1862 | (setq file-name-history | ||
| 1863 | (cons val1 | ||
| 1864 | (if history-delete-duplicates | ||
| 1865 | (delete val1 file-name-history) | ||
| 1866 | file-name-history))))))) | ||
| 1867 | val)))) | 1861 | val)))) |
| 1868 | 1862 | ||
| 1869 | (defun internal-complete-buffer-except (&optional buffer) | 1863 | (defun internal-complete-buffer-except (&optional buffer) |
| 1870 | "Perform completion on all buffers excluding BUFFER. | 1864 | "Perform completion on all buffers excluding BUFFER. |
| 1871 | BUFFER nil or omitted means use the current buffer. | 1865 | BUFFER nil or omitted means use the current buffer. |
| 1872 | Like `internal-complete-buffer', but removes BUFFER from the completion list." | 1866 | Like `internal-complete-buffer', but removes BUFFER from the completion list." |
| 1873 | (lexical-let ((except (if (stringp buffer) buffer (buffer-name buffer)))) | 1867 | (let ((except (if (stringp buffer) buffer (buffer-name buffer)))) |
| 1874 | (apply-partially 'completion-table-with-predicate | 1868 | (apply-partially 'completion-table-with-predicate |
| 1875 | 'internal-complete-buffer | 1869 | 'internal-complete-buffer |
| 1876 | (lambda (name) | 1870 | (lambda (name) |
| @@ -1879,13 +1873,13 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list." | |||
| 1879 | 1873 | ||
| 1880 | ;;; Old-style completion, used in Emacs-21 and Emacs-22. | 1874 | ;;; Old-style completion, used in Emacs-21 and Emacs-22. |
| 1881 | 1875 | ||
| 1882 | (defun completion-emacs21-try-completion (string table pred point) | 1876 | (defun completion-emacs21-try-completion (string table pred _point) |
| 1883 | (let ((completion (try-completion string table pred))) | 1877 | (let ((completion (try-completion string table pred))) |
| 1884 | (if (stringp completion) | 1878 | (if (stringp completion) |
| 1885 | (cons completion (length completion)) | 1879 | (cons completion (length completion)) |
| 1886 | completion))) | 1880 | completion))) |
| 1887 | 1881 | ||
| 1888 | (defun completion-emacs21-all-completions (string table pred point) | 1882 | (defun completion-emacs21-all-completions (string table pred _point) |
| 1889 | (completion-hilit-commonality | 1883 | (completion-hilit-commonality |
| 1890 | (all-completions string table pred) | 1884 | (all-completions string table pred) |
| 1891 | (length string) | 1885 | (length string) |
| @@ -1942,10 +1936,9 @@ Return the new suffix." | |||
| 1942 | (substring afterpoint 0 (cdr bounds))))) | 1936 | (substring afterpoint 0 (cdr bounds))))) |
| 1943 | 1937 | ||
| 1944 | (defun completion-basic-try-completion (string table pred point) | 1938 | (defun completion-basic-try-completion (string table pred point) |
| 1945 | (lexical-let* | 1939 | (let* ((beforepoint (substring string 0 point)) |
| 1946 | ((beforepoint (substring string 0 point)) | 1940 | (afterpoint (substring string point)) |
| 1947 | (afterpoint (substring string point)) | 1941 | (bounds (completion-boundaries beforepoint table pred afterpoint))) |
| 1948 | (bounds (completion-boundaries beforepoint table pred afterpoint))) | ||
| 1949 | (if (zerop (cdr bounds)) | 1942 | (if (zerop (cdr bounds)) |
| 1950 | ;; `try-completion' may return a subtly different result | 1943 | ;; `try-completion' may return a subtly different result |
| 1951 | ;; than `all+merge', so try to use it whenever possible. | 1944 | ;; than `all+merge', so try to use it whenever possible. |
| @@ -1956,30 +1949,28 @@ Return the new suffix." | |||
| 1956 | (concat completion | 1949 | (concat completion |
| 1957 | (completion--merge-suffix completion point afterpoint)) | 1950 | (completion--merge-suffix completion point afterpoint)) |
| 1958 | (length completion)))) | 1951 | (length completion)))) |
| 1959 | (lexical-let* | 1952 | (let* ((suffix (substring afterpoint (cdr bounds))) |
| 1960 | ((suffix (substring afterpoint (cdr bounds))) | 1953 | (prefix (substring beforepoint 0 (car bounds))) |
| 1961 | (prefix (substring beforepoint 0 (car bounds))) | 1954 | (pattern (delete |
| 1962 | (pattern (delete | 1955 | "" (list (substring beforepoint (car bounds)) |
| 1963 | "" (list (substring beforepoint (car bounds)) | 1956 | 'point |
| 1964 | 'point | 1957 | (substring afterpoint 0 (cdr bounds))))) |
| 1965 | (substring afterpoint 0 (cdr bounds))))) | 1958 | (all (completion-pcm--all-completions prefix pattern table pred))) |
| 1966 | (all (completion-pcm--all-completions prefix pattern table pred))) | ||
| 1967 | (if minibuffer-completing-file-name | 1959 | (if minibuffer-completing-file-name |
| 1968 | (setq all (completion-pcm--filename-try-filter all))) | 1960 | (setq all (completion-pcm--filename-try-filter all))) |
| 1969 | (completion-pcm--merge-try pattern all prefix suffix))))) | 1961 | (completion-pcm--merge-try pattern all prefix suffix))))) |
| 1970 | 1962 | ||
| 1971 | (defun completion-basic-all-completions (string table pred point) | 1963 | (defun completion-basic-all-completions (string table pred point) |
| 1972 | (lexical-let* | 1964 | (let* ((beforepoint (substring string 0 point)) |
| 1973 | ((beforepoint (substring string 0 point)) | 1965 | (afterpoint (substring string point)) |
| 1974 | (afterpoint (substring string point)) | 1966 | (bounds (completion-boundaries beforepoint table pred afterpoint)) |
| 1975 | (bounds (completion-boundaries beforepoint table pred afterpoint)) | 1967 | ;; (suffix (substring afterpoint (cdr bounds))) |
| 1976 | (suffix (substring afterpoint (cdr bounds))) | 1968 | (prefix (substring beforepoint 0 (car bounds))) |
| 1977 | (prefix (substring beforepoint 0 (car bounds))) | 1969 | (pattern (delete |
| 1978 | (pattern (delete | 1970 | "" (list (substring beforepoint (car bounds)) |
| 1979 | "" (list (substring beforepoint (car bounds)) | 1971 | 'point |
| 1980 | 'point | 1972 | (substring afterpoint 0 (cdr bounds))))) |
| 1981 | (substring afterpoint 0 (cdr bounds))))) | 1973 | (all (completion-pcm--all-completions prefix pattern table pred))) |
| 1982 | (all (completion-pcm--all-completions prefix pattern table pred))) | ||
| 1983 | (completion-hilit-commonality all point (car bounds)))) | 1974 | (completion-hilit-commonality all point (car bounds)))) |
| 1984 | 1975 | ||
| 1985 | ;;; Partial-completion-mode style completion. | 1976 | ;;; Partial-completion-mode style completion. |
| @@ -2142,13 +2133,12 @@ POINT is a position inside STRING. | |||
| 2142 | FILTER is a function applied to the return value, that can be used, e.g. to | 2133 | FILTER is a function applied to the return value, that can be used, e.g. to |
| 2143 | filter out additional entries (because TABLE migth not obey PRED)." | 2134 | filter out additional entries (because TABLE migth not obey PRED)." |
| 2144 | (unless filter (setq filter 'identity)) | 2135 | (unless filter (setq filter 'identity)) |
| 2145 | (lexical-let* | 2136 | (let* ((beforepoint (substring string 0 point)) |
| 2146 | ((beforepoint (substring string 0 point)) | 2137 | (afterpoint (substring string point)) |
| 2147 | (afterpoint (substring string point)) | 2138 | (bounds (completion-boundaries beforepoint table pred afterpoint)) |
| 2148 | (bounds (completion-boundaries beforepoint table pred afterpoint)) | 2139 | (prefix (substring beforepoint 0 (car bounds))) |
| 2149 | (prefix (substring beforepoint 0 (car bounds))) | 2140 | (suffix (substring afterpoint (cdr bounds))) |
| 2150 | (suffix (substring afterpoint (cdr bounds))) | 2141 | firsterror) |
| 2151 | firsterror) | ||
| 2152 | (setq string (substring string (car bounds) (+ point (cdr bounds)))) | 2142 | (setq string (substring string (car bounds) (+ point (cdr bounds)))) |
| 2153 | (let* ((relpoint (- point (car bounds))) | 2143 | (let* ((relpoint (- point (car bounds))) |
| 2154 | (pattern (completion-pcm--string->pattern string relpoint)) | 2144 | (pattern (completion-pcm--string->pattern string relpoint)) |
| @@ -2163,7 +2153,7 @@ filter out additional entries (because TABLE migth not obey PRED)." | |||
| 2163 | ;; The prefix has no completions at all, so we should try and fix | 2153 | ;; The prefix has no completions at all, so we should try and fix |
| 2164 | ;; that first. | 2154 | ;; that first. |
| 2165 | (let ((substring (substring prefix 0 -1))) | 2155 | (let ((substring (substring prefix 0 -1))) |
| 2166 | (destructuring-bind (subpat suball subprefix subsuffix) | 2156 | (destructuring-bind (subpat suball subprefix _subsuffix) |
| 2167 | (completion-pcm--find-all-completions | 2157 | (completion-pcm--find-all-completions |
| 2168 | substring table pred (length substring) filter) | 2158 | substring table pred (length substring) filter) |
| 2169 | (let ((sep (aref prefix (1- (length prefix)))) | 2159 | (let ((sep (aref prefix (1- (length prefix)))) |
| @@ -2228,7 +2218,7 @@ filter out additional entries (because TABLE migth not obey PRED)." | |||
| 2228 | (list pattern all prefix suffix))))) | 2218 | (list pattern all prefix suffix))))) |
| 2229 | 2219 | ||
| 2230 | (defun completion-pcm-all-completions (string table pred point) | 2220 | (defun completion-pcm-all-completions (string table pred point) |
| 2231 | (destructuring-bind (pattern all &optional prefix suffix) | 2221 | (destructuring-bind (pattern all &optional prefix _suffix) |
| 2232 | (completion-pcm--find-all-completions string table pred point) | 2222 | (completion-pcm--find-all-completions string table pred point) |
| 2233 | (when all | 2223 | (when all |
| 2234 | (nconc (completion-pcm--hilit-commonality pattern all) | 2224 | (nconc (completion-pcm--hilit-commonality pattern all) |
| @@ -2323,9 +2313,9 @@ filter out additional entries (because TABLE migth not obey PRED)." | |||
| 2323 | 2313 | ||
| 2324 | (defun completion-pcm--pattern->string (pattern) | 2314 | (defun completion-pcm--pattern->string (pattern) |
| 2325 | (mapconcat (lambda (x) (cond | 2315 | (mapconcat (lambda (x) (cond |
| 2326 | ((stringp x) x) | 2316 | ((stringp x) x) |
| 2327 | ((eq x 'star) "*") | 2317 | ((eq x 'star) "*") |
| 2328 | (t ""))) ;any, point, prefix. | 2318 | (t ""))) ;any, point, prefix. |
| 2329 | pattern | 2319 | pattern |
| 2330 | "")) | 2320 | "")) |
| 2331 | 2321 | ||
| @@ -2341,7 +2331,7 @@ filter out additional entries (because TABLE migth not obey PRED)." | |||
| 2341 | ;; second alternative. | 2331 | ;; second alternative. |
| 2342 | (defun completion-pcm--filename-try-filter (all) | 2332 | (defun completion-pcm--filename-try-filter (all) |
| 2343 | "Filter to adjust `all' file completion to the behavior of `try'." | 2333 | "Filter to adjust `all' file completion to the behavior of `try'." |
| 2344 | (when all | 2334 | (when all |
| 2345 | (let ((try ()) | 2335 | (let ((try ()) |
| 2346 | (re (concat "\\(?:\\`\\.\\.?/\\|" | 2336 | (re (concat "\\(?:\\`\\.\\.?/\\|" |
| 2347 | (regexp-opt completion-ignored-extensions) | 2337 | (regexp-opt completion-ignored-extensions) |
| @@ -2359,23 +2349,23 @@ filter out additional entries (because TABLE migth not obey PRED)." | |||
| 2359 | (equal (completion-pcm--pattern->string pattern) (car all))) | 2349 | (equal (completion-pcm--pattern->string pattern) (car all))) |
| 2360 | t) | 2350 | t) |
| 2361 | (t | 2351 | (t |
| 2362 | (let* ((mergedpat (completion-pcm--merge-completions all pattern)) | 2352 | (let* ((mergedpat (completion-pcm--merge-completions all pattern)) |
| 2363 | ;; `mergedpat' is in reverse order. Place new point (by | 2353 | ;; `mergedpat' is in reverse order. Place new point (by |
| 2364 | ;; order of preference) either at the old point, or at | 2354 | ;; order of preference) either at the old point, or at |
| 2365 | ;; the last place where there's something to choose, or | 2355 | ;; the last place where there's something to choose, or |
| 2366 | ;; at the very end. | 2356 | ;; at the very end. |
| 2367 | (pointpat (or (memq 'point mergedpat) | 2357 | (pointpat (or (memq 'point mergedpat) |
| 2368 | (memq 'any mergedpat) | 2358 | (memq 'any mergedpat) |
| 2369 | (memq 'star mergedpat) | 2359 | (memq 'star mergedpat) |
| 2370 | ;; Not `prefix'. | 2360 | ;; Not `prefix'. |
| 2371 | mergedpat)) | 2361 | mergedpat)) |
| 2372 | ;; New pos from the start. | 2362 | ;; New pos from the start. |
| 2373 | (newpos (length (completion-pcm--pattern->string pointpat))) | 2363 | (newpos (length (completion-pcm--pattern->string pointpat))) |
| 2374 | ;; Do it afterwards because it changes `pointpat' by sideeffect. | 2364 | ;; Do it afterwards because it changes `pointpat' by sideeffect. |
| 2375 | (merged (completion-pcm--pattern->string (nreverse mergedpat)))) | 2365 | (merged (completion-pcm--pattern->string (nreverse mergedpat)))) |
| 2376 | 2366 | ||
| 2377 | (setq suffix (completion--merge-suffix merged newpos suffix)) | 2367 | (setq suffix (completion--merge-suffix merged newpos suffix)) |
| 2378 | (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) | 2368 | (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) |
| 2379 | 2369 | ||
| 2380 | (defun completion-pcm-try-completion (string table pred point) | 2370 | (defun completion-pcm-try-completion (string table pred point) |
| 2381 | (destructuring-bind (pattern all prefix suffix) | 2371 | (destructuring-bind (pattern all prefix suffix) |
| @@ -2403,14 +2393,14 @@ filter out additional entries (because TABLE migth not obey PRED)." | |||
| 2403 | (list all pattern prefix suffix (car bounds)))) | 2393 | (list all pattern prefix suffix (car bounds)))) |
| 2404 | 2394 | ||
| 2405 | (defun completion-substring-try-completion (string table pred point) | 2395 | (defun completion-substring-try-completion (string table pred point) |
| 2406 | (destructuring-bind (all pattern prefix suffix carbounds) | 2396 | (destructuring-bind (all pattern prefix suffix _carbounds) |
| 2407 | (completion-substring--all-completions string table pred point) | 2397 | (completion-substring--all-completions string table pred point) |
| 2408 | (if minibuffer-completing-file-name | 2398 | (if minibuffer-completing-file-name |
| 2409 | (setq all (completion-pcm--filename-try-filter all))) | 2399 | (setq all (completion-pcm--filename-try-filter all))) |
| 2410 | (completion-pcm--merge-try pattern all prefix suffix))) | 2400 | (completion-pcm--merge-try pattern all prefix suffix))) |
| 2411 | 2401 | ||
| 2412 | (defun completion-substring-all-completions (string table pred point) | 2402 | (defun completion-substring-all-completions (string table pred point) |
| 2413 | (destructuring-bind (all pattern prefix suffix carbounds) | 2403 | (destructuring-bind (all pattern prefix _suffix _carbounds) |
| 2414 | (completion-substring--all-completions string table pred point) | 2404 | (completion-substring--all-completions string table pred point) |
| 2415 | (when all | 2405 | (when all |
| 2416 | (nconc (completion-pcm--hilit-commonality pattern all) | 2406 | (nconc (completion-pcm--hilit-commonality pattern all) |
| @@ -2447,12 +2437,12 @@ filter out additional entries (because TABLE migth not obey PRED)." | |||
| 2447 | (concat (substring str 0 (car bounds)) | 2437 | (concat (substring str 0 (car bounds)) |
| 2448 | (mapconcat 'string (substring str (car bounds)) sep)))))))) | 2438 | (mapconcat 'string (substring str (car bounds)) sep)))))))) |
| 2449 | 2439 | ||
| 2450 | (defun completion-initials-all-completions (string table pred point) | 2440 | (defun completion-initials-all-completions (string table pred _point) |
| 2451 | (let ((newstr (completion-initials-expand string table pred))) | 2441 | (let ((newstr (completion-initials-expand string table pred))) |
| 2452 | (when newstr | 2442 | (when newstr |
| 2453 | (completion-pcm-all-completions newstr table pred (length newstr))))) | 2443 | (completion-pcm-all-completions newstr table pred (length newstr))))) |
| 2454 | 2444 | ||
| 2455 | (defun completion-initials-try-completion (string table pred point) | 2445 | (defun completion-initials-try-completion (string table pred _point) |
| 2456 | (let ((newstr (completion-initials-expand string table pred))) | 2446 | (let ((newstr (completion-initials-expand string table pred))) |
| 2457 | (when newstr | 2447 | (when newstr |
| 2458 | (completion-pcm-try-completion newstr table pred (length newstr))))) | 2448 | (completion-pcm-try-completion newstr table pred (length newstr))))) |
diff --git a/lisp/mpc.el b/lisp/mpc.el index 8feddf8829b..b1e4d860cca 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8 -*- | 1 | ;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8; lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2006-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2006-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -341,9 +341,7 @@ CMD can be a string which is passed as-is to MPD or a list of strings | |||
| 341 | which will be concatenated with proper quoting before passing them to MPD." | 341 | which will be concatenated with proper quoting before passing them to MPD." |
| 342 | (let ((proc (mpc-proc))) | 342 | (let ((proc (mpc-proc))) |
| 343 | (if (and callback (not (process-get proc 'ready))) | 343 | (if (and callback (not (process-get proc 'ready))) |
| 344 | (lexical-let ((old (process-get proc 'callback)) | 344 | (let ((old (process-get proc 'callback))) |
| 345 | (callback callback) | ||
| 346 | (cmd cmd)) | ||
| 347 | (process-put proc 'callback | 345 | (process-put proc 'callback |
| 348 | (lambda () | 346 | (lambda () |
| 349 | (funcall old) | 347 | (funcall old) |
| @@ -359,15 +357,14 @@ which will be concatenated with proper quoting before passing them to MPD." | |||
| 359 | (mapconcat 'mpc--proc-quote-string cmd " ")) | 357 | (mapconcat 'mpc--proc-quote-string cmd " ")) |
| 360 | "\n"))) | 358 | "\n"))) |
| 361 | (if callback | 359 | (if callback |
| 362 | (lexical-let ((buf (current-buffer)) | 360 | ;; (let ((buf (current-buffer))) |
| 363 | (callback callback)) | ||
| 364 | (process-put proc 'callback | 361 | (process-put proc 'callback |
| 365 | callback | 362 | callback |
| 366 | ;; (lambda () | 363 | ;; (lambda () |
| 367 | ;; (funcall callback | 364 | ;; (funcall callback |
| 368 | ;; (prog1 (current-buffer) | 365 | ;; (prog1 (current-buffer) |
| 369 | ;; (set-buffer buf)))) | 366 | ;; (set-buffer buf))))) |
| 370 | )) | 367 | ) |
| 371 | ;; If `callback' is nil, we're executing synchronously. | 368 | ;; If `callback' is nil, we're executing synchronously. |
| 372 | (process-put proc 'callback 'ignore) | 369 | (process-put proc 'callback 'ignore) |
| 373 | ;; This returns the process's buffer. | 370 | ;; This returns the process's buffer. |
| @@ -402,8 +399,7 @@ which will be concatenated with proper quoting before passing them to MPD." | |||
| 402 | 399 | ||
| 403 | (defun mpc-proc-cmd-to-alist (cmd &optional callback) | 400 | (defun mpc-proc-cmd-to-alist (cmd &optional callback) |
| 404 | (if callback | 401 | (if callback |
| 405 | (lexical-let ((buf (current-buffer)) | 402 | (let ((buf (current-buffer))) |
| 406 | (callback callback)) | ||
| 407 | (mpc-proc-cmd cmd (lambda () | 403 | (mpc-proc-cmd cmd (lambda () |
| 408 | (funcall callback (prog1 (mpc-proc-buf-to-alist | 404 | (funcall callback (prog1 (mpc-proc-buf-to-alist |
| 409 | (current-buffer)) | 405 | (current-buffer)) |
| @@ -522,7 +518,7 @@ to call FUN for any change whatsoever.") | |||
| 522 | 518 | ||
| 523 | (defun mpc-status-refresh (&optional callback) | 519 | (defun mpc-status-refresh (&optional callback) |
| 524 | "Refresh `mpc-status'." | 520 | "Refresh `mpc-status'." |
| 525 | (lexical-let ((cb callback)) | 521 | (let ((cb callback)) |
| 526 | (mpc-proc-cmd (mpc-proc-cmd-list '("status" "currentsong")) | 522 | (mpc-proc-cmd (mpc-proc-cmd-list '("status" "currentsong")) |
| 527 | (lambda () | 523 | (lambda () |
| 528 | (mpc--status-callback) | 524 | (mpc--status-callback) |
| @@ -604,7 +600,7 @@ The songs are returned as alists." | |||
| 604 | (cond | 600 | (cond |
| 605 | ((eq tag 'Playlist) | 601 | ((eq tag 'Playlist) |
| 606 | ;; Special case for pseudo-tag playlist. | 602 | ;; Special case for pseudo-tag playlist. |
| 607 | (let ((l (condition-case err | 603 | (let ((l (condition-case nil |
| 608 | (mpc-proc-buf-to-alists | 604 | (mpc-proc-buf-to-alists |
| 609 | (mpc-proc-cmd (list "listplaylistinfo" value))) | 605 | (mpc-proc-cmd (list "listplaylistinfo" value))) |
| 610 | (mpc-proc-error | 606 | (mpc-proc-error |
| @@ -637,7 +633,7 @@ The songs are returned as alists." | |||
| 637 | (mpc-union (mpc-cmd-find tag1 value) | 633 | (mpc-union (mpc-cmd-find tag1 value) |
| 638 | (mpc-cmd-find tag2 value)))) | 634 | (mpc-cmd-find tag2 value)))) |
| 639 | (t | 635 | (t |
| 640 | (condition-case err | 636 | (condition-case nil |
| 641 | (mpc-proc-buf-to-alists | 637 | (mpc-proc-buf-to-alists |
| 642 | (mpc-proc-cmd (list "find" (symbol-name tag) value))) | 638 | (mpc-proc-cmd (list "find" (symbol-name tag) value))) |
| 643 | (mpc-proc-error | 639 | (mpc-proc-error |
| @@ -775,7 +771,7 @@ The songs are returned as alists." | |||
| 775 | 771 | ||
| 776 | (defun mpc-cmd-pause (&optional arg callback) | 772 | (defun mpc-cmd-pause (&optional arg callback) |
| 777 | "Pause or resume playback of the queue of songs." | 773 | "Pause or resume playback of the queue of songs." |
| 778 | (lexical-let ((cb callback)) | 774 | (let ((cb callback)) |
| 779 | (mpc-proc-cmd (list "pause" arg) | 775 | (mpc-proc-cmd (list "pause" arg) |
| 780 | (lambda () (mpc-status-refresh) (if cb (funcall cb)))) | 776 | (lambda () (mpc-status-refresh) (if cb (funcall cb)))) |
| 781 | (unless callback (mpc-proc-sync)))) | 777 | (unless callback (mpc-proc-sync)))) |
| @@ -839,7 +835,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." | |||
| 839 | (puthash (cons 'Playlist playlist) nil mpc--find-memoize)))) | 835 | (puthash (cons 'Playlist playlist) nil mpc--find-memoize)))) |
| 840 | 836 | ||
| 841 | (defun mpc-cmd-update (&optional arg callback) | 837 | (defun mpc-cmd-update (&optional arg callback) |
| 842 | (lexical-let ((cb callback)) | 838 | (let ((cb callback)) |
| 843 | (mpc-proc-cmd (if arg (list "update" arg) "update") | 839 | (mpc-proc-cmd (if arg (list "update" arg) "update") |
| 844 | (lambda () (mpc-status-refresh) (if cb (funcall cb)))) | 840 | (lambda () (mpc-status-refresh) (if cb (funcall cb)))) |
| 845 | (unless callback (mpc-proc-sync)))) | 841 | (unless callback (mpc-proc-sync)))) |
| @@ -939,7 +935,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." | |||
| 939 | 935 | ||
| 940 | (defun mpc-tempfiles-clean () | 936 | (defun mpc-tempfiles-clean () |
| 941 | (let ((live ())) | 937 | (let ((live ())) |
| 942 | (maphash (lambda (k v) (push v live)) mpc-tempfiles-reftable) | 938 | (maphash (lambda (_k v) (push v live)) mpc-tempfiles-reftable) |
| 943 | (dolist (f mpc-tempfiles) | 939 | (dolist (f mpc-tempfiles) |
| 944 | (unless (member f live) (ignore-errors (delete-file f)))) | 940 | (unless (member f live) (ignore-errors (delete-file f)))) |
| 945 | (setq mpc-tempfiles live))) | 941 | (setq mpc-tempfiles live))) |
| @@ -1163,7 +1159,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." | |||
| 1163 | (mpc-status-mode)) | 1159 | (mpc-status-mode)) |
| 1164 | (mpc-proc-buffer (mpc-proc) 'status buf)) | 1160 | (mpc-proc-buffer (mpc-proc) 'status buf)) |
| 1165 | (if (null songs-win) (pop-to-buffer buf) | 1161 | (if (null songs-win) (pop-to-buffer buf) |
| 1166 | (let ((win (split-window songs-win 20 t))) | 1162 | (let ((_win (split-window songs-win 20 t))) |
| 1167 | (set-window-dedicated-p songs-win nil) | 1163 | (set-window-dedicated-p songs-win nil) |
| 1168 | (set-window-buffer songs-win buf) | 1164 | (set-window-buffer songs-win buf) |
| 1169 | (set-window-dedicated-p songs-win 'soft))))) | 1165 | (set-window-dedicated-p songs-win 'soft))))) |
| @@ -2351,8 +2347,7 @@ This is used so that they can be compared with `eq', which is needed for | |||
| 2351 | (mpc-proc-cmd (list "seekid" songid time) | 2347 | (mpc-proc-cmd (list "seekid" songid time) |
| 2352 | 'mpc-status-refresh)))) | 2348 | 'mpc-status-refresh)))) |
| 2353 | (let ((status (mpc-cmd-status))) | 2349 | (let ((status (mpc-cmd-status))) |
| 2354 | (lexical-let* ((songid (cdr (assq 'songid status))) | 2350 | (let* ((songid (cdr (assq 'songid status))) |
| 2355 | (step step) | ||
| 2356 | (time (if songid (string-to-number | 2351 | (time (if songid (string-to-number |
| 2357 | (cdr (assq 'time status)))))) | 2352 | (cdr (assq 'time status)))))) |
| 2358 | (let ((timer (run-with-timer | 2353 | (let ((timer (run-with-timer |
| @@ -2389,17 +2384,14 @@ This is used so that they can be compared with `eq', which is needed for | |||
| 2389 | (if mpc--faster-toggle-timer | 2384 | (if mpc--faster-toggle-timer |
| 2390 | (mpc--faster-stop) | 2385 | (mpc--faster-stop) |
| 2391 | (mpc-status-refresh) (mpc-proc-sync) | 2386 | (mpc-status-refresh) (mpc-proc-sync) |
| 2392 | (lexical-let* ((speedup speedup) | 2387 | (let* (songid ;The ID of the currently ffwd/rewinding song. |
| 2393 | songid ;The ID of the currently ffwd/rewinding song. | 2388 | songduration ;The duration of that song. |
| 2394 | songnb ;The position of that song in the playlist. | 2389 | songtime ;The time of the song last time we ran. |
| 2395 | songduration ;The duration of that song. | 2390 | oldtime ;The timeoftheday last time we ran. |
| 2396 | songtime ;The time of the song last time we ran. | 2391 | prevsongid) ;The song we're in the process leaving. |
| 2397 | oldtime ;The timeoftheday last time we ran. | ||
| 2398 | prevsongid) ;The song we're in the process leaving. | ||
| 2399 | (let ((fun | 2392 | (let ((fun |
| 2400 | (lambda () | 2393 | (lambda () |
| 2401 | (let ((newsongid (cdr (assq 'songid mpc-status))) | 2394 | (let ((newsongid (cdr (assq 'songid mpc-status)))) |
| 2402 | (newsongnb (cdr (assq 'song mpc-status)))) | ||
| 2403 | 2395 | ||
| 2404 | (if (and (equal prevsongid newsongid) | 2396 | (if (and (equal prevsongid newsongid) |
| 2405 | (not (equal prevsongid songid))) | 2397 | (not (equal prevsongid songid))) |
| @@ -2450,8 +2442,7 @@ This is used so that they can be compared with `eq', which is needed for | |||
| 2450 | (mpc-proc-cmd | 2442 | (mpc-proc-cmd |
| 2451 | (list "seekid" songid songtime) | 2443 | (list "seekid" songid songtime) |
| 2452 | 'mpc-status-refresh) | 2444 | 'mpc-status-refresh) |
| 2453 | (mpc-proc-error (mpc-status-refresh))))))) | 2445 | (mpc-proc-error (mpc-status-refresh))))))))))) |
| 2454 | (setq songnb newsongnb))))) | ||
| 2455 | (setq mpc--faster-toggle-forward (> step 0)) | 2446 | (setq mpc--faster-toggle-forward (> step 0)) |
| 2456 | (funcall fun) ;Initialize values. | 2447 | (funcall fun) ;Initialize values. |
| 2457 | (setq mpc--faster-toggle-timer | 2448 | (setq mpc--faster-toggle-timer |
| @@ -2461,13 +2452,13 @@ This is used so that they can be compared with `eq', which is needed for | |||
| 2461 | 2452 | ||
| 2462 | (defvar mpc-faster-speedup 8) | 2453 | (defvar mpc-faster-speedup 8) |
| 2463 | 2454 | ||
| 2464 | (defun mpc-ffwd (event) | 2455 | (defun mpc-ffwd (_event) |
| 2465 | "Fast forward." | 2456 | "Fast forward." |
| 2466 | (interactive (list last-nonmenu-event)) | 2457 | (interactive (list last-nonmenu-event)) |
| 2467 | ;; (mpc--faster event 4.0 1) | 2458 | ;; (mpc--faster event 4.0 1) |
| 2468 | (mpc--faster-toggle mpc-faster-speedup 1)) | 2459 | (mpc--faster-toggle mpc-faster-speedup 1)) |
| 2469 | 2460 | ||
| 2470 | (defun mpc-rewind (event) | 2461 | (defun mpc-rewind (_event) |
| 2471 | "Fast rewind." | 2462 | "Fast rewind." |
| 2472 | (interactive (list last-nonmenu-event)) | 2463 | (interactive (list last-nonmenu-event)) |
| 2473 | ;; (mpc--faster event 4.0 -1) | 2464 | ;; (mpc--faster event 4.0 -1) |
diff --git a/lisp/newcomment.el b/lisp/newcomment.el index d88b76a7759..d3530b1be3e 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; newcomment.el --- (un)comment regions of buffers | 1 | ;;; newcomment.el --- (un)comment regions of buffers -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -722,7 +722,7 @@ With any other arg, set comment column to indentation of the previous comment | |||
| 722 | With prefix ARG, kill comments on that many lines starting with this one." | 722 | With prefix ARG, kill comments on that many lines starting with this one." |
| 723 | (interactive "P") | 723 | (interactive "P") |
| 724 | (comment-normalize-vars) | 724 | (comment-normalize-vars) |
| 725 | (dotimes (_ (prefix-numeric-value arg)) | 725 | (dotimes (i (prefix-numeric-value arg)) |
| 726 | (save-excursion | 726 | (save-excursion |
| 727 | (beginning-of-line) | 727 | (beginning-of-line) |
| 728 | (let ((cs (comment-search-forward (line-end-position) t))) | 728 | (let ((cs (comment-search-forward (line-end-position) t))) |
diff --git a/lisp/reveal.el b/lisp/reveal.el index 574c86a0fa4..bf18602379c 100644 --- a/lisp/reveal.el +++ b/lisp/reveal.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; reveal.el --- Automatically reveal hidden text at point | 1 | ;;; reveal.el --- Automatically reveal hidden text at point -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2000-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2000-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
diff --git a/lisp/server.el b/lisp/server.el index cb1903ad96c..ce14f133f0a 100644 --- a/lisp/server.el +++ b/lisp/server.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; server.el --- Lisp code for GNU Emacs running as server process | 1 | ;;; server.el --- Lisp code for GNU Emacs running as server process -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1986-1987, 1992, 1994-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1986-1987, 1992, 1994-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -335,9 +335,9 @@ If CLIENT is non-nil, add a description of it to the logged message." | |||
| 335 | (goto-char (point-max)) | 335 | (goto-char (point-max)) |
| 336 | (insert (funcall server-log-time-function) | 336 | (insert (funcall server-log-time-function) |
| 337 | (cond | 337 | (cond |
| 338 | ((null client) " ") | 338 | ((null client) " ") |
| 339 | ((listp client) (format " %s: " (car client))) | 339 | ((listp client) (format " %s: " (car client))) |
| 340 | (t (format " %s: " client))) | 340 | (t (format " %s: " client))) |
| 341 | string) | 341 | string) |
| 342 | (or (bolp) (newline))))) | 342 | (or (bolp) (newline))))) |
| 343 | 343 | ||
| @@ -355,7 +355,7 @@ If CLIENT is non-nil, add a description of it to the logged message." | |||
| 355 | (and (process-contact proc :server) | 355 | (and (process-contact proc :server) |
| 356 | (eq (process-status proc) 'closed) | 356 | (eq (process-status proc) 'closed) |
| 357 | (ignore-errors | 357 | (ignore-errors |
| 358 | (delete-file (process-get proc :server-file)))) | 358 | (delete-file (process-get proc :server-file)))) |
| 359 | (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc) | 359 | (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc) |
| 360 | (server-delete-client proc)) | 360 | (server-delete-client proc)) |
| 361 | 361 | ||
| @@ -410,18 +410,19 @@ If CLIENT is non-nil, add a description of it to the logged message." | |||
| 410 | proc | 410 | proc |
| 411 | ;; See if this is the last frame for this client. | 411 | ;; See if this is the last frame for this client. |
| 412 | (>= 1 (let ((frame-num 0)) | 412 | (>= 1 (let ((frame-num 0)) |
| 413 | (dolist (f (frame-list)) | 413 | (dolist (f (frame-list)) |
| 414 | (when (eq proc (frame-parameter f 'client)) | 414 | (when (eq proc (frame-parameter f 'client)) |
| 415 | (setq frame-num (1+ frame-num)))) | 415 | (setq frame-num (1+ frame-num)))) |
| 416 | frame-num))) | 416 | frame-num))) |
| 417 | (server-log (format "server-handle-delete-frame, frame %s" frame) proc) | 417 | (server-log (format "server-handle-delete-frame, frame %s" frame) proc) |
| 418 | (server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later. | 418 | (server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later. |
| 419 | 419 | ||
| 420 | (defun server-handle-suspend-tty (terminal) | 420 | (defun server-handle-suspend-tty (terminal) |
| 421 | "Notify the emacsclient process to suspend itself when its tty device is suspended." | 421 | "Notify the client process that its tty device is suspended." |
| 422 | (dolist (proc (server-clients-with 'terminal terminal)) | 422 | (dolist (proc (server-clients-with 'terminal terminal)) |
| 423 | (server-log (format "server-handle-suspend-tty, terminal %s" terminal) proc) | 423 | (server-log (format "server-handle-suspend-tty, terminal %s" terminal) |
| 424 | (condition-case err | 424 | proc) |
| 425 | (condition-case nil | ||
| 425 | (server-send-string proc "-suspend \n") | 426 | (server-send-string proc "-suspend \n") |
| 426 | (file-error ;The pipe/socket was closed. | 427 | (file-error ;The pipe/socket was closed. |
| 427 | (ignore-errors (server-delete-client proc)))))) | 428 | (ignore-errors (server-delete-client proc)))))) |
| @@ -540,8 +541,8 @@ To force-start a server, do \\[server-force-delete] and then | |||
| 540 | (if (not (eq t (server-running-p server-name))) | 541 | (if (not (eq t (server-running-p server-name))) |
| 541 | ;; Remove any leftover socket or authentication file | 542 | ;; Remove any leftover socket or authentication file |
| 542 | (ignore-errors | 543 | (ignore-errors |
| 543 | (let (delete-by-moving-to-trash) | 544 | (let (delete-by-moving-to-trash) |
| 544 | (delete-file server-file))) | 545 | (delete-file server-file))) |
| 545 | (setq server-mode nil) ;; already set by the minor mode code | 546 | (setq server-mode nil) ;; already set by the minor mode code |
| 546 | (display-warning | 547 | (display-warning |
| 547 | 'server | 548 | 'server |
| @@ -596,11 +597,11 @@ server or call `M-x server-force-delete' to forcibly disconnect it.") | |||
| 596 | (when server-use-tcp | 597 | (when server-use-tcp |
| 597 | (let ((auth-key | 598 | (let ((auth-key |
| 598 | (loop | 599 | (loop |
| 599 | ;; The auth key is a 64-byte string of random chars in the | 600 | ;; The auth key is a 64-byte string of random chars in the |
| 600 | ;; range `!'..`~'. | 601 | ;; range `!'..`~'. |
| 601 | repeat 64 | 602 | repeat 64 |
| 602 | collect (+ 33 (random 94)) into auth | 603 | collect (+ 33 (random 94)) into auth |
| 603 | finally return (concat auth)))) | 604 | finally return (concat auth)))) |
| 604 | (process-put server-process :auth-key auth-key) | 605 | (process-put server-process :auth-key auth-key) |
| 605 | (with-temp-file server-file | 606 | (with-temp-file server-file |
| 606 | (set-buffer-multibyte nil) | 607 | (set-buffer-multibyte nil) |
| @@ -695,31 +696,31 @@ Server mode runs a process that accepts commands from the | |||
| 695 | (add-to-list 'frame-inherited-parameters 'client) | 696 | (add-to-list 'frame-inherited-parameters 'client) |
| 696 | (let ((frame | 697 | (let ((frame |
| 697 | (server-with-environment (process-get proc 'env) | 698 | (server-with-environment (process-get proc 'env) |
| 698 | '("LANG" "LC_CTYPE" "LC_ALL" | 699 | '("LANG" "LC_CTYPE" "LC_ALL" |
| 699 | ;; For tgetent(3); list according to ncurses(3). | 700 | ;; For tgetent(3); list according to ncurses(3). |
| 700 | "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES" | 701 | "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES" |
| 701 | "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING" | 702 | "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING" |
| 702 | "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO" | 703 | "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO" |
| 703 | "TERMINFO_DIRS" "TERMPATH" | 704 | "TERMINFO_DIRS" "TERMPATH" |
| 704 | ;; rxvt wants these | 705 | ;; rxvt wants these |
| 705 | "COLORFGBG" "COLORTERM") | 706 | "COLORFGBG" "COLORTERM") |
| 706 | (make-frame `((window-system . nil) | 707 | (make-frame `((window-system . nil) |
| 707 | (tty . ,tty) | 708 | (tty . ,tty) |
| 708 | (tty-type . ,type) | 709 | (tty-type . ,type) |
| 709 | ;; Ignore nowait here; we always need to | 710 | ;; Ignore nowait here; we always need to |
| 710 | ;; clean up opened ttys when the client dies. | 711 | ;; clean up opened ttys when the client dies. |
| 711 | (client . ,proc) | 712 | (client . ,proc) |
| 712 | ;; This is a leftover from an earlier | 713 | ;; This is a leftover from an earlier |
| 713 | ;; attempt at making it possible for process | 714 | ;; attempt at making it possible for process |
| 714 | ;; run in the server process to use the | 715 | ;; run in the server process to use the |
| 715 | ;; environment of the client process. | 716 | ;; environment of the client process. |
| 716 | ;; It has no effect now and to make it work | 717 | ;; It has no effect now and to make it work |
| 717 | ;; we'd need to decide how to make | 718 | ;; we'd need to decide how to make |
| 718 | ;; process-environment interact with client | 719 | ;; process-environment interact with client |
| 719 | ;; envvars, and then to change the | 720 | ;; envvars, and then to change the |
| 720 | ;; C functions `child_setup' and | 721 | ;; C functions `child_setup' and |
| 721 | ;; `getenv_internal' accordingly. | 722 | ;; `getenv_internal' accordingly. |
| 722 | (environment . ,(process-get proc 'env))))))) | 723 | (environment . ,(process-get proc 'env))))))) |
| 723 | 724 | ||
| 724 | ;; ttys don't use the `display' parameter, but callproc.c does to set | 725 | ;; ttys don't use the `display' parameter, but callproc.c does to set |
| 725 | ;; the DISPLAY environment on subprocesses. | 726 | ;; the DISPLAY environment on subprocesses. |
| @@ -783,8 +784,7 @@ Server mode runs a process that accepts commands from the | |||
| 783 | ;; frame because input from that display will be blocked (until exiting | 784 | ;; frame because input from that display will be blocked (until exiting |
| 784 | ;; the minibuffer). Better exit this minibuffer right away. | 785 | ;; the minibuffer). Better exit this minibuffer right away. |
| 785 | ;; Similarly with recursive-edits such as the splash screen. | 786 | ;; Similarly with recursive-edits such as the splash screen. |
| 786 | (run-with-timer 0 nil (lexical-let ((proc proc)) | 787 | (run-with-timer 0 nil (lambda () (server-execute-continuation proc))) |
| 787 | (lambda () (server-execute-continuation proc)))) | ||
| 788 | (top-level))) | 788 | (top-level))) |
| 789 | 789 | ||
| 790 | ;; We use various special properties on process objects: | 790 | ;; We use various special properties on process objects: |
| @@ -978,7 +978,7 @@ The following commands are accepted by the client: | |||
| 978 | 978 | ||
| 979 | ;; -resume: Resume a suspended tty frame. | 979 | ;; -resume: Resume a suspended tty frame. |
| 980 | (`"-resume" | 980 | (`"-resume" |
| 981 | (lexical-let ((terminal (process-get proc 'terminal))) | 981 | (let ((terminal (process-get proc 'terminal))) |
| 982 | (setq dontkill t) | 982 | (setq dontkill t) |
| 983 | (push (lambda () | 983 | (push (lambda () |
| 984 | (when (eq (terminal-live-p terminal) t) | 984 | (when (eq (terminal-live-p terminal) t) |
| @@ -989,7 +989,7 @@ The following commands are accepted by the client: | |||
| 989 | ;; get out of sync, and a C-z sends a SIGTSTP to | 989 | ;; get out of sync, and a C-z sends a SIGTSTP to |
| 990 | ;; emacsclient.) | 990 | ;; emacsclient.) |
| 991 | (`"-suspend" | 991 | (`"-suspend" |
| 992 | (lexical-let ((terminal (process-get proc 'terminal))) | 992 | (let ((terminal (process-get proc 'terminal))) |
| 993 | (setq dontkill t) | 993 | (setq dontkill t) |
| 994 | (push (lambda () | 994 | (push (lambda () |
| 995 | (when (eq (terminal-live-p terminal) t) | 995 | (when (eq (terminal-live-p terminal) t) |
| @@ -1036,7 +1036,7 @@ The following commands are accepted by the client: | |||
| 1036 | (`"-eval" | 1036 | (`"-eval" |
| 1037 | (if use-current-frame | 1037 | (if use-current-frame |
| 1038 | (setq use-current-frame 'always)) | 1038 | (setq use-current-frame 'always)) |
| 1039 | (lexical-let ((expr (pop args-left))) | 1039 | (let ((expr (pop args-left))) |
| 1040 | (if coding-system | 1040 | (if coding-system |
| 1041 | (setq expr (decode-coding-string expr coding-system))) | 1041 | (setq expr (decode-coding-string expr coding-system))) |
| 1042 | (push (lambda () (server-eval-and-print expr proc)) | 1042 | (push (lambda () (server-eval-and-print expr proc)) |
| @@ -1081,23 +1081,15 @@ The following commands are accepted by the client: | |||
| 1081 | 1081 | ||
| 1082 | (process-put | 1082 | (process-put |
| 1083 | proc 'continuation | 1083 | proc 'continuation |
| 1084 | (lexical-let ((proc proc) | 1084 | (lambda () |
| 1085 | (files files) | 1085 | (with-current-buffer (get-buffer-create server-buffer) |
| 1086 | (nowait nowait) | 1086 | ;; Use the same cwd as the emacsclient, if possible, so |
| 1087 | (commands commands) | 1087 | ;; relative file names work correctly, even in `eval'. |
| 1088 | (dontkill dontkill) | 1088 | (let ((default-directory |
| 1089 | (frame frame) | 1089 | (if (and dir (file-directory-p dir)) |
| 1090 | (dir dir) | 1090 | dir default-directory))) |
| 1091 | (tty-name tty-name)) | 1091 | (server-execute proc files nowait commands |
| 1092 | (lambda () | 1092 | dontkill frame tty-name))))) |
| 1093 | (with-current-buffer (get-buffer-create server-buffer) | ||
| 1094 | ;; Use the same cwd as the emacsclient, if possible, so | ||
| 1095 | ;; relative file names work correctly, even in `eval'. | ||
| 1096 | (let ((default-directory | ||
| 1097 | (if (and dir (file-directory-p dir)) | ||
| 1098 | dir default-directory))) | ||
| 1099 | (server-execute proc files nowait commands | ||
| 1100 | dontkill frame tty-name)))))) | ||
| 1101 | 1093 | ||
| 1102 | (when (or frame files) | 1094 | (when (or frame files) |
| 1103 | (server-goto-toplevel proc)) | 1095 | (server-goto-toplevel proc)) |
| @@ -1222,7 +1214,10 @@ so don't mark these buffers specially, just visit them normally." | |||
| 1222 | (process-put proc 'buffers | 1214 | (process-put proc 'buffers |
| 1223 | (nconc (process-get proc 'buffers) client-record))) | 1215 | (nconc (process-get proc 'buffers) client-record))) |
| 1224 | client-record)) | 1216 | client-record)) |
| 1225 | 1217 | ||
| 1218 | (defvar server-kill-buffer-running nil | ||
| 1219 | "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.") | ||
| 1220 | |||
| 1226 | (defun server-buffer-done (buffer &optional for-killing) | 1221 | (defun server-buffer-done (buffer &optional for-killing) |
| 1227 | "Mark BUFFER as \"done\" for its client(s). | 1222 | "Mark BUFFER as \"done\" for its client(s). |
| 1228 | This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED). | 1223 | This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED). |
| @@ -1344,9 +1339,6 @@ specifically for the clients and did not exist before their request for it." | |||
| 1344 | (setq live-client t)))) | 1339 | (setq live-client t)))) |
| 1345 | (yes-or-no-p "This Emacs session has clients; exit anyway? "))) | 1340 | (yes-or-no-p "This Emacs session has clients; exit anyway? "))) |
| 1346 | 1341 | ||
| 1347 | (defvar server-kill-buffer-running nil | ||
| 1348 | "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.") | ||
| 1349 | |||
| 1350 | (defun server-kill-buffer () | 1342 | (defun server-kill-buffer () |
| 1351 | "Remove the current buffer from its clients' buffer list. | 1343 | "Remove the current buffer from its clients' buffer list. |
| 1352 | Designed to be added to `kill-buffer-hook'." | 1344 | Designed to be added to `kill-buffer-hook'." |
| @@ -1374,12 +1366,12 @@ If invoked with a prefix argument, or if there is no server process running, | |||
| 1374 | starts server process and that is all. Invoked by \\[server-edit]." | 1366 | starts server process and that is all. Invoked by \\[server-edit]." |
| 1375 | (interactive "P") | 1367 | (interactive "P") |
| 1376 | (cond | 1368 | (cond |
| 1377 | ((or arg | 1369 | ((or arg |
| 1378 | (not server-process) | 1370 | (not server-process) |
| 1379 | (memq (process-status server-process) '(signal exit))) | 1371 | (memq (process-status server-process) '(signal exit))) |
| 1380 | (server-mode 1)) | 1372 | (server-mode 1)) |
| 1381 | (server-clients (apply 'server-switch-buffer (server-done))) | 1373 | (server-clients (apply 'server-switch-buffer (server-done))) |
| 1382 | (t (message "No server editing buffers exist")))) | 1374 | (t (message "No server editing buffers exist")))) |
| 1383 | 1375 | ||
| 1384 | (defun server-switch-buffer (&optional next-buffer killed-one filepos) | 1376 | (defun server-switch-buffer (&optional next-buffer killed-one filepos) |
| 1385 | "Switch to another buffer, preferably one that has a client. | 1377 | "Switch to another buffer, preferably one that has a client. |
diff --git a/lisp/simple.el b/lisp/simple.el index bd7d5da257e..a414fc77a39 100644 --- a/lisp/simple.el +++ b/lisp/simple.el | |||
| @@ -28,8 +28,7 @@ | |||
| 28 | 28 | ||
| 29 | ;;; Code: | 29 | ;;; Code: |
| 30 | 30 | ||
| 31 | ;; This is for lexical-let in apply-partially. | 31 | (eval-when-compile (require 'cl)) ;For define-minor-mode. |
| 32 | (eval-when-compile (require 'cl)) | ||
| 33 | 32 | ||
| 34 | (declare-function widget-convert "wid-edit" (type &rest args)) | 33 | (declare-function widget-convert "wid-edit" (type &rest args)) |
| 35 | (declare-function shell-mode "shell" ()) | 34 | (declare-function shell-mode "shell" ()) |
| @@ -1000,7 +999,7 @@ When called interactively, the word count is printed in echo area." | |||
| 1000 | (goto-char (point-min)) | 999 | (goto-char (point-min)) |
| 1001 | (while (forward-word 1) | 1000 | (while (forward-word 1) |
| 1002 | (setq count (1+ count))))) | 1001 | (setq count (1+ count))))) |
| 1003 | (if (interactive-p) | 1002 | (if (called-interactively-p 'interactive) |
| 1004 | (message "Region has %d words" count)) | 1003 | (message "Region has %d words" count)) |
| 1005 | count)) | 1004 | count)) |
| 1006 | 1005 | ||
| @@ -1220,12 +1219,12 @@ this command arranges for all errors to enter the debugger." | |||
| 1220 | current-prefix-arg)) | 1219 | current-prefix-arg)) |
| 1221 | 1220 | ||
| 1222 | (if (null eval-expression-debug-on-error) | 1221 | (if (null eval-expression-debug-on-error) |
| 1223 | (setq values (cons (eval eval-expression-arg) values)) | 1222 | (push (eval eval-expression-arg lexical-binding) values) |
| 1224 | (let ((old-value (make-symbol "t")) new-value) | 1223 | (let ((old-value (make-symbol "t")) new-value) |
| 1225 | ;; Bind debug-on-error to something unique so that we can | 1224 | ;; Bind debug-on-error to something unique so that we can |
| 1226 | ;; detect when evaled code changes it. | 1225 | ;; detect when evaled code changes it. |
| 1227 | (let ((debug-on-error old-value)) | 1226 | (let ((debug-on-error old-value)) |
| 1228 | (setq values (cons (eval eval-expression-arg) values)) | 1227 | (push (eval eval-expression-arg lexical-binding) values) |
| 1229 | (setq new-value debug-on-error)) | 1228 | (setq new-value debug-on-error)) |
| 1230 | ;; If evaled code has changed the value of debug-on-error, | 1229 | ;; If evaled code has changed the value of debug-on-error, |
| 1231 | ;; propagate that change to the global binding. | 1230 | ;; propagate that change to the global binding. |
| @@ -2829,51 +2828,6 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]." | |||
| 2829 | (reset-this-command-lengths) | 2828 | (reset-this-command-lengths) |
| 2830 | (restore-overriding-map)) | 2829 | (restore-overriding-map)) |
| 2831 | 2830 | ||
| 2832 | ;; This function is here rather than in subr.el because it uses CL. | ||
| 2833 | (defmacro with-wrapper-hook (var args &rest body) | ||
| 2834 | "Run BODY wrapped with the VAR hook. | ||
| 2835 | VAR is a special hook: its functions are called with a first argument | ||
| 2836 | which is the \"original\" code (the BODY), so the hook function can wrap | ||
| 2837 | the original function, or call it any number of times (including not calling | ||
| 2838 | it at all). This is similar to an `around' advice. | ||
| 2839 | VAR is normally a symbol (a variable) in which case it is treated like | ||
| 2840 | a hook, with a buffer-local and a global part. But it can also be an | ||
| 2841 | arbitrary expression. | ||
| 2842 | ARGS is a list of variables which will be passed as additional arguments | ||
| 2843 | to each function, after the initial argument, and which the first argument | ||
| 2844 | expects to receive when called." | ||
| 2845 | (declare (indent 2) (debug t)) | ||
| 2846 | ;; We need those two gensyms because CL's lexical scoping is not available | ||
| 2847 | ;; for function arguments :-( | ||
| 2848 | (let ((funs (make-symbol "funs")) | ||
| 2849 | (global (make-symbol "global")) | ||
| 2850 | (argssym (make-symbol "args"))) | ||
| 2851 | ;; Since the hook is a wrapper, the loop has to be done via | ||
| 2852 | ;; recursion: a given hook function will call its parameter in order to | ||
| 2853 | ;; continue looping. | ||
| 2854 | `(labels ((runrestofhook (,funs ,global ,argssym) | ||
| 2855 | ;; `funs' holds the functions left on the hook and `global' | ||
| 2856 | ;; holds the functions left on the global part of the hook | ||
| 2857 | ;; (in case the hook is local). | ||
| 2858 | (lexical-let ((funs ,funs) | ||
| 2859 | (global ,global)) | ||
| 2860 | (if (consp funs) | ||
| 2861 | (if (eq t (car funs)) | ||
| 2862 | (runrestofhook | ||
| 2863 | (append global (cdr funs)) nil ,argssym) | ||
| 2864 | (apply (car funs) | ||
| 2865 | (lambda (&rest ,argssym) | ||
| 2866 | (runrestofhook (cdr funs) global ,argssym)) | ||
| 2867 | ,argssym)) | ||
| 2868 | ;; Once there are no more functions on the hook, run | ||
| 2869 | ;; the original body. | ||
| 2870 | (apply (lambda ,args ,@body) ,argssym))))) | ||
| 2871 | (runrestofhook ,var | ||
| 2872 | ;; The global part of the hook, if any. | ||
| 2873 | ,(if (symbolp var) | ||
| 2874 | `(if (local-variable-p ',var) | ||
| 2875 | (default-value ',var))) | ||
| 2876 | (list ,@args))))) | ||
| 2877 | 2831 | ||
| 2878 | (defvar filter-buffer-substring-functions nil | 2832 | (defvar filter-buffer-substring-functions nil |
| 2879 | "Wrapper hook around `filter-buffer-substring'. | 2833 | "Wrapper hook around `filter-buffer-substring'. |
| @@ -6652,37 +6606,25 @@ saving the value of `buffer-invisibility-spec' and setting it to nil." | |||
| 6652 | buffer-invisibility-spec) | 6606 | buffer-invisibility-spec) |
| 6653 | (setq buffer-invisibility-spec nil))) | 6607 | (setq buffer-invisibility-spec nil))) |
| 6654 | 6608 | ||
| 6655 | ;; Partial application of functions (similar to "currying"). | ||
| 6656 | ;; This function is here rather than in subr.el because it uses CL. | ||
| 6657 | (defun apply-partially (fun &rest args) | ||
| 6658 | "Return a function that is a partial application of FUN to ARGS. | ||
| 6659 | ARGS is a list of the first N arguments to pass to FUN. | ||
| 6660 | The result is a new function which does the same as FUN, except that | ||
| 6661 | the first N arguments are fixed at the values with which this function | ||
| 6662 | was called." | ||
| 6663 | (lexical-let ((fun fun) (args1 args)) | ||
| 6664 | (lambda (&rest args2) (apply fun (append args1 args2))))) | ||
| 6665 | |||
| 6666 | ;; Minibuffer prompt stuff. | 6609 | ;; Minibuffer prompt stuff. |
| 6667 | 6610 | ||
| 6668 | ;(defun minibuffer-prompt-modification (start end) | 6611 | ;;(defun minibuffer-prompt-modification (start end) |
| 6669 | ; (error "You cannot modify the prompt")) | 6612 | ;; (error "You cannot modify the prompt")) |
| 6670 | ; | 6613 | ;; |
| 6671 | ; | 6614 | ;; |
| 6672 | ;(defun minibuffer-prompt-insertion (start end) | 6615 | ;;(defun minibuffer-prompt-insertion (start end) |
| 6673 | ; (let ((inhibit-modification-hooks t)) | 6616 | ;; (let ((inhibit-modification-hooks t)) |
| 6674 | ; (delete-region start end) | 6617 | ;; (delete-region start end) |
| 6675 | ; ;; Discard undo information for the text insertion itself | 6618 | ;; ;; Discard undo information for the text insertion itself |
| 6676 | ; ;; and for the text deletion.above. | 6619 | ;; ;; and for the text deletion.above. |
| 6677 | ; (when (consp buffer-undo-list) | 6620 | ;; (when (consp buffer-undo-list) |
| 6678 | ; (setq buffer-undo-list (cddr buffer-undo-list))) | 6621 | ;; (setq buffer-undo-list (cddr buffer-undo-list))) |
| 6679 | ; (message "You cannot modify the prompt"))) | 6622 | ;; (message "You cannot modify the prompt"))) |
| 6680 | ; | 6623 | ;; |
| 6681 | ; | 6624 | ;; |
| 6682 | ;(setq minibuffer-prompt-properties | 6625 | ;;(setq minibuffer-prompt-properties |
| 6683 | ; (list 'modification-hooks '(minibuffer-prompt-modification) | 6626 | ;; (list 'modification-hooks '(minibuffer-prompt-modification) |
| 6684 | ; 'insert-in-front-hooks '(minibuffer-prompt-insertion))) | 6627 | ;; 'insert-in-front-hooks '(minibuffer-prompt-insertion))) |
| 6685 | ; | ||
| 6686 | 6628 | ||
| 6687 | 6629 | ||
| 6688 | ;;;; Problematic external packages. | 6630 | ;;;; Problematic external packages. |
diff --git a/lisp/startup.el b/lisp/startup.el index e8e85a41c77..d2184778212 100644 --- a/lisp/startup.el +++ b/lisp/startup.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; startup.el --- process Emacs shell arguments | 1 | ;;; startup.el --- process Emacs shell arguments -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1985-1986, 1992, 1994-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1985-1986, 1992, 1994-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -98,6 +98,7 @@ the remaining command-line args are in the variable `command-line-args-left'.") | |||
| 98 | "List of command-line args not yet processed.") | 98 | "List of command-line args not yet processed.") |
| 99 | 99 | ||
| 100 | (defvaralias 'argv 'command-line-args-left | 100 | (defvaralias 'argv 'command-line-args-left |
| 101 | ;; FIXME: Bad name for a dynamically bound variable. | ||
| 101 | "List of command-line args not yet processed. | 102 | "List of command-line args not yet processed. |
| 102 | This is a convenience alias, so that one can write \(pop argv\) | 103 | This is a convenience alias, so that one can write \(pop argv\) |
| 103 | inside of --eval command line arguments in order to access | 104 | inside of --eval command line arguments in order to access |
| @@ -326,7 +327,7 @@ this variable usefully is to set it while building and dumping Emacs." | |||
| 326 | :type '(choice (const :tag "none" nil) string) | 327 | :type '(choice (const :tag "none" nil) string) |
| 327 | :group 'initialization | 328 | :group 'initialization |
| 328 | :initialize 'custom-initialize-default | 329 | :initialize 'custom-initialize-default |
| 329 | :set (lambda (variable value) | 330 | :set (lambda (_variable _value) |
| 330 | (error "Customizing `site-run-file' does not work"))) | 331 | (error "Customizing `site-run-file' does not work"))) |
| 331 | 332 | ||
| 332 | (defcustom mail-host-address nil | 333 | (defcustom mail-host-address nil |
| @@ -1095,7 +1096,8 @@ the `--debug-init' option to view a complete error backtrace." | |||
| 1095 | user-init-file | 1096 | user-init-file |
| 1096 | (get (car error) 'error-message) | 1097 | (get (car error) 'error-message) |
| 1097 | (if (cdr error) ": " "") | 1098 | (if (cdr error) ": " "") |
| 1098 | (mapconcat (lambda (s) (prin1-to-string s t)) (cdr error) ", ")) | 1099 | (mapconcat (lambda (s) (prin1-to-string s t)) |
| 1100 | (cdr error) ", ")) | ||
| 1099 | :warning) | 1101 | :warning) |
| 1100 | (setq init-file-had-error t)))) | 1102 | (setq init-file-had-error t)))) |
| 1101 | 1103 | ||
| @@ -1291,25 +1293,25 @@ If this is nil, no message will be displayed." | |||
| 1291 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | 1293 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 1292 | 1294 | ||
| 1293 | (defconst fancy-startup-text | 1295 | (defconst fancy-startup-text |
| 1294 | '((:face (variable-pitch (:foreground "red")) | 1296 | `((:face (variable-pitch (:foreground "red")) |
| 1295 | "Welcome to " | 1297 | "Welcome to " |
| 1296 | :link ("GNU Emacs" | 1298 | :link ("GNU Emacs" |
| 1297 | (lambda (button) (browse-url "http://www.gnu.org/software/emacs/")) | 1299 | ,(lambda (_button) (browse-url "http://www.gnu.org/software/emacs/")) |
| 1298 | "Browse http://www.gnu.org/software/emacs/") | 1300 | "Browse http://www.gnu.org/software/emacs/") |
| 1299 | ", one component of the " | 1301 | ", one component of the " |
| 1300 | :link | 1302 | :link |
| 1301 | (lambda () | 1303 | ,(lambda () |
| 1302 | (if (eq system-type 'gnu/linux) | 1304 | (if (eq system-type 'gnu/linux) |
| 1303 | '("GNU/Linux" | 1305 | `("GNU/Linux" |
| 1304 | (lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html")) | 1306 | ,(lambda (_button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html")) |
| 1305 | "Browse http://www.gnu.org/gnu/linux-and-gnu.html") | 1307 | "Browse http://www.gnu.org/gnu/linux-and-gnu.html") |
| 1306 | '("GNU" (lambda (button) (describe-gnu-project)) | 1308 | `("GNU" ,(lambda (_button) (describe-gnu-project)) |
| 1307 | "Display info on the GNU project"))) | 1309 | "Display info on the GNU project"))) |
| 1308 | " operating system.\n\n" | 1310 | " operating system.\n\n" |
| 1309 | :face variable-pitch | 1311 | :face variable-pitch |
| 1310 | :link ("Emacs Tutorial" (lambda (button) (help-with-tutorial))) | 1312 | :link ("Emacs Tutorial" ,(lambda (_button) (help-with-tutorial))) |
| 1311 | "\tLearn basic keystroke commands" | 1313 | "\tLearn basic keystroke commands" |
| 1312 | (lambda () | 1314 | ,(lambda () |
| 1313 | (let* ((en "TUTORIAL") | 1315 | (let* ((en "TUTORIAL") |
| 1314 | (tut (or (get-language-info current-language-environment | 1316 | (tut (or (get-language-info current-language-environment |
| 1315 | 'tutorial) | 1317 | 'tutorial) |
| @@ -1327,19 +1329,20 @@ If this is nil, no message will be displayed." | |||
| 1327 | (concat " (" title ")")))) | 1329 | (concat " (" title ")")))) |
| 1328 | "\n" | 1330 | "\n" |
| 1329 | :link ("Emacs Guided Tour" | 1331 | :link ("Emacs Guided Tour" |
| 1330 | (lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/")) | 1332 | ,(lambda (_button) |
| 1333 | (browse-url "http://www.gnu.org/software/emacs/tour/")) | ||
| 1331 | "Browse http://www.gnu.org/software/emacs/tour/") | 1334 | "Browse http://www.gnu.org/software/emacs/tour/") |
| 1332 | "\tOverview of Emacs features at gnu.org\n" | 1335 | "\tOverview of Emacs features at gnu.org\n" |
| 1333 | :link ("View Emacs Manual" (lambda (button) (info-emacs-manual))) | 1336 | :link ("View Emacs Manual" ,(lambda (_button) (info-emacs-manual))) |
| 1334 | "\tView the Emacs manual using Info\n" | 1337 | "\tView the Emacs manual using Info\n" |
| 1335 | :link ("Absence of Warranty" (lambda (button) (describe-no-warranty))) | 1338 | :link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty))) |
| 1336 | "\tGNU Emacs comes with " | 1339 | "\tGNU Emacs comes with " |
| 1337 | :face (variable-pitch (:slant oblique)) | 1340 | :face (variable-pitch (:slant oblique)) |
| 1338 | "ABSOLUTELY NO WARRANTY\n" | 1341 | "ABSOLUTELY NO WARRANTY\n" |
| 1339 | :face variable-pitch | 1342 | :face variable-pitch |
| 1340 | :link ("Copying Conditions" (lambda (button) (describe-copying))) | 1343 | :link ("Copying Conditions" ,(lambda (_button) (describe-copying))) |
| 1341 | "\tConditions for redistributing and changing Emacs\n" | 1344 | "\tConditions for redistributing and changing Emacs\n" |
| 1342 | :link ("Ordering Manuals" (lambda (button) (view-order-manuals))) | 1345 | :link ("Ordering Manuals" ,(lambda (_button) (view-order-manuals))) |
| 1343 | "\tPurchasing printed copies of manuals\n" | 1346 | "\tPurchasing printed copies of manuals\n" |
| 1344 | "\n")) | 1347 | "\n")) |
| 1345 | "A list of texts to show in the middle part of splash screens. | 1348 | "A list of texts to show in the middle part of splash screens. |
| @@ -1347,61 +1350,62 @@ Each element in the list should be a list of strings or pairs | |||
| 1347 | `:face FACE', like `fancy-splash-insert' accepts them.") | 1350 | `:face FACE', like `fancy-splash-insert' accepts them.") |
| 1348 | 1351 | ||
| 1349 | (defconst fancy-about-text | 1352 | (defconst fancy-about-text |
| 1350 | '((:face (variable-pitch (:foreground "red")) | 1353 | `((:face (variable-pitch (:foreground "red")) |
| 1351 | "This is " | 1354 | "This is " |
| 1352 | :link ("GNU Emacs" | 1355 | :link ("GNU Emacs" |
| 1353 | (lambda (button) (browse-url "http://www.gnu.org/software/emacs/")) | 1356 | ,(lambda (_button) (browse-url "http://www.gnu.org/software/emacs/")) |
| 1354 | "Browse http://www.gnu.org/software/emacs/") | 1357 | "Browse http://www.gnu.org/software/emacs/") |
| 1355 | ", one component of the " | 1358 | ", one component of the " |
| 1356 | :link | 1359 | :link |
| 1357 | (lambda () | 1360 | ,(lambda () |
| 1358 | (if (eq system-type 'gnu/linux) | 1361 | (if (eq system-type 'gnu/linux) |
| 1359 | '("GNU/Linux" | 1362 | `("GNU/Linux" |
| 1360 | (lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html")) | 1363 | ,(lambda (_button) |
| 1364 | (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html")) | ||
| 1361 | "Browse http://www.gnu.org/gnu/linux-and-gnu.html") | 1365 | "Browse http://www.gnu.org/gnu/linux-and-gnu.html") |
| 1362 | '("GNU" (lambda (button) (describe-gnu-project)) | 1366 | `("GNU" ,(lambda (_button) (describe-gnu-project)) |
| 1363 | "Display info on the GNU project."))) | 1367 | "Display info on the GNU project."))) |
| 1364 | " operating system.\n" | 1368 | " operating system.\n" |
| 1365 | :face (lambda () | 1369 | :face ,(lambda () |
| 1366 | (list 'variable-pitch | 1370 | (list 'variable-pitch |
| 1367 | (list :foreground | 1371 | (list :foreground |
| 1368 | (if (eq (frame-parameter nil 'background-mode) 'dark) | 1372 | (if (eq (frame-parameter nil 'background-mode) 'dark) |
| 1369 | "cyan" "darkblue")))) | 1373 | "cyan" "darkblue")))) |
| 1370 | "\n" | 1374 | "\n" |
| 1371 | (lambda () (emacs-version)) | 1375 | ,(lambda () (emacs-version)) |
| 1372 | "\n" | 1376 | "\n" |
| 1373 | :face (variable-pitch (:height 0.8)) | 1377 | :face (variable-pitch (:height 0.8)) |
| 1374 | (lambda () emacs-copyright) | 1378 | ,(lambda () emacs-copyright) |
| 1375 | "\n\n" | 1379 | "\n\n" |
| 1376 | :face variable-pitch | 1380 | :face variable-pitch |
| 1377 | :link ("Authors" | 1381 | :link ("Authors" |
| 1378 | (lambda (button) | 1382 | ,(lambda (_button) |
| 1379 | (view-file (expand-file-name "AUTHORS" data-directory)) | 1383 | (view-file (expand-file-name "AUTHORS" data-directory)) |
| 1380 | (goto-char (point-min)))) | 1384 | (goto-char (point-min)))) |
| 1381 | "\tMany people have contributed code included in GNU Emacs\n" | 1385 | "\tMany people have contributed code included in GNU Emacs\n" |
| 1382 | :link ("Contributing" | 1386 | :link ("Contributing" |
| 1383 | (lambda (button) | 1387 | ,(lambda (_button) |
| 1384 | (view-file (expand-file-name "CONTRIBUTE" data-directory)) | 1388 | (view-file (expand-file-name "CONTRIBUTE" data-directory)) |
| 1385 | (goto-char (point-min)))) | 1389 | (goto-char (point-min)))) |
| 1386 | "\tHow to contribute improvements to Emacs\n" | 1390 | "\tHow to contribute improvements to Emacs\n" |
| 1387 | "\n" | 1391 | "\n" |
| 1388 | :link ("GNU and Freedom" (lambda (button) (describe-gnu-project))) | 1392 | :link ("GNU and Freedom" ,(lambda (_button) (describe-gnu-project))) |
| 1389 | "\tWhy we developed GNU Emacs, and the GNU operating system\n" | 1393 | "\tWhy we developed GNU Emacs, and the GNU operating system\n" |
| 1390 | :link ("Absence of Warranty" (lambda (button) (describe-no-warranty))) | 1394 | :link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty))) |
| 1391 | "\tGNU Emacs comes with " | 1395 | "\tGNU Emacs comes with " |
| 1392 | :face (variable-pitch (:slant oblique)) | 1396 | :face (variable-pitch (:slant oblique)) |
| 1393 | "ABSOLUTELY NO WARRANTY\n" | 1397 | "ABSOLUTELY NO WARRANTY\n" |
| 1394 | :face variable-pitch | 1398 | :face variable-pitch |
| 1395 | :link ("Copying Conditions" (lambda (button) (describe-copying))) | 1399 | :link ("Copying Conditions" ,(lambda (_button) (describe-copying))) |
| 1396 | "\tConditions for redistributing and changing Emacs\n" | 1400 | "\tConditions for redistributing and changing Emacs\n" |
| 1397 | :link ("Getting New Versions" (lambda (button) (describe-distribution))) | 1401 | :link ("Getting New Versions" ,(lambda (_button) (describe-distribution))) |
| 1398 | "\tHow to obtain the latest version of Emacs\n" | 1402 | "\tHow to obtain the latest version of Emacs\n" |
| 1399 | :link ("Ordering Manuals" (lambda (button) (view-order-manuals))) | 1403 | :link ("Ordering Manuals" ,(lambda (_button) (view-order-manuals))) |
| 1400 | "\tBuying printed manuals from the FSF\n" | 1404 | "\tBuying printed manuals from the FSF\n" |
| 1401 | "\n" | 1405 | "\n" |
| 1402 | :link ("Emacs Tutorial" (lambda (button) (help-with-tutorial))) | 1406 | :link ("Emacs Tutorial" ,(lambda (_button) (help-with-tutorial))) |
| 1403 | "\tLearn basic Emacs keystroke commands" | 1407 | "\tLearn basic Emacs keystroke commands" |
| 1404 | (lambda () | 1408 | ,(lambda () |
| 1405 | (let* ((en "TUTORIAL") | 1409 | (let* ((en "TUTORIAL") |
| 1406 | (tut (or (get-language-info current-language-environment | 1410 | (tut (or (get-language-info current-language-environment |
| 1407 | 'tutorial) | 1411 | 'tutorial) |
| @@ -1419,7 +1423,8 @@ Each element in the list should be a list of strings or pairs | |||
| 1419 | (concat " (" title ")")))) | 1423 | (concat " (" title ")")))) |
| 1420 | "\n" | 1424 | "\n" |
| 1421 | :link ("Emacs Guided Tour" | 1425 | :link ("Emacs Guided Tour" |
| 1422 | (lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/")) | 1426 | ,(lambda (_button) |
| 1427 | (browse-url "http://www.gnu.org/software/emacs/tour/")) | ||
| 1423 | "Browse http://www.gnu.org/software/emacs/tour/") | 1428 | "Browse http://www.gnu.org/software/emacs/tour/") |
| 1424 | "\tSee an overview of Emacs features at gnu.org" | 1429 | "\tSee an overview of Emacs features at gnu.org" |
| 1425 | )) | 1430 | )) |
| @@ -1526,7 +1531,7 @@ a face or button specification." | |||
| 1526 | (make-button (prog1 (point) (insert-image img)) (point) | 1531 | (make-button (prog1 (point) (insert-image img)) (point) |
| 1527 | 'face 'default | 1532 | 'face 'default |
| 1528 | 'help-echo "mouse-2, RET: Browse http://www.gnu.org/" | 1533 | 'help-echo "mouse-2, RET: Browse http://www.gnu.org/" |
| 1529 | 'action (lambda (button) (browse-url "http://www.gnu.org/")) | 1534 | 'action (lambda (_button) (browse-url "http://www.gnu.org/")) |
| 1530 | 'follow-link t) | 1535 | 'follow-link t) |
| 1531 | (insert "\n\n"))))) | 1536 | (insert "\n\n"))))) |
| 1532 | 1537 | ||
| @@ -1538,16 +1543,16 @@ a face or button specification." | |||
| 1538 | (fancy-splash-insert | 1543 | (fancy-splash-insert |
| 1539 | :face 'variable-pitch | 1544 | :face 'variable-pitch |
| 1540 | "\nTo start... " | 1545 | "\nTo start... " |
| 1541 | :link '("Open a File" | 1546 | :link `("Open a File" |
| 1542 | (lambda (button) (call-interactively 'find-file)) | 1547 | ,(lambda (_button) (call-interactively 'find-file)) |
| 1543 | "Specify a new file's name, to edit the file") | 1548 | "Specify a new file's name, to edit the file") |
| 1544 | " " | 1549 | " " |
| 1545 | :link '("Open Home Directory" | 1550 | :link `("Open Home Directory" |
| 1546 | (lambda (button) (dired "~")) | 1551 | ,(lambda (_button) (dired "~")) |
| 1547 | "Open your home directory, to operate on its files") | 1552 | "Open your home directory, to operate on its files") |
| 1548 | " " | 1553 | " " |
| 1549 | :link '("Customize Startup" | 1554 | :link `("Customize Startup" |
| 1550 | (lambda (button) (customize-group 'initialization)) | 1555 | ,(lambda (_button) (customize-group 'initialization)) |
| 1551 | "Change initialization settings including this screen") | 1556 | "Change initialization settings including this screen") |
| 1552 | "\n")) | 1557 | "\n")) |
| 1553 | (fancy-splash-insert | 1558 | (fancy-splash-insert |
| @@ -1586,15 +1591,15 @@ a face or button specification." | |||
| 1586 | (when concise | 1591 | (when concise |
| 1587 | (fancy-splash-insert | 1592 | (fancy-splash-insert |
| 1588 | :face 'variable-pitch "\n" | 1593 | :face 'variable-pitch "\n" |
| 1589 | :link '("Dismiss this startup screen" | 1594 | :link `("Dismiss this startup screen" |
| 1590 | (lambda (button) | 1595 | ,(lambda (_button) |
| 1591 | (when startup-screen-inhibit-startup-screen | 1596 | (when startup-screen-inhibit-startup-screen |
| 1592 | (customize-set-variable 'inhibit-startup-screen t) | 1597 | (customize-set-variable 'inhibit-startup-screen t) |
| 1593 | (customize-mark-to-save 'inhibit-startup-screen) | 1598 | (customize-mark-to-save 'inhibit-startup-screen) |
| 1594 | (custom-save-all)) | 1599 | (custom-save-all)) |
| 1595 | (let ((w (get-buffer-window "*GNU Emacs*"))) | 1600 | (let ((w (get-buffer-window "*GNU Emacs*"))) |
| 1596 | (and w (not (one-window-p)) (delete-window w))) | 1601 | (and w (not (one-window-p)) (delete-window w))) |
| 1597 | (kill-buffer "*GNU Emacs*"))) | 1602 | (kill-buffer "*GNU Emacs*"))) |
| 1598 | " ") | 1603 | " ") |
| 1599 | (when (or user-init-file custom-file) | 1604 | (when (or user-init-file custom-file) |
| 1600 | (let ((checked (create-image "checked.xpm" | 1605 | (let ((checked (create-image "checked.xpm" |
| @@ -1809,37 +1814,37 @@ To quit a partially entered command, type Control-g.\n") | |||
| 1809 | 1814 | ||
| 1810 | (insert "\nImportant Help menu items:\n") | 1815 | (insert "\nImportant Help menu items:\n") |
| 1811 | (insert-button "Emacs Tutorial" | 1816 | (insert-button "Emacs Tutorial" |
| 1812 | 'action (lambda (button) (help-with-tutorial)) | 1817 | 'action (lambda (_button) (help-with-tutorial)) |
| 1813 | 'follow-link t) | 1818 | 'follow-link t) |
| 1814 | (insert "\t\tLearn basic Emacs keystroke commands\n") | 1819 | (insert "\t\tLearn basic Emacs keystroke commands\n") |
| 1815 | (insert-button "Read the Emacs Manual" | 1820 | (insert-button "Read the Emacs Manual" |
| 1816 | 'action (lambda (button) (info-emacs-manual)) | 1821 | 'action (lambda (_button) (info-emacs-manual)) |
| 1817 | 'follow-link t) | 1822 | 'follow-link t) |
| 1818 | (insert "\tView the Emacs manual using Info\n") | 1823 | (insert "\tView the Emacs manual using Info\n") |
| 1819 | (insert-button "\(Non)Warranty" | 1824 | (insert-button "\(Non)Warranty" |
| 1820 | 'action (lambda (button) (describe-no-warranty)) | 1825 | 'action (lambda (_button) (describe-no-warranty)) |
| 1821 | 'follow-link t) | 1826 | 'follow-link t) |
| 1822 | (insert "\t\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n") | 1827 | (insert "\t\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n") |
| 1823 | (insert-button "Copying Conditions" | 1828 | (insert-button "Copying Conditions" |
| 1824 | 'action (lambda (button) (describe-copying)) | 1829 | 'action (lambda (_button) (describe-copying)) |
| 1825 | 'follow-link t) | 1830 | 'follow-link t) |
| 1826 | (insert "\tConditions for redistributing and changing Emacs\n") | 1831 | (insert "\tConditions for redistributing and changing Emacs\n") |
| 1827 | (insert-button "More Manuals / Ordering Manuals" | 1832 | (insert-button "More Manuals / Ordering Manuals" |
| 1828 | 'action (lambda (button) (view-order-manuals)) | 1833 | 'action (lambda (_button) (view-order-manuals)) |
| 1829 | 'follow-link t) | 1834 | 'follow-link t) |
| 1830 | (insert " How to order printed manuals from the FSF\n") | 1835 | (insert " How to order printed manuals from the FSF\n") |
| 1831 | 1836 | ||
| 1832 | (insert "\nUseful tasks:\n") | 1837 | (insert "\nUseful tasks:\n") |
| 1833 | (insert-button "Visit New File" | 1838 | (insert-button "Visit New File" |
| 1834 | 'action (lambda (button) (call-interactively 'find-file)) | 1839 | 'action (lambda (_button) (call-interactively 'find-file)) |
| 1835 | 'follow-link t) | 1840 | 'follow-link t) |
| 1836 | (insert "\t\tSpecify a new file's name, to edit the file\n") | 1841 | (insert "\t\tSpecify a new file's name, to edit the file\n") |
| 1837 | (insert-button "Open Home Directory" | 1842 | (insert-button "Open Home Directory" |
| 1838 | 'action (lambda (button) (dired "~")) | 1843 | 'action (lambda (_button) (dired "~")) |
| 1839 | 'follow-link t) | 1844 | 'follow-link t) |
| 1840 | (insert "\tOpen your home directory, to operate on its files\n") | 1845 | (insert "\tOpen your home directory, to operate on its files\n") |
| 1841 | (insert-button "Customize Startup" | 1846 | (insert-button "Customize Startup" |
| 1842 | 'action (lambda (button) (customize-group 'initialization)) | 1847 | 'action (lambda (_button) (customize-group 'initialization)) |
| 1843 | 'follow-link t) | 1848 | 'follow-link t) |
| 1844 | (insert "\tChange initialization settings including this screen\n") | 1849 | (insert "\tChange initialization settings including this screen\n") |
| 1845 | 1850 | ||
| @@ -1873,20 +1878,20 @@ To quit a partially entered command, type Control-g.\n") | |||
| 1873 | (where (key-description where)) | 1878 | (where (key-description where)) |
| 1874 | (t "M-x help"))))) | 1879 | (t "M-x help"))))) |
| 1875 | (insert-button "Emacs manual" | 1880 | (insert-button "Emacs manual" |
| 1876 | 'action (lambda (button) (info-emacs-manual)) | 1881 | 'action (lambda (_button) (info-emacs-manual)) |
| 1877 | 'follow-link t) | 1882 | 'follow-link t) |
| 1878 | (insert (substitute-command-keys"\t \\[info-emacs-manual]\t")) | 1883 | (insert (substitute-command-keys"\t \\[info-emacs-manual]\t")) |
| 1879 | (insert-button "Browse manuals" | 1884 | (insert-button "Browse manuals" |
| 1880 | 'action (lambda (button) (Info-directory)) | 1885 | 'action (lambda (_button) (Info-directory)) |
| 1881 | 'follow-link t) | 1886 | 'follow-link t) |
| 1882 | (insert (substitute-command-keys "\t \\[info]\n")) | 1887 | (insert (substitute-command-keys "\t \\[info]\n")) |
| 1883 | (insert-button "Emacs tutorial" | 1888 | (insert-button "Emacs tutorial" |
| 1884 | 'action (lambda (button) (help-with-tutorial)) | 1889 | 'action (lambda (_button) (help-with-tutorial)) |
| 1885 | 'follow-link t) | 1890 | 'follow-link t) |
| 1886 | (insert (substitute-command-keys | 1891 | (insert (substitute-command-keys |
| 1887 | "\t \\[help-with-tutorial]\tUndo changes\t \\[undo]\n")) | 1892 | "\t \\[help-with-tutorial]\tUndo changes\t \\[undo]\n")) |
| 1888 | (insert-button "Buy manuals" | 1893 | (insert-button "Buy manuals" |
| 1889 | 'action (lambda (button) (view-order-manuals)) | 1894 | 'action (lambda (_button) (view-order-manuals)) |
| 1890 | 'follow-link t) | 1895 | 'follow-link t) |
| 1891 | (insert (substitute-command-keys | 1896 | (insert (substitute-command-keys |
| 1892 | "\t \\[view-order-manuals]\tExit Emacs\t \\[save-buffers-kill-terminal]"))) | 1897 | "\t \\[view-order-manuals]\tExit Emacs\t \\[save-buffers-kill-terminal]"))) |
| @@ -1894,7 +1899,7 @@ To quit a partially entered command, type Control-g.\n") | |||
| 1894 | ;; Say how to use the menu bar with the keyboard. | 1899 | ;; Say how to use the menu bar with the keyboard. |
| 1895 | (insert "\n") | 1900 | (insert "\n") |
| 1896 | (insert-button "Activate menubar" | 1901 | (insert-button "Activate menubar" |
| 1897 | 'action (lambda (button) (tmm-menubar)) | 1902 | 'action (lambda (_button) (tmm-menubar)) |
| 1898 | 'follow-link t) | 1903 | 'follow-link t) |
| 1899 | (if (and (eq (key-binding "\M-`") 'tmm-menubar) | 1904 | (if (and (eq (key-binding "\M-`") 'tmm-menubar) |
| 1900 | (eq (key-binding [f10]) 'tmm-menubar)) | 1905 | (eq (key-binding [f10]) 'tmm-menubar)) |
| @@ -1910,21 +1915,21 @@ If you have no Meta key, you may instead type ESC followed by the character.)") | |||
| 1910 | (insert "\nUseful tasks:\n") | 1915 | (insert "\nUseful tasks:\n") |
| 1911 | 1916 | ||
| 1912 | (insert-button "Visit New File" | 1917 | (insert-button "Visit New File" |
| 1913 | 'action (lambda (button) (call-interactively 'find-file)) | 1918 | 'action (lambda (_button) (call-interactively 'find-file)) |
| 1914 | 'follow-link t) | 1919 | 'follow-link t) |
| 1915 | (insert "\t\t\t") | 1920 | (insert "\t\t\t") |
| 1916 | (insert-button "Open Home Directory" | 1921 | (insert-button "Open Home Directory" |
| 1917 | 'action (lambda (button) (dired "~")) | 1922 | 'action (lambda (_button) (dired "~")) |
| 1918 | 'follow-link t) | 1923 | 'follow-link t) |
| 1919 | (insert "\n") | 1924 | (insert "\n") |
| 1920 | 1925 | ||
| 1921 | (insert-button "Customize Startup" | 1926 | (insert-button "Customize Startup" |
| 1922 | 'action (lambda (button) (customize-group 'initialization)) | 1927 | 'action (lambda (_button) (customize-group 'initialization)) |
| 1923 | 'follow-link t) | 1928 | 'follow-link t) |
| 1924 | (insert "\t\t") | 1929 | (insert "\t\t") |
| 1925 | (insert-button "Open *scratch* buffer" | 1930 | (insert-button "Open *scratch* buffer" |
| 1926 | 'action (lambda (button) (switch-to-buffer | 1931 | 'action (lambda (_button) (switch-to-buffer |
| 1927 | (get-buffer-create "*scratch*"))) | 1932 | (get-buffer-create "*scratch*"))) |
| 1928 | 'follow-link t) | 1933 | 'follow-link t) |
| 1929 | (insert "\n") | 1934 | (insert "\n") |
| 1930 | (insert "\n" (emacs-version) "\n" emacs-copyright "\n") | 1935 | (insert "\n" (emacs-version) "\n" emacs-copyright "\n") |
| @@ -1937,36 +1942,36 @@ If you have no Meta key, you may instead type ESC followed by the character.)") | |||
| 1937 | " | 1942 | " |
| 1938 | GNU Emacs comes with ABSOLUTELY NO WARRANTY; type C-h C-w for ") | 1943 | GNU Emacs comes with ABSOLUTELY NO WARRANTY; type C-h C-w for ") |
| 1939 | (insert-button "full details" | 1944 | (insert-button "full details" |
| 1940 | 'action (lambda (button) (describe-no-warranty)) | 1945 | 'action (lambda (_button) (describe-no-warranty)) |
| 1941 | 'follow-link t) | 1946 | 'follow-link t) |
| 1942 | (insert ". | 1947 | (insert ". |
| 1943 | Emacs is Free Software--Free as in Freedom--so you can redistribute copies | 1948 | Emacs is Free Software--Free as in Freedom--so you can redistribute copies |
| 1944 | of Emacs and modify it; type C-h C-c to see ") | 1949 | of Emacs and modify it; type C-h C-c to see ") |
| 1945 | (insert-button "the conditions" | 1950 | (insert-button "the conditions" |
| 1946 | 'action (lambda (button) (describe-copying)) | 1951 | 'action (lambda (_button) (describe-copying)) |
| 1947 | 'follow-link t) | 1952 | 'follow-link t) |
| 1948 | (insert ". | 1953 | (insert ". |
| 1949 | Type C-h C-d for information on ") | 1954 | Type C-h C-d for information on ") |
| 1950 | (insert-button "getting the latest version" | 1955 | (insert-button "getting the latest version" |
| 1951 | 'action (lambda (button) (describe-distribution)) | 1956 | 'action (lambda (_button) (describe-distribution)) |
| 1952 | 'follow-link t) | 1957 | 'follow-link t) |
| 1953 | (insert ".")) | 1958 | (insert ".")) |
| 1954 | (insert (substitute-command-keys | 1959 | (insert (substitute-command-keys |
| 1955 | " | 1960 | " |
| 1956 | GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for ")) | 1961 | GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for ")) |
| 1957 | (insert-button "full details" | 1962 | (insert-button "full details" |
| 1958 | 'action (lambda (button) (describe-no-warranty)) | 1963 | 'action (lambda (_button) (describe-no-warranty)) |
| 1959 | 'follow-link t) | 1964 | 'follow-link t) |
| 1960 | (insert (substitute-command-keys ". | 1965 | (insert (substitute-command-keys ". |
| 1961 | Emacs is Free Software--Free as in Freedom--so you can redistribute copies | 1966 | Emacs is Free Software--Free as in Freedom--so you can redistribute copies |
| 1962 | of Emacs and modify it; type \\[describe-copying] to see ")) | 1967 | of Emacs and modify it; type \\[describe-copying] to see ")) |
| 1963 | (insert-button "the conditions" | 1968 | (insert-button "the conditions" |
| 1964 | 'action (lambda (button) (describe-copying)) | 1969 | 'action (lambda (_button) (describe-copying)) |
| 1965 | 'follow-link t) | 1970 | 'follow-link t) |
| 1966 | (insert (substitute-command-keys". | 1971 | (insert (substitute-command-keys". |
| 1967 | Type \\[describe-distribution] for information on ")) | 1972 | Type \\[describe-distribution] for information on ")) |
| 1968 | (insert-button "getting the latest version" | 1973 | (insert-button "getting the latest version" |
| 1969 | 'action (lambda (button) (describe-distribution)) | 1974 | 'action (lambda (_button) (describe-distribution)) |
| 1970 | 'follow-link t) | 1975 | 'follow-link t) |
| 1971 | (insert "."))) | 1976 | (insert "."))) |
| 1972 | 1977 | ||
| @@ -1977,7 +1982,7 @@ Type \\[describe-distribution] for information on ")) | |||
| 1977 | 1982 | ||
| 1978 | (insert-button "Authors" | 1983 | (insert-button "Authors" |
| 1979 | 'action | 1984 | 'action |
| 1980 | (lambda (button) | 1985 | (lambda (_button) |
| 1981 | (view-file (expand-file-name "AUTHORS" data-directory)) | 1986 | (view-file (expand-file-name "AUTHORS" data-directory)) |
| 1982 | (goto-char (point-min))) | 1987 | (goto-char (point-min))) |
| 1983 | 'follow-link t) | 1988 | 'follow-link t) |
| @@ -1985,34 +1990,34 @@ Type \\[describe-distribution] for information on ")) | |||
| 1985 | 1990 | ||
| 1986 | (insert-button "Contributing" | 1991 | (insert-button "Contributing" |
| 1987 | 'action | 1992 | 'action |
| 1988 | (lambda (button) | 1993 | (lambda (_button) |
| 1989 | (view-file (expand-file-name "CONTRIBUTE" data-directory)) | 1994 | (view-file (expand-file-name "CONTRIBUTE" data-directory)) |
| 1990 | (goto-char (point-min))) | 1995 | (goto-char (point-min))) |
| 1991 | 'follow-link t) | 1996 | 'follow-link t) |
| 1992 | (insert "\tHow to contribute improvements to Emacs\n\n") | 1997 | (insert "\tHow to contribute improvements to Emacs\n\n") |
| 1993 | 1998 | ||
| 1994 | (insert-button "GNU and Freedom" | 1999 | (insert-button "GNU and Freedom" |
| 1995 | 'action (lambda (button) (describe-gnu-project)) | 2000 | 'action (lambda (_button) (describe-gnu-project)) |
| 1996 | 'follow-link t) | 2001 | 'follow-link t) |
| 1997 | (insert "\t\tWhy we developed GNU Emacs and the GNU system\n") | 2002 | (insert "\t\tWhy we developed GNU Emacs and the GNU system\n") |
| 1998 | 2003 | ||
| 1999 | (insert-button "Absence of Warranty" | 2004 | (insert-button "Absence of Warranty" |
| 2000 | 'action (lambda (button) (describe-no-warranty)) | 2005 | 'action (lambda (_button) (describe-no-warranty)) |
| 2001 | 'follow-link t) | 2006 | 'follow-link t) |
| 2002 | (insert "\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n") | 2007 | (insert "\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n") |
| 2003 | 2008 | ||
| 2004 | (insert-button "Copying Conditions" | 2009 | (insert-button "Copying Conditions" |
| 2005 | 'action (lambda (button) (describe-copying)) | 2010 | 'action (lambda (_button) (describe-copying)) |
| 2006 | 'follow-link t) | 2011 | 'follow-link t) |
| 2007 | (insert "\tConditions for redistributing and changing Emacs\n") | 2012 | (insert "\tConditions for redistributing and changing Emacs\n") |
| 2008 | 2013 | ||
| 2009 | (insert-button "Getting New Versions" | 2014 | (insert-button "Getting New Versions" |
| 2010 | 'action (lambda (button) (describe-distribution)) | 2015 | 'action (lambda (_button) (describe-distribution)) |
| 2011 | 'follow-link t) | 2016 | 'follow-link t) |
| 2012 | (insert "\tHow to get the latest version of GNU Emacs\n") | 2017 | (insert "\tHow to get the latest version of GNU Emacs\n") |
| 2013 | 2018 | ||
| 2014 | (insert-button "More Manuals / Ordering Manuals" | 2019 | (insert-button "More Manuals / Ordering Manuals" |
| 2015 | 'action (lambda (button) (view-order-manuals)) | 2020 | 'action (lambda (_button) (view-order-manuals)) |
| 2016 | 'follow-link t) | 2021 | 'follow-link t) |
| 2017 | (insert "\tBuying printed manuals from the FSF\n")) | 2022 | (insert "\tBuying printed manuals from the FSF\n")) |
| 2018 | 2023 | ||
| @@ -2078,7 +2083,7 @@ A fancy display is used on graphic displays, normal otherwise." | |||
| 2078 | (defalias 'about-emacs 'display-about-screen) | 2083 | (defalias 'about-emacs 'display-about-screen) |
| 2079 | (defalias 'display-splash-screen 'display-startup-screen) | 2084 | (defalias 'display-splash-screen 'display-startup-screen) |
| 2080 | 2085 | ||
| 2081 | (defun command-line-1 (command-line-args-left) | 2086 | (defun command-line-1 (args-left) |
| 2082 | (display-startup-echo-area-message) | 2087 | (display-startup-echo-area-message) |
| 2083 | (when (and pure-space-overflow | 2088 | (when (and pure-space-overflow |
| 2084 | (not noninteractive)) | 2089 | (not noninteractive)) |
| @@ -2089,14 +2094,12 @@ A fancy display is used on graphic displays, normal otherwise." | |||
| 2089 | :warning)) | 2094 | :warning)) |
| 2090 | 2095 | ||
| 2091 | (let ((file-count 0) | 2096 | (let ((file-count 0) |
| 2097 | (command-line-args-left args-left) | ||
| 2092 | first-file-buffer) | 2098 | first-file-buffer) |
| 2093 | (when command-line-args-left | 2099 | (when command-line-args-left |
| 2094 | ;; We have command args; process them. | 2100 | ;; We have command args; process them. |
| 2095 | ;; Note that any local variables in this function affect the | 2101 | (let ((dir command-line-default-directory) |
| 2096 | ;; ability of -f batch-byte-compile to detect free variables. | 2102 | tem |
| 2097 | ;; So we give some of them with common names a cl1- prefix. | ||
| 2098 | (let ((cl1-dir command-line-default-directory) | ||
| 2099 | cl1-tem | ||
| 2100 | ;; This approach loses for "-batch -L DIR --eval "(require foo)", | 2103 | ;; This approach loses for "-batch -L DIR --eval "(require foo)", |
| 2101 | ;; if foo is intended to be found in DIR. | 2104 | ;; if foo is intended to be found in DIR. |
| 2102 | ;; | 2105 | ;; |
| @@ -2119,8 +2122,8 @@ A fancy display is used on graphic displays, normal otherwise." | |||
| 2119 | "--find-file" "--visit" "--file" "--no-desktop") | 2122 | "--find-file" "--visit" "--file" "--no-desktop") |
| 2120 | (mapcar (lambda (elt) (concat "-" (car elt))) | 2123 | (mapcar (lambda (elt) (concat "-" (car elt))) |
| 2121 | command-switch-alist))) | 2124 | command-switch-alist))) |
| 2122 | (cl1-line 0) | 2125 | (line 0) |
| 2123 | (cl1-column 0)) | 2126 | (column 0)) |
| 2124 | 2127 | ||
| 2125 | ;; Add the long X options to longopts. | 2128 | ;; Add the long X options to longopts. |
| 2126 | (dolist (tem command-line-x-option-alist) | 2129 | (dolist (tem command-line-x-option-alist) |
| @@ -2161,12 +2164,12 @@ A fancy display is used on graphic displays, normal otherwise." | |||
| 2161 | argi orig-argi))))) | 2164 | argi orig-argi))))) |
| 2162 | 2165 | ||
| 2163 | ;; Execute the option. | 2166 | ;; Execute the option. |
| 2164 | (cond ((setq cl1-tem (assoc argi command-switch-alist)) | 2167 | (cond ((setq tem (assoc argi command-switch-alist)) |
| 2165 | (if argval | 2168 | (if argval |
| 2166 | (let ((command-line-args-left | 2169 | (let ((command-line-args-left |
| 2167 | (cons argval command-line-args-left))) | 2170 | (cons argval command-line-args-left))) |
| 2168 | (funcall (cdr cl1-tem) argi)) | 2171 | (funcall (cdr tem) argi)) |
| 2169 | (funcall (cdr cl1-tem) argi))) | 2172 | (funcall (cdr tem) argi))) |
| 2170 | 2173 | ||
| 2171 | ((equal argi "-no-splash") | 2174 | ((equal argi "-no-splash") |
| 2172 | (setq inhibit-startup-screen t)) | 2175 | (setq inhibit-startup-screen t)) |
| @@ -2175,22 +2178,22 @@ A fancy display is used on graphic displays, normal otherwise." | |||
| 2175 | "-funcall" | 2178 | "-funcall" |
| 2176 | "-e")) ; what the source used to say | 2179 | "-e")) ; what the source used to say |
| 2177 | (setq inhibit-startup-screen t) | 2180 | (setq inhibit-startup-screen t) |
| 2178 | (setq cl1-tem (intern (or argval (pop command-line-args-left)))) | 2181 | (setq tem (intern (or argval (pop command-line-args-left)))) |
| 2179 | (if (commandp cl1-tem) | 2182 | (if (commandp tem) |
| 2180 | (command-execute cl1-tem) | 2183 | (command-execute tem) |
| 2181 | (funcall cl1-tem))) | 2184 | (funcall tem))) |
| 2182 | 2185 | ||
| 2183 | ((member argi '("-eval" "-execute")) | 2186 | ((member argi '("-eval" "-execute")) |
| 2184 | (setq inhibit-startup-screen t) | 2187 | (setq inhibit-startup-screen t) |
| 2185 | (eval (read (or argval (pop command-line-args-left))))) | 2188 | (eval (read (or argval (pop command-line-args-left))))) |
| 2186 | 2189 | ||
| 2187 | ((member argi '("-L" "-directory")) | 2190 | ((member argi '("-L" "-directory")) |
| 2188 | (setq cl1-tem (expand-file-name | 2191 | (setq tem (expand-file-name |
| 2189 | (command-line-normalize-file-name | 2192 | (command-line-normalize-file-name |
| 2190 | (or argval (pop command-line-args-left))))) | 2193 | (or argval (pop command-line-args-left))))) |
| 2191 | (cond (splice (setcdr splice (cons cl1-tem (cdr splice))) | 2194 | (cond (splice (setcdr splice (cons tem (cdr splice))) |
| 2192 | (setq splice (cdr splice))) | 2195 | (setq splice (cdr splice))) |
| 2193 | (t (setq load-path (cons cl1-tem load-path) | 2196 | (t (setq load-path (cons tem load-path) |
| 2194 | splice load-path)))) | 2197 | splice load-path)))) |
| 2195 | 2198 | ||
| 2196 | ((member argi '("-l" "-load")) | 2199 | ((member argi '("-l" "-load")) |
| @@ -2214,10 +2217,10 @@ A fancy display is used on graphic displays, normal otherwise." | |||
| 2214 | 2217 | ||
| 2215 | ((equal argi "-insert") | 2218 | ((equal argi "-insert") |
| 2216 | (setq inhibit-startup-screen t) | 2219 | (setq inhibit-startup-screen t) |
| 2217 | (setq cl1-tem (or argval (pop command-line-args-left))) | 2220 | (setq tem (or argval (pop command-line-args-left))) |
| 2218 | (or (stringp cl1-tem) | 2221 | (or (stringp tem) |
| 2219 | (error "File name omitted from `-insert' option")) | 2222 | (error "File name omitted from `-insert' option")) |
| 2220 | (insert-file-contents (command-line-normalize-file-name cl1-tem))) | 2223 | (insert-file-contents (command-line-normalize-file-name tem))) |
| 2221 | 2224 | ||
| 2222 | ((equal argi "-kill") | 2225 | ((equal argi "-kill") |
| 2223 | (kill-emacs t)) | 2226 | (kill-emacs t)) |
| @@ -2230,42 +2233,42 @@ A fancy display is used on graphic displays, normal otherwise." | |||
| 2230 | (message "\"--no-desktop\" ignored because the Desktop package is not loaded")) | 2233 | (message "\"--no-desktop\" ignored because the Desktop package is not loaded")) |
| 2231 | 2234 | ||
| 2232 | ((string-match "^\\+[0-9]+\\'" argi) | 2235 | ((string-match "^\\+[0-9]+\\'" argi) |
| 2233 | (setq cl1-line (string-to-number argi))) | 2236 | (setq line (string-to-number argi))) |
| 2234 | 2237 | ||
| 2235 | ((string-match "^\\+\\([0-9]+\\):\\([0-9]+\\)\\'" argi) | 2238 | ((string-match "^\\+\\([0-9]+\\):\\([0-9]+\\)\\'" argi) |
| 2236 | (setq cl1-line (string-to-number (match-string 1 argi)) | 2239 | (setq line (string-to-number (match-string 1 argi)) |
| 2237 | cl1-column (string-to-number (match-string 2 argi)))) | 2240 | column (string-to-number (match-string 2 argi)))) |
| 2238 | 2241 | ||
| 2239 | ((setq cl1-tem (assoc orig-argi command-line-x-option-alist)) | 2242 | ((setq tem (assoc orig-argi command-line-x-option-alist)) |
| 2240 | ;; Ignore X-windows options and their args if not using X. | 2243 | ;; Ignore X-windows options and their args if not using X. |
| 2241 | (setq command-line-args-left | 2244 | (setq command-line-args-left |
| 2242 | (nthcdr (nth 1 cl1-tem) command-line-args-left))) | 2245 | (nthcdr (nth 1 tem) command-line-args-left))) |
| 2243 | 2246 | ||
| 2244 | ((setq cl1-tem (assoc orig-argi command-line-ns-option-alist)) | 2247 | ((setq tem (assoc orig-argi command-line-ns-option-alist)) |
| 2245 | ;; Ignore NS-windows options and their args if not using NS. | 2248 | ;; Ignore NS-windows options and their args if not using NS. |
| 2246 | (setq command-line-args-left | 2249 | (setq command-line-args-left |
| 2247 | (nthcdr (nth 1 cl1-tem) command-line-args-left))) | 2250 | (nthcdr (nth 1 tem) command-line-args-left))) |
| 2248 | 2251 | ||
| 2249 | ((member argi '("-find-file" "-file" "-visit")) | 2252 | ((member argi '("-find-file" "-file" "-visit")) |
| 2250 | (setq inhibit-startup-screen t) | 2253 | (setq inhibit-startup-screen t) |
| 2251 | ;; An explicit option to specify visiting a file. | 2254 | ;; An explicit option to specify visiting a file. |
| 2252 | (setq cl1-tem (or argval (pop command-line-args-left))) | 2255 | (setq tem (or argval (pop command-line-args-left))) |
| 2253 | (unless (stringp cl1-tem) | 2256 | (unless (stringp tem) |
| 2254 | (error "File name omitted from `%s' option" argi)) | 2257 | (error "File name omitted from `%s' option" argi)) |
| 2255 | (setq file-count (1+ file-count)) | 2258 | (setq file-count (1+ file-count)) |
| 2256 | (let ((file (expand-file-name | 2259 | (let ((file (expand-file-name |
| 2257 | (command-line-normalize-file-name cl1-tem) | 2260 | (command-line-normalize-file-name tem) |
| 2258 | cl1-dir))) | 2261 | dir))) |
| 2259 | (if (= file-count 1) | 2262 | (if (= file-count 1) |
| 2260 | (setq first-file-buffer (find-file file)) | 2263 | (setq first-file-buffer (find-file file)) |
| 2261 | (find-file-other-window file))) | 2264 | (find-file-other-window file))) |
| 2262 | (unless (zerop cl1-line) | 2265 | (unless (zerop line) |
| 2263 | (goto-char (point-min)) | 2266 | (goto-char (point-min)) |
| 2264 | (forward-line (1- cl1-line))) | 2267 | (forward-line (1- line))) |
| 2265 | (setq cl1-line 0) | 2268 | (setq line 0) |
| 2266 | (unless (< cl1-column 1) | 2269 | (unless (< column 1) |
| 2267 | (move-to-column (1- cl1-column))) | 2270 | (move-to-column (1- column))) |
| 2268 | (setq cl1-column 0)) | 2271 | (setq column 0)) |
| 2269 | 2272 | ||
| 2270 | ;; These command lines now have no effect. | 2273 | ;; These command lines now have no effect. |
| 2271 | ((string-match "\\`--?\\(no-\\)?\\(uni\\|multi\\)byte$" argi) | 2274 | ((string-match "\\`--?\\(no-\\)?\\(uni\\|multi\\)byte$" argi) |
| @@ -2293,19 +2296,19 @@ A fancy display is used on graphic displays, normal otherwise." | |||
| 2293 | (let ((file | 2296 | (let ((file |
| 2294 | (expand-file-name | 2297 | (expand-file-name |
| 2295 | (command-line-normalize-file-name orig-argi) | 2298 | (command-line-normalize-file-name orig-argi) |
| 2296 | cl1-dir))) | 2299 | dir))) |
| 2297 | (cond ((= file-count 1) | 2300 | (cond ((= file-count 1) |
| 2298 | (setq first-file-buffer (find-file file))) | 2301 | (setq first-file-buffer (find-file file))) |
| 2299 | (inhibit-startup-screen | 2302 | (inhibit-startup-screen |
| 2300 | (find-file-other-window file)) | 2303 | (find-file-other-window file)) |
| 2301 | (t (find-file file)))) | 2304 | (t (find-file file)))) |
| 2302 | (unless (zerop cl1-line) | 2305 | (unless (zerop line) |
| 2303 | (goto-char (point-min)) | 2306 | (goto-char (point-min)) |
| 2304 | (forward-line (1- cl1-line))) | 2307 | (forward-line (1- line))) |
| 2305 | (setq cl1-line 0) | 2308 | (setq line 0) |
| 2306 | (unless (< cl1-column 1) | 2309 | (unless (< column 1) |
| 2307 | (move-to-column (1- cl1-column))) | 2310 | (move-to-column (1- column))) |
| 2308 | (setq cl1-column 0)))))) | 2311 | (setq column 0)))))) |
| 2309 | ;; In unusual circumstances, the execution of Lisp code due | 2312 | ;; In unusual circumstances, the execution of Lisp code due |
| 2310 | ;; to command-line options can cause the last visible frame | 2313 | ;; to command-line options can cause the last visible frame |
| 2311 | ;; to be deleted. In this case, kill emacs to avoid an | 2314 | ;; to be deleted. In this case, kill emacs to avoid an |
diff --git a/lisp/subr.el b/lisp/subr.el index 8ea4becdc11..e6e0c62e0b4 100644 --- a/lisp/subr.el +++ b/lisp/subr.el | |||
| @@ -116,6 +116,17 @@ BODY should be a list of Lisp expressions. | |||
| 116 | ;; depend on backquote.el. | 116 | ;; depend on backquote.el. |
| 117 | (list 'function (cons 'lambda cdr))) | 117 | (list 'function (cons 'lambda cdr))) |
| 118 | 118 | ||
| 119 | ;; Partial application of functions (similar to "currying"). | ||
| 120 | ;; This function is here rather than in subr.el because it uses CL. | ||
| 121 | (defun apply-partially (fun &rest args) | ||
| 122 | "Return a function that is a partial application of FUN to ARGS. | ||
| 123 | ARGS is a list of the first N arguments to pass to FUN. | ||
| 124 | The result is a new function which does the same as FUN, except that | ||
| 125 | the first N arguments are fixed at the values with which this function | ||
| 126 | was called." | ||
| 127 | `(closure (t) (&rest args) | ||
| 128 | (apply ',fun ,@(mapcar (lambda (arg) `',arg) args) args))) | ||
| 129 | |||
| 119 | (if (null (featurep 'cl)) | 130 | (if (null (featurep 'cl)) |
| 120 | (progn | 131 | (progn |
| 121 | ;; If we reload subr.el after having loaded CL, be careful not to | 132 | ;; If we reload subr.el after having loaded CL, be careful not to |
| @@ -163,8 +174,6 @@ value of last one, or nil if there are none. | |||
| 163 | ;; If we reload subr.el after having loaded CL, be careful not to | 174 | ;; If we reload subr.el after having loaded CL, be careful not to |
| 164 | ;; overwrite CL's extended definition of `dolist', `dotimes', | 175 | ;; overwrite CL's extended definition of `dolist', `dotimes', |
| 165 | ;; `declare', `push' and `pop'. | 176 | ;; `declare', `push' and `pop'. |
| 166 | (defvar --dolist-tail-- nil | ||
| 167 | "Temporary variable used in `dolist' expansion.") | ||
| 168 | 177 | ||
| 169 | (defmacro dolist (spec &rest body) | 178 | (defmacro dolist (spec &rest body) |
| 170 | "Loop over a list. | 179 | "Loop over a list. |
| @@ -176,18 +185,29 @@ Then evaluate RESULT to get return value, default nil. | |||
| 176 | ;; It would be cleaner to create an uninterned symbol, | 185 | ;; It would be cleaner to create an uninterned symbol, |
| 177 | ;; but that uses a lot more space when many functions in many files | 186 | ;; but that uses a lot more space when many functions in many files |
| 178 | ;; use dolist. | 187 | ;; use dolist. |
| 188 | ;; FIXME: This cost disappears in byte-compiled lexical-binding files. | ||
| 179 | (let ((temp '--dolist-tail--)) | 189 | (let ((temp '--dolist-tail--)) |
| 180 | `(let ((,temp ,(nth 1 spec)) | 190 | ;; This is not a reliable test, but it does not matter because both |
| 181 | ,(car spec)) | 191 | ;; semantics are acceptable, tho one is slightly faster with dynamic |
| 182 | (while ,temp | 192 | ;; scoping and the other is slightly faster (and has cleaner semantics) |
| 183 | (setq ,(car spec) (car ,temp)) | 193 | ;; with lexical scoping. |
| 184 | ,@body | 194 | (if lexical-binding |
| 185 | (setq ,temp (cdr ,temp))) | 195 | `(let ((,temp ,(nth 1 spec))) |
| 186 | ,@(if (cdr (cdr spec)) | 196 | (while ,temp |
| 187 | `((setq ,(car spec) nil) ,@(cdr (cdr spec))))))) | 197 | (let ((,(car spec) (car ,temp))) |
| 188 | 198 | ,@body | |
| 189 | (defvar --dotimes-limit-- nil | 199 | (setq ,temp (cdr ,temp)))) |
| 190 | "Temporary variable used in `dotimes' expansion.") | 200 | ,@(if (cdr (cdr spec)) |
| 201 | ;; FIXME: This let often leads to "unused var" warnings. | ||
| 202 | `((let ((,(car spec) nil)) ,@(cdr (cdr spec)))))) | ||
| 203 | `(let ((,temp ,(nth 1 spec)) | ||
| 204 | ,(car spec)) | ||
| 205 | (while ,temp | ||
| 206 | (setq ,(car spec) (car ,temp)) | ||
| 207 | ,@body | ||
| 208 | (setq ,temp (cdr ,temp))) | ||
| 209 | ,@(if (cdr (cdr spec)) | ||
| 210 | `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))) | ||
| 191 | 211 | ||
| 192 | (defmacro dotimes (spec &rest body) | 212 | (defmacro dotimes (spec &rest body) |
| 193 | "Loop a certain number of times. | 213 | "Loop a certain number of times. |
| @@ -200,15 +220,30 @@ the return value (nil if RESULT is omitted). | |||
| 200 | ;; It would be cleaner to create an uninterned symbol, | 220 | ;; It would be cleaner to create an uninterned symbol, |
| 201 | ;; but that uses a lot more space when many functions in many files | 221 | ;; but that uses a lot more space when many functions in many files |
| 202 | ;; use dotimes. | 222 | ;; use dotimes. |
| 223 | ;; FIXME: This cost disappears in byte-compiled lexical-binding files. | ||
| 203 | (let ((temp '--dotimes-limit--) | 224 | (let ((temp '--dotimes-limit--) |
| 204 | (start 0) | 225 | (start 0) |
| 205 | (end (nth 1 spec))) | 226 | (end (nth 1 spec))) |
| 206 | `(let ((,temp ,end) | 227 | ;; This is not a reliable test, but it does not matter because both |
| 207 | (,(car spec) ,start)) | 228 | ;; semantics are acceptable, tho one is slightly faster with dynamic |
| 208 | (while (< ,(car spec) ,temp) | 229 | ;; scoping and the other has cleaner semantics. |
| 209 | ,@body | 230 | (if lexical-binding |
| 210 | (setq ,(car spec) (1+ ,(car spec)))) | 231 | (let ((counter '--dotimes-counter--)) |
| 211 | ,@(cdr (cdr spec))))) | 232 | `(let ((,temp ,end) |
| 233 | (,counter ,start)) | ||
| 234 | (while (< ,counter ,temp) | ||
| 235 | (let ((,(car spec) ,counter)) | ||
| 236 | ,@body) | ||
| 237 | (setq ,counter (1+ ,counter))) | ||
| 238 | ,@(if (cddr spec) | ||
| 239 | ;; FIXME: This let often leads to "unused var" warnings. | ||
| 240 | `((let ((,(car spec) ,counter)) ,@(cddr spec)))))) | ||
| 241 | `(let ((,temp ,end) | ||
| 242 | (,(car spec) ,start)) | ||
| 243 | (while (< ,(car spec) ,temp) | ||
| 244 | ,@body | ||
| 245 | (setq ,(car spec) (1+ ,(car spec)))) | ||
| 246 | ,@(cdr (cdr spec)))))) | ||
| 212 | 247 | ||
| 213 | (defmacro declare (&rest specs) | 248 | (defmacro declare (&rest specs) |
| 214 | "Do not evaluate any arguments and return nil. | 249 | "Do not evaluate any arguments and return nil. |
| @@ -249,20 +284,6 @@ Any list whose car is `frame-configuration' is assumed to be a frame | |||
| 249 | configuration." | 284 | configuration." |
| 250 | (and (consp object) | 285 | (and (consp object) |
| 251 | (eq (car object) 'frame-configuration))) | 286 | (eq (car object) 'frame-configuration))) |
| 252 | |||
| 253 | (defun functionp (object) | ||
| 254 | "Non-nil if OBJECT is a function." | ||
| 255 | (or (and (symbolp object) (fboundp object) | ||
| 256 | (condition-case nil | ||
| 257 | (setq object (indirect-function object)) | ||
| 258 | (error nil)) | ||
| 259 | (eq (car-safe object) 'autoload) | ||
| 260 | (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object))))))) | ||
| 261 | (and (subrp object) | ||
| 262 | ;; Filter out special forms. | ||
| 263 | (not (eq 'unevalled (cdr (subr-arity object))))) | ||
| 264 | (byte-code-function-p object) | ||
| 265 | (eq (car-safe object) 'lambda))) | ||
| 266 | 287 | ||
| 267 | ;;;; List functions. | 288 | ;;;; List functions. |
| 268 | 289 | ||
| @@ -1258,6 +1279,67 @@ the hook's buffer-local value rather than its default value." | |||
| 1258 | (kill-local-variable hook) | 1279 | (kill-local-variable hook) |
| 1259 | (set hook hook-value)))))) | 1280 | (set hook hook-value)))))) |
| 1260 | 1281 | ||
| 1282 | (defmacro letrec (binders &rest body) | ||
| 1283 | "Bind variables according to BINDERS then eval BODY. | ||
| 1284 | The value of the last form in BODY is returned. | ||
| 1285 | Each element of BINDERS is a list (SYMBOL VALUEFORM) which binds | ||
| 1286 | SYMBOL to the value of VALUEFORM. | ||
| 1287 | All symbols are bound before the VALUEFORMs are evalled." | ||
| 1288 | ;; Only useful in lexical-binding mode. | ||
| 1289 | ;; As a special-form, we could implement it more efficiently (and cleanly, | ||
| 1290 | ;; making the vars actually unbound during evaluation of the binders). | ||
| 1291 | (declare (debug let) (indent 1)) | ||
| 1292 | `(let ,(mapcar #'car binders) | ||
| 1293 | ,@(mapcar (lambda (binder) `(setq ,@binder)) binders) | ||
| 1294 | ,@body)) | ||
| 1295 | |||
| 1296 | (defmacro with-wrapper-hook (var args &rest body) | ||
| 1297 | "Run BODY wrapped with the VAR hook. | ||
| 1298 | VAR is a special hook: its functions are called with a first argument | ||
| 1299 | which is the \"original\" code (the BODY), so the hook function can wrap | ||
| 1300 | the original function, or call it any number of times (including not calling | ||
| 1301 | it at all). This is similar to an `around' advice. | ||
| 1302 | VAR is normally a symbol (a variable) in which case it is treated like | ||
| 1303 | a hook, with a buffer-local and a global part. But it can also be an | ||
| 1304 | arbitrary expression. | ||
| 1305 | ARGS is a list of variables which will be passed as additional arguments | ||
| 1306 | to each function, after the initial argument, and which the first argument | ||
| 1307 | expects to receive when called." | ||
| 1308 | (declare (indent 2) (debug t)) | ||
| 1309 | ;; We need those two gensyms because CL's lexical scoping is not available | ||
| 1310 | ;; for function arguments :-( | ||
| 1311 | (let ((funs (make-symbol "funs")) | ||
| 1312 | (global (make-symbol "global")) | ||
| 1313 | (argssym (make-symbol "args")) | ||
| 1314 | (runrestofhook (make-symbol "runrestofhook"))) | ||
| 1315 | ;; Since the hook is a wrapper, the loop has to be done via | ||
| 1316 | ;; recursion: a given hook function will call its parameter in order to | ||
| 1317 | ;; continue looping. | ||
| 1318 | `(letrec ((,runrestofhook | ||
| 1319 | (lambda (,funs ,global ,argssym) | ||
| 1320 | ;; `funs' holds the functions left on the hook and `global' | ||
| 1321 | ;; holds the functions left on the global part of the hook | ||
| 1322 | ;; (in case the hook is local). | ||
| 1323 | (if (consp ,funs) | ||
| 1324 | (if (eq t (car ,funs)) | ||
| 1325 | (funcall ,runrestofhook | ||
| 1326 | (append ,global (cdr ,funs)) nil ,argssym) | ||
| 1327 | (apply (car ,funs) | ||
| 1328 | (apply-partially | ||
| 1329 | (lambda (,funs ,global &rest ,argssym) | ||
| 1330 | (funcall ,runrestofhook ,funs ,global ,argssym)) | ||
| 1331 | (cdr ,funs) ,global) | ||
| 1332 | ,argssym)) | ||
| 1333 | ;; Once there are no more functions on the hook, run | ||
| 1334 | ;; the original body. | ||
| 1335 | (apply (lambda ,args ,@body) ,argssym))))) | ||
| 1336 | (funcall ,runrestofhook ,var | ||
| 1337 | ;; The global part of the hook, if any. | ||
| 1338 | ,(if (symbolp var) | ||
| 1339 | `(if (local-variable-p ',var) | ||
| 1340 | (default-value ',var))) | ||
| 1341 | (list ,@args))))) | ||
| 1342 | |||
| 1261 | (defun add-to-list (list-var element &optional append compare-fn) | 1343 | (defun add-to-list (list-var element &optional append compare-fn) |
| 1262 | "Add ELEMENT to the value of LIST-VAR if it isn't there yet. | 1344 | "Add ELEMENT to the value of LIST-VAR if it isn't there yet. |
| 1263 | The test for presence of ELEMENT is done with `equal', | 1345 | The test for presence of ELEMENT is done with `equal', |
| @@ -1630,6 +1712,8 @@ This function makes or adds to an entry on `after-load-alist'." | |||
| 1630 | (unless elt | 1712 | (unless elt |
| 1631 | (setq elt (list regexp-or-feature)) | 1713 | (setq elt (list regexp-or-feature)) |
| 1632 | (push elt after-load-alist)) | 1714 | (push elt after-load-alist)) |
| 1715 | ;; Make sure `form' is evalled in the current lexical/dynamic code. | ||
| 1716 | (setq form `(funcall ',(eval `(lambda () ,form) lexical-binding))) | ||
| 1633 | (when (symbolp regexp-or-feature) | 1717 | (when (symbolp regexp-or-feature) |
| 1634 | ;; For features, the after-load-alist elements get run when `provide' is | 1718 | ;; For features, the after-load-alist elements get run when `provide' is |
| 1635 | ;; called rather than at the end of the file. So add an indirection to | 1719 | ;; called rather than at the end of the file. So add an indirection to |
| @@ -2763,6 +2847,71 @@ nor the buffer list." | |||
| 2763 | (when (buffer-live-p ,old-buffer) | 2847 | (when (buffer-live-p ,old-buffer) |
| 2764 | (set-buffer ,old-buffer)))))) | 2848 | (set-buffer ,old-buffer)))))) |
| 2765 | 2849 | ||
| 2850 | (defmacro save-window-excursion (&rest body) | ||
| 2851 | "Execute BODY, preserving window sizes and contents. | ||
| 2852 | Return the value of the last form in BODY. | ||
| 2853 | Restore which buffer appears in which window, where display starts, | ||
| 2854 | and the value of point and mark for each window. | ||
| 2855 | Also restore the choice of selected window. | ||
| 2856 | Also restore which buffer is current. | ||
| 2857 | Does not restore the value of point in current buffer. | ||
| 2858 | |||
| 2859 | BEWARE: Most uses of this macro introduce bugs. | ||
| 2860 | E.g. it should not be used to try and prevent some code from opening | ||
| 2861 | a new window, since that window may sometimes appear in another frame, | ||
| 2862 | in which case `save-window-excursion' cannot help." | ||
| 2863 | (declare (indent 0) (debug t)) | ||
| 2864 | (let ((c (make-symbol "wconfig"))) | ||
| 2865 | `(let ((,c (current-window-configuration))) | ||
| 2866 | (unwind-protect (progn ,@body) | ||
| 2867 | (set-window-configuration ,c))))) | ||
| 2868 | |||
| 2869 | (defmacro with-output-to-temp-buffer (bufname &rest body) | ||
| 2870 | "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. | ||
| 2871 | |||
| 2872 | This construct makes buffer BUFNAME empty before running BODY. | ||
| 2873 | It does not make the buffer current for BODY. | ||
| 2874 | Instead it binds `standard-output' to that buffer, so that output | ||
| 2875 | generated with `prin1' and similar functions in BODY goes into | ||
| 2876 | the buffer. | ||
| 2877 | |||
| 2878 | At the end of BODY, this marks buffer BUFNAME unmodifed and displays | ||
| 2879 | it in a window, but does not select it. The normal way to do this is | ||
| 2880 | by calling `display-buffer', then running `temp-buffer-show-hook'. | ||
| 2881 | However, if `temp-buffer-show-function' is non-nil, it calls that | ||
| 2882 | function instead (and does not run `temp-buffer-show-hook'). The | ||
| 2883 | function gets one argument, the buffer to display. | ||
| 2884 | |||
| 2885 | The return value of `with-output-to-temp-buffer' is the value of the | ||
| 2886 | last form in BODY. If BODY does not finish normally, the buffer | ||
| 2887 | BUFNAME is not displayed. | ||
| 2888 | |||
| 2889 | This runs the hook `temp-buffer-setup-hook' before BODY, | ||
| 2890 | with the buffer BUFNAME temporarily current. It runs the hook | ||
| 2891 | `temp-buffer-show-hook' after displaying buffer BUFNAME, with that | ||
| 2892 | buffer temporarily current, and the window that was used to display it | ||
| 2893 | temporarily selected. But it doesn't run `temp-buffer-show-hook' | ||
| 2894 | if it uses `temp-buffer-show-function'." | ||
| 2895 | (let ((old-dir (make-symbol "old-dir")) | ||
| 2896 | (buf (make-symbol "buf"))) | ||
| 2897 | `(let* ((,old-dir default-directory) | ||
| 2898 | (,buf | ||
| 2899 | (with-current-buffer (get-buffer-create ,bufname) | ||
| 2900 | (prog1 (current-buffer) | ||
| 2901 | (kill-all-local-variables) | ||
| 2902 | ;; FIXME: delete_all_overlays | ||
| 2903 | (setq default-directory ,old-dir) | ||
| 2904 | (setq buffer-read-only nil) | ||
| 2905 | (setq buffer-file-name nil) | ||
| 2906 | (setq buffer-undo-list t) | ||
| 2907 | (let ((inhibit-read-only t) | ||
| 2908 | (inhibit-modification-hooks t)) | ||
| 2909 | (erase-buffer) | ||
| 2910 | (run-hooks 'temp-buffer-setup-hook))))) | ||
| 2911 | (standard-output ,buf)) | ||
| 2912 | (prog1 (progn ,@body) | ||
| 2913 | (internal-temp-output-buffer-show ,buf))))) | ||
| 2914 | |||
| 2766 | (defmacro with-temp-file (file &rest body) | 2915 | (defmacro with-temp-file (file &rest body) |
| 2767 | "Create a new buffer, evaluate BODY there, and write the buffer to FILE. | 2916 | "Create a new buffer, evaluate BODY there, and write the buffer to FILE. |
| 2768 | The value returned is the value of the last form in BODY. | 2917 | The value returned is the value of the last form in BODY. |
diff --git a/lisp/textmodes/bibtex-style.el b/lisp/textmodes/bibtex-style.el index 831d4e86676..bc5326240a3 100644 --- a/lisp/textmodes/bibtex-style.el +++ b/lisp/textmodes/bibtex-style.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; bibtex-style.el --- Major mode for BibTeX Style files | 1 | ;;; bibtex-style.el --- Major mode for BibTeX Style files -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -141,7 +141,7 @@ | |||
| 141 | (looking-at "if\\$")) | 141 | (looking-at "if\\$")) |
| 142 | (scan-error nil)))) | 142 | (scan-error nil)))) |
| 143 | (save-excursion | 143 | (save-excursion |
| 144 | (condition-case err | 144 | (condition-case nil |
| 145 | (while (progn | 145 | (while (progn |
| 146 | (backward-sexp 1) | 146 | (backward-sexp 1) |
| 147 | (save-excursion (skip-chars-backward " \t{") (not (bolp))))) | 147 | (save-excursion (skip-chars-backward " \t{") (not (bolp))))) |
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index b611261723a..ef51fb25035 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; css-mode.el --- Major mode to edit CSS files | 1 | ;;; css-mode.el --- Major mode to edit CSS files -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2006-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2006-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
diff --git a/lisp/uniquify.el b/lisp/uniquify.el index e894127cdb1..3153e143ba3 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; uniquify.el --- unique buffer names dependent on file name | 1 | ;;; uniquify.el --- unique buffer names dependent on file name -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1989, 1995-1997, 2001-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1989, 1995-1997, 2001-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el index 7354e616c99..063eb414579 100644 --- a/lisp/vc/cvs-status.el +++ b/lisp/vc/cvs-status.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*- | 1 | ;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8; lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -87,6 +87,12 @@ | |||
| 87 | '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t))) | 87 | '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t))) |
| 88 | 88 | ||
| 89 | (defvar cvs-minor-wrap-function) | 89 | (defvar cvs-minor-wrap-function) |
| 90 | (defvar cvs-force-command) | ||
| 91 | (defvar cvs-minor-current-files) | ||
| 92 | (defvar cvs-secondary-branch-prefix) | ||
| 93 | (defvar cvs-branch-prefix) | ||
| 94 | (defvar cvs-tag-print-rev) | ||
| 95 | |||
| 90 | (put 'cvs-status-mode 'mode-class 'special) | 96 | (put 'cvs-status-mode 'mode-class 'special) |
| 91 | ;;;###autoload | 97 | ;;;###autoload |
| 92 | (define-derived-mode cvs-status-mode fundamental-mode "CVS-Status" | 98 | (define-derived-mode cvs-status-mode fundamental-mode "CVS-Status" |
| @@ -472,7 +478,7 @@ Optional prefix ARG chooses between two representations." | |||
| 472 | (nprev (if (and cvs-tree-nomerge next | 478 | (nprev (if (and cvs-tree-nomerge next |
| 473 | (equal vlist (cvs-tag->vlist next))) | 479 | (equal vlist (cvs-tag->vlist next))) |
| 474 | prev vlist))) | 480 | prev vlist))) |
| 475 | (cvs-map (lambda (v p) v) nprev prev))) | 481 | (cvs-map (lambda (v _p) v) nprev prev))) |
| 476 | (after (save-excursion | 482 | (after (save-excursion |
| 477 | (newline) | 483 | (newline) |
| 478 | (cvs-tree-tags-insert (cdr tags) nprev))) | 484 | (cvs-tree-tags-insert (cdr tags) nprev))) |
| @@ -512,24 +518,24 @@ Optional prefix ARG chooses between two representations." | |||
| 512 | ;;;; Merged trees from different files | 518 | ;;;; Merged trees from different files |
| 513 | ;;;; | 519 | ;;;; |
| 514 | 520 | ||
| 515 | (defun cvs-tree-fuzzy-merge-1 (trees tree prev) | 521 | ;; (defun cvs-tree-fuzzy-merge-1 (trees tree prev) |
| 516 | ) | 522 | ;; ) |
| 517 | 523 | ||
| 518 | (defun cvs-tree-fuzzy-merge (trees tree) | 524 | ;; (defun cvs-tree-fuzzy-merge (trees tree) |
| 519 | "Do the impossible: merge TREE into TREES." | 525 | ;; "Do the impossible: merge TREE into TREES." |
| 520 | ()) | 526 | ;; ()) |
| 521 | 527 | ||
| 522 | (defun cvs-tree () | 528 | ;; (defun cvs-tree () |
| 523 | "Get tags from the status output and merge tham all into a big tree." | 529 | ;; "Get tags from the status output and merge them all into a big tree." |
| 524 | (save-excursion | 530 | ;; (save-excursion |
| 525 | (goto-char (point-min)) | 531 | ;; (goto-char (point-min)) |
| 526 | (let ((inhibit-read-only t) | 532 | ;; (let ((inhibit-read-only t) |
| 527 | (trees (make-vector 31 0)) tree) | 533 | ;; (trees (make-vector 31 0)) tree) |
| 528 | (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags)))) | 534 | ;; (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags)))) |
| 529 | (cvs-tree-fuzzy-merge trees tree)) | 535 | ;; (cvs-tree-fuzzy-merge trees tree)) |
| 530 | (erase-buffer) | 536 | ;; (erase-buffer) |
| 531 | (let ((cvs-tag-print-rev nil)) | 537 | ;; (let ((cvs-tag-print-rev nil)) |
| 532 | (cvs-tree-print tree 'cvs-tag->string 3))))) | 538 | ;; (cvs-tree-print tree 'cvs-tag->string 3))))) |
| 533 | 539 | ||
| 534 | 540 | ||
| 535 | (provide 'cvs-status) | 541 | (provide 'cvs-status) |
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 72f415a9b94..50f20cea779 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; diff-mode.el --- a mode for viewing/editing context diffs | 1 | ;;; diff-mode.el --- a mode for viewing/editing context diffs -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1998-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1998-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -814,7 +814,7 @@ PREFIX is only used internally: don't use it." | |||
| 814 | (defun diff-ediff-patch () | 814 | (defun diff-ediff-patch () |
| 815 | "Call `ediff-patch-file' on the current buffer." | 815 | "Call `ediff-patch-file' on the current buffer." |
| 816 | (interactive) | 816 | (interactive) |
| 817 | (condition-case err | 817 | (condition-case nil |
| 818 | (ediff-patch-file nil (current-buffer)) | 818 | (ediff-patch-file nil (current-buffer)) |
| 819 | (wrong-number-of-arguments (ediff-patch-file)))) | 819 | (wrong-number-of-arguments (ediff-patch-file)))) |
| 820 | 820 | ||
| @@ -1171,7 +1171,7 @@ else cover the whole buffer." | |||
| 1171 | ;; *-change-function is asking for trouble, whereas making them | 1171 | ;; *-change-function is asking for trouble, whereas making them |
| 1172 | ;; from a post-command-hook doesn't pose much problems | 1172 | ;; from a post-command-hook doesn't pose much problems |
| 1173 | (defvar diff-unhandled-changes nil) | 1173 | (defvar diff-unhandled-changes nil) |
| 1174 | (defun diff-after-change-function (beg end len) | 1174 | (defun diff-after-change-function (beg end _len) |
| 1175 | "Remember to fixup the hunk header. | 1175 | "Remember to fixup the hunk header. |
| 1176 | See `after-change-functions' for the meaning of BEG, END and LEN." | 1176 | See `after-change-functions' for the meaning of BEG, END and LEN." |
| 1177 | ;; Ignoring changes when inhibit-read-only is set is strictly speaking | 1177 | ;; Ignoring changes when inhibit-read-only is set is strictly speaking |
| @@ -1281,7 +1281,7 @@ a diff with \\[diff-reverse-direction]. | |||
| 1281 | (add-hook 'after-change-functions 'diff-after-change-function nil t) | 1281 | (add-hook 'after-change-functions 'diff-after-change-function nil t) |
| 1282 | (add-hook 'post-command-hook 'diff-post-command-hook nil t)) | 1282 | (add-hook 'post-command-hook 'diff-post-command-hook nil t)) |
| 1283 | ;; Neat trick from Dave Love to add more bindings in read-only mode: | 1283 | ;; Neat trick from Dave Love to add more bindings in read-only mode: |
| 1284 | (lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map))) | 1284 | (let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map))) |
| 1285 | (add-to-list 'minor-mode-overriding-map-alist ro-bind) | 1285 | (add-to-list 'minor-mode-overriding-map-alist ro-bind) |
| 1286 | ;; Turn off this little trick in case the buffer is put in view-mode. | 1286 | ;; Turn off this little trick in case the buffer is put in view-mode. |
| 1287 | (add-hook 'view-mode-hook | 1287 | (add-hook 'view-mode-hook |
| @@ -1693,7 +1693,7 @@ With a prefix argument, REVERSE the hunk." | |||
| 1693 | "See whether it's possible to apply the current hunk. | 1693 | "See whether it's possible to apply the current hunk. |
| 1694 | With a prefix argument, try to REVERSE the hunk." | 1694 | With a prefix argument, try to REVERSE the hunk." |
| 1695 | (interactive "P") | 1695 | (interactive "P") |
| 1696 | (destructuring-bind (buf line-offset pos src dst &optional switched) | 1696 | (destructuring-bind (buf line-offset pos src _dst &optional switched) |
| 1697 | (diff-find-source-location nil reverse) | 1697 | (diff-find-source-location nil reverse) |
| 1698 | (set-window-point (display-buffer buf) (+ (car pos) (cdr src))) | 1698 | (set-window-point (display-buffer buf) (+ (car pos) (cdr src))) |
| 1699 | (diff-hunk-status-msg line-offset (diff-xor reverse switched) t))) | 1699 | (diff-hunk-status-msg line-offset (diff-xor reverse switched) t))) |
| @@ -1713,7 +1713,7 @@ then `diff-jump-to-old-file' is also set, for the next invocations." | |||
| 1713 | ;; This is a convenient detail when using smerge-diff. | 1713 | ;; This is a convenient detail when using smerge-diff. |
| 1714 | (if event (posn-set-point (event-end event))) | 1714 | (if event (posn-set-point (event-end event))) |
| 1715 | (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) | 1715 | (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) |
| 1716 | (destructuring-bind (buf line-offset pos src dst &optional switched) | 1716 | (destructuring-bind (buf line-offset pos src _dst &optional switched) |
| 1717 | (diff-find-source-location other-file rev) | 1717 | (diff-find-source-location other-file rev) |
| 1718 | (pop-to-buffer buf) | 1718 | (pop-to-buffer buf) |
| 1719 | (goto-char (+ (car pos) (cdr src))) | 1719 | (goto-char (+ (car pos) (cdr src))) |
| @@ -1731,7 +1731,7 @@ For use in `add-log-current-defun-function'." | |||
| 1731 | (when (looking-at diff-hunk-header-re) | 1731 | (when (looking-at diff-hunk-header-re) |
| 1732 | (forward-line 1) | 1732 | (forward-line 1) |
| 1733 | (re-search-forward "^[^ ]" nil t)) | 1733 | (re-search-forward "^[^ ]" nil t)) |
| 1734 | (destructuring-bind (&optional buf line-offset pos src dst switched) | 1734 | (destructuring-bind (&optional buf _line-offset pos src dst switched) |
| 1735 | ;; Use `noprompt' since this is used in which-func-mode and such. | 1735 | ;; Use `noprompt' since this is used in which-func-mode and such. |
| 1736 | (ignore-errors ;Signals errors in place of prompting. | 1736 | (ignore-errors ;Signals errors in place of prompting. |
| 1737 | (diff-find-source-location nil nil 'noprompt)) | 1737 | (diff-find-source-location nil nil 'noprompt)) |
| @@ -1879,28 +1879,27 @@ I.e. like `add-change-log-entry-other-window' but applied to all hunks." | |||
| 1879 | ;; good to call it for each change. | 1879 | ;; good to call it for each change. |
| 1880 | (save-excursion | 1880 | (save-excursion |
| 1881 | (goto-char (point-min)) | 1881 | (goto-char (point-min)) |
| 1882 | (let ((orig-buffer (current-buffer))) | 1882 | (condition-case nil |
| 1883 | (condition-case nil | 1883 | ;; Call add-change-log-entry-other-window for each hunk in |
| 1884 | ;; Call add-change-log-entry-other-window for each hunk in | 1884 | ;; the diff buffer. |
| 1885 | ;; the diff buffer. | 1885 | (while (progn |
| 1886 | (while (progn | 1886 | (diff-hunk-next) |
| 1887 | (diff-hunk-next) | 1887 | ;; Move to where the changes are, |
| 1888 | ;; Move to where the changes are, | 1888 | ;; `add-change-log-entry-other-window' works better in |
| 1889 | ;; `add-change-log-entry-other-window' works better in | 1889 | ;; that case. |
| 1890 | ;; that case. | 1890 | (re-search-forward |
| 1891 | (re-search-forward | 1891 | (concat "\n[!+-<>]" |
| 1892 | (concat "\n[!+-<>]" | 1892 | ;; If the hunk is a context hunk with an empty first |
| 1893 | ;; If the hunk is a context hunk with an empty first | 1893 | ;; half, recognize the "--- NNN,MMM ----" line |
| 1894 | ;; half, recognize the "--- NNN,MMM ----" line | 1894 | "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n" |
| 1895 | "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n" | 1895 | ;; and skip to the next non-context line. |
| 1896 | ;; and skip to the next non-context line. | 1896 | "\\( .*\n\\)*[+]\\)?") |
| 1897 | "\\( .*\n\\)*[+]\\)?") | 1897 | nil t)) |
| 1898 | nil t)) | 1898 | (save-excursion |
| 1899 | (save-excursion | 1899 | ;; FIXME: this pops up windows of all the buffers. |
| 1900 | ;; FIXME: this pops up windows of all the buffers. | 1900 | (add-change-log-entry nil nil t nil t))) |
| 1901 | (add-change-log-entry nil nil t nil t))) | 1901 | ;; When there's no more hunks, diff-hunk-next signals an error. |
| 1902 | ;; When there's no more hunks, diff-hunk-next signals an error. | 1902 | (error nil)))) |
| 1903 | (error nil))))) | ||
| 1904 | 1903 | ||
| 1905 | ;; provide the package | 1904 | ;; provide the package |
| 1906 | (provide 'diff-mode) | 1905 | (provide 'diff-mode) |
diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 192ab1f78d2..54a2cb4f196 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; log-edit.el --- Major mode for editing CVS commit messages | 1 | ;;; log-edit.el --- Major mode for editing CVS commit messages -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -329,7 +329,7 @@ automatically." | |||
| 329 | (defconst log-edit-header-contents-regexp | 329 | (defconst log-edit-header-contents-regexp |
| 330 | "[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?") | 330 | "[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?") |
| 331 | 331 | ||
| 332 | (defun log-edit-match-to-eoh (limit) | 332 | (defun log-edit-match-to-eoh (_limit) |
| 333 | ;; FIXME: copied from message-match-to-eoh. | 333 | ;; FIXME: copied from message-match-to-eoh. |
| 334 | (let ((start (point))) | 334 | (let ((start (point))) |
| 335 | (rfc822-goto-eoh) | 335 | (rfc822-goto-eoh) |
| @@ -361,7 +361,7 @@ automatically." | |||
| 361 | nil lax))))) | 361 | nil lax))))) |
| 362 | 362 | ||
| 363 | ;;;###autoload | 363 | ;;;###autoload |
| 364 | (defun log-edit (callback &optional setup params buffer mode &rest ignore) | 364 | (defun log-edit (callback &optional setup params buffer mode &rest _ignore) |
| 365 | "Setup a buffer to enter a log message. | 365 | "Setup a buffer to enter a log message. |
| 366 | \\<log-edit-mode-map>The buffer will be put in mode MODE or `log-edit-mode' | 366 | \\<log-edit-mode-map>The buffer will be put in mode MODE or `log-edit-mode' |
| 367 | if MODE is nil. | 367 | if MODE is nil. |
diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index cb1c181fa61..9f6ad19fdb1 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output | 1 | ;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -115,6 +115,7 @@ | |||
| 115 | (autoload 'vc-diff-internal "vc") | 115 | (autoload 'vc-diff-internal "vc") |
| 116 | 116 | ||
| 117 | (defvar cvs-minor-wrap-function) | 117 | (defvar cvs-minor-wrap-function) |
| 118 | (defvar cvs-force-command) | ||
| 118 | 119 | ||
| 119 | (defgroup log-view nil | 120 | (defgroup log-view nil |
| 120 | "Major mode for browsing log output of RCS/CVS/SCCS." | 121 | "Major mode for browsing log output of RCS/CVS/SCCS." |
diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index 37cdd41ee55..75e3b514531 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts | 1 | ;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts -*- lexical-binding: t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. |
| 4 | 4 | ||
diff --git a/src/ChangeLog b/src/ChangeLog index 99447fd8748..56400fbb08f 100644 --- a/src/ChangeLog +++ b/src/ChangeLog | |||
| @@ -35,6 +35,64 @@ | |||
| 35 | * deps.mk (sysdep.o): Depend on ../lib/allocator.h and on | 35 | * deps.mk (sysdep.o): Depend on ../lib/allocator.h and on |
| 36 | ../lib/careadlinkat.h. | 36 | ../lib/careadlinkat.h. |
| 37 | 37 | ||
| 38 | 2011-04-01 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 39 | |||
| 40 | Add lexical binding. | ||
| 41 | |||
| 42 | * window.c (Ftemp_output_buffer_show): New fun. | ||
| 43 | (Fsave_window_excursion): | ||
| 44 | * print.c (Fwith_output_to_temp_buffer): Move to subr.el. | ||
| 45 | |||
| 46 | * lread.c (lisp_file_lexically_bound_p): New function. | ||
| 47 | (Fload): Bind Qlexical_binding. | ||
| 48 | (readevalloop): Remove `evalfun' arg. | ||
| 49 | Bind Qinternal_interpreter_environment. | ||
| 50 | (Feval_buffer): Bind Qlexical_binding. | ||
| 51 | (defvar_int, defvar_bool, defvar_lisp_nopro, defvar_kboard): | ||
| 52 | Mark as dynamic. | ||
| 53 | (syms_of_lread): Declare `lexical-binding'. | ||
| 54 | |||
| 55 | * lisp.h (struct Lisp_Symbol): New field `declared_special'. | ||
| 56 | |||
| 57 | * keyboard.c (eval_dyn): New fun. | ||
| 58 | (menu_item_eval_property): Use it. | ||
| 59 | |||
| 60 | * image.c (parse_image_spec): Use Ffunctionp. | ||
| 61 | |||
| 62 | * fns.c (concat, mapcar1): Accept byte-code-functions. | ||
| 63 | |||
| 64 | * eval.c (Fsetq): Handle lexical vars. | ||
| 65 | (Fdefun, Fdefmacro, Ffunction): Make closures when needed. | ||
| 66 | (Fdefconst, Fdefvaralias, Fdefvar): Mark as dynamic. | ||
| 67 | (FletX, Flet): Obey lexical binding. | ||
| 68 | (Fcommandp): Handle closures. | ||
| 69 | (Feval): New `lexical' arg. | ||
| 70 | (eval_sub): New function extracted from Feval. Use it almost | ||
| 71 | everywhere where Feval was used. Look up vars in lexical env. | ||
| 72 | Handle closures. | ||
| 73 | (Ffunctionp): Move from subr.el. | ||
| 74 | (Ffuncall): Handle closures. | ||
| 75 | (apply_lambda): Remove `eval_flags'. | ||
| 76 | (funcall_lambda): Handle closures and new byte-code-functions. | ||
| 77 | (Fspecial_variable_p): New function. | ||
| 78 | (syms_of_eval): Initialize the Vinternal_interpreter_environment var, | ||
| 79 | but without exporting it to Lisp. | ||
| 80 | |||
| 81 | * doc.c (Fdocumentation, store_function_docstring): | ||
| 82 | * data.c (Finteractive_form): Handle closures. | ||
| 83 | |||
| 84 | * callint.c (Fcall_interactively): Preserve lexical-binding mode for | ||
| 85 | interactive spec. | ||
| 86 | |||
| 87 | * bytecode.c (Bstack_ref, Bstack_set, Bstack_set2, BdiscardN): New | ||
| 88 | byte-codes. | ||
| 89 | (exec_byte_code): New function extracted from Fbyte_code to handle new | ||
| 90 | calling convention for byte-code-functions. Add new byte-codes. | ||
| 91 | |||
| 92 | * buffer.c (defvar_per_buffer): Set new `declared_special' field. | ||
| 93 | |||
| 94 | * alloc.c (Fmake_symbol): Init new `declared_special' field. | ||
| 95 | |||
| 38 | 2011-03-31 Juanma Barranquero <lekktu@gmail.com> | 96 | 2011-03-31 Juanma Barranquero <lekktu@gmail.com> |
| 39 | 97 | ||
| 40 | * xdisp.c (redisplay_internal): Fix prototype. | 98 | * xdisp.c (redisplay_internal): Fix prototype. |
diff --git a/src/alloc.c b/src/alloc.c index 177a2266fb6..07f1caae46b 100644 --- a/src/alloc.c +++ b/src/alloc.c | |||
| @@ -2940,10 +2940,19 @@ usage: (vector &rest OBJECTS) */) | |||
| 2940 | 2940 | ||
| 2941 | DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, | 2941 | DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, |
| 2942 | doc: /* Create a byte-code object with specified arguments as elements. | 2942 | doc: /* Create a byte-code object with specified arguments as elements. |
| 2943 | The arguments should be the arglist, bytecode-string, constant vector, | 2943 | The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant |
| 2944 | stack size, (optional) doc string, and (optional) interactive spec. | 2944 | vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING, |
| 2945 | and (optional) INTERACTIVE-SPEC. | ||
| 2945 | The first four arguments are required; at most six have any | 2946 | The first four arguments are required; at most six have any |
| 2946 | significance. | 2947 | significance. |
| 2948 | The ARGLIST can be either like the one of `lambda', in which case the arguments | ||
| 2949 | will be dynamically bound before executing the byte code, or it can be an | ||
| 2950 | integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the | ||
| 2951 | minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number | ||
| 2952 | of arguments (ignoring &rest) and the R bit specifies whether there is a &rest | ||
| 2953 | argument to catch the left-over arguments. If such an integer is used, the | ||
| 2954 | arguments will not be dynamically bound but will be instead pushed on the | ||
| 2955 | stack before executing the byte-code. | ||
| 2947 | usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) | 2956 | usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) |
| 2948 | (register size_t nargs, Lisp_Object *args) | 2957 | (register size_t nargs, Lisp_Object *args) |
| 2949 | { | 2958 | { |
| @@ -3071,6 +3080,7 @@ Its value and function definition are void, and its property list is nil. */) | |||
| 3071 | p->gcmarkbit = 0; | 3080 | p->gcmarkbit = 0; |
| 3072 | p->interned = SYMBOL_UNINTERNED; | 3081 | p->interned = SYMBOL_UNINTERNED; |
| 3073 | p->constant = 0; | 3082 | p->constant = 0; |
| 3083 | p->declared_special = 0; | ||
| 3074 | consing_since_gc += sizeof (struct Lisp_Symbol); | 3084 | consing_since_gc += sizeof (struct Lisp_Symbol); |
| 3075 | symbols_consed++; | 3085 | symbols_consed++; |
| 3076 | return val; | 3086 | return val; |
diff --git a/src/buffer.c b/src/buffer.c index 8b56b285e48..cdcd2ccecff 100644 --- a/src/buffer.c +++ b/src/buffer.c | |||
| @@ -5240,6 +5240,7 @@ defvar_per_buffer (struct Lisp_Buffer_Objfwd *bo_fwd, const char *namestring, | |||
| 5240 | bo_fwd->type = Lisp_Fwd_Buffer_Obj; | 5240 | bo_fwd->type = Lisp_Fwd_Buffer_Obj; |
| 5241 | bo_fwd->offset = offset; | 5241 | bo_fwd->offset = offset; |
| 5242 | bo_fwd->slottype = type; | 5242 | bo_fwd->slottype = type; |
| 5243 | sym->declared_special = 1; | ||
| 5243 | sym->redirect = SYMBOL_FORWARDED; | 5244 | sym->redirect = SYMBOL_FORWARDED; |
| 5244 | { | 5245 | { |
| 5245 | /* I tried to do the job without a cast, but it seems impossible. | 5246 | /* I tried to do the job without a cast, but it seems impossible. |
diff --git a/src/bytecode.c b/src/bytecode.c index 5a62c913a40..5879d312b07 100644 --- a/src/bytecode.c +++ b/src/bytecode.c | |||
| @@ -80,9 +80,11 @@ Lisp_Object Qbyte_code_meter; | |||
| 80 | 80 | ||
| 81 | 81 | ||
| 82 | Lisp_Object Qbytecode; | 82 | Lisp_Object Qbytecode; |
| 83 | extern Lisp_Object Qand_optional, Qand_rest; | ||
| 83 | 84 | ||
| 84 | /* Byte codes: */ | 85 | /* Byte codes: */ |
| 85 | 86 | ||
| 87 | #define Bstack_ref 0 /* Actually, Bstack_ref+0 is not implemented: use dup. */ | ||
| 86 | #define Bvarref 010 | 88 | #define Bvarref 010 |
| 87 | #define Bvarset 020 | 89 | #define Bvarset 020 |
| 88 | #define Bvarbind 030 | 90 | #define Bvarbind 030 |
| @@ -132,7 +134,7 @@ Lisp_Object Qbytecode; | |||
| 132 | 134 | ||
| 133 | #define Bpoint 0140 | 135 | #define Bpoint 0140 |
| 134 | /* Was Bmark in v17. */ | 136 | /* Was Bmark in v17. */ |
| 135 | #define Bsave_current_buffer 0141 | 137 | #define Bsave_current_buffer 0141 /* Obsolete. */ |
| 136 | #define Bgoto_char 0142 | 138 | #define Bgoto_char 0142 |
| 137 | #define Binsert 0143 | 139 | #define Binsert 0143 |
| 138 | #define Bpoint_max 0144 | 140 | #define Bpoint_max 0144 |
| @@ -158,7 +160,7 @@ Lisp_Object Qbytecode; | |||
| 158 | #ifdef BYTE_CODE_SAFE | 160 | #ifdef BYTE_CODE_SAFE |
| 159 | #define Bset_mark 0163 /* this loser is no longer generated as of v18 */ | 161 | #define Bset_mark 0163 /* this loser is no longer generated as of v18 */ |
| 160 | #endif | 162 | #endif |
| 161 | #define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */ | 163 | #define Binteractive_p 0164 /* Obsolete since Emacs-24.1. */ |
| 162 | 164 | ||
| 163 | #define Bforward_char 0165 | 165 | #define Bforward_char 0165 |
| 164 | #define Bforward_word 0166 | 166 | #define Bforward_word 0166 |
| @@ -183,16 +185,16 @@ Lisp_Object Qbytecode; | |||
| 183 | #define Bdup 0211 | 185 | #define Bdup 0211 |
| 184 | 186 | ||
| 185 | #define Bsave_excursion 0212 | 187 | #define Bsave_excursion 0212 |
| 186 | #define Bsave_window_excursion 0213 | 188 | #define Bsave_window_excursion 0213 /* Obsolete since Emacs-24.1. */ |
| 187 | #define Bsave_restriction 0214 | 189 | #define Bsave_restriction 0214 |
| 188 | #define Bcatch 0215 | 190 | #define Bcatch 0215 |
| 189 | 191 | ||
| 190 | #define Bunwind_protect 0216 | 192 | #define Bunwind_protect 0216 |
| 191 | #define Bcondition_case 0217 | 193 | #define Bcondition_case 0217 |
| 192 | #define Btemp_output_buffer_setup 0220 | 194 | #define Btemp_output_buffer_setup 0220 /* Obsolete since Emacs-24.1. */ |
| 193 | #define Btemp_output_buffer_show 0221 | 195 | #define Btemp_output_buffer_show 0221 /* Obsolete since Emacs-24.1. */ |
| 194 | 196 | ||
| 195 | #define Bunbind_all 0222 | 197 | #define Bunbind_all 0222 /* Obsolete. Never used. */ |
| 196 | 198 | ||
| 197 | #define Bset_marker 0223 | 199 | #define Bset_marker 0223 |
| 198 | #define Bmatch_beginning 0224 | 200 | #define Bmatch_beginning 0224 |
| @@ -228,6 +230,11 @@ Lisp_Object Qbytecode; | |||
| 228 | #define BconcatN 0260 | 230 | #define BconcatN 0260 |
| 229 | #define BinsertN 0261 | 231 | #define BinsertN 0261 |
| 230 | 232 | ||
| 233 | /* Bstack_ref is code 0. */ | ||
| 234 | #define Bstack_set 0262 | ||
| 235 | #define Bstack_set2 0263 | ||
| 236 | #define BdiscardN 0266 | ||
| 237 | |||
| 231 | #define Bconstant 0300 | 238 | #define Bconstant 0300 |
| 232 | 239 | ||
| 233 | /* Whether to maintain a `top' and `bottom' field in the stack frame. */ | 240 | /* Whether to maintain a `top' and `bottom' field in the stack frame. */ |
| @@ -414,6 +421,21 @@ the third, MAXDEPTH, the maximum stack depth used in this function. | |||
| 414 | If the third argument is incorrect, Emacs may crash. */) | 421 | If the third argument is incorrect, Emacs may crash. */) |
| 415 | (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth) | 422 | (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth) |
| 416 | { | 423 | { |
| 424 | return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); | ||
| 425 | } | ||
| 426 | |||
| 427 | /* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and | ||
| 428 | MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect, | ||
| 429 | emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp | ||
| 430 | argument list (including &rest, &optional, etc.), and ARGS, of size | ||
| 431 | NARGS, should be a vector of the actual arguments. The arguments in | ||
| 432 | ARGS are pushed on the stack according to ARGS_TEMPLATE before | ||
| 433 | executing BYTESTR. */ | ||
| 434 | |||
| 435 | Lisp_Object | ||
| 436 | exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, | ||
| 437 | Lisp_Object args_template, int nargs, Lisp_Object *args) | ||
| 438 | { | ||
| 417 | int count = SPECPDL_INDEX (); | 439 | int count = SPECPDL_INDEX (); |
| 418 | #ifdef BYTE_CODE_METER | 440 | #ifdef BYTE_CODE_METER |
| 419 | int this_op = 0; | 441 | int this_op = 0; |
| @@ -475,6 +497,52 @@ If the third argument is incorrect, Emacs may crash. */) | |||
| 475 | stacke = stack.bottom - 1 + XFASTINT (maxdepth); | 497 | stacke = stack.bottom - 1 + XFASTINT (maxdepth); |
| 476 | #endif | 498 | #endif |
| 477 | 499 | ||
| 500 | if (INTEGERP (args_template)) | ||
| 501 | { | ||
| 502 | int at = XINT (args_template); | ||
| 503 | int rest = at & 128; | ||
| 504 | int mandatory = at & 127; | ||
| 505 | int nonrest = at >> 8; | ||
| 506 | eassert (mandatory <= nonrest); | ||
| 507 | if (nargs <= nonrest) | ||
| 508 | { | ||
| 509 | int i; | ||
| 510 | for (i = 0 ; i < nargs; i++, args++) | ||
| 511 | PUSH (*args); | ||
| 512 | if (nargs < mandatory) | ||
| 513 | /* Too few arguments. */ | ||
| 514 | Fsignal (Qwrong_number_of_arguments, | ||
| 515 | Fcons (Fcons (make_number (mandatory), | ||
| 516 | rest ? Qand_rest : make_number (nonrest)), | ||
| 517 | Fcons (make_number (nargs), Qnil))); | ||
| 518 | else | ||
| 519 | { | ||
| 520 | for (; i < nonrest; i++) | ||
| 521 | PUSH (Qnil); | ||
| 522 | if (rest) | ||
| 523 | PUSH (Qnil); | ||
| 524 | } | ||
| 525 | } | ||
| 526 | else if (rest) | ||
| 527 | { | ||
| 528 | int i; | ||
| 529 | for (i = 0 ; i < nonrest; i++, args++) | ||
| 530 | PUSH (*args); | ||
| 531 | PUSH (Flist (nargs - nonrest, args)); | ||
| 532 | } | ||
| 533 | else | ||
| 534 | /* Too many arguments. */ | ||
| 535 | Fsignal (Qwrong_number_of_arguments, | ||
| 536 | Fcons (Fcons (make_number (mandatory), | ||
| 537 | make_number (nonrest)), | ||
| 538 | Fcons (make_number (nargs), Qnil))); | ||
| 539 | } | ||
| 540 | else if (! NILP (args_template)) | ||
| 541 | /* We should push some arguments on the stack. */ | ||
| 542 | { | ||
| 543 | error ("Unknown args template!"); | ||
| 544 | } | ||
| 545 | |||
| 478 | while (1) | 546 | while (1) |
| 479 | { | 547 | { |
| 480 | #ifdef BYTE_CODE_SAFE | 548 | #ifdef BYTE_CODE_SAFE |
| @@ -735,7 +803,7 @@ If the third argument is incorrect, Emacs may crash. */) | |||
| 735 | AFTER_POTENTIAL_GC (); | 803 | AFTER_POTENTIAL_GC (); |
| 736 | break; | 804 | break; |
| 737 | 805 | ||
| 738 | case Bunbind_all: | 806 | case Bunbind_all: /* Obsolete. Never used. */ |
| 739 | /* To unbind back to the beginning of this frame. Not used yet, | 807 | /* To unbind back to the beginning of this frame. Not used yet, |
| 740 | but will be needed for tail-recursion elimination. */ | 808 | but will be needed for tail-recursion elimination. */ |
| 741 | BEFORE_POTENTIAL_GC (); | 809 | BEFORE_POTENTIAL_GC (); |
| @@ -863,37 +931,43 @@ If the third argument is incorrect, Emacs may crash. */) | |||
| 863 | save_excursion_save ()); | 931 | save_excursion_save ()); |
| 864 | break; | 932 | break; |
| 865 | 933 | ||
| 866 | case Bsave_current_buffer: | 934 | case Bsave_current_buffer: /* Obsolete since ??. */ |
| 867 | case Bsave_current_buffer_1: | 935 | case Bsave_current_buffer_1: |
| 868 | record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ()); | 936 | record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ()); |
| 869 | break; | 937 | break; |
| 870 | 938 | ||
| 871 | case Bsave_window_excursion: | 939 | case Bsave_window_excursion: /* Obsolete since 24.1. */ |
| 872 | BEFORE_POTENTIAL_GC (); | 940 | { |
| 873 | TOP = Fsave_window_excursion (TOP); | 941 | register int count = SPECPDL_INDEX (); |
| 874 | AFTER_POTENTIAL_GC (); | 942 | record_unwind_protect (Fset_window_configuration, |
| 875 | break; | 943 | Fcurrent_window_configuration (Qnil)); |
| 944 | BEFORE_POTENTIAL_GC (); | ||
| 945 | TOP = Fprogn (TOP); | ||
| 946 | unbind_to (count, TOP); | ||
| 947 | AFTER_POTENTIAL_GC (); | ||
| 948 | break; | ||
| 949 | } | ||
| 876 | 950 | ||
| 877 | case Bsave_restriction: | 951 | case Bsave_restriction: |
| 878 | record_unwind_protect (save_restriction_restore, | 952 | record_unwind_protect (save_restriction_restore, |
| 879 | save_restriction_save ()); | 953 | save_restriction_save ()); |
| 880 | break; | 954 | break; |
| 881 | 955 | ||
| 882 | case Bcatch: | 956 | case Bcatch: /* FIXME: ill-suited for lexbind */ |
| 883 | { | 957 | { |
| 884 | Lisp_Object v1; | 958 | Lisp_Object v1; |
| 885 | BEFORE_POTENTIAL_GC (); | 959 | BEFORE_POTENTIAL_GC (); |
| 886 | v1 = POP; | 960 | v1 = POP; |
| 887 | TOP = internal_catch (TOP, Feval, v1); | 961 | TOP = internal_catch (TOP, eval_sub, v1); |
| 888 | AFTER_POTENTIAL_GC (); | 962 | AFTER_POTENTIAL_GC (); |
| 889 | break; | 963 | break; |
| 890 | } | 964 | } |
| 891 | 965 | ||
| 892 | case Bunwind_protect: | 966 | case Bunwind_protect: /* FIXME: avoid closure for lexbind */ |
| 893 | record_unwind_protect (Fprogn, POP); | 967 | record_unwind_protect (Fprogn, POP); |
| 894 | break; | 968 | break; |
| 895 | 969 | ||
| 896 | case Bcondition_case: | 970 | case Bcondition_case: /* FIXME: ill-suited for lexbind */ |
| 897 | { | 971 | { |
| 898 | Lisp_Object handlers, body; | 972 | Lisp_Object handlers, body; |
| 899 | handlers = POP; | 973 | handlers = POP; |
| @@ -904,7 +978,7 @@ If the third argument is incorrect, Emacs may crash. */) | |||
| 904 | break; | 978 | break; |
| 905 | } | 979 | } |
| 906 | 980 | ||
| 907 | case Btemp_output_buffer_setup: | 981 | case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ |
| 908 | BEFORE_POTENTIAL_GC (); | 982 | BEFORE_POTENTIAL_GC (); |
| 909 | CHECK_STRING (TOP); | 983 | CHECK_STRING (TOP); |
| 910 | temp_output_buffer_setup (SSDATA (TOP)); | 984 | temp_output_buffer_setup (SSDATA (TOP)); |
| @@ -912,7 +986,7 @@ If the third argument is incorrect, Emacs may crash. */) | |||
| 912 | TOP = Vstandard_output; | 986 | TOP = Vstandard_output; |
| 913 | break; | 987 | break; |
| 914 | 988 | ||
| 915 | case Btemp_output_buffer_show: | 989 | case Btemp_output_buffer_show: /* Obsolete since 24.1. */ |
| 916 | { | 990 | { |
| 917 | Lisp_Object v1; | 991 | Lisp_Object v1; |
| 918 | BEFORE_POTENTIAL_GC (); | 992 | BEFORE_POTENTIAL_GC (); |
| @@ -1384,7 +1458,7 @@ If the third argument is incorrect, Emacs may crash. */) | |||
| 1384 | AFTER_POTENTIAL_GC (); | 1458 | AFTER_POTENTIAL_GC (); |
| 1385 | break; | 1459 | break; |
| 1386 | 1460 | ||
| 1387 | case Binteractive_p: | 1461 | case Binteractive_p: /* Obsolete since 24.1. */ |
| 1388 | PUSH (Finteractive_p ()); | 1462 | PUSH (Finteractive_p ()); |
| 1389 | break; | 1463 | break; |
| 1390 | 1464 | ||
| @@ -1674,8 +1748,57 @@ If the third argument is incorrect, Emacs may crash. */) | |||
| 1674 | #endif | 1748 | #endif |
| 1675 | 1749 | ||
| 1676 | case 0: | 1750 | case 0: |
| 1751 | /* Actually this is Bstack_ref with offset 0, but we use Bdup | ||
| 1752 | for that instead. */ | ||
| 1753 | /* case Bstack_ref: */ | ||
| 1677 | abort (); | 1754 | abort (); |
| 1678 | 1755 | ||
| 1756 | /* Handy byte-codes for lexical binding. */ | ||
| 1757 | case Bstack_ref+1: | ||
| 1758 | case Bstack_ref+2: | ||
| 1759 | case Bstack_ref+3: | ||
| 1760 | case Bstack_ref+4: | ||
| 1761 | case Bstack_ref+5: | ||
| 1762 | { | ||
| 1763 | Lisp_Object *ptr = top - (op - Bstack_ref); | ||
| 1764 | PUSH (*ptr); | ||
| 1765 | break; | ||
| 1766 | } | ||
| 1767 | case Bstack_ref+6: | ||
| 1768 | { | ||
| 1769 | Lisp_Object *ptr = top - (FETCH); | ||
| 1770 | PUSH (*ptr); | ||
| 1771 | break; | ||
| 1772 | } | ||
| 1773 | case Bstack_ref+7: | ||
| 1774 | { | ||
| 1775 | Lisp_Object *ptr = top - (FETCH2); | ||
| 1776 | PUSH (*ptr); | ||
| 1777 | break; | ||
| 1778 | } | ||
| 1779 | /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ | ||
| 1780 | case Bstack_set: | ||
| 1781 | { | ||
| 1782 | Lisp_Object *ptr = top - (FETCH); | ||
| 1783 | *ptr = POP; | ||
| 1784 | break; | ||
| 1785 | } | ||
| 1786 | case Bstack_set2: | ||
| 1787 | { | ||
| 1788 | Lisp_Object *ptr = top - (FETCH2); | ||
| 1789 | *ptr = POP; | ||
| 1790 | break; | ||
| 1791 | } | ||
| 1792 | case BdiscardN: | ||
| 1793 | op = FETCH; | ||
| 1794 | if (op & 0x80) | ||
| 1795 | { | ||
| 1796 | op &= 0x7F; | ||
| 1797 | top[-op] = TOP; | ||
| 1798 | } | ||
| 1799 | DISCARD (op); | ||
| 1800 | break; | ||
| 1801 | |||
| 1679 | case 255: | 1802 | case 255: |
| 1680 | default: | 1803 | default: |
| 1681 | #ifdef BYTE_CODE_SAFE | 1804 | #ifdef BYTE_CODE_SAFE |
diff --git a/src/callint.c b/src/callint.c index 40d89acd16c..60570369d9e 100644 --- a/src/callint.c +++ b/src/callint.c | |||
| @@ -121,8 +121,9 @@ usage: (interactive &optional ARGS) */) | |||
| 121 | static Lisp_Object | 121 | static Lisp_Object |
| 122 | quotify_arg (register Lisp_Object exp) | 122 | quotify_arg (register Lisp_Object exp) |
| 123 | { | 123 | { |
| 124 | if (!INTEGERP (exp) && !STRINGP (exp) | 124 | if (CONSP (exp) |
| 125 | && !NILP (exp) && !EQ (exp, Qt)) | 125 | || (SYMBOLP (exp) |
| 126 | && !NILP (exp) && !EQ (exp, Qt))) | ||
| 126 | return Fcons (Qquote, Fcons (exp, Qnil)); | 127 | return Fcons (Qquote, Fcons (exp, Qnil)); |
| 127 | 128 | ||
| 128 | return exp; | 129 | return exp; |
| @@ -169,6 +170,9 @@ check_mark (int for_region) | |||
| 169 | static void | 170 | static void |
| 170 | fix_command (Lisp_Object input, Lisp_Object values) | 171 | fix_command (Lisp_Object input, Lisp_Object values) |
| 171 | { | 172 | { |
| 173 | /* FIXME: Instead of this ugly hack, we should provide a way for an | ||
| 174 | interactive spec to return an expression/function that will re-build the | ||
| 175 | args without user intervention. */ | ||
| 172 | if (CONSP (input)) | 176 | if (CONSP (input)) |
| 173 | { | 177 | { |
| 174 | Lisp_Object car; | 178 | Lisp_Object car; |
| @@ -332,11 +336,14 @@ invoke it. If KEYS is omitted or nil, the return value of | |||
| 332 | else | 336 | else |
| 333 | { | 337 | { |
| 334 | Lisp_Object input; | 338 | Lisp_Object input; |
| 339 | Lisp_Object funval = Findirect_function (function, Qt); | ||
| 335 | i = num_input_events; | 340 | i = num_input_events; |
| 336 | input = specs; | 341 | input = specs; |
| 337 | /* Compute the arg values using the user's expression. */ | 342 | /* Compute the arg values using the user's expression. */ |
| 338 | GCPRO2 (input, filter_specs); | 343 | GCPRO2 (input, filter_specs); |
| 339 | specs = Feval (specs); | 344 | specs = Feval (specs, |
| 345 | CONSP (funval) && EQ (Qclosure, XCAR (funval)) | ||
| 346 | ? Qt : Qnil); | ||
| 340 | UNGCPRO; | 347 | UNGCPRO; |
| 341 | if (i != num_input_events || !NILP (record_flag)) | 348 | if (i != num_input_events || !NILP (record_flag)) |
| 342 | { | 349 | { |
diff --git a/src/data.c b/src/data.c index ba7ae58d7b2..4b9d2ec0387 100644 --- a/src/data.c +++ b/src/data.c | |||
| @@ -745,7 +745,9 @@ Value, if non-nil, is a list \(interactive SPEC). */) | |||
| 745 | else if (CONSP (fun)) | 745 | else if (CONSP (fun)) |
| 746 | { | 746 | { |
| 747 | Lisp_Object funcar = XCAR (fun); | 747 | Lisp_Object funcar = XCAR (fun); |
| 748 | if (EQ (funcar, Qlambda)) | 748 | if (EQ (funcar, Qclosure)) |
| 749 | return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))); | ||
| 750 | else if (EQ (funcar, Qlambda)) | ||
| 749 | return Fassq (Qinteractive, Fcdr (XCDR (fun))); | 751 | return Fassq (Qinteractive, Fcdr (XCDR (fun))); |
| 750 | else if (EQ (funcar, Qautoload)) | 752 | else if (EQ (funcar, Qautoload)) |
| 751 | { | 753 | { |
| @@ -1431,7 +1433,7 @@ usage: (setq-default [VAR VALUE]...) */) | |||
| 1431 | 1433 | ||
| 1432 | do | 1434 | do |
| 1433 | { | 1435 | { |
| 1434 | val = Feval (Fcar (Fcdr (args_left))); | 1436 | val = eval_sub (Fcar (Fcdr (args_left))); |
| 1435 | symbol = XCAR (args_left); | 1437 | symbol = XCAR (args_left); |
| 1436 | Fset_default (symbol, val); | 1438 | Fset_default (symbol, val); |
| 1437 | args_left = Fcdr (XCDR (args_left)); | 1439 | args_left = Fcdr (XCDR (args_left)); |
| @@ -2101,7 +2103,7 @@ or a byte-code object. IDX starts at 0. */) | |||
| 2101 | 2103 | ||
| 2102 | if (idxval < 0 || idxval >= size) | 2104 | if (idxval < 0 || idxval >= size) |
| 2103 | args_out_of_range (array, idx); | 2105 | args_out_of_range (array, idx); |
| 2104 | return XVECTOR (array)->contents[idxval]; | 2106 | return AREF (array, idxval); |
| 2105 | } | 2107 | } |
| 2106 | } | 2108 | } |
| 2107 | 2109 | ||
| @@ -36,6 +36,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ | |||
| 36 | 36 | ||
| 37 | Lisp_Object Qfunction_documentation; | 37 | Lisp_Object Qfunction_documentation; |
| 38 | 38 | ||
| 39 | extern Lisp_Object Qclosure; | ||
| 39 | /* Buffer used for reading from documentation file. */ | 40 | /* Buffer used for reading from documentation file. */ |
| 40 | static char *get_doc_string_buffer; | 41 | static char *get_doc_string_buffer; |
| 41 | static int get_doc_string_buffer_size; | 42 | static int get_doc_string_buffer_size; |
| @@ -374,6 +375,7 @@ string is passed through `substitute-command-keys'. */) | |||
| 374 | else if (EQ (funcar, Qkeymap)) | 375 | else if (EQ (funcar, Qkeymap)) |
| 375 | return build_string ("Prefix command (definition is a keymap associating keystrokes with commands)."); | 376 | return build_string ("Prefix command (definition is a keymap associating keystrokes with commands)."); |
| 376 | else if (EQ (funcar, Qlambda) | 377 | else if (EQ (funcar, Qlambda) |
| 378 | || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1)) | ||
| 377 | || EQ (funcar, Qautoload)) | 379 | || EQ (funcar, Qautoload)) |
| 378 | { | 380 | { |
| 379 | Lisp_Object tem1 = Fcdr (Fcdr (fun)); | 381 | Lisp_Object tem1 = Fcdr (Fcdr (fun)); |
| @@ -480,7 +482,7 @@ aren't strings. */) | |||
| 480 | } | 482 | } |
| 481 | else if (!STRINGP (tem)) | 483 | else if (!STRINGP (tem)) |
| 482 | /* Feval protects its argument. */ | 484 | /* Feval protects its argument. */ |
| 483 | tem = Feval (tem); | 485 | tem = Feval (tem, Qnil); |
| 484 | 486 | ||
| 485 | if (NILP (raw) && STRINGP (tem)) | 487 | if (NILP (raw) && STRINGP (tem)) |
| 486 | tem = Fsubstitute_command_keys (tem); | 488 | tem = Fsubstitute_command_keys (tem); |
| @@ -507,7 +509,8 @@ store_function_docstring (Lisp_Object fun, EMACS_INT offset) | |||
| 507 | Lisp_Object tem; | 509 | Lisp_Object tem; |
| 508 | 510 | ||
| 509 | tem = XCAR (fun); | 511 | tem = XCAR (fun); |
| 510 | if (EQ (tem, Qlambda) || EQ (tem, Qautoload)) | 512 | if (EQ (tem, Qlambda) || EQ (tem, Qautoload) |
| 513 | || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1))) | ||
| 511 | { | 514 | { |
| 512 | tem = Fcdr (Fcdr (fun)); | 515 | tem = Fcdr (Fcdr (fun)); |
| 513 | if (CONSP (tem) && INTEGERP (XCAR (tem))) | 516 | if (CONSP (tem) && INTEGERP (XCAR (tem))) |
diff --git a/src/eval.c b/src/eval.c index 718e58c693f..948c2e4d158 100644 --- a/src/eval.c +++ b/src/eval.c | |||
| @@ -64,6 +64,8 @@ Lisp_Object Qinhibit_quit; | |||
| 64 | Lisp_Object Qand_rest, Qand_optional; | 64 | Lisp_Object Qand_rest, Qand_optional; |
| 65 | Lisp_Object Qdebug_on_error; | 65 | Lisp_Object Qdebug_on_error; |
| 66 | Lisp_Object Qdeclare; | 66 | Lisp_Object Qdeclare; |
| 67 | Lisp_Object Qinternal_interpreter_environment, Qclosure; | ||
| 68 | |||
| 67 | Lisp_Object Qdebug; | 69 | Lisp_Object Qdebug; |
| 68 | 70 | ||
| 69 | /* This holds either the symbol `run-hooks' or nil. | 71 | /* This holds either the symbol `run-hooks' or nil. |
| @@ -115,10 +117,10 @@ Lisp_Object Vsignaling_function; | |||
| 115 | 117 | ||
| 116 | int handling_signal; | 118 | int handling_signal; |
| 117 | 119 | ||
| 118 | static Lisp_Object funcall_lambda (Lisp_Object, size_t, Lisp_Object*); | 120 | static Lisp_Object funcall_lambda (Lisp_Object, size_t, Lisp_Object *); |
| 119 | static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN; | 121 | static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN; |
| 120 | static int interactive_p (int); | 122 | static int interactive_p (int); |
| 121 | static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, int); | 123 | static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); |
| 122 | 124 | ||
| 123 | void | 125 | void |
| 124 | init_eval_once (void) | 126 | init_eval_once (void) |
| @@ -127,7 +129,7 @@ init_eval_once (void) | |||
| 127 | specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding)); | 129 | specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding)); |
| 128 | specpdl_ptr = specpdl; | 130 | specpdl_ptr = specpdl; |
| 129 | /* Don't forget to update docs (lispref node "Local Variables"). */ | 131 | /* Don't forget to update docs (lispref node "Local Variables"). */ |
| 130 | max_specpdl_size = 1000; | 132 | max_specpdl_size = 1300; /* 1000 is not enough for CEDET's c-by.el. */ |
| 131 | max_lisp_eval_depth = 600; | 133 | max_lisp_eval_depth = 600; |
| 132 | 134 | ||
| 133 | Vrun_hooks = Qnil; | 135 | Vrun_hooks = Qnil; |
| @@ -244,7 +246,7 @@ usage: (or CONDITIONS...) */) | |||
| 244 | 246 | ||
| 245 | while (CONSP (args)) | 247 | while (CONSP (args)) |
| 246 | { | 248 | { |
| 247 | val = Feval (XCAR (args)); | 249 | val = eval_sub (XCAR (args)); |
| 248 | if (!NILP (val)) | 250 | if (!NILP (val)) |
| 249 | break; | 251 | break; |
| 250 | args = XCDR (args); | 252 | args = XCDR (args); |
| @@ -268,7 +270,7 @@ usage: (and CONDITIONS...) */) | |||
| 268 | 270 | ||
| 269 | while (CONSP (args)) | 271 | while (CONSP (args)) |
| 270 | { | 272 | { |
| 271 | val = Feval (XCAR (args)); | 273 | val = eval_sub (XCAR (args)); |
| 272 | if (NILP (val)) | 274 | if (NILP (val)) |
| 273 | break; | 275 | break; |
| 274 | args = XCDR (args); | 276 | args = XCDR (args); |
| @@ -290,11 +292,11 @@ usage: (if COND THEN ELSE...) */) | |||
| 290 | struct gcpro gcpro1; | 292 | struct gcpro gcpro1; |
| 291 | 293 | ||
| 292 | GCPRO1 (args); | 294 | GCPRO1 (args); |
| 293 | cond = Feval (Fcar (args)); | 295 | cond = eval_sub (Fcar (args)); |
| 294 | UNGCPRO; | 296 | UNGCPRO; |
| 295 | 297 | ||
| 296 | if (!NILP (cond)) | 298 | if (!NILP (cond)) |
| 297 | return Feval (Fcar (Fcdr (args))); | 299 | return eval_sub (Fcar (Fcdr (args))); |
| 298 | return Fprogn (Fcdr (Fcdr (args))); | 300 | return Fprogn (Fcdr (Fcdr (args))); |
| 299 | } | 301 | } |
| 300 | 302 | ||
| @@ -318,7 +320,7 @@ usage: (cond CLAUSES...) */) | |||
| 318 | while (!NILP (args)) | 320 | while (!NILP (args)) |
| 319 | { | 321 | { |
| 320 | clause = Fcar (args); | 322 | clause = Fcar (args); |
| 321 | val = Feval (Fcar (clause)); | 323 | val = eval_sub (Fcar (clause)); |
| 322 | if (!NILP (val)) | 324 | if (!NILP (val)) |
| 323 | { | 325 | { |
| 324 | if (!EQ (XCDR (clause), Qnil)) | 326 | if (!EQ (XCDR (clause), Qnil)) |
| @@ -344,7 +346,7 @@ usage: (progn BODY...) */) | |||
| 344 | 346 | ||
| 345 | while (CONSP (args)) | 347 | while (CONSP (args)) |
| 346 | { | 348 | { |
| 347 | val = Feval (XCAR (args)); | 349 | val = eval_sub (XCAR (args)); |
| 348 | args = XCDR (args); | 350 | args = XCDR (args); |
| 349 | } | 351 | } |
| 350 | 352 | ||
| @@ -373,13 +375,12 @@ usage: (prog1 FIRST BODY...) */) | |||
| 373 | 375 | ||
| 374 | do | 376 | do |
| 375 | { | 377 | { |
| 378 | Lisp_Object tem = eval_sub (XCAR (args_left)); | ||
| 376 | if (!(argnum++)) | 379 | if (!(argnum++)) |
| 377 | val = Feval (Fcar (args_left)); | 380 | val = tem; |
| 378 | else | 381 | args_left = XCDR (args_left); |
| 379 | Feval (Fcar (args_left)); | ||
| 380 | args_left = Fcdr (args_left); | ||
| 381 | } | 382 | } |
| 382 | while (!NILP(args_left)); | 383 | while (CONSP (args_left)); |
| 383 | 384 | ||
| 384 | UNGCPRO; | 385 | UNGCPRO; |
| 385 | return val; | 386 | return val; |
| @@ -408,13 +409,12 @@ usage: (prog2 FORM1 FORM2 BODY...) */) | |||
| 408 | 409 | ||
| 409 | do | 410 | do |
| 410 | { | 411 | { |
| 412 | Lisp_Object tem = eval_sub (XCAR (args_left)); | ||
| 411 | if (!(argnum++)) | 413 | if (!(argnum++)) |
| 412 | val = Feval (Fcar (args_left)); | 414 | val = tem; |
| 413 | else | 415 | args_left = XCDR (args_left); |
| 414 | Feval (Fcar (args_left)); | ||
| 415 | args_left = Fcdr (args_left); | ||
| 416 | } | 416 | } |
| 417 | while (!NILP (args_left)); | 417 | while (CONSP (args_left)); |
| 418 | 418 | ||
| 419 | UNGCPRO; | 419 | UNGCPRO; |
| 420 | return val; | 420 | return val; |
| @@ -432,7 +432,7 @@ usage: (setq [SYM VAL]...) */) | |||
| 432 | (Lisp_Object args) | 432 | (Lisp_Object args) |
| 433 | { | 433 | { |
| 434 | register Lisp_Object args_left; | 434 | register Lisp_Object args_left; |
| 435 | register Lisp_Object val, sym; | 435 | register Lisp_Object val, sym, lex_binding; |
| 436 | struct gcpro gcpro1; | 436 | struct gcpro gcpro1; |
| 437 | 437 | ||
| 438 | if (NILP (args)) | 438 | if (NILP (args)) |
| @@ -443,9 +443,19 @@ usage: (setq [SYM VAL]...) */) | |||
| 443 | 443 | ||
| 444 | do | 444 | do |
| 445 | { | 445 | { |
| 446 | val = Feval (Fcar (Fcdr (args_left))); | 446 | val = eval_sub (Fcar (Fcdr (args_left))); |
| 447 | sym = Fcar (args_left); | 447 | sym = Fcar (args_left); |
| 448 | Fset (sym, val); | 448 | |
| 449 | /* Like for eval_sub, we do not check declared_special here since | ||
| 450 | it's been done when let-binding. */ | ||
| 451 | if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */ | ||
| 452 | && SYMBOLP (sym) | ||
| 453 | && !NILP (lex_binding | ||
| 454 | = Fassq (sym, Vinternal_interpreter_environment))) | ||
| 455 | XSETCDR (lex_binding, val); /* SYM is lexically bound. */ | ||
| 456 | else | ||
| 457 | Fset (sym, val); /* SYM is dynamically bound. */ | ||
| 458 | |||
| 449 | args_left = Fcdr (Fcdr (args_left)); | 459 | args_left = Fcdr (Fcdr (args_left)); |
| 450 | } | 460 | } |
| 451 | while (!NILP(args_left)); | 461 | while (!NILP(args_left)); |
| @@ -471,9 +481,21 @@ In byte compilation, `function' causes its argument to be compiled. | |||
| 471 | usage: (function ARG) */) | 481 | usage: (function ARG) */) |
| 472 | (Lisp_Object args) | 482 | (Lisp_Object args) |
| 473 | { | 483 | { |
| 484 | Lisp_Object quoted = XCAR (args); | ||
| 485 | |||
| 474 | if (!NILP (Fcdr (args))) | 486 | if (!NILP (Fcdr (args))) |
| 475 | xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); | 487 | xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); |
| 476 | return Fcar (args); | 488 | |
| 489 | if (!NILP (Vinternal_interpreter_environment) | ||
| 490 | && CONSP (quoted) | ||
| 491 | && EQ (XCAR (quoted), Qlambda)) | ||
| 492 | /* This is a lambda expression within a lexical environment; | ||
| 493 | return an interpreted closure instead of a simple lambda. */ | ||
| 494 | return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, | ||
| 495 | XCDR (quoted))); | ||
| 496 | else | ||
| 497 | /* Simply quote the argument. */ | ||
| 498 | return quoted; | ||
| 477 | } | 499 | } |
| 478 | 500 | ||
| 479 | 501 | ||
| @@ -496,7 +518,7 @@ spec that specifies non-nil unconditionally (such as \"p\"); or (ii) | |||
| 496 | use `called-interactively-p'. */) | 518 | use `called-interactively-p'. */) |
| 497 | (void) | 519 | (void) |
| 498 | { | 520 | { |
| 499 | return (INTERACTIVE && interactive_p (1)) ? Qt : Qnil; | 521 | return interactive_p (1) ? Qt : Qnil; |
| 500 | } | 522 | } |
| 501 | 523 | ||
| 502 | 524 | ||
| @@ -589,6 +611,8 @@ usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */) | |||
| 589 | fn_name = Fcar (args); | 611 | fn_name = Fcar (args); |
| 590 | CHECK_SYMBOL (fn_name); | 612 | CHECK_SYMBOL (fn_name); |
| 591 | defn = Fcons (Qlambda, Fcdr (args)); | 613 | defn = Fcons (Qlambda, Fcdr (args)); |
| 614 | if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */ | ||
| 615 | defn = Ffunction (Fcons (defn, Qnil)); | ||
| 592 | if (!NILP (Vpurify_flag)) | 616 | if (!NILP (Vpurify_flag)) |
| 593 | defn = Fpurecopy (defn); | 617 | defn = Fpurecopy (defn); |
| 594 | if (CONSP (XSYMBOL (fn_name)->function) | 618 | if (CONSP (XSYMBOL (fn_name)->function) |
| @@ -660,7 +684,11 @@ usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */) | |||
| 660 | tail = Fcons (lambda_list, tail); | 684 | tail = Fcons (lambda_list, tail); |
| 661 | else | 685 | else |
| 662 | tail = Fcons (lambda_list, Fcons (doc, tail)); | 686 | tail = Fcons (lambda_list, Fcons (doc, tail)); |
| 663 | defn = Fcons (Qmacro, Fcons (Qlambda, tail)); | 687 | |
| 688 | defn = Fcons (Qlambda, tail); | ||
| 689 | if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */ | ||
| 690 | defn = Ffunction (Fcons (defn, Qnil)); | ||
| 691 | defn = Fcons (Qmacro, defn); | ||
| 664 | 692 | ||
| 665 | if (!NILP (Vpurify_flag)) | 693 | if (!NILP (Vpurify_flag)) |
| 666 | defn = Fpurecopy (defn); | 694 | defn = Fpurecopy (defn); |
| @@ -720,6 +748,7 @@ The return value is BASE-VARIABLE. */) | |||
| 720 | error ("Don't know how to make a let-bound variable an alias"); | 748 | error ("Don't know how to make a let-bound variable an alias"); |
| 721 | } | 749 | } |
| 722 | 750 | ||
| 751 | sym->declared_special = 1; | ||
| 723 | sym->redirect = SYMBOL_VARALIAS; | 752 | sym->redirect = SYMBOL_VARALIAS; |
| 724 | SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable)); | 753 | SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable)); |
| 725 | sym->constant = SYMBOL_CONSTANT_P (base_variable); | 754 | sym->constant = SYMBOL_CONSTANT_P (base_variable); |
| @@ -765,6 +794,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) | |||
| 765 | tem = Fdefault_boundp (sym); | 794 | tem = Fdefault_boundp (sym); |
| 766 | if (!NILP (tail)) | 795 | if (!NILP (tail)) |
| 767 | { | 796 | { |
| 797 | /* Do it before evaluating the initial value, for self-references. */ | ||
| 798 | XSYMBOL (sym)->declared_special = 1; | ||
| 799 | |||
| 768 | if (SYMBOL_CONSTANT_P (sym)) | 800 | if (SYMBOL_CONSTANT_P (sym)) |
| 769 | { | 801 | { |
| 770 | /* For upward compatibility, allow (defvar :foo (quote :foo)). */ | 802 | /* For upward compatibility, allow (defvar :foo (quote :foo)). */ |
| @@ -778,7 +810,7 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) | |||
| 778 | } | 810 | } |
| 779 | 811 | ||
| 780 | if (NILP (tem)) | 812 | if (NILP (tem)) |
| 781 | Fset_default (sym, Feval (Fcar (tail))); | 813 | Fset_default (sym, eval_sub (Fcar (tail))); |
| 782 | else | 814 | else |
| 783 | { /* Check if there is really a global binding rather than just a let | 815 | { /* Check if there is really a global binding rather than just a let |
| 784 | binding that shadows the global unboundness of the var. */ | 816 | binding that shadows the global unboundness of the var. */ |
| @@ -804,6 +836,13 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) | |||
| 804 | } | 836 | } |
| 805 | LOADHIST_ATTACH (sym); | 837 | LOADHIST_ATTACH (sym); |
| 806 | } | 838 | } |
| 839 | else if (!NILP (Vinternal_interpreter_environment) | ||
| 840 | && !XSYMBOL (sym)->declared_special) | ||
| 841 | /* A simple (defvar foo) with lexical scoping does "nothing" except | ||
| 842 | declare that var to be dynamically scoped *locally* (i.e. within | ||
| 843 | the current file or let-block). */ | ||
| 844 | Vinternal_interpreter_environment = | ||
| 845 | Fcons (sym, Vinternal_interpreter_environment); | ||
| 807 | else | 846 | else |
| 808 | { | 847 | { |
| 809 | /* Simple (defvar <var>) should not count as a definition at all. | 848 | /* Simple (defvar <var>) should not count as a definition at all. |
| @@ -834,10 +873,11 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */) | |||
| 834 | if (!NILP (Fcdr (Fcdr (Fcdr (args))))) | 873 | if (!NILP (Fcdr (Fcdr (Fcdr (args))))) |
| 835 | error ("Too many arguments"); | 874 | error ("Too many arguments"); |
| 836 | 875 | ||
| 837 | tem = Feval (Fcar (Fcdr (args))); | 876 | tem = eval_sub (Fcar (Fcdr (args))); |
| 838 | if (!NILP (Vpurify_flag)) | 877 | if (!NILP (Vpurify_flag)) |
| 839 | tem = Fpurecopy (tem); | 878 | tem = Fpurecopy (tem); |
| 840 | Fset_default (sym, tem); | 879 | Fset_default (sym, tem); |
| 880 | XSYMBOL (sym)->declared_special = 1; | ||
| 841 | tem = Fcar (Fcdr (Fcdr (args))); | 881 | tem = Fcar (Fcdr (Fcdr (args))); |
| 842 | if (!NILP (tem)) | 882 | if (!NILP (tem)) |
| 843 | { | 883 | { |
| @@ -924,27 +964,53 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST. | |||
| 924 | usage: (let* VARLIST BODY...) */) | 964 | usage: (let* VARLIST BODY...) */) |
| 925 | (Lisp_Object args) | 965 | (Lisp_Object args) |
| 926 | { | 966 | { |
| 927 | Lisp_Object varlist, val, elt; | 967 | Lisp_Object varlist, var, val, elt, lexenv; |
| 928 | int count = SPECPDL_INDEX (); | 968 | int count = SPECPDL_INDEX (); |
| 929 | struct gcpro gcpro1, gcpro2, gcpro3; | 969 | struct gcpro gcpro1, gcpro2, gcpro3; |
| 930 | 970 | ||
| 931 | GCPRO3 (args, elt, varlist); | 971 | GCPRO3 (args, elt, varlist); |
| 932 | 972 | ||
| 973 | lexenv = Vinternal_interpreter_environment; | ||
| 974 | |||
| 933 | varlist = Fcar (args); | 975 | varlist = Fcar (args); |
| 934 | while (!NILP (varlist)) | 976 | while (CONSP (varlist)) |
| 935 | { | 977 | { |
| 936 | QUIT; | 978 | QUIT; |
| 937 | elt = Fcar (varlist); | 979 | |
| 980 | elt = XCAR (varlist); | ||
| 938 | if (SYMBOLP (elt)) | 981 | if (SYMBOLP (elt)) |
| 939 | specbind (elt, Qnil); | 982 | { |
| 983 | var = elt; | ||
| 984 | val = Qnil; | ||
| 985 | } | ||
| 940 | else if (! NILP (Fcdr (Fcdr (elt)))) | 986 | else if (! NILP (Fcdr (Fcdr (elt)))) |
| 941 | signal_error ("`let' bindings can have only one value-form", elt); | 987 | signal_error ("`let' bindings can have only one value-form", elt); |
| 942 | else | 988 | else |
| 943 | { | 989 | { |
| 944 | val = Feval (Fcar (Fcdr (elt))); | 990 | var = Fcar (elt); |
| 945 | specbind (Fcar (elt), val); | 991 | val = eval_sub (Fcar (Fcdr (elt))); |
| 992 | } | ||
| 993 | |||
| 994 | if (!NILP (lexenv) && SYMBOLP (var) | ||
| 995 | && !XSYMBOL (var)->declared_special | ||
| 996 | && NILP (Fmemq (var, Vinternal_interpreter_environment))) | ||
| 997 | /* Lexically bind VAR by adding it to the interpreter's binding | ||
| 998 | alist. */ | ||
| 999 | { | ||
| 1000 | Lisp_Object newenv | ||
| 1001 | = Fcons (Fcons (var, val), Vinternal_interpreter_environment); | ||
| 1002 | if (EQ (Vinternal_interpreter_environment, lexenv)) | ||
| 1003 | /* Save the old lexical environment on the specpdl stack, | ||
| 1004 | but only for the first lexical binding, since we'll never | ||
| 1005 | need to revert to one of the intermediate ones. */ | ||
| 1006 | specbind (Qinternal_interpreter_environment, newenv); | ||
| 1007 | else | ||
| 1008 | Vinternal_interpreter_environment = newenv; | ||
| 946 | } | 1009 | } |
| 947 | varlist = Fcdr (varlist); | 1010 | else |
| 1011 | specbind (var, val); | ||
| 1012 | |||
| 1013 | varlist = XCDR (varlist); | ||
| 948 | } | 1014 | } |
| 949 | UNGCPRO; | 1015 | UNGCPRO; |
| 950 | val = Fprogn (Fcdr (args)); | 1016 | val = Fprogn (Fcdr (args)); |
| @@ -960,7 +1026,7 @@ All the VALUEFORMs are evalled before any symbols are bound. | |||
| 960 | usage: (let VARLIST BODY...) */) | 1026 | usage: (let VARLIST BODY...) */) |
| 961 | (Lisp_Object args) | 1027 | (Lisp_Object args) |
| 962 | { | 1028 | { |
| 963 | Lisp_Object *temps, tem; | 1029 | Lisp_Object *temps, tem, lexenv; |
| 964 | register Lisp_Object elt, varlist; | 1030 | register Lisp_Object elt, varlist; |
| 965 | int count = SPECPDL_INDEX (); | 1031 | int count = SPECPDL_INDEX (); |
| 966 | register size_t argnum; | 1032 | register size_t argnum; |
| @@ -987,22 +1053,36 @@ usage: (let VARLIST BODY...) */) | |||
| 987 | else if (! NILP (Fcdr (Fcdr (elt)))) | 1053 | else if (! NILP (Fcdr (Fcdr (elt)))) |
| 988 | signal_error ("`let' bindings can have only one value-form", elt); | 1054 | signal_error ("`let' bindings can have only one value-form", elt); |
| 989 | else | 1055 | else |
| 990 | temps [argnum++] = Feval (Fcar (Fcdr (elt))); | 1056 | temps [argnum++] = eval_sub (Fcar (Fcdr (elt))); |
| 991 | gcpro2.nvars = argnum; | 1057 | gcpro2.nvars = argnum; |
| 992 | } | 1058 | } |
| 993 | UNGCPRO; | 1059 | UNGCPRO; |
| 994 | 1060 | ||
| 1061 | lexenv = Vinternal_interpreter_environment; | ||
| 1062 | |||
| 995 | varlist = Fcar (args); | 1063 | varlist = Fcar (args); |
| 996 | for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) | 1064 | for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) |
| 997 | { | 1065 | { |
| 1066 | Lisp_Object var; | ||
| 1067 | |||
| 998 | elt = XCAR (varlist); | 1068 | elt = XCAR (varlist); |
| 1069 | var = SYMBOLP (elt) ? elt : Fcar (elt); | ||
| 999 | tem = temps[argnum++]; | 1070 | tem = temps[argnum++]; |
| 1000 | if (SYMBOLP (elt)) | 1071 | |
| 1001 | specbind (elt, tem); | 1072 | if (!NILP (lexenv) && SYMBOLP (var) |
| 1073 | && !XSYMBOL (var)->declared_special | ||
| 1074 | && NILP (Fmemq (var, Vinternal_interpreter_environment))) | ||
| 1075 | /* Lexically bind VAR by adding it to the lexenv alist. */ | ||
| 1076 | lexenv = Fcons (Fcons (var, tem), lexenv); | ||
| 1002 | else | 1077 | else |
| 1003 | specbind (Fcar (elt), tem); | 1078 | /* Dynamically bind VAR. */ |
| 1079 | specbind (var, tem); | ||
| 1004 | } | 1080 | } |
| 1005 | 1081 | ||
| 1082 | if (!EQ (lexenv, Vinternal_interpreter_environment)) | ||
| 1083 | /* Instantiate a new lexical environment. */ | ||
| 1084 | specbind (Qinternal_interpreter_environment, lexenv); | ||
| 1085 | |||
| 1006 | elt = Fprogn (Fcdr (args)); | 1086 | elt = Fprogn (Fcdr (args)); |
| 1007 | SAFE_FREE (); | 1087 | SAFE_FREE (); |
| 1008 | return unbind_to (count, elt); | 1088 | return unbind_to (count, elt); |
| @@ -1022,7 +1102,7 @@ usage: (while TEST BODY...) */) | |||
| 1022 | 1102 | ||
| 1023 | test = Fcar (args); | 1103 | test = Fcar (args); |
| 1024 | body = Fcdr (args); | 1104 | body = Fcdr (args); |
| 1025 | while (!NILP (Feval (test))) | 1105 | while (!NILP (eval_sub (test))) |
| 1026 | { | 1106 | { |
| 1027 | QUIT; | 1107 | QUIT; |
| 1028 | Fprogn (body); | 1108 | Fprogn (body); |
| @@ -1124,7 +1204,7 @@ usage: (catch TAG BODY...) */) | |||
| 1124 | struct gcpro gcpro1; | 1204 | struct gcpro gcpro1; |
| 1125 | 1205 | ||
| 1126 | GCPRO1 (args); | 1206 | GCPRO1 (args); |
| 1127 | tag = Feval (Fcar (args)); | 1207 | tag = eval_sub (Fcar (args)); |
| 1128 | UNGCPRO; | 1208 | UNGCPRO; |
| 1129 | return internal_catch (tag, Fprogn, Fcdr (args)); | 1209 | return internal_catch (tag, Fprogn, Fcdr (args)); |
| 1130 | } | 1210 | } |
| @@ -1254,7 +1334,7 @@ usage: (unwind-protect BODYFORM UNWINDFORMS...) */) | |||
| 1254 | int count = SPECPDL_INDEX (); | 1334 | int count = SPECPDL_INDEX (); |
| 1255 | 1335 | ||
| 1256 | record_unwind_protect (Fprogn, Fcdr (args)); | 1336 | record_unwind_protect (Fprogn, Fcdr (args)); |
| 1257 | val = Feval (Fcar (args)); | 1337 | val = eval_sub (Fcar (args)); |
| 1258 | return unbind_to (count, val); | 1338 | return unbind_to (count, val); |
| 1259 | } | 1339 | } |
| 1260 | 1340 | ||
| @@ -1355,7 +1435,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, | |||
| 1355 | h.tag = &c; | 1435 | h.tag = &c; |
| 1356 | handlerlist = &h; | 1436 | handlerlist = &h; |
| 1357 | 1437 | ||
| 1358 | val = Feval (bodyform); | 1438 | val = eval_sub (bodyform); |
| 1359 | catchlist = c.next; | 1439 | catchlist = c.next; |
| 1360 | handlerlist = h.next; | 1440 | handlerlist = h.next; |
| 1361 | return val; | 1441 | return val; |
| @@ -1999,9 +2079,12 @@ then strings and vectors are not accepted. */) | |||
| 1999 | if (!CONSP (fun)) | 2079 | if (!CONSP (fun)) |
| 2000 | return Qnil; | 2080 | return Qnil; |
| 2001 | funcar = XCAR (fun); | 2081 | funcar = XCAR (fun); |
| 2002 | if (EQ (funcar, Qlambda)) | 2082 | if (EQ (funcar, Qclosure)) |
| 2083 | return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))))) | ||
| 2084 | ? Qt : if_prop); | ||
| 2085 | else if (EQ (funcar, Qlambda)) | ||
| 2003 | return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop; | 2086 | return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop; |
| 2004 | if (EQ (funcar, Qautoload)) | 2087 | else if (EQ (funcar, Qautoload)) |
| 2005 | return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop; | 2088 | return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop; |
| 2006 | else | 2089 | else |
| 2007 | return Qnil; | 2090 | return Qnil; |
| @@ -2119,9 +2202,21 @@ do_autoload (Lisp_Object fundef, Lisp_Object funname) | |||
| 2119 | } | 2202 | } |
| 2120 | 2203 | ||
| 2121 | 2204 | ||
| 2122 | DEFUN ("eval", Feval, Seval, 1, 1, 0, | 2205 | DEFUN ("eval", Feval, Seval, 1, 2, 0, |
| 2123 | doc: /* Evaluate FORM and return its value. */) | 2206 | doc: /* Evaluate FORM and return its value. |
| 2124 | (Lisp_Object form) | 2207 | If LEXICAL is t, evaluate using lexical scoping. */) |
| 2208 | (Lisp_Object form, Lisp_Object lexical) | ||
| 2209 | { | ||
| 2210 | int count = SPECPDL_INDEX (); | ||
| 2211 | specbind (Qinternal_interpreter_environment, | ||
| 2212 | NILP (lexical) ? Qnil : Fcons (Qt, Qnil)); | ||
| 2213 | return unbind_to (count, eval_sub (form)); | ||
| 2214 | } | ||
| 2215 | |||
| 2216 | /* Eval a sub-expression of the current expression (i.e. in the same | ||
| 2217 | lexical scope). */ | ||
| 2218 | Lisp_Object | ||
| 2219 | eval_sub (Lisp_Object form) | ||
| 2125 | { | 2220 | { |
| 2126 | Lisp_Object fun, val, original_fun, original_args; | 2221 | Lisp_Object fun, val, original_fun, original_args; |
| 2127 | Lisp_Object funcar; | 2222 | Lisp_Object funcar; |
| @@ -2132,7 +2227,20 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, | |||
| 2132 | abort (); | 2227 | abort (); |
| 2133 | 2228 | ||
| 2134 | if (SYMBOLP (form)) | 2229 | if (SYMBOLP (form)) |
| 2135 | return Fsymbol_value (form); | 2230 | { |
| 2231 | /* Look up its binding in the lexical environment. | ||
| 2232 | We do not pay attention to the declared_special flag here, since we | ||
| 2233 | already did that when let-binding the variable. */ | ||
| 2234 | Lisp_Object lex_binding | ||
| 2235 | = !NILP (Vinternal_interpreter_environment) /* Mere optimization! */ | ||
| 2236 | ? Fassq (form, Vinternal_interpreter_environment) | ||
| 2237 | : Qnil; | ||
| 2238 | if (CONSP (lex_binding)) | ||
| 2239 | return XCDR (lex_binding); | ||
| 2240 | else | ||
| 2241 | return Fsymbol_value (form); | ||
| 2242 | } | ||
| 2243 | |||
| 2136 | if (!CONSP (form)) | 2244 | if (!CONSP (form)) |
| 2137 | return form; | 2245 | return form; |
| 2138 | 2246 | ||
| @@ -2216,7 +2324,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, | |||
| 2216 | 2324 | ||
| 2217 | while (!NILP (args_left)) | 2325 | while (!NILP (args_left)) |
| 2218 | { | 2326 | { |
| 2219 | vals[argnum++] = Feval (Fcar (args_left)); | 2327 | vals[argnum++] = eval_sub (Fcar (args_left)); |
| 2220 | args_left = Fcdr (args_left); | 2328 | args_left = Fcdr (args_left); |
| 2221 | gcpro3.nvars = argnum; | 2329 | gcpro3.nvars = argnum; |
| 2222 | } | 2330 | } |
| @@ -2237,7 +2345,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, | |||
| 2237 | maxargs = XSUBR (fun)->max_args; | 2345 | maxargs = XSUBR (fun)->max_args; |
| 2238 | for (i = 0; i < maxargs; args_left = Fcdr (args_left)) | 2346 | for (i = 0; i < maxargs; args_left = Fcdr (args_left)) |
| 2239 | { | 2347 | { |
| 2240 | argvals[i] = Feval (Fcar (args_left)); | 2348 | argvals[i] = eval_sub (Fcar (args_left)); |
| 2241 | gcpro3.nvars = ++i; | 2349 | gcpro3.nvars = ++i; |
| 2242 | } | 2350 | } |
| 2243 | 2351 | ||
| @@ -2297,7 +2405,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, | |||
| 2297 | } | 2405 | } |
| 2298 | } | 2406 | } |
| 2299 | else if (COMPILEDP (fun)) | 2407 | else if (COMPILEDP (fun)) |
| 2300 | val = apply_lambda (fun, original_args, 1); | 2408 | val = apply_lambda (fun, original_args); |
| 2301 | else | 2409 | else |
| 2302 | { | 2410 | { |
| 2303 | if (EQ (fun, Qunbound)) | 2411 | if (EQ (fun, Qunbound)) |
| @@ -2313,9 +2421,10 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, | |||
| 2313 | goto retry; | 2421 | goto retry; |
| 2314 | } | 2422 | } |
| 2315 | if (EQ (funcar, Qmacro)) | 2423 | if (EQ (funcar, Qmacro)) |
| 2316 | val = Feval (apply1 (Fcdr (fun), original_args)); | 2424 | val = eval_sub (apply1 (Fcdr (fun), original_args)); |
| 2317 | else if (EQ (funcar, Qlambda)) | 2425 | else if (EQ (funcar, Qlambda) |
| 2318 | val = apply_lambda (fun, original_args, 1); | 2426 | || EQ (funcar, Qclosure)) |
| 2427 | val = apply_lambda (fun, original_args); | ||
| 2319 | else | 2428 | else |
| 2320 | xsignal1 (Qinvalid_function, original_fun); | 2429 | xsignal1 (Qinvalid_function, original_fun); |
| 2321 | } | 2430 | } |
| @@ -2786,6 +2895,39 @@ call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, | |||
| 2786 | 2895 | ||
| 2787 | /* The caller should GCPRO all the elements of ARGS. */ | 2896 | /* The caller should GCPRO all the elements of ARGS. */ |
| 2788 | 2897 | ||
| 2898 | DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, | ||
| 2899 | doc: /* Non-nil if OBJECT is a function. */) | ||
| 2900 | (Lisp_Object object) | ||
| 2901 | { | ||
| 2902 | if (SYMBOLP (object) && !NILP (Ffboundp (object))) | ||
| 2903 | { | ||
| 2904 | object = Findirect_function (object, Qt); | ||
| 2905 | |||
| 2906 | if (CONSP (object) && EQ (XCAR (object), Qautoload)) | ||
| 2907 | { | ||
| 2908 | /* Autoloaded symbols are functions, except if they load | ||
| 2909 | macros or keymaps. */ | ||
| 2910 | int i; | ||
| 2911 | for (i = 0; i < 4 && CONSP (object); i++) | ||
| 2912 | object = XCDR (object); | ||
| 2913 | |||
| 2914 | return (CONSP (object) && !NILP (XCAR (object))) ? Qnil : Qt; | ||
| 2915 | } | ||
| 2916 | } | ||
| 2917 | |||
| 2918 | if (SUBRP (object)) | ||
| 2919 | return (XSUBR (object)->max_args != UNEVALLED) ? Qt : Qnil; | ||
| 2920 | else if (COMPILEDP (object)) | ||
| 2921 | return Qt; | ||
| 2922 | else if (CONSP (object)) | ||
| 2923 | { | ||
| 2924 | Lisp_Object car = XCAR (object); | ||
| 2925 | return (EQ (car, Qlambda) || EQ (car, Qclosure)) ? Qt : Qnil; | ||
| 2926 | } | ||
| 2927 | else | ||
| 2928 | return Qnil; | ||
| 2929 | } | ||
| 2930 | |||
| 2789 | DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, | 2931 | DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, |
| 2790 | doc: /* Call first argument as a function, passing remaining arguments to it. | 2932 | doc: /* Call first argument as a function, passing remaining arguments to it. |
| 2791 | Return the value that function returns. | 2933 | Return the value that function returns. |
| @@ -2930,7 +3072,8 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) | |||
| 2930 | funcar = XCAR (fun); | 3072 | funcar = XCAR (fun); |
| 2931 | if (!SYMBOLP (funcar)) | 3073 | if (!SYMBOLP (funcar)) |
| 2932 | xsignal1 (Qinvalid_function, original_fun); | 3074 | xsignal1 (Qinvalid_function, original_fun); |
| 2933 | if (EQ (funcar, Qlambda)) | 3075 | if (EQ (funcar, Qlambda) |
| 3076 | || EQ (funcar, Qclosure)) | ||
| 2934 | val = funcall_lambda (fun, numargs, args + 1); | 3077 | val = funcall_lambda (fun, numargs, args + 1); |
| 2935 | else if (EQ (funcar, Qautoload)) | 3078 | else if (EQ (funcar, Qautoload)) |
| 2936 | { | 3079 | { |
| @@ -2950,7 +3093,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) | |||
| 2950 | } | 3093 | } |
| 2951 | 3094 | ||
| 2952 | static Lisp_Object | 3095 | static Lisp_Object |
| 2953 | apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag) | 3096 | apply_lambda (Lisp_Object fun, Lisp_Object args) |
| 2954 | { | 3097 | { |
| 2955 | Lisp_Object args_left; | 3098 | Lisp_Object args_left; |
| 2956 | size_t numargs; | 3099 | size_t numargs; |
| @@ -2970,18 +3113,15 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag) | |||
| 2970 | for (i = 0; i < numargs; ) | 3113 | for (i = 0; i < numargs; ) |
| 2971 | { | 3114 | { |
| 2972 | tem = Fcar (args_left), args_left = Fcdr (args_left); | 3115 | tem = Fcar (args_left), args_left = Fcdr (args_left); |
| 2973 | if (eval_flag) tem = Feval (tem); | 3116 | tem = eval_sub (tem); |
| 2974 | arg_vector[i++] = tem; | 3117 | arg_vector[i++] = tem; |
| 2975 | gcpro1.nvars = i; | 3118 | gcpro1.nvars = i; |
| 2976 | } | 3119 | } |
| 2977 | 3120 | ||
| 2978 | UNGCPRO; | 3121 | UNGCPRO; |
| 2979 | 3122 | ||
| 2980 | if (eval_flag) | 3123 | backtrace_list->args = arg_vector; |
| 2981 | { | 3124 | backtrace_list->nargs = i; |
| 2982 | backtrace_list->args = arg_vector; | ||
| 2983 | backtrace_list->nargs = i; | ||
| 2984 | } | ||
| 2985 | backtrace_list->evalargs = 0; | 3125 | backtrace_list->evalargs = 0; |
| 2986 | tem = funcall_lambda (fun, numargs, arg_vector); | 3126 | tem = funcall_lambda (fun, numargs, arg_vector); |
| 2987 | 3127 | ||
| @@ -3002,13 +3142,21 @@ static Lisp_Object | |||
| 3002 | funcall_lambda (Lisp_Object fun, size_t nargs, | 3142 | funcall_lambda (Lisp_Object fun, size_t nargs, |
| 3003 | register Lisp_Object *arg_vector) | 3143 | register Lisp_Object *arg_vector) |
| 3004 | { | 3144 | { |
| 3005 | Lisp_Object val, syms_left, next; | 3145 | Lisp_Object val, syms_left, next, lexenv; |
| 3006 | int count = SPECPDL_INDEX (); | 3146 | int count = SPECPDL_INDEX (); |
| 3007 | size_t i; | 3147 | size_t i; |
| 3008 | int optional, rest; | 3148 | int optional, rest; |
| 3009 | 3149 | ||
| 3010 | if (CONSP (fun)) | 3150 | if (CONSP (fun)) |
| 3011 | { | 3151 | { |
| 3152 | if (EQ (XCAR (fun), Qclosure)) | ||
| 3153 | { | ||
| 3154 | fun = XCDR (fun); /* Drop `closure'. */ | ||
| 3155 | lexenv = XCAR (fun); | ||
| 3156 | CHECK_LIST_CONS (fun, fun); | ||
| 3157 | } | ||
| 3158 | else | ||
| 3159 | lexenv = Qnil; | ||
| 3012 | syms_left = XCDR (fun); | 3160 | syms_left = XCDR (fun); |
| 3013 | if (CONSP (syms_left)) | 3161 | if (CONSP (syms_left)) |
| 3014 | syms_left = XCAR (syms_left); | 3162 | syms_left = XCAR (syms_left); |
| @@ -3016,7 +3164,30 @@ funcall_lambda (Lisp_Object fun, size_t nargs, | |||
| 3016 | xsignal1 (Qinvalid_function, fun); | 3164 | xsignal1 (Qinvalid_function, fun); |
| 3017 | } | 3165 | } |
| 3018 | else if (COMPILEDP (fun)) | 3166 | else if (COMPILEDP (fun)) |
| 3019 | syms_left = AREF (fun, COMPILED_ARGLIST); | 3167 | { |
| 3168 | syms_left = AREF (fun, COMPILED_ARGLIST); | ||
| 3169 | if (INTEGERP (syms_left)) | ||
| 3170 | /* A byte-code object with a non-nil `push args' slot means we | ||
| 3171 | shouldn't bind any arguments, instead just call the byte-code | ||
| 3172 | interpreter directly; it will push arguments as necessary. | ||
| 3173 | |||
| 3174 | Byte-code objects with either a non-existant, or a nil value for | ||
| 3175 | the `push args' slot (the default), have dynamically-bound | ||
| 3176 | arguments, and use the argument-binding code below instead (as do | ||
| 3177 | all interpreted functions, even lexically bound ones). */ | ||
| 3178 | { | ||
| 3179 | /* If we have not actually read the bytecode string | ||
| 3180 | and constants vector yet, fetch them from the file. */ | ||
| 3181 | if (CONSP (AREF (fun, COMPILED_BYTECODE))) | ||
| 3182 | Ffetch_bytecode (fun); | ||
| 3183 | return exec_byte_code (AREF (fun, COMPILED_BYTECODE), | ||
| 3184 | AREF (fun, COMPILED_CONSTANTS), | ||
| 3185 | AREF (fun, COMPILED_STACK_DEPTH), | ||
| 3186 | syms_left, | ||
| 3187 | nargs, arg_vector); | ||
| 3188 | } | ||
| 3189 | lexenv = Qnil; | ||
| 3190 | } | ||
| 3020 | else | 3191 | else |
| 3021 | abort (); | 3192 | abort (); |
| 3022 | 3193 | ||
| @@ -3033,17 +3204,29 @@ funcall_lambda (Lisp_Object fun, size_t nargs, | |||
| 3033 | rest = 1; | 3204 | rest = 1; |
| 3034 | else if (EQ (next, Qand_optional)) | 3205 | else if (EQ (next, Qand_optional)) |
| 3035 | optional = 1; | 3206 | optional = 1; |
| 3036 | else if (rest) | 3207 | else |
| 3037 | { | 3208 | { |
| 3038 | specbind (next, Flist (nargs - i, &arg_vector[i])); | 3209 | Lisp_Object val; |
| 3039 | i = nargs; | 3210 | if (rest) |
| 3211 | { | ||
| 3212 | val = Flist (nargs - i, &arg_vector[i]); | ||
| 3213 | i = nargs; | ||
| 3214 | } | ||
| 3215 | else if (i < nargs) | ||
| 3216 | val = arg_vector[i++]; | ||
| 3217 | else if (!optional) | ||
| 3218 | xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); | ||
| 3219 | else | ||
| 3220 | val = Qnil; | ||
| 3221 | |||
| 3222 | /* Bind the argument. */ | ||
| 3223 | if (!NILP (lexenv) && SYMBOLP (next)) | ||
| 3224 | /* Lexically bind NEXT by adding it to the lexenv alist. */ | ||
| 3225 | lexenv = Fcons (Fcons (next, val), lexenv); | ||
| 3226 | else | ||
| 3227 | /* Dynamically bind NEXT. */ | ||
| 3228 | specbind (next, val); | ||
| 3040 | } | 3229 | } |
| 3041 | else if (i < nargs) | ||
| 3042 | specbind (next, arg_vector[i++]); | ||
| 3043 | else if (!optional) | ||
| 3044 | xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); | ||
| 3045 | else | ||
| 3046 | specbind (next, Qnil); | ||
| 3047 | } | 3230 | } |
| 3048 | 3231 | ||
| 3049 | if (!NILP (syms_left)) | 3232 | if (!NILP (syms_left)) |
| @@ -3051,6 +3234,10 @@ funcall_lambda (Lisp_Object fun, size_t nargs, | |||
| 3051 | else if (i < nargs) | 3234 | else if (i < nargs) |
| 3052 | xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); | 3235 | xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); |
| 3053 | 3236 | ||
| 3237 | if (!EQ (lexenv, Vinternal_interpreter_environment)) | ||
| 3238 | /* Instantiate a new lexical environment. */ | ||
| 3239 | specbind (Qinternal_interpreter_environment, lexenv); | ||
| 3240 | |||
| 3054 | if (CONSP (fun)) | 3241 | if (CONSP (fun)) |
| 3055 | val = Fprogn (XCDR (XCDR (fun))); | 3242 | val = Fprogn (XCDR (XCDR (fun))); |
| 3056 | else | 3243 | else |
| @@ -3059,9 +3246,10 @@ funcall_lambda (Lisp_Object fun, size_t nargs, | |||
| 3059 | and constants vector yet, fetch them from the file. */ | 3246 | and constants vector yet, fetch them from the file. */ |
| 3060 | if (CONSP (AREF (fun, COMPILED_BYTECODE))) | 3247 | if (CONSP (AREF (fun, COMPILED_BYTECODE))) |
| 3061 | Ffetch_bytecode (fun); | 3248 | Ffetch_bytecode (fun); |
| 3062 | val = Fbyte_code (AREF (fun, COMPILED_BYTECODE), | 3249 | val = exec_byte_code (AREF (fun, COMPILED_BYTECODE), |
| 3063 | AREF (fun, COMPILED_CONSTANTS), | 3250 | AREF (fun, COMPILED_CONSTANTS), |
| 3064 | AREF (fun, COMPILED_STACK_DEPTH)); | 3251 | AREF (fun, COMPILED_STACK_DEPTH), |
| 3252 | Qnil, 0, 0); | ||
| 3065 | } | 3253 | } |
| 3066 | 3254 | ||
| 3067 | return unbind_to (count, val); | 3255 | return unbind_to (count, val); |
| @@ -3297,6 +3485,17 @@ unbind_to (int count, Lisp_Object value) | |||
| 3297 | UNGCPRO; | 3485 | UNGCPRO; |
| 3298 | return value; | 3486 | return value; |
| 3299 | } | 3487 | } |
| 3488 | |||
| 3489 | DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0, | ||
| 3490 | doc: /* Return non-nil if SYMBOL's global binding has been declared special. | ||
| 3491 | A special variable is one that will be bound dynamically, even in a | ||
| 3492 | context where binding is lexical by default. */) | ||
| 3493 | (Lisp_Object symbol) | ||
| 3494 | { | ||
| 3495 | CHECK_SYMBOL (symbol); | ||
| 3496 | return XSYMBOL (symbol)->declared_special ? Qt : Qnil; | ||
| 3497 | } | ||
| 3498 | |||
| 3300 | 3499 | ||
| 3301 | DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, | 3500 | DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, |
| 3302 | doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. | 3501 | doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. |
| @@ -3437,6 +3636,8 @@ mark_backtrace (void) | |||
| 3437 | } | 3636 | } |
| 3438 | } | 3637 | } |
| 3439 | 3638 | ||
| 3639 | EXFUN (Funintern, 2); | ||
| 3640 | |||
| 3440 | void | 3641 | void |
| 3441 | syms_of_eval (void) | 3642 | syms_of_eval (void) |
| 3442 | { | 3643 | { |
| @@ -3509,6 +3710,9 @@ before making `inhibit-quit' nil. */); | |||
| 3509 | Qand_optional = intern_c_string ("&optional"); | 3710 | Qand_optional = intern_c_string ("&optional"); |
| 3510 | staticpro (&Qand_optional); | 3711 | staticpro (&Qand_optional); |
| 3511 | 3712 | ||
| 3713 | Qclosure = intern_c_string ("closure"); | ||
| 3714 | staticpro (&Qclosure); | ||
| 3715 | |||
| 3512 | Qdebug = intern_c_string ("debug"); | 3716 | Qdebug = intern_c_string ("debug"); |
| 3513 | staticpro (&Qdebug); | 3717 | staticpro (&Qdebug); |
| 3514 | 3718 | ||
| @@ -3576,6 +3780,28 @@ DECL is a list `(declare ...)' containing the declarations. | |||
| 3576 | The value the function returns is not used. */); | 3780 | The value the function returns is not used. */); |
| 3577 | Vmacro_declaration_function = Qnil; | 3781 | Vmacro_declaration_function = Qnil; |
| 3578 | 3782 | ||
| 3783 | /* When lexical binding is being used, | ||
| 3784 | vinternal_interpreter_environment is non-nil, and contains an alist | ||
| 3785 | of lexically-bound variable, or (t), indicating an empty | ||
| 3786 | environment. The lisp name of this variable would be | ||
| 3787 | `internal-interpreter-environment' if it weren't hidden. | ||
| 3788 | Every element of this list can be either a cons (VAR . VAL) | ||
| 3789 | specifying a lexical binding, or a single symbol VAR indicating | ||
| 3790 | that this variable should use dynamic scoping. */ | ||
| 3791 | Qinternal_interpreter_environment | ||
| 3792 | = intern_c_string ("internal-interpreter-environment"); | ||
| 3793 | staticpro (&Qinternal_interpreter_environment); | ||
| 3794 | DEFVAR_LISP ("internal-interpreter-environment", | ||
| 3795 | Vinternal_interpreter_environment, | ||
| 3796 | doc: /* If non-nil, the current lexical environment of the lisp interpreter. | ||
| 3797 | When lexical binding is not being used, this variable is nil. | ||
| 3798 | A value of `(t)' indicates an empty environment, otherwise it is an | ||
| 3799 | alist of active lexical bindings. */); | ||
| 3800 | Vinternal_interpreter_environment = Qnil; | ||
| 3801 | /* Don't export this variable to Elisp, so noone can mess with it | ||
| 3802 | (Just imagine if someone makes it buffer-local). */ | ||
| 3803 | Funintern (Qinternal_interpreter_environment, Qnil); | ||
| 3804 | |||
| 3579 | Vrun_hooks = intern_c_string ("run-hooks"); | 3805 | Vrun_hooks = intern_c_string ("run-hooks"); |
| 3580 | staticpro (&Vrun_hooks); | 3806 | staticpro (&Vrun_hooks); |
| 3581 | 3807 | ||
| @@ -3625,4 +3851,6 @@ The value the function returns is not used. */); | |||
| 3625 | defsubr (&Sbacktrace_debug); | 3851 | defsubr (&Sbacktrace_debug); |
| 3626 | defsubr (&Sbacktrace); | 3852 | defsubr (&Sbacktrace); |
| 3627 | defsubr (&Sbacktrace_frame); | 3853 | defsubr (&Sbacktrace_frame); |
| 3854 | defsubr (&Sspecial_variable_p); | ||
| 3855 | defsubr (&Sfunctionp); | ||
| 3628 | } | 3856 | } |
| @@ -510,7 +510,7 @@ concat (size_t nargs, Lisp_Object *args, | |||
| 510 | Lisp_Object ch; | 510 | Lisp_Object ch; |
| 511 | EMACS_INT this_len_byte; | 511 | EMACS_INT this_len_byte; |
| 512 | 512 | ||
| 513 | if (VECTORP (this)) | 513 | if (VECTORP (this) || COMPILEDP (this)) |
| 514 | for (i = 0; i < len; i++) | 514 | for (i = 0; i < len; i++) |
| 515 | { | 515 | { |
| 516 | ch = AREF (this, i); | 516 | ch = AREF (this, i); |
| @@ -2297,7 +2297,7 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) | |||
| 2297 | 1) lists are not relocated and 2) the list is marked via `seq' so will not | 2297 | 1) lists are not relocated and 2) the list is marked via `seq' so will not |
| 2298 | be freed */ | 2298 | be freed */ |
| 2299 | 2299 | ||
| 2300 | if (VECTORP (seq)) | 2300 | if (VECTORP (seq) || COMPILEDP (seq)) |
| 2301 | { | 2301 | { |
| 2302 | for (i = 0; i < leni; i++) | 2302 | for (i = 0; i < leni; i++) |
| 2303 | { | 2303 | { |
diff --git a/src/image.c b/src/image.c index 25929d1004c..b37ba398d83 100644 --- a/src/image.c +++ b/src/image.c | |||
| @@ -831,9 +831,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, | |||
| 831 | 831 | ||
| 832 | case IMAGE_FUNCTION_VALUE: | 832 | case IMAGE_FUNCTION_VALUE: |
| 833 | value = indirect_function (value); | 833 | value = indirect_function (value); |
| 834 | if (SUBRP (value) | 834 | if (!NILP (Ffunctionp (value))) |
| 835 | || COMPILEDP (value) | ||
| 836 | || (CONSP (value) && EQ (XCAR (value), Qlambda))) | ||
| 837 | break; | 835 | break; |
| 838 | return 0; | 836 | return 0; |
| 839 | 837 | ||
diff --git a/src/keyboard.c b/src/keyboard.c index 70098d46ebb..d307250b868 100644 --- a/src/keyboard.c +++ b/src/keyboard.c | |||
| @@ -1134,7 +1134,7 @@ command_loop_2 (Lisp_Object ignore) | |||
| 1134 | static Lisp_Object | 1134 | static Lisp_Object |
| 1135 | top_level_2 (void) | 1135 | top_level_2 (void) |
| 1136 | { | 1136 | { |
| 1137 | return Feval (Vtop_level); | 1137 | return Feval (Vtop_level, Qnil); |
| 1138 | } | 1138 | } |
| 1139 | 1139 | ||
| 1140 | Lisp_Object | 1140 | Lisp_Object |
| @@ -3095,7 +3095,7 @@ read_char (int commandflag, int nmaps, Lisp_Object *maps, Lisp_Object prev_event | |||
| 3095 | help_form_saved_window_configs); | 3095 | help_form_saved_window_configs); |
| 3096 | record_unwind_protect (read_char_help_form_unwind, Qnil); | 3096 | record_unwind_protect (read_char_help_form_unwind, Qnil); |
| 3097 | 3097 | ||
| 3098 | tem0 = Feval (Vhelp_form); | 3098 | tem0 = Feval (Vhelp_form, Qnil); |
| 3099 | if (STRINGP (tem0)) | 3099 | if (STRINGP (tem0)) |
| 3100 | internal_with_output_to_temp_buffer ("*Help*", print_help, tem0); | 3100 | internal_with_output_to_temp_buffer ("*Help*", print_help, tem0); |
| 3101 | 3101 | ||
| @@ -7571,6 +7571,12 @@ menu_item_eval_property_1 (Lisp_Object arg) | |||
| 7571 | return Qnil; | 7571 | return Qnil; |
| 7572 | } | 7572 | } |
| 7573 | 7573 | ||
| 7574 | static Lisp_Object | ||
| 7575 | eval_dyn (Lisp_Object form) | ||
| 7576 | { | ||
| 7577 | return Feval (form, Qnil); | ||
| 7578 | } | ||
| 7579 | |||
| 7574 | /* Evaluate an expression and return the result (or nil if something | 7580 | /* Evaluate an expression and return the result (or nil if something |
| 7575 | went wrong). Used to evaluate dynamic parts of menu items. */ | 7581 | went wrong). Used to evaluate dynamic parts of menu items. */ |
| 7576 | Lisp_Object | 7582 | Lisp_Object |
| @@ -7579,7 +7585,7 @@ menu_item_eval_property (Lisp_Object sexpr) | |||
| 7579 | int count = SPECPDL_INDEX (); | 7585 | int count = SPECPDL_INDEX (); |
| 7580 | Lisp_Object val; | 7586 | Lisp_Object val; |
| 7581 | specbind (Qinhibit_redisplay, Qt); | 7587 | specbind (Qinhibit_redisplay, Qt); |
| 7582 | val = internal_condition_case_1 (Feval, sexpr, Qerror, | 7588 | val = internal_condition_case_1 (eval_dyn, sexpr, Qerror, |
| 7583 | menu_item_eval_property_1); | 7589 | menu_item_eval_property_1); |
| 7584 | return unbind_to (count, val); | 7590 | return unbind_to (count, val); |
| 7585 | } | 7591 | } |
diff --git a/src/lisp.h b/src/lisp.h index 63f346f6a25..dfaa3fd01f0 100644 --- a/src/lisp.h +++ b/src/lisp.h | |||
| @@ -1016,6 +1016,10 @@ struct Lisp_Symbol | |||
| 1016 | /* Interned state of the symbol. This is an enumerator from | 1016 | /* Interned state of the symbol. This is an enumerator from |
| 1017 | enum symbol_interned. */ | 1017 | enum symbol_interned. */ |
| 1018 | unsigned interned : 2; | 1018 | unsigned interned : 2; |
| 1019 | |||
| 1020 | /* Non-zero means that this variable has been explicitly declared | ||
| 1021 | special (with `defvar' etc), and shouldn't be lexically bound. */ | ||
| 1022 | unsigned declared_special : 1; | ||
| 1019 | 1023 | ||
| 1020 | /* The symbol's name, as a Lisp string. | 1024 | /* The symbol's name, as a Lisp string. |
| 1021 | 1025 | ||
| @@ -2814,7 +2818,7 @@ extern void syms_of_lread (void); | |||
| 2814 | 2818 | ||
| 2815 | /* Defined in eval.c. */ | 2819 | /* Defined in eval.c. */ |
| 2816 | extern Lisp_Object Qautoload, Qexit, Qinteractive, Qcommandp, Qdefun, Qmacro; | 2820 | extern Lisp_Object Qautoload, Qexit, Qinteractive, Qcommandp, Qdefun, Qmacro; |
| 2817 | extern Lisp_Object Qinhibit_quit; | 2821 | extern Lisp_Object Qinhibit_quit, Qclosure; |
| 2818 | extern Lisp_Object Vautoload_queue; | 2822 | extern Lisp_Object Vautoload_queue; |
| 2819 | extern Lisp_Object Vsignaling_function; | 2823 | extern Lisp_Object Vsignaling_function; |
| 2820 | extern int handling_signal; | 2824 | extern int handling_signal; |
| @@ -2844,7 +2848,9 @@ extern void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN; | |||
| 2844 | extern void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN; | 2848 | extern void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN; |
| 2845 | extern void signal_error (const char *, Lisp_Object) NO_RETURN; | 2849 | extern void signal_error (const char *, Lisp_Object) NO_RETURN; |
| 2846 | EXFUN (Fcommandp, 2); | 2850 | EXFUN (Fcommandp, 2); |
| 2847 | EXFUN (Feval, 1); | 2851 | EXFUN (Ffunctionp, 1); |
| 2852 | EXFUN (Feval, 2); | ||
| 2853 | extern Lisp_Object eval_sub (Lisp_Object form); | ||
| 2848 | EXFUN (Fapply, MANY); | 2854 | EXFUN (Fapply, MANY); |
| 2849 | EXFUN (Ffuncall, MANY); | 2855 | EXFUN (Ffuncall, MANY); |
| 2850 | EXFUN (Fbacktrace, 0); | 2856 | EXFUN (Fbacktrace, 0); |
| @@ -3264,6 +3270,8 @@ extern struct byte_stack *byte_stack_list; | |||
| 3264 | extern void mark_byte_stack (void); | 3270 | extern void mark_byte_stack (void); |
| 3265 | #endif | 3271 | #endif |
| 3266 | extern void unmark_byte_stack (void); | 3272 | extern void unmark_byte_stack (void); |
| 3273 | extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, | ||
| 3274 | Lisp_Object, int, Lisp_Object *); | ||
| 3267 | 3275 | ||
| 3268 | /* Defined in macros.c */ | 3276 | /* Defined in macros.c */ |
| 3269 | extern Lisp_Object Qexecute_kbd_macro; | 3277 | extern Lisp_Object Qexecute_kbd_macro; |
diff --git a/src/lread.c b/src/lread.c index a5fd1513c39..6a24569f552 100644 --- a/src/lread.c +++ b/src/lread.c | |||
| @@ -73,6 +73,7 @@ Lisp_Object Qascii_character, Qload, Qload_file_name; | |||
| 73 | Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction; | 73 | Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction; |
| 74 | Lisp_Object Qinhibit_file_name_operation; | 74 | Lisp_Object Qinhibit_file_name_operation; |
| 75 | Lisp_Object Qeval_buffer_list; | 75 | Lisp_Object Qeval_buffer_list; |
| 76 | Lisp_Object Qlexical_binding; | ||
| 76 | Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */ | 77 | Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */ |
| 77 | 78 | ||
| 78 | /* Used instead of Qget_file_char while loading *.elc files compiled | 79 | /* Used instead of Qget_file_char while loading *.elc files compiled |
| @@ -81,6 +82,8 @@ static Lisp_Object Qget_emacs_mule_file_char; | |||
| 81 | 82 | ||
| 82 | static Lisp_Object Qload_force_doc_strings; | 83 | static Lisp_Object Qload_force_doc_strings; |
| 83 | 84 | ||
| 85 | extern Lisp_Object Qinternal_interpreter_environment; | ||
| 86 | |||
| 84 | static Lisp_Object Qload_in_progress; | 87 | static Lisp_Object Qload_in_progress; |
| 85 | 88 | ||
| 86 | /* The association list of objects read with the #n=object form. | 89 | /* The association list of objects read with the #n=object form. |
| @@ -147,8 +150,7 @@ static Lisp_Object Vloads_in_progress; | |||
| 147 | static int read_emacs_mule_char (int, int (*) (int, Lisp_Object), | 150 | static int read_emacs_mule_char (int, int (*) (int, Lisp_Object), |
| 148 | Lisp_Object); | 151 | Lisp_Object); |
| 149 | 152 | ||
| 150 | static void readevalloop (Lisp_Object, FILE*, Lisp_Object, | 153 | static void readevalloop (Lisp_Object, FILE*, Lisp_Object, int, |
| 151 | Lisp_Object (*) (Lisp_Object), int, | ||
| 152 | Lisp_Object, Lisp_Object, | 154 | Lisp_Object, Lisp_Object, |
| 153 | Lisp_Object, Lisp_Object); | 155 | Lisp_Object, Lisp_Object); |
| 154 | static Lisp_Object load_unwind (Lisp_Object); | 156 | static Lisp_Object load_unwind (Lisp_Object); |
| @@ -769,6 +771,116 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0, | |||
| 769 | 771 | ||
| 770 | 772 | ||
| 771 | 773 | ||
| 774 | |||
| 775 | /* Return true if the lisp code read using READCHARFUN defines a non-nil | ||
| 776 | `lexical-binding' file variable. After returning, the stream is | ||
| 777 | positioned following the first line, if it is a comment, otherwise | ||
| 778 | nothing is read. */ | ||
| 779 | |||
| 780 | static int | ||
| 781 | lisp_file_lexically_bound_p (Lisp_Object readcharfun) | ||
| 782 | { | ||
| 783 | int ch = READCHAR; | ||
| 784 | if (ch != ';') | ||
| 785 | /* The first line isn't a comment, just give up. */ | ||
| 786 | { | ||
| 787 | UNREAD (ch); | ||
| 788 | return 0; | ||
| 789 | } | ||
| 790 | else | ||
| 791 | /* Look for an appropriate file-variable in the first line. */ | ||
| 792 | { | ||
| 793 | int rv = 0; | ||
| 794 | enum { | ||
| 795 | NOMINAL, AFTER_FIRST_DASH, AFTER_ASTERIX, | ||
| 796 | } beg_end_state = NOMINAL; | ||
| 797 | int in_file_vars = 0; | ||
| 798 | |||
| 799 | #define UPDATE_BEG_END_STATE(ch) \ | ||
| 800 | if (beg_end_state == NOMINAL) \ | ||
| 801 | beg_end_state = (ch == '-' ? AFTER_FIRST_DASH : NOMINAL); \ | ||
| 802 | else if (beg_end_state == AFTER_FIRST_DASH) \ | ||
| 803 | beg_end_state = (ch == '*' ? AFTER_ASTERIX : NOMINAL); \ | ||
| 804 | else if (beg_end_state == AFTER_ASTERIX) \ | ||
| 805 | { \ | ||
| 806 | if (ch == '-') \ | ||
| 807 | in_file_vars = !in_file_vars; \ | ||
| 808 | beg_end_state = NOMINAL; \ | ||
| 809 | } | ||
| 810 | |||
| 811 | /* Skip until we get to the file vars, if any. */ | ||
| 812 | do | ||
| 813 | { | ||
| 814 | ch = READCHAR; | ||
| 815 | UPDATE_BEG_END_STATE (ch); | ||
| 816 | } | ||
| 817 | while (!in_file_vars && ch != '\n' && ch != EOF); | ||
| 818 | |||
| 819 | while (in_file_vars) | ||
| 820 | { | ||
| 821 | char var[100], *var_end, val[100], *val_end; | ||
| 822 | |||
| 823 | ch = READCHAR; | ||
| 824 | |||
| 825 | /* Read a variable name. */ | ||
| 826 | while (ch == ' ' || ch == '\t') | ||
| 827 | ch = READCHAR; | ||
| 828 | |||
| 829 | var_end = var; | ||
| 830 | while (ch != ':' && ch != '\n' && ch != EOF) | ||
| 831 | { | ||
| 832 | if (var_end < var + sizeof var - 1) | ||
| 833 | *var_end++ = ch; | ||
| 834 | UPDATE_BEG_END_STATE (ch); | ||
| 835 | ch = READCHAR; | ||
| 836 | } | ||
| 837 | |||
| 838 | while (var_end > var | ||
| 839 | && (var_end[-1] == ' ' || var_end[-1] == '\t')) | ||
| 840 | var_end--; | ||
| 841 | *var_end = '\0'; | ||
| 842 | |||
| 843 | if (ch == ':') | ||
| 844 | { | ||
| 845 | /* Read a variable value. */ | ||
| 846 | ch = READCHAR; | ||
| 847 | |||
| 848 | while (ch == ' ' || ch == '\t') | ||
| 849 | ch = READCHAR; | ||
| 850 | |||
| 851 | val_end = val; | ||
| 852 | while (ch != ';' && ch != '\n' && ch != EOF && in_file_vars) | ||
| 853 | { | ||
| 854 | if (val_end < val + sizeof val - 1) | ||
| 855 | *val_end++ = ch; | ||
| 856 | UPDATE_BEG_END_STATE (ch); | ||
| 857 | ch = READCHAR; | ||
| 858 | } | ||
| 859 | if (! in_file_vars) | ||
| 860 | /* The value was terminated by an end-marker, which | ||
| 861 | remove. */ | ||
| 862 | val_end -= 3; | ||
| 863 | while (val_end > val | ||
| 864 | && (val_end[-1] == ' ' || val_end[-1] == '\t')) | ||
| 865 | val_end--; | ||
| 866 | *val_end = '\0'; | ||
| 867 | |||
| 868 | if (strcmp (var, "lexical-binding") == 0) | ||
| 869 | /* This is it... */ | ||
| 870 | { | ||
| 871 | rv = (strcmp (val, "nil") != 0); | ||
| 872 | break; | ||
| 873 | } | ||
| 874 | } | ||
| 875 | } | ||
| 876 | |||
| 877 | while (ch != '\n' && ch != EOF) | ||
| 878 | ch = READCHAR; | ||
| 879 | |||
| 880 | return rv; | ||
| 881 | } | ||
| 882 | } | ||
| 883 | |||
| 772 | /* Value is a version number of byte compiled code if the file | 884 | /* Value is a version number of byte compiled code if the file |
| 773 | associated with file descriptor FD is a compiled Lisp file that's | 885 | associated with file descriptor FD is a compiled Lisp file that's |
| 774 | safe to load. Only files compiled with Emacs are safe to load. | 886 | safe to load. Only files compiled with Emacs are safe to load. |
| @@ -1033,6 +1145,12 @@ Return t if the file exists and loads successfully. */) | |||
| 1033 | Vloads_in_progress = Fcons (found, Vloads_in_progress); | 1145 | Vloads_in_progress = Fcons (found, Vloads_in_progress); |
| 1034 | } | 1146 | } |
| 1035 | 1147 | ||
| 1148 | /* All loads are by default dynamic, unless the file itself specifies | ||
| 1149 | otherwise using a file-variable in the first line. This is bound here | ||
| 1150 | so that it takes effect whether or not we use | ||
| 1151 | Vload_source_file_function. */ | ||
| 1152 | specbind (Qlexical_binding, Qnil); | ||
| 1153 | |||
| 1036 | /* Get the name for load-history. */ | 1154 | /* Get the name for load-history. */ |
| 1037 | hist_file_name = (! NILP (Vpurify_flag) | 1155 | hist_file_name = (! NILP (Vpurify_flag) |
| 1038 | ? Fconcat (2, (tmp[0] = Ffile_name_directory (file), | 1156 | ? Fconcat (2, (tmp[0] = Ffile_name_directory (file), |
| @@ -1157,15 +1275,20 @@ Return t if the file exists and loads successfully. */) | |||
| 1157 | load_descriptor_list | 1275 | load_descriptor_list |
| 1158 | = Fcons (make_number (fileno (stream)), load_descriptor_list); | 1276 | = Fcons (make_number (fileno (stream)), load_descriptor_list); |
| 1159 | specbind (Qload_in_progress, Qt); | 1277 | specbind (Qload_in_progress, Qt); |
| 1278 | |||
| 1279 | instream = stream; | ||
| 1280 | if (lisp_file_lexically_bound_p (Qget_file_char)) | ||
| 1281 | Fset (Qlexical_binding, Qt); | ||
| 1282 | |||
| 1160 | if (! version || version >= 22) | 1283 | if (! version || version >= 22) |
| 1161 | readevalloop (Qget_file_char, stream, hist_file_name, | 1284 | readevalloop (Qget_file_char, stream, hist_file_name, |
| 1162 | Feval, 0, Qnil, Qnil, Qnil, Qnil); | 1285 | 0, Qnil, Qnil, Qnil, Qnil); |
| 1163 | else | 1286 | else |
| 1164 | { | 1287 | { |
| 1165 | /* We can't handle a file which was compiled with | 1288 | /* We can't handle a file which was compiled with |
| 1166 | byte-compile-dynamic by older version of Emacs. */ | 1289 | byte-compile-dynamic by older version of Emacs. */ |
| 1167 | specbind (Qload_force_doc_strings, Qt); | 1290 | specbind (Qload_force_doc_strings, Qt); |
| 1168 | readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name, Feval, | 1291 | readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name, |
| 1169 | 0, Qnil, Qnil, Qnil, Qnil); | 1292 | 0, Qnil, Qnil, Qnil, Qnil); |
| 1170 | } | 1293 | } |
| 1171 | unbind_to (count, Qnil); | 1294 | unbind_to (count, Qnil); |
| @@ -1535,7 +1658,6 @@ static void | |||
| 1535 | readevalloop (Lisp_Object readcharfun, | 1658 | readevalloop (Lisp_Object readcharfun, |
| 1536 | FILE *stream, | 1659 | FILE *stream, |
| 1537 | Lisp_Object sourcename, | 1660 | Lisp_Object sourcename, |
| 1538 | Lisp_Object (*evalfun) (Lisp_Object), | ||
| 1539 | int printflag, | 1661 | int printflag, |
| 1540 | Lisp_Object unibyte, Lisp_Object readfun, | 1662 | Lisp_Object unibyte, Lisp_Object readfun, |
| 1541 | Lisp_Object start, Lisp_Object end) | 1663 | Lisp_Object start, Lisp_Object end) |
| @@ -1546,6 +1668,7 @@ readevalloop (Lisp_Object readcharfun, | |||
| 1546 | struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | 1668 | struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; |
| 1547 | struct buffer *b = 0; | 1669 | struct buffer *b = 0; |
| 1548 | int continue_reading_p; | 1670 | int continue_reading_p; |
| 1671 | Lisp_Object lex_bound; | ||
| 1549 | /* Nonzero if reading an entire buffer. */ | 1672 | /* Nonzero if reading an entire buffer. */ |
| 1550 | int whole_buffer = 0; | 1673 | int whole_buffer = 0; |
| 1551 | /* 1 on the first time around. */ | 1674 | /* 1 on the first time around. */ |
| @@ -1571,6 +1694,14 @@ readevalloop (Lisp_Object readcharfun, | |||
| 1571 | record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil); | 1694 | record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil); |
| 1572 | load_convert_to_unibyte = !NILP (unibyte); | 1695 | load_convert_to_unibyte = !NILP (unibyte); |
| 1573 | 1696 | ||
| 1697 | /* If lexical binding is active (either because it was specified in | ||
| 1698 | the file's header, or via a buffer-local variable), create an empty | ||
| 1699 | lexical environment, otherwise, turn off lexical binding. */ | ||
| 1700 | lex_bound = find_symbol_value (Qlexical_binding); | ||
| 1701 | specbind (Qinternal_interpreter_environment, | ||
| 1702 | NILP (lex_bound) || EQ (lex_bound, Qunbound) | ||
| 1703 | ? Qnil : Fcons (Qt, Qnil)); | ||
| 1704 | |||
| 1574 | GCPRO4 (sourcename, readfun, start, end); | 1705 | GCPRO4 (sourcename, readfun, start, end); |
| 1575 | 1706 | ||
| 1576 | /* Try to ensure sourcename is a truename, except whilst preloading. */ | 1707 | /* Try to ensure sourcename is a truename, except whilst preloading. */ |
| @@ -1672,7 +1803,7 @@ readevalloop (Lisp_Object readcharfun, | |||
| 1672 | unbind_to (count1, Qnil); | 1803 | unbind_to (count1, Qnil); |
| 1673 | 1804 | ||
| 1674 | /* Now eval what we just read. */ | 1805 | /* Now eval what we just read. */ |
| 1675 | val = (*evalfun) (val); | 1806 | val = eval_sub (val); |
| 1676 | 1807 | ||
| 1677 | if (printflag) | 1808 | if (printflag) |
| 1678 | { | 1809 | { |
| @@ -1732,7 +1863,8 @@ This function preserves the position of point. */) | |||
| 1732 | specbind (Qstandard_output, tem); | 1863 | specbind (Qstandard_output, tem); |
| 1733 | record_unwind_protect (save_excursion_restore, save_excursion_save ()); | 1864 | record_unwind_protect (save_excursion_restore, save_excursion_save ()); |
| 1734 | BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); | 1865 | BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); |
| 1735 | readevalloop (buf, 0, filename, Feval, | 1866 | specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil); |
| 1867 | readevalloop (buf, 0, filename, | ||
| 1736 | !NILP (printflag), unibyte, Qnil, Qnil, Qnil); | 1868 | !NILP (printflag), unibyte, Qnil, Qnil, Qnil); |
| 1737 | unbind_to (count, Qnil); | 1869 | unbind_to (count, Qnil); |
| 1738 | 1870 | ||
| @@ -1753,6 +1885,7 @@ which is the input stream for reading characters. | |||
| 1753 | This function does not move point. */) | 1885 | This function does not move point. */) |
| 1754 | (Lisp_Object start, Lisp_Object end, Lisp_Object printflag, Lisp_Object read_function) | 1886 | (Lisp_Object start, Lisp_Object end, Lisp_Object printflag, Lisp_Object read_function) |
| 1755 | { | 1887 | { |
| 1888 | /* FIXME: Do the eval-sexp-add-defvars danse! */ | ||
| 1756 | int count = SPECPDL_INDEX (); | 1889 | int count = SPECPDL_INDEX (); |
| 1757 | Lisp_Object tem, cbuf; | 1890 | Lisp_Object tem, cbuf; |
| 1758 | 1891 | ||
| @@ -1766,7 +1899,7 @@ This function does not move point. */) | |||
| 1766 | specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list)); | 1899 | specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list)); |
| 1767 | 1900 | ||
| 1768 | /* readevalloop calls functions which check the type of start and end. */ | 1901 | /* readevalloop calls functions which check the type of start and end. */ |
| 1769 | readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename), Feval, | 1902 | readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename), |
| 1770 | !NILP (printflag), Qnil, read_function, | 1903 | !NILP (printflag), Qnil, read_function, |
| 1771 | start, end); | 1904 | start, end); |
| 1772 | 1905 | ||
| @@ -3838,6 +3971,7 @@ defvar_int (struct Lisp_Intfwd *i_fwd, | |||
| 3838 | sym = intern_c_string (namestring); | 3971 | sym = intern_c_string (namestring); |
| 3839 | i_fwd->type = Lisp_Fwd_Int; | 3972 | i_fwd->type = Lisp_Fwd_Int; |
| 3840 | i_fwd->intvar = address; | 3973 | i_fwd->intvar = address; |
| 3974 | XSYMBOL (sym)->declared_special = 1; | ||
| 3841 | XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; | 3975 | XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; |
| 3842 | SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd); | 3976 | SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd); |
| 3843 | } | 3977 | } |
| @@ -3852,6 +3986,7 @@ defvar_bool (struct Lisp_Boolfwd *b_fwd, | |||
| 3852 | sym = intern_c_string (namestring); | 3986 | sym = intern_c_string (namestring); |
| 3853 | b_fwd->type = Lisp_Fwd_Bool; | 3987 | b_fwd->type = Lisp_Fwd_Bool; |
| 3854 | b_fwd->boolvar = address; | 3988 | b_fwd->boolvar = address; |
| 3989 | XSYMBOL (sym)->declared_special = 1; | ||
| 3855 | XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; | 3990 | XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; |
| 3856 | SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd); | 3991 | SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd); |
| 3857 | Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars); | 3992 | Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars); |
| @@ -3870,6 +4005,7 @@ defvar_lisp_nopro (struct Lisp_Objfwd *o_fwd, | |||
| 3870 | sym = intern_c_string (namestring); | 4005 | sym = intern_c_string (namestring); |
| 3871 | o_fwd->type = Lisp_Fwd_Obj; | 4006 | o_fwd->type = Lisp_Fwd_Obj; |
| 3872 | o_fwd->objvar = address; | 4007 | o_fwd->objvar = address; |
| 4008 | XSYMBOL (sym)->declared_special = 1; | ||
| 3873 | XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; | 4009 | XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; |
| 3874 | SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd); | 4010 | SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd); |
| 3875 | } | 4011 | } |
| @@ -3893,6 +4029,7 @@ defvar_kboard (struct Lisp_Kboard_Objfwd *ko_fwd, | |||
| 3893 | sym = intern_c_string (namestring); | 4029 | sym = intern_c_string (namestring); |
| 3894 | ko_fwd->type = Lisp_Fwd_Kboard_Obj; | 4030 | ko_fwd->type = Lisp_Fwd_Kboard_Obj; |
| 3895 | ko_fwd->offset = offset; | 4031 | ko_fwd->offset = offset; |
| 4032 | XSYMBOL (sym)->declared_special = 1; | ||
| 3896 | XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; | 4033 | XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; |
| 3897 | SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd); | 4034 | SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd); |
| 3898 | } | 4035 | } |
| @@ -4320,6 +4457,15 @@ to load. See also `load-dangerous-libraries'. */); | |||
| 4320 | Vbytecomp_version_regexp | 4457 | Vbytecomp_version_regexp |
| 4321 | = make_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)"); | 4458 | = make_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)"); |
| 4322 | 4459 | ||
| 4460 | Qlexical_binding = intern ("lexical-binding"); | ||
| 4461 | staticpro (&Qlexical_binding); | ||
| 4462 | DEFVAR_LISP ("lexical-binding", Vlexical_binding, | ||
| 4463 | doc: /* If non-nil, use lexical binding when evaluating code. | ||
| 4464 | This only applies to code evaluated by `eval-buffer' and `eval-region'. | ||
| 4465 | This variable is automatically set from the file variables of an interpreted | ||
| 4466 | Lisp file read using `load'. */); | ||
| 4467 | Fmake_variable_buffer_local (Qlexical_binding); | ||
| 4468 | |||
| 4323 | DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list, | 4469 | DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list, |
| 4324 | doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */); | 4470 | doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */); |
| 4325 | Veval_buffer_list = Qnil; | 4471 | Veval_buffer_list = Qnil; |
diff --git a/src/minibuf.c b/src/minibuf.c index 7bed9bb2f2d..4adf665f8f4 100644 --- a/src/minibuf.c +++ b/src/minibuf.c | |||
| @@ -971,7 +971,8 @@ Such arguments are used as in `read-from-minibuffer'.) */) | |||
| 971 | { | 971 | { |
| 972 | return Feval (read_minibuf (Vread_expression_map, initial_contents, | 972 | return Feval (read_minibuf (Vread_expression_map, initial_contents, |
| 973 | prompt, Qnil, 1, Qread_expression_history, | 973 | prompt, Qnil, 1, Qread_expression_history, |
| 974 | make_number (0), Qnil, 0, 0)); | 974 | make_number (0), Qnil, 0, 0), |
| 975 | Qnil); | ||
| 975 | } | 976 | } |
| 976 | 977 | ||
| 977 | /* Functions that use the minibuffer to read various things. */ | 978 | /* Functions that use the minibuffer to read various things. */ |
diff --git a/src/print.c b/src/print.c index dd3d1c9bbb2..3e0e168381b 100644 --- a/src/print.c +++ b/src/print.c | |||
| @@ -521,6 +521,7 @@ temp_output_buffer_setup (const char *bufname) | |||
| 521 | specbind (Qstandard_output, buf); | 521 | specbind (Qstandard_output, buf); |
| 522 | } | 522 | } |
| 523 | 523 | ||
| 524 | /* FIXME: Use Lisp's with-output-to-temp-buffer instead! */ | ||
| 524 | Lisp_Object | 525 | Lisp_Object |
| 525 | internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function) (Lisp_Object), Lisp_Object args) | 526 | internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function) (Lisp_Object), Lisp_Object args) |
| 526 | { | 527 | { |
| @@ -542,60 +543,6 @@ internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function | |||
| 542 | 543 | ||
| 543 | return unbind_to (count, val); | 544 | return unbind_to (count, val); |
| 544 | } | 545 | } |
| 545 | |||
| 546 | DEFUN ("with-output-to-temp-buffer", | ||
| 547 | Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer, | ||
| 548 | 1, UNEVALLED, 0, | ||
| 549 | doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. | ||
| 550 | |||
| 551 | This construct makes buffer BUFNAME empty before running BODY. | ||
| 552 | It does not make the buffer current for BODY. | ||
| 553 | Instead it binds `standard-output' to that buffer, so that output | ||
| 554 | generated with `prin1' and similar functions in BODY goes into | ||
| 555 | the buffer. | ||
| 556 | |||
| 557 | At the end of BODY, this marks buffer BUFNAME unmodifed and displays | ||
| 558 | it in a window, but does not select it. The normal way to do this is | ||
| 559 | by calling `display-buffer', then running `temp-buffer-show-hook'. | ||
| 560 | However, if `temp-buffer-show-function' is non-nil, it calls that | ||
| 561 | function instead (and does not run `temp-buffer-show-hook'). The | ||
| 562 | function gets one argument, the buffer to display. | ||
| 563 | |||
| 564 | The return value of `with-output-to-temp-buffer' is the value of the | ||
| 565 | last form in BODY. If BODY does not finish normally, the buffer | ||
| 566 | BUFNAME is not displayed. | ||
| 567 | |||
| 568 | This runs the hook `temp-buffer-setup-hook' before BODY, | ||
| 569 | with the buffer BUFNAME temporarily current. It runs the hook | ||
| 570 | `temp-buffer-show-hook' after displaying buffer BUFNAME, with that | ||
| 571 | buffer temporarily current, and the window that was used to display it | ||
| 572 | temporarily selected. But it doesn't run `temp-buffer-show-hook' | ||
| 573 | if it uses `temp-buffer-show-function'. | ||
| 574 | |||
| 575 | usage: (with-output-to-temp-buffer BUFNAME BODY...) */) | ||
| 576 | (Lisp_Object args) | ||
| 577 | { | ||
| 578 | struct gcpro gcpro1; | ||
| 579 | Lisp_Object name; | ||
| 580 | int count = SPECPDL_INDEX (); | ||
| 581 | Lisp_Object buf, val; | ||
| 582 | |||
| 583 | GCPRO1(args); | ||
| 584 | name = Feval (Fcar (args)); | ||
| 585 | CHECK_STRING (name); | ||
| 586 | temp_output_buffer_setup (SSDATA (name)); | ||
| 587 | buf = Vstandard_output; | ||
| 588 | UNGCPRO; | ||
| 589 | |||
| 590 | val = Fprogn (XCDR (args)); | ||
| 591 | |||
| 592 | GCPRO1 (val); | ||
| 593 | temp_output_buffer_show (buf); | ||
| 594 | UNGCPRO; | ||
| 595 | |||
| 596 | return unbind_to (count, val); | ||
| 597 | } | ||
| 598 | |||
| 599 | 546 | ||
| 600 | static void print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag); | 547 | static void print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag); |
| 601 | static void print_preprocess (Lisp_Object obj); | 548 | static void print_preprocess (Lisp_Object obj); |
| @@ -2289,6 +2236,4 @@ priorities. */); | |||
| 2289 | 2236 | ||
| 2290 | print_prune_charset_plist = Qnil; | 2237 | print_prune_charset_plist = Qnil; |
| 2291 | staticpro (&print_prune_charset_plist); | 2238 | staticpro (&print_prune_charset_plist); |
| 2292 | |||
| 2293 | defsubr (&Swith_output_to_temp_buffer); | ||
| 2294 | } | 2239 | } |
diff --git a/src/window.c b/src/window.c index 0d299b7cd93..5ca46dd3316 100644 --- a/src/window.c +++ b/src/window.c | |||
| @@ -3705,6 +3705,16 @@ temp_output_buffer_show (register Lisp_Object buf) | |||
| 3705 | } | 3705 | } |
| 3706 | } | 3706 | } |
| 3707 | } | 3707 | } |
| 3708 | |||
| 3709 | DEFUN ("internal-temp-output-buffer-show", | ||
| 3710 | Ftemp_output_buffer_show, Stemp_output_buffer_show, | ||
| 3711 | 1, 1, 0, | ||
| 3712 | doc: /* Internal function for `with-output-to-temp-buffer''. */) | ||
| 3713 | (Lisp_Object buf) | ||
| 3714 | { | ||
| 3715 | temp_output_buffer_show (buf); | ||
| 3716 | return Qnil; | ||
| 3717 | } | ||
| 3708 | 3718 | ||
| 3709 | static void | 3719 | static void |
| 3710 | make_dummy_parent (Lisp_Object window) | 3720 | make_dummy_parent (Lisp_Object window) |
| @@ -6390,28 +6400,6 @@ redirection (see `redirect-frame-focus'). */) | |||
| 6390 | return (tem); | 6400 | return (tem); |
| 6391 | } | 6401 | } |
| 6392 | 6402 | ||
| 6393 | DEFUN ("save-window-excursion", Fsave_window_excursion, Ssave_window_excursion, | ||
| 6394 | 0, UNEVALLED, 0, | ||
| 6395 | doc: /* Execute BODY, preserving window sizes and contents. | ||
| 6396 | Return the value of the last form in BODY. | ||
| 6397 | Restore which buffer appears in which window, where display starts, | ||
| 6398 | and the value of point and mark for each window. | ||
| 6399 | Also restore the choice of selected window. | ||
| 6400 | Also restore which buffer is current. | ||
| 6401 | Does not restore the value of point in current buffer. | ||
| 6402 | usage: (save-window-excursion BODY...) */) | ||
| 6403 | (Lisp_Object args) | ||
| 6404 | { | ||
| 6405 | register Lisp_Object val; | ||
| 6406 | register int count = SPECPDL_INDEX (); | ||
| 6407 | |||
| 6408 | record_unwind_protect (Fset_window_configuration, | ||
| 6409 | Fcurrent_window_configuration (Qnil)); | ||
| 6410 | val = Fprogn (args); | ||
| 6411 | return unbind_to (count, val); | ||
| 6412 | } | ||
| 6413 | |||
| 6414 | |||
| 6415 | 6403 | ||
| 6416 | /*********************************************************************** | 6404 | /*********************************************************************** |
| 6417 | Window Split Tree | 6405 | Window Split Tree |
| @@ -7167,6 +7155,7 @@ frame to be redrawn only if it is a tty frame. */); | |||
| 7167 | defsubr (&Sset_window_buffer); | 7155 | defsubr (&Sset_window_buffer); |
| 7168 | defsubr (&Sselect_window); | 7156 | defsubr (&Sselect_window); |
| 7169 | defsubr (&Sforce_window_update); | 7157 | defsubr (&Sforce_window_update); |
| 7158 | defsubr (&Stemp_output_buffer_show); | ||
| 7170 | defsubr (&Ssplit_window); | 7159 | defsubr (&Ssplit_window); |
| 7171 | defsubr (&Senlarge_window); | 7160 | defsubr (&Senlarge_window); |
| 7172 | defsubr (&Sshrink_window); | 7161 | defsubr (&Sshrink_window); |
| @@ -7185,7 +7174,6 @@ frame to be redrawn only if it is a tty frame. */); | |||
| 7185 | defsubr (&Swindow_configuration_frame); | 7174 | defsubr (&Swindow_configuration_frame); |
| 7186 | defsubr (&Sset_window_configuration); | 7175 | defsubr (&Sset_window_configuration); |
| 7187 | defsubr (&Scurrent_window_configuration); | 7176 | defsubr (&Scurrent_window_configuration); |
| 7188 | defsubr (&Ssave_window_excursion); | ||
| 7189 | defsubr (&Swindow_tree); | 7177 | defsubr (&Swindow_tree); |
| 7190 | defsubr (&Sset_window_margins); | 7178 | defsubr (&Sset_window_margins); |
| 7191 | defsubr (&Swindow_margins); | 7179 | defsubr (&Swindow_margins); |
diff --git a/src/window.h b/src/window.h index f788e126d6d..ad627aca340 100644 --- a/src/window.h +++ b/src/window.h | |||
| @@ -853,7 +853,6 @@ EXFUN (Fwindow_minibuffer_p, 1); | |||
| 853 | EXFUN (Fdelete_window, 1); | 853 | EXFUN (Fdelete_window, 1); |
| 854 | EXFUN (Fwindow_buffer, 1); | 854 | EXFUN (Fwindow_buffer, 1); |
| 855 | EXFUN (Fget_buffer_window, 2); | 855 | EXFUN (Fget_buffer_window, 2); |
| 856 | EXFUN (Fsave_window_excursion, UNEVALLED); | ||
| 857 | EXFUN (Fset_window_configuration, 1); | 856 | EXFUN (Fset_window_configuration, 1); |
| 858 | EXFUN (Fcurrent_window_configuration, 1); | 857 | EXFUN (Fcurrent_window_configuration, 1); |
| 859 | extern int compare_window_configurations (Lisp_Object, Lisp_Object, int); | 858 | extern int compare_window_configurations (Lisp_Object, Lisp_Object, int); |
diff --git a/test/ChangeLog b/test/ChangeLog index b247b88bc94..dc9b87adfac 100644 --- a/test/ChangeLog +++ b/test/ChangeLog | |||
| @@ -1,3 +1,7 @@ | |||
| 1 | 2011-03-10 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * automated/lexbind-tests.el: New file. | ||
| 4 | |||
| 1 | 2011-03-05 Glenn Morris <rgm@gnu.org> | 5 | 2011-03-05 Glenn Morris <rgm@gnu.org> |
| 2 | 6 | ||
| 3 | * eshell.el: Move here from lisp/eshell/esh-test.el. | 7 | * eshell.el: Move here from lisp/eshell/esh-test.el. |
diff --git a/test/automated/lexbind-tests.el b/test/automated/lexbind-tests.el new file mode 100644 index 00000000000..95b8bbe8858 --- /dev/null +++ b/test/automated/lexbind-tests.el | |||
| @@ -0,0 +1,75 @@ | |||
| 1 | ;;; lexbind-tests.el --- Testing the lexbind byte-compiler | ||
| 2 | |||
| 3 | ;; Copyright (C) 2011 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 6 | ;; Keywords: | ||
| 7 | |||
| 8 | ;; This program is free software; you can redistribute it and/or modify | ||
| 9 | ;; it under the terms of the GNU General Public License as published by | ||
| 10 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 11 | ;; (at your option) any later version. | ||
| 12 | |||
| 13 | ;; This program is distributed in the hope that it will be useful, | ||
| 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 16 | ;; GNU General Public License for more details. | ||
| 17 | |||
| 18 | ;; You should have received a copy of the GNU General Public License | ||
| 19 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
| 20 | |||
| 21 | ;;; Commentary: | ||
| 22 | |||
| 23 | ;; | ||
| 24 | |||
| 25 | ;;; Code: | ||
| 26 | |||
| 27 | (require 'ert) | ||
| 28 | |||
| 29 | (defconst lexbind-tests | ||
| 30 | `( | ||
| 31 | (let ((f #'car)) | ||
| 32 | (let ((f (lambda (x) (cons (funcall f x) (cdr x))))) | ||
| 33 | (funcall f '(1 . 2)))) | ||
| 34 | ) | ||
| 35 | "List of expression for test. | ||
| 36 | Each element will be executed by interpreter and with | ||
| 37 | bytecompiled code, and their results compared.") | ||
| 38 | |||
| 39 | |||
| 40 | |||
| 41 | (defun lexbind-check-1 (pat) | ||
| 42 | "Return non-nil if PAT is the same whether directly evalled or compiled." | ||
| 43 | (let ((warning-minimum-log-level :emergency) | ||
| 44 | (byte-compile-warnings nil) | ||
| 45 | (v0 (condition-case nil | ||
| 46 | (eval pat t) | ||
| 47 | (error nil))) | ||
| 48 | (v1 (condition-case nil | ||
| 49 | (funcall (let ((lexical-binding t)) | ||
| 50 | (byte-compile `(lambda nil ,pat)))) | ||
| 51 | (error nil)))) | ||
| 52 | (equal v0 v1))) | ||
| 53 | |||
| 54 | (put 'lexbind-check-1 'ert-explainer 'lexbind-explain-1) | ||
| 55 | |||
| 56 | (defun lexbind-explain-1 (pat) | ||
| 57 | (let ((v0 (condition-case nil | ||
| 58 | (eval pat t) | ||
| 59 | (error nil))) | ||
| 60 | (v1 (condition-case nil | ||
| 61 | (funcall (let ((lexical-binding t)) | ||
| 62 | (byte-compile (list 'lambda nil pat)))) | ||
| 63 | (error nil)))) | ||
| 64 | (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." | ||
| 65 | pat v0 v1))) | ||
| 66 | |||
| 67 | (ert-deftest lexbind-tests () | ||
| 68 | "Test the Emacs byte compiler lexbind handling." | ||
| 69 | (dolist (pat lexbind-tests) | ||
| 70 | (should (lexbind-check-1 pat)))) | ||
| 71 | |||
| 72 | |||
| 73 | |||
| 74 | (provide 'lexbind-tests) | ||
| 75 | ;;; lexbind-tests.el ends here | ||