# HG changeset patch # User Mats Lidell # Date 1293751649 -3600 # Node ID 6506fcb40fcffde0e3104c86f74660bd227c9154 # Parent 388762703a2184accb1adc2a7d738580b935fc34# Parent d0bb90d90736edce79c191c51c5592f8ee49ced7 Merged with trunk. diff -r 388762703a21 -r 6506fcb40fcf lisp/ChangeLog --- a/lisp/ChangeLog Sun Dec 26 01:48:40 2010 +0100 +++ b/lisp/ChangeLog Fri Dec 31 00:27:29 2010 +0100 @@ -1,3 +1,79 @@ +2010-12-30 Aidan Kehoe + + * x-misc.el (device-x-display): + Provide this function, documented in the Lispref for years, but + not existing previously. Thank you Julian Bradfield, thank you + Jeff Mincy. + +2010-12-30 Aidan Kehoe + + * simple.el (assoc-ignore-case): Remove a duplicate definition of + this function (it's already in subr.el). + * iso8859-1.el (char-width): + On non-Mule, make this function equivalent to that produced by + (constantly 1), but preserve its docstring. + * subr.el (subst-char-in-string): Define this in terms of + #'substitute, #'nsubstitute. + (string-width): Define this using #'reduce and #'char-width. + (char-width): Give this a simpler definition, it makes far more + sense to check for mule at load time and redefine, as we do in + iso8859-1.el. + (store-substring): Implement this in terms of #'replace, now + #'replace is cheap. + +2010-12-30 Aidan Kehoe + + * update-elc.el (lisp-files-needed-for-byte-compilation) + (lisp-files-needing-early-byte-compilation): + cl-macs belongs in the former, not the latter, it is as + fundamental as bytecomp.el. + +2010-12-30 Aidan Kehoe + + * cl.el: + Provde the Common Lisp program-error, type-error as error + symbols. This doesn't nearly go far enough for anyone using the + Common Lisp errors. + +2010-12-29 Aidan Kehoe + + * cl-macs.el (delete-duplicates): + If the form has an incorrect number of arguments, don't attempt a + compiler macroexpansion. + +2010-12-29 Aidan Kehoe + + * cl-macs.el (cl-safe-expr-p): + Forms that start with the symbol lambda are also safe. + +2010-12-29 Aidan Kehoe + + * cl-macs.el (= < > <= >=): + For these functions' compiler macros, the optimisation is safe + even if the first and the last arguments have side effects, since + they're only used the once. + +2010-12-29 Aidan Kehoe + + * cl-macs.el (inline-side-effect-free-compiler-macros): + Unroll a loop here at macro-expansion time, so these compiler + macros are compiled. Use #'eql instead of #'eq in a couple of + places for better style. + +2010-12-29 Aidan Kehoe + + * cl-extra.el (notany, notevery): Avoid some dynamic scope + stupidity with local variable names in these functions, when they + weren't prefixed with cl-; go into some more detail in the doc + strings. + +2010-12-29 Aidan Kehoe + + * byte-optimize.el (side-effect-free-fns): #'remove, #'remq are + free of side-effects. + (side-effect-and-error-free-fns): + Drop dot, dot-marker from the list. + 2010-11-17 Aidan Kehoe * cl-extra.el (coerce): diff -r 388762703a21 -r 6506fcb40fcf lisp/byte-optimize.el --- a/lisp/byte-optimize.el Sun Dec 26 01:48:40 2010 +0100 +++ b/lisp/byte-optimize.el Fri Dec 31 00:27:29 2010 +0100 @@ -1243,7 +1243,7 @@ marker-buffer max member memq min mod next-window nth nthcdr number-to-string numerator parse-colon-path plist-get previous-window - radians-to-degrees rassq regexp-quote reverse round + radians-to-degrees rassq rassoc remove remq regexp-quote reverse round sin sqrt string< string= string-equal string-lessp string-to-char string-to-int string-to-number substring symbol-plist symbol-value symbol-name symbol-function symbol @@ -1269,7 +1269,7 @@ current-buffer ;; XEmacs: extent functions, frame-live-p, various other stuff devicep device-live-p - dot dot-marker eobp eolp eq eql equal eventp extentp + eobp eolp eq eql equal eventp extentp extent-live-p fixnump floatingp floatp framep frame-live-p get-largest-window get-lru-window hash-table-p diff -r 388762703a21 -r 6506fcb40fcf lisp/cl-extra.el --- a/lisp/cl-extra.el Sun Dec 26 01:48:40 2010 +0100 +++ b/lisp/cl-extra.el Fri Dec 31 00:27:29 2010 +0100 @@ -126,13 +126,23 @@ `(lambda (&rest arguments) ,@(if documentation (list documentation)) (not (apply ',function arguments)))) -(defun notany (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is false of every element of SEQ or SEQs." - (not (apply 'some cl-pred cl-seq cl-rest))) +(defun notany (cl-predicate cl-seq &rest cl-rest) + "Return true if PREDICATE is false of every element of SEQUENCE. + +With optional SEQUENCES, call PREDICATE each time with as many arguments as +there are SEQUENCES (plus one for the element from SEQUENCE). + +arguments: (PREDICATE SEQUENCES &rest SEQUENCES)" + (not (apply 'some cl-predicate cl-seq cl-rest))) -(defun notevery (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is false of some element of SEQ or SEQs." - (not (apply 'every cl-pred cl-seq cl-rest))) +(defun notevery (cl-predicate cl-seq &rest cl-rest) + "Return true if PREDICATE is false of some element of SEQUENCE. + +With optional SEQUENCES, call PREDICATE each time with as many arguments as +there are SEQUENCES (plus one for the element from SEQUENCE). + +arguments: (PREDICATE SEQUENCES &rest SEQUENCES)" + (not (apply 'every cl-predicate cl-seq cl-rest))) ;;; Support for `loop'. (defalias 'cl-map-keymap 'map-keymap) diff -r 388762703a21 -r 6506fcb40fcf lisp/cl-macs.el --- a/lisp/cl-macs.el Sun Dec 26 01:48:40 2010 +0100 +++ b/lisp/cl-macs.el Fri Dec 31 00:27:29 2010 +0100 @@ -109,7 +109,8 @@ ;;; Check if no side effects. (defun cl-safe-expr-p (x) - (or (not (and (consp x) (not (memq (car x) '(quote function function*))))) + (or (not (and (consp x) (not (memq (car x) + '(quote function function* lambda))))) (and (symbolp (car x)) (or (memq (car x) cl-simple-funcs) (memq (car x) cl-safe-funcs) @@ -3484,56 +3485,60 @@ ;; 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) - (if (not (or (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)) - (and (listp cl-seq) (equal (butlast cl-seq) '(the list))))) - form - (cond - ((or (plists-equal cl-keys '(:test 'eq) t) - (plists-equal cl-keys '(:test #'eq) t)) - `(let* ((begin ,cl-seq) - cl-seq) - (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)) - ((or (plists-equal cl-keys '(:test 'eq :from-end t) t) - (plists-equal cl-keys '(:test #'eq :from-end t) t)) - `(let* ((begin ,cl-seq) - (cl-seq begin)) - (while cl-seq - (setq cl-seq (setcdr cl-seq - (delq (car cl-seq) (cdr cl-seq))))) - begin)) - ((or (plists-equal cl-keys '(:test 'equal) t) - (plists-equal cl-keys '(:test #'equal) t)) - `(let* ((begin ,cl-seq) - cl-seq) - (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)) - ((or (plists-equal cl-keys '(:test 'equal :from-end t) t) - (plists-equal cl-keys '(:test #'equal :from-end t) t)) - `(let* ((begin ,cl-seq) - (cl-seq begin)) - (while cl-seq - (setq cl-seq (setcdr cl-seq (delete (car cl-seq) - (cdr cl-seq))))) - begin)) - (t form)))) +(define-compiler-macro delete-duplicates (&whole form &rest cl-keys) + (let ((cl-seq (if cl-keys (pop cl-keys)))) + (if (or + (not (or (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)) + (and (listp cl-seq) (equal (butlast cl-seq) '(the list))))) + ;; Wrong number of arguments. + (not (cdr form))) + form + (cond + ((or (plists-equal cl-keys '(:test 'eq) t) + (plists-equal cl-keys '(:test #'eq) t)) + `(let* ((begin ,cl-seq) + cl-seq) + (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)) + ((or (plists-equal cl-keys '(:test 'eq :from-end t) t) + (plists-equal cl-keys '(:test #'eq :from-end t) t)) + `(let* ((begin ,cl-seq) + (cl-seq begin)) + (while cl-seq + (setq cl-seq (setcdr cl-seq + (delq (car cl-seq) (cdr cl-seq))))) + begin)) + ((or (plists-equal cl-keys '(:test 'equal) t) + (plists-equal cl-keys '(:test #'equal) t)) + `(let* ((begin ,cl-seq) + cl-seq) + (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)) + ((or (plists-equal cl-keys '(:test 'equal :from-end t) t) + (plists-equal cl-keys '(:test #'equal :from-end t) t)) + `(let* ((begin ,cl-seq) + (cl-seq begin)) + (while cl-seq + (setq cl-seq (setcdr cl-seq (delete (car cl-seq) + (cdr cl-seq))))) + begin)) + (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 @@ -3750,7 +3755,7 @@ (put function 'cl-compiler-macro #'(lambda (form &rest arguments) (if (or (null (nthcdr 3 form)) - (notevery #'cl-safe-expr-p (cdr form))) + (notevery #'cl-safe-expr-p (butlast (cdr arguments)))) form (cons 'and (mapcon #'(lambda (rest) @@ -3760,22 +3765,28 @@ (cdr form))))))) '(= < > <= >=)) -(mapc - #'(lambda (y) - (put (car y) 'side-effect-free t) - (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) - (put (car y) 'cl-compiler-macro - (list 'lambda '(w x) - (if (symbolp (cadr y)) - (list 'list (list 'quote (cadr y)) - (list 'list (list 'quote (caddr y)) 'x)) - (cons 'list (cdr y)))))) - '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) +;; XEmacs; unroll this loop at macro-expansion time, so the compiler macros +;; are byte-compiled. +(macrolet + ((inline-side-effect-free-compiler-macros (&rest details) + (cons + 'progn + (loop + for (function . details) in details + nconc `((put ',function 'side-effect-free t) + (define-compiler-macro ,function (&whole form x) + ,(if (symbolp (car details)) + (reduce #'(lambda (object1 object2) + `(list ',object1 ,object2)) + details :from-end t :initial-value 'x) + (cons 'list details)))))))) + (inline-side-effect-free-compiler-macros + (first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) (rest 'cdr x) (plusp '> x 0) (minusp '< x 0) - (oddp 'eq (list 'logand x 1) 1) - (evenp 'eq (list 'logand x 1) 0) + (oddp 'eql (list 'logand x 1) 1) + (evenp 'eql (list 'logand x 1) 0) (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr) (caaar car caar) (caadr car cadr) (cadar car cdar) (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) diff -r 388762703a21 -r 6506fcb40fcf lisp/cl.el --- a/lisp/cl.el Sun Dec 26 01:48:40 2010 +0100 +++ b/lisp/cl.el Fri Dec 31 00:27:29 2010 +0100 @@ -601,6 +601,19 @@ ;; XEmacs change (define-error 'cl-assertion-failed "Assertion failed") +;; XEmacs; provide a milquetoast amount of compatibility in our error symbols. +(define-error 'type-error "Wrong type" 'wrong-type-argument) +(define-error 'program-error "Error in your program" 'invalid-argument) + +(map-plist + #'(lambda (key value) + (mapc #'(lambda (error) + (put error 'error-conditions + (cons key (get error 'error-conditions)))) + value)) + '(program-error (wrong-number-of-arguments invalid-keyword-argument) + type-error (wrong-type-argument malformed-list circular-list))) + ;; XEmacs change: omit the autoload rules; we handle those a different way ;;; Define data for indentation and edebug. diff -r 388762703a21 -r 6506fcb40fcf lisp/iso8859-1.el --- a/lisp/iso8859-1.el Sun Dec 26 01:48:40 2010 +0100 +++ b/lisp/iso8859-1.el Fri Dec 31 00:27:29 2010 +0100 @@ -82,6 +82,17 @@ ;; by default. (setq-default ctl-arrow #xA0) +(when (and (compiled-function-p (symbol-function 'char-width)) + (not (featurep 'mule))) + (defalias 'char-width + (let ((constantly (constantly 1))) + (make-byte-code (compiled-function-arglist constantly) + (compiled-function-instructions constantly) + (compiled-function-constants constantly) + (compiled-function-stack-depth constantly) + (compiled-function-doc-string + (symbol-function 'char-width)))))) + ;; Shouldn't be necessary, but one file in the packages uses it: (provide 'iso8859-1) diff -r 388762703a21 -r 6506fcb40fcf lisp/simple.el --- a/lisp/simple.el Sun Dec 26 01:48:40 2010 +0100 +++ b/lisp/simple.el Fri Dec 31 00:27:29 2010 +0100 @@ -3330,11 +3330,6 @@ ;; keyboard-quit ;; buffer-quit-function ;; keyboard-escape-quit - -(defun assoc-ignore-case (key alist) - "Like `assoc', but assumes KEY is a string and ignores case when comparing." - (assoc* key alist :test #'equalp)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; mail composition code ;; diff -r 388762703a21 -r 6506fcb40fcf lisp/subr.el --- a/lisp/subr.el Sun Dec 26 01:48:40 2010 +0100 +++ b/lisp/subr.el Fri Dec 31 00:27:29 2010 +0100 @@ -763,14 +763,8 @@ (defun subst-char-in-string (fromchar tochar string &optional inplace) "Replace FROMCHAR with TOCHAR in STRING each time it occurs. Unless optional argument INPLACE is non-nil, return a new string." - (let ((i (length string)) - (newstr (if inplace string (copy-sequence string)))) - (while (> i 0) - (setq i (1- i)) - (if (eq (aref newstr i) fromchar) - (aset newstr i tochar))) - newstr)) - + (funcall (if inplace #'nsubstitute #'substitute) tochar fromchar + (the string string) :test #'eq)) ;; XEmacs addition: (defun replace-in-string (str regexp newtext &optional literal) @@ -959,23 +953,11 @@ the characters in STRING, which may not accurately represent the actual display width when using a window system. With no international support, simply returns the length of the string." - (if (featurep 'mule) - (let ((col 0) - (len (length string)) - (i 0)) - (with-fboundp '(charset-width char-charset) - (while (< i len) - (setq col (+ col (charset-width (char-charset (aref string i))))) - (setq i (1+ i)))) - col) - (length string))) + (reduce #'+ (the string string) :initial-value 0 :key #'char-width)) (defun char-width (character) "Return number of columns a CHARACTER occupies when displayed." - (if (featurep 'mule) - (with-fboundp '(charset-width char-charset) - (charset-width (char-charset character))) - 1)) + (charset-width (char-charset character))) ;; The following several functions are useful in GNU Emacs 20 because ;; of the multibyte "characters" the internal representation of which @@ -1001,18 +983,9 @@ (defun store-substring (string idx obj) "Embed OBJ (string or character) at index IDX of STRING." - (let* ((str (cond ((stringp obj) obj) - ((characterp obj) (char-to-string obj)) - (t (error - "Invalid argument (should be string or character): %s" - obj)))) - (string-len (length string)) - (len (length str)) - (i 0)) - (while (and (< i len) (< idx string-len)) - (aset string idx (aref str i)) - (setq idx (1+ idx) i (1+ i))) - string)) + (if (stringp obj) + (replace (the string string) obj :start1 idx) + (prog1 string (aset string idx obj)))) ;; From FSF 21.1; ELLIPSES is XEmacs addition. diff -r 388762703a21 -r 6506fcb40fcf lisp/update-elc.el --- a/lisp/update-elc.el Sun Dec 26 01:48:40 2010 +0100 +++ b/lisp/update-elc.el Fri Dec 31 00:27:29 2010 +0100 @@ -100,6 +100,7 @@ ;; .elc's. (defvar lisp-files-needed-for-byte-compilation '("bytecomp" + "cl-macs" "byte-optimize")) ;; Lisp files not in `lisp-files-needed-for-byte-compilation' that need @@ -108,8 +109,7 @@ (defvar lisp-files-needing-early-byte-compilation '("easy-mmode" "autoload" - "shadow" - "cl-macs")) + "shadow")) (defvar unbytecompiled-lisp-files '("paths.el" diff -r 388762703a21 -r 6506fcb40fcf lisp/x-misc.el --- a/lisp/x-misc.el Sun Dec 26 01:48:40 2010 +0100 +++ b/lisp/x-misc.el Fri Dec 31 00:27:29 2010 +0100 @@ -84,4 +84,10 @@ (x-bogosity-check-resource name class type)) (x-get-resource name class type locale nil 'warn)) +(defun device-x-display (&optional device) + "If DEVICE is an X11 device, return its DISPLAY. + +DEVICE defaults to the selected device." + (and (eq 'x (device-type device)) (device-connection device))) + ;;; x-misc.el ends here diff -r 388762703a21 -r 6506fcb40fcf src/ChangeLog --- a/src/ChangeLog Sun Dec 26 01:48:40 2010 +0100 +++ b/src/ChangeLog Fri Dec 31 00:27:29 2010 +0100 @@ -1,3 +1,26 @@ +2010-12-30 Aidan Kehoe + + * lisp.h (DECLARE_N_KEYWORDS_8, DECLARE_N_KEYWORDS_9) + (CHECK_N_KEYWORDS_8, CHECK_N_KEYWORDS_9): + Support up to nine keywords in the PARSE_KEYWORDS() macro. + +2010-12-30 Aidan Kehoe + + * elhash.c (syms_of_elhash): + * chartab.c (syms_of_chartab): + * abbrev.c (syms_of_abbrev): + * general-slots.h: + Move Qcount, Q_default, Q_test to general-slots.h, they're about + to be used by other files. Rename Q_default to Q_default_, for the + sake of the PARSE_KEYWORDS macro (given that default is a reserved + identifier in C). Add SYMBOL_KEYWORD_GENERAL(), analogous to + SYMBOL_GENERAL() to make this easier. + +2010-12-29 Aidan Kehoe + + * floatfns.c (Ffloat): If we've been handed a bigfloat here, it's + appropriate to give the same bigfloat back. + 2010-11-30 Aidan Kehoe * fns.c (Ffill): diff -r 388762703a21 -r 6506fcb40fcf src/abbrev.c --- a/src/abbrev.c Sun Dec 26 01:48:40 2010 +0100 +++ b/src/abbrev.c Fri Dec 31 00:27:29 2010 +0100 @@ -73,7 +73,7 @@ /* Hook to run before expanding any abbrev. */ Lisp_Object Vpre_abbrev_expand_hook, Qpre_abbrev_expand_hook; -Lisp_Object Qsystem_type, Qcount; +Lisp_Object Qsystem_type; struct abbrev_match_mapper_closure { @@ -556,9 +556,6 @@ void syms_of_abbrev (void) { - DEFSYMBOL(Qcount); - Qcount = intern ("count"); - staticpro (&Qcount); DEFSYMBOL(Qsystem_type); Qsystem_type = intern ("system-type"); DEFSYMBOL (Qpre_abbrev_expand_hook); diff -r 388762703a21 -r 6506fcb40fcf src/chartab.c --- a/src/chartab.c Sun Dec 26 01:48:40 2010 +0100 +++ b/src/chartab.c Fri Dec 31 00:27:29 2010 +0100 @@ -40,7 +40,7 @@ #include "chartab.h" #include "syntax.h" -Lisp_Object Qchar_tablep, Qchar_table, Q_default; +Lisp_Object Qchar_tablep, Qchar_table; Lisp_Object Vall_syntax_tables; @@ -1579,7 +1579,7 @@ { type = value; } - else if (EQ (key, Q_default)) + else if (EQ (key, Q_default_)) { default_ = value; } @@ -1624,7 +1624,11 @@ check_valid_char_table_value (default_, XCHAR_TABLE_TYPE (chartab), ERROR_ME); set_char_table_default (chartab, default_); - set_char_table_default (XCHAR_TABLE (chartab)->mirror_table, default_); + if (!NILP (XCHAR_TABLE (chartab)->mirror_table)) + { + set_char_table_default (XCHAR_TABLE (chartab)->mirror_table, + default_); + } } while (!NILP (dataval)) @@ -1900,7 +1904,6 @@ DEFSYMBOL (Qchar_table); DEFSYMBOL_MULTIWORD_PREDICATE (Qchar_tablep); - DEFKEYWORD (Q_default); DEFSUBR (Fchar_table_p); DEFSUBR (Fchar_table_type_list); @@ -1955,7 +1958,7 @@ define_structure_type_keyword (st, Q_type, chartab_type_validate); define_structure_type_keyword (st, Q_data, chartab_data_validate); - define_structure_type_keyword (st, Q_default, chartab_default_validate); + define_structure_type_keyword (st, Q_default_, chartab_default_validate); } void diff -r 388762703a21 -r 6506fcb40fcf src/elhash.c --- a/src/elhash.c Sun Dec 26 01:48:40 2010 +0100 +++ b/src/elhash.c Fri Dec 31 00:27:29 2010 +0100 @@ -91,7 +91,7 @@ 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; -static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold; +static Lisp_Object Q_size, Q_weakness, Q_rehash_size, Q_rehash_threshold; static Lisp_Object Vhash_table_test_eq, Vhash_table_test_eql; static Lisp_Object Vhash_table_test_weak_list; @@ -2289,7 +2289,6 @@ DEFSYMBOL (Qnon_weak); /* obsolete */ DEFKEYWORD (Q_data); - DEFKEYWORD (Q_test); DEFKEYWORD (Q_size); DEFKEYWORD (Q_rehash_size); DEFKEYWORD (Q_rehash_threshold); diff -r 388762703a21 -r 6506fcb40fcf src/floatfns.c --- a/src/floatfns.c Sun Dec 26 01:48:40 2010 +0100 +++ b/src/floatfns.c Fri Dec 31 00:27:29 2010 +0100 @@ -787,6 +787,11 @@ if (FLOATP (number)) /* give 'em the same float back */ return number; + if (BIGFLOATP (number)) + { + return number; + } + return Ffloat (wrong_type_argument (Qnumberp, number)); } diff -r 388762703a21 -r 6506fcb40fcf src/general-slots.h --- a/src/general-slots.h Sun Dec 26 01:48:40 2010 +0100 +++ b/src/general-slots.h Fri Dec 31 00:27:29 2010 +0100 @@ -30,6 +30,8 @@ SYMBOL_KEYWORD (Q_foo); declares a keyword symbol ":foo" SYMBOL_GENERAL (Qfoo, "bar"); declares a symbol named "bar" but stored in the variable Qfoo + SYMBOL_KEYWORD_GENERAL (Q_foo_, ":bar"); declares a keyword named ":bar" + but stored in the variable Q_foo_. To sort the crap in this file, use the following: @@ -90,6 +92,7 @@ SYMBOL (Qconsole); SYMBOL (Qcontrol_1); SYMBOL (Qcopies); +SYMBOL (Qcount); SYMBOL_MODULE_API (Qcritical); SYMBOL (Qctext); SYMBOL (Qcurrent); @@ -100,6 +103,9 @@ SYMBOL (Qdead); SYMBOL (Qdebug); SYMBOL (Qdefault); +/* We name the C variable corresponding to the keyword Q_default_, not + Q_default, to allow it to be useful with PARSE_KEYWORDS (). */ +SYMBOL_KEYWORD_GENERAL (Q_default_, ":default"); SYMBOL_MODULE_API (Qdelete); SYMBOL (Qdelq); SYMBOL (Qdescription); @@ -268,6 +274,7 @@ SYMBOL_KEYWORD (Q_start); SYMBOL (Qstream); SYMBOL (Qstring); +SYMBOL (Qstring_match); SYMBOL_KEYWORD (Q_style); SYMBOL_KEYWORD (Q_suffix); SYMBOL (Qsubtype); @@ -277,6 +284,7 @@ SYMBOL (Qsystem_default); SYMBOL (Qterminal); SYMBOL (Qtest); +SYMBOL_KEYWORD (Q_test); SYMBOL (Qtext); SYMBOL_KEYWORD (Q_text); SYMBOL (Qthis_command); diff -r 388762703a21 -r 6506fcb40fcf src/general.c --- a/src/general.c Sun Dec 26 01:48:40 2010 +0100 +++ b/src/general.c Fri Dec 31 00:27:29 2010 +0100 @@ -27,8 +27,9 @@ #define SYMBOL(fou) Lisp_Object fou #define SYMBOL_MODULE_API(fou) Lisp_Object fou -#define SYMBOL_KEYWORD(la_cle_est_fou) Lisp_Object la_cle_est_fou +#define SYMBOL_KEYWORD(la_cle_est_folle) Lisp_Object la_cle_est_folle #define SYMBOL_GENERAL(tout_le_monde, est_fou) Lisp_Object tout_le_monde +#define SYMBOL_KEYWORD_GENERAL(ponle, la_clave) Lisp_Object ponle #include "general-slots.h" @@ -36,6 +37,7 @@ #undef SYMBOL_MODULE_API #undef SYMBOL_KEYWORD #undef SYMBOL_GENERAL +#undef SYMBOL_KEYWORD_GENERAL void syms_of_general (void) @@ -44,10 +46,13 @@ #define SYMBOL_MODULE_API(loco) DEFSYMBOL (loco) #define SYMBOL_KEYWORD(meshugeneh) DEFKEYWORD (meshugeneh) #define SYMBOL_GENERAL(vachement, fou) defsymbol (&vachement, fou) +#define SYMBOL_KEYWORD_GENERAL(bescheuert, gaaanz_bescheuert) \ + defkeyword (&bescheuert, gaaanz_bescheuert) #include "general-slots.h" #undef SYMBOL #undef SYMBOL_KEYWORD #undef SYMBOL_GENERAL +#undef SYMBOL_KEYWORD_GENERAL } diff -r 388762703a21 -r 6506fcb40fcf src/lisp.h --- a/src/lisp.h Sun Dec 26 01:48:40 2010 +0100 +++ b/src/lisp.h Fri Dec 31 00:27:29 2010 +0100 @@ -3639,6 +3639,10 @@ 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 DECLARE_N_KEYWORDS_8(a,b,c,d,e,f,g,h) \ + DECLARE_N_KEYWORDS_7(a,b,c,d,e,f,g), h = Qnil +#define DECLARE_N_KEYWORDS_9(a,b,c,d,e,f,g,h,i) \ + DECLARE_N_KEYWORDS_8(a,b,c,d,e,f,g,h), i = Qnil #define CHECK_N_KEYWORDS_1(a) \ else if (EQ (pk_key, Q_##a)) { a = pk_value; } @@ -3654,6 +3658,12 @@ 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; } +#define CHECK_N_KEYWORDS_8(a,b,c,d,e,f,g,h) \ + CHECK_N_KEYWORDS_7(a,b,c,d,e,f,g) \ + else if (EQ (pk_key, Q_##h)) { h = pk_value; } +#define CHECK_N_KEYWORDS_9(a,b,c,d,e,f,g,h,i) \ + CHECK_N_KEYWORDS_8(a,b,c,d,e,f,g,h) \ + else if (EQ (pk_key, Q_##i)) { i = pk_value; } Boolint non_nil_allow_other_keys_p (Elemcount offset, int nargs, Lisp_Object *args); @@ -5303,9 +5313,11 @@ /* Defined in general.c */ #define SYMBOL(fou) extern Lisp_Object fou #define SYMBOL_MODULE_API(fou) extern MODULE_API Lisp_Object fou -#define SYMBOL_KEYWORD(la_cle_est_fou) extern Lisp_Object la_cle_est_fou +#define SYMBOL_KEYWORD(la_cle_est_folle) extern Lisp_Object la_cle_est_folle #define SYMBOL_GENERAL(tout_le_monde, est_fou) \ extern Lisp_Object tout_le_monde +#define SYMBOL_KEYWORD_GENERAL(y_compris_ben, mais_que_peut_on_faire) \ + extern Lisp_Object y_compris_ben #include "general-slots.h" @@ -5313,6 +5325,7 @@ #undef SYMBOL_MODULE_API #undef SYMBOL_KEYWORD #undef SYMBOL_GENERAL +#undef SYMBOL_KEYWORD_GENERAL extern Lisp_Object Qeq; extern Lisp_Object Qeql; diff -r 388762703a21 -r 6506fcb40fcf tests/ChangeLog --- a/tests/ChangeLog Sun Dec 26 01:48:40 2010 +0100 +++ b/tests/ChangeLog Fri Dec 31 00:27:29 2010 +0100 @@ -1,3 +1,11 @@ +2010-12-30 Aidan Kehoe + + * automated/lisp-tests.el (wrong-type-argument): Add a missing + parenthesis here. + Make sure #'count #'position #'find #'delete* #'remove* #'reduce + #'delete-duplicates #'remove-duplicates #'replace #'mismatch + #'search sanity check their :start and :end keyword arguments. + 2010-11-20 Aidan Kehoe * automated/lisp-tests.el: diff -r 388762703a21 -r 6506fcb40fcf tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el Sun Dec 26 01:48:40 2010 +0100 +++ b/tests/automated/lisp-tests.el Fri Dec 31 00:27:29 2010 +0100 @@ -2547,7 +2547,7 @@ (Check-Error wrong-type-argument (fill "1 2 3 4 5" ?1 :start (float most-positive-fixnum))) (Check-Error wrong-type-argument - (fill #*10101010 1 :start (float most-positive-fixnum)) + (fill #*10101010 1 :start (float most-positive-fixnum))) (Check-Error wrong-type-argument (fill '(1 2 3 4 5) 1 :end (float most-positive-fixnum))) (Check-Error wrong-type-argument @@ -2667,4 +2667,125 @@ (replace '(1 2 3 4 5) [5 4 3 2 1] :end2 (1+ most-positive-fixnum)))) +(symbol-macrolet + ((list-length 2048) (vector-length 512) (string-length (* 8192 2))) + (let ((list + ;; CIRCULAR_LIST_SUSPICION_LENGTH is 1024, it's helpful if this list + ;; is longer than that. + (make-list list-length 'make-list)) + (vector (make-vector vector-length 'make-vector)) + (bit-vector (make-bit-vector vector-length 1)) + (string (make-string string-length + (or (decode-char 'ucs #x20ac) ?\xFF))) + (item 'cons)) + (dolist (function '(count position find delete* remove* reduce)) + (Check-Error args-out-of-range + (funcall function item list + :start (1+ list-length) :end (1+ list-length))) + (Check-Error wrong-type-argument + (funcall function item list + :start -1 :end list-length)) + (Check-Error args-out-of-range + (funcall function item list :end (* 2 list-length))) + (Check-Error args-out-of-range + (funcall function item vector + :start (1+ vector-length) :end (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function item vector :start -1)) + (Check-Error args-out-of-range + (funcall function item vector :end (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function item bit-vector + :start (1+ vector-length) :end (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function item bit-vector :start -1)) + (Check-Error args-out-of-range + (funcall function item bit-vector :end (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function item string + :start (1+ string-length) :end (1+ string-length))) + (Check-Error wrong-type-argument + (funcall function item string :start -1)) + (Check-Error args-out-of-range + (funcall function item string :end (* 2 string-length)))) + (dolist (function '(delete-duplicates remove-duplicates)) + (Check-Error args-out-of-range + (funcall function (copy-sequence list) + :start (1+ list-length) :end (1+ list-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence list) + :start -1 :end list-length)) + (Check-Error args-out-of-range + (funcall function (copy-sequence list) + :end (* 2 list-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence vector) + :start (1+ vector-length) :end (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence vector) :start -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence vector) + :end (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence bit-vector) + :start (1+ vector-length) :end (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence bit-vector) :start -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence bit-vector) + :end (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence string) + :start (1+ string-length) :end (1+ string-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence string) :start -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence string) + :end (* 2 string-length)))) + (dolist (function '(replace mismatch search)) + (Check-Error args-out-of-range + (funcall function (copy-sequence list) (copy-sequence list) + :start1 (1+ list-length) :end1 (1+ list-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence list) (copy-sequence list) + :start1 -1 :end1 list-length)) + (Check-Error args-out-of-range + (funcall function (copy-sequence list) (copy-sequence list) + :end1 (* 2 list-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence vector) + (copy-sequence vector) :start1 (1+ vector-length) + :end1 (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence vector) + (copy-sequence vector) :start1 -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence vector) + (copy-sequence vector) + :end1 (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence bit-vector) + (copy-sequence bit-vector) + :start1 (1+ vector-length) + :end1 (1+ vector-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence bit-vector) + (copy-sequence bit-vector) :start1 -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence bit-vector) + (copy-sequence bit-vector) + :end1 (* 2 vector-length))) + (Check-Error args-out-of-range + (funcall function (copy-sequence string) + (copy-sequence string) + :start1 (1+ string-length) + :end1 (1+ string-length))) + (Check-Error wrong-type-argument + (funcall function (copy-sequence string) + (copy-sequence string) :start1 -1)) + (Check-Error args-out-of-range + (funcall function (copy-sequence string) + (copy-sequence string) + :end1 (* 2 string-length)))))) + ;;; end of lisp-tests.el