Mercurial > hg > xemacs-beta
changeset 5095:cb4f2e1bacc4
merge
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Thu, 04 Mar 2010 02:46:38 -0600 |
| parents | ebee7d1e58bd (current diff) 207dad9e74f7 (diff) |
| children | e0587c615e8b |
| files | man/ChangeLog man/custom.texi src/ChangeLog src/lisp.h |
| diffstat | 15 files changed, 347 insertions(+), 517 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Wed Mar 03 05:41:44 2010 -0600 +++ b/lisp/ChangeLog Thu Mar 04 02:46:38 2010 -0600 @@ -1,3 +1,16 @@ +2010-03-02 Aidan Kehoe <kehoea@parhasard.net> + + * cl-macs.el (delete-dups): New compiler macro for this function, + expanding to inline byte codes. + (delete-duplicates): Handle the :from-end argument correctly in + this compiler macro. + +2010-03-01 Aidan Kehoe <kehoea@parhasard.net> + + * cl-seq.el (cl-parsing-keywords): + * cl-macs.el (cl-do-arglist): + Use the new invalid-keyword-argument error here. + 2010-02-26 Aidan Kehoe <kehoea@parhasard.net> Back out Ben's revision c673987f5f3d.
--- a/lisp/cl-macs.el Wed Mar 03 05:41:44 2010 -0600 +++ b/lisp/cl-macs.el Thu Mar 04 02:46:38 2010 -0600 @@ -494,8 +494,7 @@ (list t (list 'error - (format "Keyword argument %%s not one of %s" - keys) + ''invalid-keyword-argument (list 'car var))))))) (push (list 'let (list (list var restarg)) check) bind-forms))) (while (and (eq (car args) '&aux) (pop args)) @@ -3293,50 +3292,113 @@ (list 'let (list (list temp val)) (subst temp val res))))) form)) -;; XEmacs; inline delete-duplicates if it's called with a literal -;; #'equal or #'eq and no other keywords, we want the speed in -;; font-lock.el. +(define-compiler-macro delete-dups (list) + `(delete-duplicates (the list ,list) :test #'equal :from-end t)) + +;; XEmacs; inline delete-duplicates if it's called with one of the +;; common compile-time constant tests and an optional :from-end +;; argument, we want the speed in font-lock.el. (define-compiler-macro delete-duplicates (&whole form cl-seq &rest cl-keys) (let ((listp-check - (if (memq (car-safe cl-seq) - ;; No need to check for a list at runtime with these. We - ;; could expand the list, but these are all the functions - ;; in the relevant context at the moment. - '(nreverse append nconc mapcan mapcar)) - t - '(listp begin)))) - (cond ((and (= 4 (length form)) - (eq :test (third form)) - (or (equal '(quote eq) (fourth form)) - (equal '(function eq) (fourth form)))) + (cond + ((memq (car-safe cl-seq) + ;; No need to check for a list at runtime with these. We + ;; could expand the list, but these are all the functions + ;; in the relevant context at the moment. + '(nreverse append nconc mapcan mapcar string-to-list)) + t) + ((and (listp cl-seq) (eq (first cl-seq) 'the) + (eq (second cl-seq) 'list)) + ;; Allow users to force this, if they really want to. + t) + (t + '(listp begin))))) + (cond ((loop + for relevant-key-values + in '((:test 'eq) + (:test #'eq) + (:test 'eq :from-end nil) + (:test #'eq :from-end nil)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) + `(let* ((begin ,cl-seq) + cl-seq) + (if ,listp-check + (progn + (while (memq (car begin) (cdr begin)) + (setq begin (cdr begin))) + (setq cl-seq begin) + (while (cddr cl-seq) + (if (memq (cadr cl-seq) (cddr cl-seq)) + (setcdr (cdr cl-seq) (cddr cl-seq)) + (setq cl-seq (cdr cl-seq)))) + begin) + ;; Call cl-delete-duplicates explicitly, to avoid the form + ;; getting compiler-macroexpanded again: + (cl-delete-duplicates begin ',cl-keys nil)))) + ((loop + for relevant-key-values + in '((:test 'eq :from-end t) + (:test #'eq :from-end t)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) + `(let* ((begin ,cl-seq) + (cl-seq begin)) + (if ,listp-check + (progn + (while cl-seq + (setq cl-seq (setcdr cl-seq + (delq (car cl-seq) (cdr cl-seq))))) + begin) + ;; Call cl-delete-duplicates explicitly, to avoid the form + ;; getting compiler-macroexpanded again: + (cl-delete-duplicates begin ',cl-keys nil)))) + + ((loop + for relevant-key-values + in '((:test 'equal) + (:test #'equal) + (:test 'equal :from-end nil) + (:test #'equal :from-end nil)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) + `(let* ((begin ,cl-seq) + cl-seq) + (if ,listp-check + (progn + (while (member (car begin) (cdr begin)) + (setq begin (cdr begin))) + (setq cl-seq begin) + (while (cddr cl-seq) + (if (member (cadr cl-seq) (cddr cl-seq)) + (setcdr (cdr cl-seq) (cddr cl-seq))) + (setq cl-seq (cdr cl-seq))) + begin) + ;; Call cl-delete-duplicates explicitly, to avoid the form + ;; getting compiler-macroexpanded again: + (cl-delete-duplicates begin ',cl-keys nil)))) + ((loop + for relevant-key-values + in '((:test 'equal :from-end t) + (:test #'equal :from-end t)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) `(let* ((begin ,cl-seq) (cl-seq begin)) (if ,listp-check (progn (while cl-seq - (setq cl-seq (setcdr cl-seq (delq (car cl-seq) - (cdr cl-seq))))) - begin) + (setq cl-seq + (setcdr cl-seq (delete (car cl-seq) (cdr cl-seq))))) + begin) ;; Call cl-delete-duplicates explicitly, to avoid the form ;; getting compiler-macroexpanded again: (cl-delete-duplicates begin ',cl-keys nil)))) - ((and (= 4 (length form)) - (eq :test (third form)) - (or (equal '(quote equal) (fourth form)) - (equal '(function equal) (fourth form)))) - `(let* ((begin ,cl-seq) - (cl-seq begin)) - (if ,listp-check - (progn - (while cl-seq - (setq cl-seq (setcdr cl-seq (delete (car cl-seq) - (cdr cl-seq))))) - begin) - ;; Call cl-delete-duplicates explicitly, to avoid the form - ;; getting compiler-macroexpanded again: - (cl-delete-duplicates begin ',cl-keys nil)))) - (t - form)))) + (t form)))) ;; XEmacs; it's perfectly reasonable, and often much clearer to those ;; reading the code, to call regexp-quote on a constant string, which is
--- a/lisp/cl-seq.el Wed Mar 03 05:41:44 2010 -0600 +++ b/lisp/cl-seq.el Thu Mar 04 02:46:38 2010 -0600 @@ -107,7 +107,7 @@ other-keys)))) '(car (cdr (memq (quote :allow-other-keys) cl-keys))) - '(error "Bad keyword argument %s" + '(error 'invalid-keyword-argument (car cl-keys-temp))) '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) body))))
--- a/man/ChangeLog Wed Mar 03 05:41:44 2010 -0600 +++ b/man/ChangeLog Thu Mar 04 02:46:38 2010 -0600 @@ -6,6 +6,12 @@ Update to make note of e.g. the fact that the bottom gutter is actually above the minibuffer. +2010-03-02 Jerry James <james@xemacs.org> + + * custom.texi: Delete, redundant with xemacs/custom.texi and + lispref/customize.texi. + * Makefile: Remove all rules relating to custom.texi. + 2010-02-25 Didier Verna <didier@xemacs.org> The background-placement face property.
--- a/man/Makefile Wed Mar 03 05:41:44 2010 -0600 +++ b/man/Makefile Thu Mar 04 02:46:38 2010 -0600 @@ -46,7 +46,6 @@ info_files = \ $(INFODIR)/beta.info \ $(INFODIR)/cl.info \ - $(INFODIR)/custom.info \ $(INFODIR)/emodules.info \ $(INFODIR)/external-widget.info \ $(INFODIR)/info.info \ @@ -63,7 +62,6 @@ html_files = \ $(HTMLDIR)/beta.html \ $(HTMLDIR)/cl.html \ - $(HTMLDIR)/custom.html \ $(HTMLDIR)/emodules.html \ $(HTMLDIR)/external-widget.html \ $(HTMLDIR)/info.html \ @@ -80,7 +78,6 @@ dvi_files = \ beta.dvi \ cl.dvi \ - custom.dvi \ emodules.dvi \ external-widget.dvi \ info.dvi \ @@ -97,7 +94,6 @@ pdf_files = \ beta.pdf \ cl.pdf \ - custom.pdf \ emodules.pdf \ external-widget.pdf \ info.pdf \ @@ -245,9 +241,6 @@ $(INFODIR)/cl.info : cl.texi $(MAKEINFO) -o $(INFODIR)/cl.info cl.texi -$(INFODIR)/custom.info : custom.texi - $(MAKEINFO) -o $(INFODIR)/custom.info custom.texi - $(INFODIR)/emodules.info : emodules.texi $(MAKEINFO) -o $(INFODIR)/emodules.info emodules.texi @@ -353,9 +346,6 @@ $(HTMLDIR)/cl.html : cl.texi $(TEXI2HTML_SPLIT) cl.texi -$(HTMLDIR)/custom.html : custom.texi - $(TEXI2HTML_SPLIT) custom.texi - $(HTMLDIR)/emodules.html : emodules.texi $(TEXI2HTML_SPLIT) emodules.texi
--- a/man/custom.texi Wed Mar 03 05:41:44 2010 -0600 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,438 +0,0 @@ -\input texinfo.tex - -@c %**start of header -@setfilename ../info/custom.info -@settitle The Customization Library -@iftex -@afourpaper -@headings double -@end iftex -@c %**end of header - -@ifinfo -@dircategory XEmacs Editor -@direntry -* Customizations: (custom). Customization Library. -@end direntry -@end ifinfo - -@node Top, Declaring Groups, (dir), (dir) -@comment node-name, next, previous, up -@top The Customization Library - -This manual describes how to declare customization groups, variables, -and faces. It doesn't contain any examples, but please look at the file -@file{cus-edit.el} which contains many declarations you can learn from. - -@menu -* Declaring Groups:: -* Declaring Variables:: -* Declaring Faces:: -* Usage for Package Authors:: -* Utilities:: -* The Init File:: -* Wishlist:: -@end menu - -All the customization declarations can be changes by keyword arguments. -Groups, variables, and faces all share these common keywords: - -@table @code -@item :group -@var{value} should be a customization group. -Add @var{symbol} to that group. -@item :link -@var{value} should be a widget type. -Add @var{value} to the external links for this customization option. -Useful widget types include @code{custom-manual}, @code{info-link}, and -@code{url-link}. -@item :load -Add @var{value} to the files that should be loaded before displaying -this customization option. The value should be either a string, which -should be a string which will be loaded with @code{load-library} unless -present in @code{load-history}, or a symbol which will be loaded with -@code{require}. -@item :tag -@var{Value} should be a short string used for identifying the option in -customization menus and buffers. By default the tag will be -automatically created from the options name. -@end table - -@node Declaring Groups, Declaring Variables, Top, Top -@comment node-name, next, previous, up -@section Declaring Groups - -Use @code{defgroup} to declare new customization groups. - -@defun defgroup symbol members doc [keyword value]... -Declare @var{symbol} as a customization group containing @var{members}. -@var{symbol} does not need to be quoted. - -@var{doc} is the group documentation. - -@var{members} should be an alist of the form ((@var{name} -@var{widget})...) where @var{name} is a symbol and @var{widget} is a -widget for editing that symbol. Useful widgets are -@code{custom-variable} for editing variables, @code{custom-face} for -editing faces, and @code{custom-group} for editing groups.@refill - -Internally, custom uses the symbol property @code{custom-group} to keep -track of the group members, and @code{group-documentation} for the -documentation string. - -The following additional @var{keyword}'s are defined: - -@table @code -@item :prefix -@var{value} should be a string. If the string is a prefix for the name -of a member of the group, that prefix will be ignored when creating a -tag for that member. -@end table -@end defun - -@node Declaring Variables, Declaring Faces, Declaring Groups, Top -@comment node-name, next, previous, up -@section Declaring Variables - -Use @code{defcustom} to declare user editable variables. - -@defun defcustom symbol value doc [keyword value]... -Declare @var{symbol} as a customizable variable that defaults to @var{value}. -Neither @var{symbol} nor @var{value} needs to be quoted. -If @var{symbol} is not already bound, initialize it to @var{value}. - -@var{doc} is the variable documentation. - -The following additional @var{keyword}'s are defined: - -@table @code -@item :type -@var{value} should be a widget type. - -@item :options -@var{value} should be a list of possible members of the specified type. -For hooks, this is a list of function names. - -@item :initialize -@var{value} should be a function used to initialize the variable. It -takes two arguments, the symbol and value given in the @code{defcustom} call. -Some predefined functions are: - -@table @code -@item custom-initialize-set -Use the @code{:set} method to initialize the variable. Do not -initialize it if already bound. This is the default @code{:initialize} -method. - -@item custom-initialize-default -Always use @code{set-default} to initialize the variable, even if a -@code{:set} method has been specified. - -@item custom-initialize-reset -If the variable is already bound, reset it by calling the @code{:set} -method with the value returned by the @code{:get} method. - -@item custom-initialize-changed -Like @code{custom-initialize-reset}, but use @code{set-default} to -initialize the variable if it is not bound and has not been set -already. -@end table - -@item :set -@var{value} should be a function to set the value of the symbol. It -takes two arguments, the symbol to set and the value to give it. The -default is @code{set-default}. - -@item :get -@var{value} should be a function to extract the value of symbol. The -function takes one argument, a symbol, and should return the current -value for that symbol. The default is @code{default-value}. - -@item :require -@var{value} should be a feature symbol. Each feature will be required -when the `defcustom' is evaluated, or when Emacs is started if the user -has saved this option. - -@end table - -@xref{Sexp Types,,,widget,The Widget Library}, for information about -widgets to use together with the @code{:type} keyword. -@end defun - -Internally, custom uses the symbol property @code{custom-type} to keep -track of the variables type, @code{standard-value} for the program -specified default value, @code{saved-value} for a value saved by the -user, and @code{variable-documentation} for the documentation string. - -Use @code{custom-add-option} to specify that a specific function is -useful as a member of a hook. - -@defun custom-add-option symbol option -To the variable @var{symbol} add @var{option}. - -If @var{symbol} is a hook variable, @var{option} should be a hook -member. For other types of variables, the effect is undefined." -@end defun - -@node Declaring Faces, Usage for Package Authors, Declaring Variables, Top -@comment node-name, next, previous, up -@section Declaring Faces - -Faces are declared with @code{defface}. - -@defun defface face spec doc [keyword value]... - -Declare @var{face} as a customizable face that defaults to @var{spec}. -@var{face} does not need to be quoted. - -If @var{face} has been set with `custom-set-face', set the face attributes -as specified by that function, otherwise set the face attributes -according to @var{spec}. - -@var{doc} is the face documentation. - -@var{spec} should be an alist of the form @samp{((@var{display} @var{atts})...)}. - -@var{atts} is a list of face attributes and their values. The possible -attributes are defined in the variable `custom-face-attributes'. - -The @var{atts} of the first entry in @var{spec} where the @var{display} -matches the frame should take effect in that frame. @var{display} can -either be the symbol `t', which will match all frames, or an alist of -the form @samp{((@var{req} @var{item}...)...)}@refill - -For the @var{display} to match a FRAME, the @var{req} property of the -frame must match one of the @var{item}. The following @var{req} are -defined:@refill - -@table @code -@item type -(the value of (window-system))@* -Should be one of @code{x} or @code{tty}. - -@item class -(the frame's color support)@* -Should be one of @code{color}, @code{grayscale}, or @code{mono}. - -@item background -(what color is used for the background text)@* -Should be one of @code{light} or @code{dark}. -@end table - -Internally, custom uses the symbol property @code{face-defface-spec} for -the program specified default face properties, @code{saved-face} for -properties saved by the user, and @code{face-documentation} for the -documentation string.@refill - -@end defun - -@node Usage for Package Authors, Utilities, Declaring Faces, Top -@comment node-name, next, previous, up -@section Usage for Package Authors - -The recommended usage for the author of a typical emacs lisp package is -to create one group identifying the package, and make all user options -and faces members of that group. If the package has more than around 20 -such options, they should be divided into a number of subgroups, with -each subgroup being member of the top level group. - -The top level group for the package should itself be member of one or -more of the standard customization groups. There exists a group for -each @emph{finder} keyword. Press @kbd{C-h p} to see a list of finder -keywords, and add you group to each of them, using the @code{:group} -keyword. - -@node Utilities, The Init File, Usage for Package Authors, Top -@comment node-name, next, previous, up -@section Utilities - -These utilities can come in handy when adding customization support. - -@deffn Widget custom-manual -Widget type for specifying the info manual entry for a customization -option. It takes one argument, an info address. -@end deffn - -@defun custom-add-to-group group member widget -To existing @var{group} add a new @var{member} of type @var{widget}, -If there already is an entry for that member, overwrite it. -@end defun - -@defun custom-add-link symbol widget -To the custom option @var{symbol} add the link @var{widget}. -@end defun - -@defun custom-add-load symbol load -To the custom option @var{symbol} add the dependency @var{load}. -@var{load} should be either a library file name, or a feature name. -@end defun - -@defun customize-menu-create symbol &optional name -Create menu for customization group @var{symbol}. -If optional @var{name} is given, use that as the name of the menu. -Otherwise the menu will be named `Customize'. -The menu is in a format applicable to @code{easy-menu-define}. -@end defun - -@node The Init File, Wishlist, Utilities, Top -@comment node-name, next, previous, up -@section The Init File - -Customizations are saved to the file specified by @code{custom-file}, as -calls to @code{custom-set-variables} and @code{custom-set-faces}. - -When you save customizations, the current implementation removes the -calls to @code{custom-set-variables} and @code{custom-set-faces}, and -replaces them with code generated on the basis of the current -customization state in Emacs. - -By default @code{custom-file} is your @file{.emacs} file (for GNU Emacs -and older XEmacs) and is @file{custom.el} in the same directory as -@file{init.el} (in XEmacs 21.4 and later). If you use another file, you -must explicitly load it yourself. - -As of XEmacs 21.4.7, when @code{custom-file} is present, it is loaded -@emph{after} @file{init.el}. This is likely to change in the future, -because (1) actions in @file{init.el} often would like to depend on -customizations for consistent appearance and (2) Custom is quite brutal -about enforcing its idea of the correct values at initialization. - -@node Wishlist, , The Init File, Top -@comment node-name, next, previous, up -@section Wishlist - -@itemize @bullet -@item -Better support for keyboard operations in the customize buffer. - -@item -Integrate with @file{w3} so you can get customization buffers with much -better formatting. I'm thinking about adding a <custom>name</custom> -tag. The latest w3 have some support for this, so come up with a -convincing example. - -@item -Add an `examples' section, with explained examples of custom type -definitions. - -@item -Support selectable color themes. I.e., change many faces by setting one -variable. - -@item -Support undo using lmi's @file{gnus-undo.el}. - - -@item -Make it possible to append to `choice', `radio', and `set' options. - -@item -Ask whether set or modified variables should be saved in -@code{kill-buffer-hook}. - -Ditto for @code{kill-emacs-query-functions}. - -@item -Command to check if there are any customization options that -does not belong to an existing group. - -@item -Optionally disable the point-cursor and instead highlight the selected -item in XEmacs. This is like the *Completions* buffer in XEmacs. -Suggested by Jens Lautenbacher -@samp{<jens@@lemming0.lem.uni-karlsruhe.de>}.@refill - -@item -Explain why it is necessary that all choices have different default -values. - -@item -Add some direct support for meta variables, i.e. make it possible to -specify that this variable should be reset when that variable is -changed. - -@item -Add tutorial. - -@item -Describe the @code{:type} syntax in this manual. - -@item -Find a place is this manual for the following text: - -@strong{Radio vs. Buttons} - -Use a radio if you can't find a good way to describe the item in the -choice menu text. I.e. it is better to use a radio if you expect the -user would otherwise manually select each item from the choice menu in -turn to see what it expands too. - -Avoid radios if some of the items expands to complex structures. - -I mostly use radios when most of the items are of type -@code{function-item} or @code{variable-item}. - -@item -Update customize buffers when @code{custom-set-variable} or -@code{custom-save-customized} is called. - -@item -Better handling of saved but uninitialized items. - -@item -Detect when faces have been changed outside customize. - -@item -Enable mouse help in Emacs by default. - -@item -Add an easy way to display the standard settings when an item is modified. - -@item -See if it is feasible to scan files for customization information -instead of loading them, - -@item -Add hint message when user push a non-pushable tag. - -Suggest that the user unhide if hidden, and edit the value directly -otherwise. - -@item -Use checkboxes and radio buttons in the state menus. - -@item -Add option to hide @samp{[hide]} for short options. Default, on. - -@item -Add option to hide @samp{[state]} for options with their standard -settings. - -@item -There should be a way to specify site defaults for user options. - -@item -There should be more buffer styles. The default `nested style, the old -`outline' style, a `numeric' style with numbers instead of stars, an -`empty' style with just the group name, and `compact' with only one line -per item. - -@item -Newline and tab should be displayed as @samp{^J} and @samp{^I} in the -@code{regexp} and @code{file} widgets. I think this can be done in -XEmacs by adding a display table to the face. - -@item -Use glyphs to draw the @code{customize-browse} tree. - -Add echo and balloon help. You should be able to read the documentation -simply by moving the mouse pointer above the name. - -Add parent links. - -Add colors. - -@end itemize - -@contents -@bye
--- a/nt/ChangeLog Wed Mar 03 05:41:44 2010 -0600 +++ b/nt/ChangeLog Thu Mar 04 02:46:38 2010 -0600 @@ -1,3 +1,7 @@ +2010-03-02 Jerry James <james@xemacs.org> + + * xemacs.mak (INFO_FILES): Removed custom.info. + 2010-02-18 Vin Shelton <acs@xemacs.org> * xemacs.mak (INFO_FILES): Removed term.info.
--- a/nt/xemacs.mak Wed Mar 03 05:41:44 2010 -0600 +++ b/nt/xemacs.mak Thu Mar 04 02:46:38 2010 -0600 @@ -1488,7 +1488,6 @@ INFO_FILES= \ $(INFODIR)\beta.info \ $(INFODIR)\cl.info \ - $(INFODIR)\custom.info \ $(INFODIR)\emodules.info \ $(INFODIR)\external-widget.info \ $(INFODIR)\info.info \
--- a/src/ChangeLog Wed Mar 03 05:41:44 2010 -0600 +++ b/src/ChangeLog Thu Mar 04 02:46:38 2010 -0600 @@ -97,6 +97,29 @@ Use const for variables holding string constants to avoid C++ warnings. +2010-03-02 Jerry James <james@xemacs.org> + + * lread.c (read_atom): Signal a read error upon encountering a + ratio constant with a zero denominator. + +2010-03-02 Aidan Kehoe <kehoea@parhasard.net> + + * eval.c (print_multiple_value): + Say #<INTERNAL OBJECT (XEmacs bug?) ...> when printing these, for + consistency with the rest of the print code. + +2010-03-01 Aidan Kehoe <kehoea@parhasard.net> + + * lisp.h (PARSE_KEYWORDS): New macro, for parsing keyword + arguments from C subrs. + * elhash.c (Fmake_hash_table): Use it. + * general-slots.h (Q_allow_other_keys): Add this symbol. + * eval.c (non_nil_allow_other_keys_p): + (invalid_keyword_argument): + New functions, called from the keyword argument parsing code. + * data.c (init_errors_once_early): + Add the new invalid-keyword-argument error here. + 2010-02-26 Aidan Kehoe <kehoea@parhasard.net> * file-coding.c (Fmake_coding_system_internal):
--- a/src/data.c Wed Mar 03 05:41:44 2010 -0600 +++ b/src/data.c Thu Mar 04 02:46:38 2010 -0600 @@ -41,7 +41,8 @@ Lisp_Object Qcircular_list, Qcircular_property_list; Lisp_Object Qinvalid_argument, Qinvalid_constant, Qwrong_type_argument; Lisp_Object Qargs_out_of_range; -Lisp_Object Qwrong_number_of_arguments, Qinvalid_function, Qno_catch; +Lisp_Object Qwrong_number_of_arguments, Qinvalid_function; +Lisp_Object Qinvalid_keyword_argument, Qno_catch; Lisp_Object Qinternal_error, Qinvalid_state, Qstack_overflow, Qout_of_memory; Lisp_Object Qvoid_variable, Qcyclic_variable_indirection; Lisp_Object Qvoid_function, Qcyclic_function_indirection; @@ -3472,6 +3473,7 @@ DEFERROR_STANDARD (Qwrong_number_of_arguments, Qinvalid_argument); DEFERROR_STANDARD (Qinvalid_function, Qinvalid_argument); DEFERROR_STANDARD (Qinvalid_constant, Qinvalid_argument); + DEFERROR_STANDARD (Qinvalid_keyword_argument, Qinvalid_argument); DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument); DEFERROR_STANDARD (Qinvalid_state, Qerror);
--- a/src/elhash.c Wed Mar 03 05:41:44 2010 -0600 +++ b/src/elhash.c Thu Mar 04 02:46:38 2010 -0600 @@ -84,7 +84,7 @@ #include "opaque.h" Lisp_Object Qhash_tablep; -static Lisp_Object Qhashtable, Qhash_table; +static Lisp_Object Qhashtable, Qhash_table, Qmake_hash_table; static Lisp_Object Qweakness, Qvalue, Qkey_or_value, Qkey_and_value; static Lisp_Object Vall_weak_hash_tables; static Lisp_Object Qrehash_size, Qrehash_threshold; @@ -993,29 +993,27 @@ */ (int nargs, Lisp_Object *args)) { - int i = 0; - Lisp_Object test = Qnil; - Lisp_Object size = Qnil; - Lisp_Object rehash_size = Qnil; - Lisp_Object rehash_threshold = Qnil; - Lisp_Object weakness = Qnil; - - while (i + 1 < nargs) - { - Lisp_Object keyword = args[i++]; - Lisp_Object value = args[i++]; +#ifdef NO_NEED_TO_HANDLE_21_4_CODE + PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 5, + (test, size, rehash_size, rehash_threshold, weakness), + NULL, weakness = Qunbound), 0); +#else + PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 6, + (test, size, rehash_size, rehash_threshold, weakness, + type), (type = Qunbound, weakness = Qunbound), 0); - if (EQ (keyword, Q_test)) test = value; - else if (EQ (keyword, Q_size)) size = value; - else if (EQ (keyword, Q_rehash_size)) rehash_size = value; - else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value; - else if (EQ (keyword, Q_weakness)) weakness = value; - else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value; - else invalid_constant ("Invalid hash table property keyword", keyword); + if (EQ (weakness, Qunbound)) + { + if (EQ (weakness, Qunbound) && !EQ (type, Qunbound)) + { + weakness = type; + } + else + { + weakness = Qnil; + } } - - if (i < nargs) - sferror ("Hash table property requires a value", args[i]); +#endif #define VALIDATE_VAR(var) \ if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME); @@ -1854,6 +1852,7 @@ DEFSYMBOL_MULTIWORD_PREDICATE (Qhash_tablep); DEFSYMBOL (Qhash_table); DEFSYMBOL (Qhashtable); + DEFSYMBOL (Qmake_hash_table); DEFSYMBOL (Qweakness); DEFSYMBOL (Qvalue); DEFSYMBOL (Qkey_or_value);
--- a/src/eval.c Wed Mar 03 05:41:44 2010 -0600 +++ b/src/eval.c Thu Mar 04 02:46:38 2010 -0600 @@ -418,6 +418,29 @@ static Lisp_Object maybe_get_trapping_problems_backtrace (void); + +/* When parsing keyword arguments; is some element of NARGS + :allow-other-keys, and is that element followed by a non-nil Lisp + object? */ + +Boolint +non_nil_allow_other_keys_p (Elemcount offset, int nargs, Lisp_Object *args) +{ + Lisp_Object key, value; + while (offset + 1 < nargs) + { + key = args[offset++]; + value = args[offset++]; + if (EQ (key, Q_allow_other_keys)) + { + /* The ANSI Common Lisp standard says the first value for a given + keyword overrides. */ + return !NILP (value); + } + } + return 0; +} + /************************************************************************/ /* The subr object type */ /************************************************************************/ @@ -3050,6 +3073,12 @@ } DOESNT_RETURN +invalid_keyword_argument (Lisp_Object function, Lisp_Object keyword) +{ + signal_error_1 (Qinvalid_keyword_argument, list2 (function, keyword)); +} + +DOESNT_RETURN invalid_constant (const Ascbyte *reason, Lisp_Object frob) { signal_error (Qinvalid_constant, reason, frob); @@ -4579,10 +4608,9 @@ printing_unreadable_object ("multiple values"); } - if (0 == count) - { - write_msg_string (printcharfun, "#<zero-length multiple value>"); - } + write_fmt_string (printcharfun, + "#<INTERNAL OBJECT (XEmacs bug?) %d multiple values," + " data (", count); for (index = 0; index < count;) { @@ -4603,9 +4631,11 @@ if (count > 1 && index < count) { - write_ascstring (printcharfun, " ;\n"); + write_ascstring (printcharfun, " "); } } + + write_fmt_string (printcharfun, ") 0x%lx>", (unsigned long) XPNTR (obj)); } static Lisp_Object
--- a/src/general-slots.h Wed Mar 03 05:41:44 2010 -0600 +++ b/src/general-slots.h Thu Mar 04 02:46:38 2010 -0600 @@ -49,6 +49,7 @@ SYMBOL (Qactually_requested); SYMBOL (Qafter); SYMBOL (Qall); +SYMBOL_KEYWORD (Q_allow_other_keys); SYMBOL (Qand); SYMBOL (Qappend); SYMBOL (Qascii);
--- a/src/lisp.h Wed Mar 03 05:41:44 2010 -0600 +++ b/src/lisp.h Thu Mar 04 02:46:38 2010 -0600 @@ -4013,6 +4013,136 @@ while (NILP (Ffunctionp (fun))) \ signal_invalid_function_error (fun); \ } while (0) + +/************************************************************************/ +/* Parsing keyword arguments */ +/************************************************************************/ + +/* The C subr must have been declared with MANY as its max args, and this + PARSE_KEYWORDS call must come before any statements. + + FUNCTION is the name of the current function, as a symbol. + + NARGS is the count of arguments supplied to FUNCTION. + + ARGS is a pointer to the argument vector (not a Lisp vector) supplied to + FUNCTION. + + KEYWORDS_OFFSET is the offset into ARGS where the keyword arguments start. + + KEYWORD_COUNT is the number of keywords FUNCTION is normally prepared to + handle. + + KEYWORDS is a parenthesised list of those keywords, without the initial + Q_. + + KEYWORD_DEFAULTS allows you to set non-nil defaults. Put (keywordname = + initial_value) in this parameter, a collection of C statements surrounded + by parentheses and separated by the comma operator. If you don't need + this, supply NULL as KEYWORD_DEFAULTS. + + ALLOW_OTHER_KEYS corresponds to the &allow-other-keys argument list + entry in defun*; it is 1 if other keys are normally allowed, 0 + otherwise. This may be overridden in the caller by specifying + :allow-other-keys t in the argument list. + + For keywords which appear multiple times in the called argument list, the + leftmost one overrides, as specified in section 7.1.1 of the CLHS. + + If you want to check whether a given keyword argument was set (as in the + SVAR argument to defun*), supply Qunbound as its default in + KEYWORD_DEFAULTS, and examine it once PARSE_KEYWORDS is done. Lisp code + cannot supply Qunbound as an argument, so if it is still Qunbound, it was + not set. + + There is no elegant way with this macro to have one name for the keyword + and an unrelated name for the local variable, as is possible with the + ((:keyword unrelated-var)) syntax in defun* and in Common Lisp. That + shouldn't matter in practice. */ + +#define PARSE_KEYWORDS(function, nargs, args, keywords_offset, \ + keyword_count, keywords, keyword_defaults, \ + allow_other_keys) \ + DECLARE_N_KEYWORDS_##keyword_count keywords; \ + \ + do \ + { \ + Lisp_Object pk_key, pk_value; \ + Elemcount pk_i = nargs - 1; \ + Boolint pk_allow_other_keys = allow_other_keys; \ + \ + if ((nargs - keywords_offset) & 1) \ + { \ + if (!allow_other_keys \ + && !(pk_allow_other_keys \ + = non_nil_allow_other_keys_p (keywords_offset, \ + nargs, args))) \ + { \ + signal_wrong_number_of_arguments_error (function, nargs); \ + } \ + else \ + { \ + /* Ignore the trailing arg; so below always sees an even \ + number of arguments. */ \ + pk_i -= 1; \ + } \ + } \ + \ + (void)(keyword_defaults); \ + \ + /* Start from the end, because the leftmost element overrides. */ \ + while (pk_i > keywords_offset) \ + { \ + pk_value = args[pk_i--]; \ + pk_key = args[pk_i--]; \ + \ + if (0) {} \ + CHECK_N_KEYWORDS_##keyword_count keywords \ + else if (allow_other_keys || pk_allow_other_keys) \ + { \ + continue; \ + } \ + else if (!(pk_allow_other_keys \ + = non_nil_allow_other_keys_p (keywords_offset, \ + nargs, args))) \ + { \ + invalid_keyword_argument (function, pk_key); \ + } \ + } \ + } while (0) + +#define DECLARE_N_KEYWORDS_1(a) \ + Lisp_Object a = Qnil +#define DECLARE_N_KEYWORDS_2(a,b) \ + DECLARE_N_KEYWORDS_1(a), b = Qnil +#define DECLARE_N_KEYWORDS_3(a,b,c) \ + DECLARE_N_KEYWORDS_2(a,b), c = Qnil +#define DECLARE_N_KEYWORDS_4(a,b,c,d) \ + DECLARE_N_KEYWORDS_3(a,b,c), d = Qnil +#define DECLARE_N_KEYWORDS_5(a,b,c,d,e) \ + DECLARE_N_KEYWORDS_4(a,b,c,d), e = Qnil +#define DECLARE_N_KEYWORDS_6(a,b,c,d,e,f) \ + DECLARE_N_KEYWORDS_5(a,b,c,d,e), f = Qnil +#define DECLARE_N_KEYWORDS_7(a,b,c,d,e,f,g) \ + DECLARE_N_KEYWORDS_6(a,b,c,d,e,f), g = Qnil + +#define CHECK_N_KEYWORDS_1(a) \ + else if (EQ (pk_key, Q_##a)) { a = pk_value; } +#define CHECK_N_KEYWORDS_2(a,b) CHECK_N_KEYWORDS_1(a) \ + else if (EQ (pk_key, Q_##b)) { b = pk_value; } +#define CHECK_N_KEYWORDS_3(a,b,c) CHECK_N_KEYWORDS_2(a,b) \ + else if (EQ (pk_key, Q_##c)) { c = pk_value; } +#define CHECK_N_KEYWORDS_4(a,b,c,d) CHECK_N_KEYWORDS_3(a,b,c) \ + else if (EQ (pk_key, Q_##d)) { d = pk_value; } +#define CHECK_N_KEYWORDS_5(a,b,c,d,e) CHECK_N_KEYWORDS_4(a,b,c,d) \ + else if (EQ (pk_key, Q_##e)) { e = pk_value; } +#define CHECK_N_KEYWORDS_6(a,b,c,d,e,f) CHECK_N_KEYWORDS_5(a,b,c,d,e) \ + else if (EQ (pk_key, Q_##f)) { f = pk_value; } +#define CHECK_N_KEYWORDS_7(a,b,c,d,e,f,g) CHECK_N_KEYWORDS_6(a,b,c,d,e,f) \ + else if (EQ (pk_key, Q_##g)) { g = pk_value; } + +Boolint non_nil_allow_other_keys_p (Elemcount offset, int nargs, + Lisp_Object *args); /************************************************************************/ @@ -4870,7 +5000,8 @@ Qcircular_list, Qcircular_property_list, Qconversion_error, Qcyclic_variable_indirection, Qdomain_error, Qediting_error, Qend_of_buffer, Qend_of_file, Qerror, Qfile_error, Qinternal_error, - Qinvalid_change, Qinvalid_constant, Qinvalid_function, Qinvalid_operation, + Qinvalid_change, Qinvalid_constant, Qinvalid_function, + Qinvalid_keyword_argument, Qinvalid_operation, Qinvalid_read_syntax, Qinvalid_state, Qio_error, Qlist_formation_error, Qmalformed_list, Qmalformed_property_list, Qno_catch, Qout_of_memory, Qoverflow_error, Qprinting_unreadable_object, Qquit, Qrange_error, @@ -5098,6 +5229,8 @@ Lisp_Object frob2)); void maybe_invalid_argument (const Ascbyte *, Lisp_Object, Lisp_Object, Error_Behavior); +MODULE_API DECLARE_DOESNT_RETURN (invalid_keyword_argument (Lisp_Object fun, + Lisp_Object kw)); MODULE_API DECLARE_DOESNT_RETURN (invalid_operation (const Ascbyte *reason, Lisp_Object frob)); MODULE_API DECLARE_DOESNT_RETURN (invalid_operation_2 (const Ascbyte *reason,
--- a/src/lread.c Wed Mar 03 05:41:44 2010 -0600 +++ b/src/lread.c Thu Mar 04 02:46:38 2010 -0600 @@ -1982,8 +1982,14 @@ if (*read_ptr == '+') read_ptr++; ratio_set_string (scratch_ratio, read_ptr, 0); - ratio_canonicalize (scratch_ratio); - return Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + if (bignum_sign (ratio_denominator (scratch_ratio)) != 0) { + ratio_canonicalize (scratch_ratio); + return Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + return Fsignal (Qinvalid_read_syntax, + list2 (build_msg_string + ("Invalid ratio constant in reader"), + make_string ((Ibyte *) read_ptr, len))); } #endif if (isfloat_string (read_ptr))