Mercurial > hg > xemacs-beta
changeset 5292:e4305eb6fb8c
Merge some permissions corrections to trunk.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Mon, 18 Oct 2010 23:21:23 +0900 |
| parents | 85bd42a1e544 (current diff) 99de5fd48e87 (diff) |
| children | 63f247c5da0a |
| files | lisp/ChangeLog lisp/gtk-widget-accessors.el src/ChangeLog tests/ChangeLog |
| diffstat | 73 files changed, 3870 insertions(+), 1563 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/ChangeLog Mon Oct 18 23:21:23 2010 +0900 @@ -45,6 +45,226 @@ * mule/kinsoku.el: Add "part of XEmacs" text to permission notice. +2010-10-14 Aidan Kehoe <kehoea@parhasard.net> + + * byte-optimize.el (side-effect-free-fns): + * cl-macs.el (remf, getf): + * cl-extra.el (tailp, cl-set-getf, cl-do-remf): + * cl.el (ldiff, endp): + Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp; + add circularity checking for the first two. + + #'cl-set-getf and #'cl-do-remf were Lisp implementations of + #'plist-put and #'plist-remprop; change the names to aliases, + changes the macros that use them to using #'plist-put and + #'plist-remprop directly. + +2010-10-12 Aidan Kehoe <kehoea@parhasard.net> + + * abbrev.el (fundamental-mode-abbrev-table, global-abbrev-table): + Create both these abbrev tables using the usual + #'define-abbrev-table calls, rather than attempting to + special-case them. + * cl-extra.el: Force cl-macs to be loaded here, if cl-extra.el is + being loaded interpreted. Previously other, later files would + redundantly call (load "cl-macs") when interpreted, it's more + reasonable to do it here, once. + * cmdloop.el (read-quoted-char-radix): Use defcustom here, we + don't have any dump-order dependencies that would prevent that. + * custom.el (eval-when-compile): Don't load cl-macs when + interpreted or when byte-compiling, rely on cl-extra.el in the + former case and the appropriate entry in bytecomp-load-hook in the + latter. Get rid of custom-declare-variable-list, we have no + dump-time dependencies that would require it. + * faces.el (eval-when-compile): Don't load cl-macs when + interpreted or when byte-compiling. + * packages.el: Remove some inaccurate comments. + * post-gc.el (cleanup-simple-finalizers): Use #'delete-if-not + here, now the order of preloaded-file-list has been changed to + make it available. + * subr.el (custom-declare-variable-list): Remove. No need for it. + Also remove a stub define-abbrev-table from this file, given the + current order of preloaded-file-list there's no need for it. + +2010-10-10 Aidan Kehoe <kehoea@parhasard.net> + + * bytecomp.el (byte-compile-constp) Forms quoted with FUNCTION are + also constant. + (byte-compile-initial-macro-environment): In #'the, if FORM is + constant and does not match TYPE, warn at byte-compile time. + +2010-10-10 Aidan Kehoe <kehoea@parhasard.net> + + * backquote.el (bq-vector-contents, bq-list*): Remove; the former + is equivalent to (append VECTOR nil), the latter to (list* ...). + (bq-process-2): Use (append VECTOR nil) instead of using + #'bq-vector-contents to convert to a list. + (bq-process-1): Now we use list* instead of bq-list + * subr.el (list*): Moved from cl.el, since it is now required to + be available the first time a backquoted form is encountered. + * cl.el (list*): Move to subr.el. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * test-harness.el (Check-Message): + Add an omitted comma here, thank you the buildbot. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * hash-table.el (hash-table-key-list, hash-table-value-list) + (hash-table-key-value-alist, hash-table-key-value-plist): + Remove some useless #'nreverse calls in these files; our hash + tables have no order, it's not helpful to pretend they do. + * behavior.el (read-behavior): + Do the same in this file, in some code evidently copied from + hash-table.el. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * info.el (Info-insert-dir): + * format.el (format-deannotate-region): + * files.el (cd, save-buffers-kill-emacs): + Use #'some, #'every and related functions for applying boolean + operations to lists, instead of rolling our own ones that cons and + don't short-circuit. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * bytecomp.el (byte-compile-initial-macro-environment): + * cl-macs.el (the): + Rephrase the docstring, make its implementation when compiling + files a little nicer. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * descr-text.el (unidata-initialize-unicodedata-database) + (unidata-initialize-unihan-database, describe-char-unicode-data) + (describe-char-unicode-data): + Wrap calls to the database functions with (with-fboundp ...), + avoiding byte compile warnings on builds without support for the + database functions. + (describe-char): (reduce #'max ...), not (apply #'max ...), no + need to cons needlessly. + (describe-char): Remove a redundant lambda wrapping + #'extent-properties. + (describe-char-unicode-data): Call #'nsubst when replacing "" with + nil in the result of #'split-string, instead of consing inside + mapcar. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * x-faces.el (x-available-font-sizes): + * specifier.el (let-specifier): + * package-ui.el (pui-add-required-packages): + * msw-faces.el (mswindows-available-font-sizes): + * modeline.el (modeline-minor-mode-menu): + * minibuf.el (minibuf-directory-files): + Replace the O2N (delq nil (mapcar (lambda (W) (and X Y)) Z)) with + the ON (mapcan (lambda (W) (and X (list Y))) Z) in these files. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * cl-macs.el (= < > <= >=): + When these functions are handed more than two arguments, and those + arguments have no side effects, transform to a series of two + argument calls, avoiding funcall in the byte-compiled code. + * mule/mule-cmds.el (finish-set-language-environment): + Take advantage of this change in a function called 256 times at + startup. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * bytecomp.el (byte-compile-function-form, byte-compile-quote) + (byte-compile-quote-form): + Warn at compile time, and error at runtime, if a (quote ...) or a + (function ...) form attempts to quote more than one object. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc + (mapcar ...)) to (mapcan ...); warn about use of the first idiom. + + * update-elc.el (do-autoload-commands): + * packages.el (packages-find-package-library-path): + * frame.el (frame-list): + * extents.el (extent-descendants): + * etags.el (buffer-tag-table-files): + * dumped-lisp.el (preloaded-file-list): + * device.el (device-list): + * bytecomp-runtime.el (proclaim-inline, proclaim-notinline) + Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files. + + * bytecomp-runtime.el (eval-when-compile, eval-and-compile): + In passing, mention that these macros also evaluate the body when + interpreted. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * cl-macs.el (the): Add a docstring and an implementation for this + macro. + * bytecomp.el (byte-compile-initial-macro-environment): Add #'the + to this, checking byte-compile-delete-errors to decide whether to + make the type assertion. Change the initvalue to use backquote and + preceding commas for the lambda expressions, to allow the latter + to be compiled. + +2010-09-06 Aidan Kehoe <kehoea@parhasard.net> + + * cl-seq.el (replace): + Move this function, with added bounds-checking per ANSI Common + Lisp, to fns.c. + +2010-09-05 Aidan Kehoe <kehoea@parhasard.net> + + * x-compose.el (define-compose-map, compose-map) + (decide-on-bindings): Support the precomposed characters with + stroke here too, necessary for Polish and Danish, among others. + * x-init.el (x-initialize-compose): Add the appropriate map + autoloads and bindings here. + +2010-09-03 Aidan Kehoe <kehoea@parhasard.net> + + * cl-extra.el (coerce): + Add fixnum as an accepted destination type. + +2010-09-02 Aidan Kehoe <kehoea@parhasard.net> + + * obsolete.el (process-get): + Make #'process-get, #'process-put, #'process-plist, + #'set-process-plist available as aliases to the more general + functions #'get, #'put, #'object-plist, #'object-setplist, for GNU + compatibility. + +2010-08-20 Mike Sperber <mike@xemacs.org> + + * files.el (save-some-buffers-action-alist): Add. + (save-some-buffers-1): Use (synching with (GPLv2) FSF Emacs. + +2010-08-18 Mike Sperber <mike@xemacs.org> + + * files.el (diff-files-for-recover): Abstract this out out + `recover-file'. + (diff-buffer-with-file): Add from (GPLv2) FSF Emacs. + (recover-file): Use `diff-files-for-recover'. + +2010-08-15 Aidan Kehoe <kehoea@parhasard.net> + + * specifier.el (canonicalize-inst-pair, canonicalize-spec): + If a specifier tag set is correct, but an instantiator is not in + an accepted format, don't error with the message "Invalid + specifier tag set". + Also, when we error, use error-symbols, for better structured + error handling and more ease when testing. + +2010-07-24 Aidan Kehoe <kehoea@parhasard.net> + + * cl-extra.el (concatenate): + * cl-seq.el (remove*, cl-delete-duplicates): + Bit vectors are also sequences; enforce this in these functions. + * cl-macs.el (concatenate): + If TYPE is constant, don't inline #'concatenate, replace it by a + call to the appropriate C functions. + 2010-06-13 Stephen J. Turnbull <stephen@xemacs.org> * gnome.el:
--- a/lisp/abbrev.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/abbrev.el Mon Oct 18 23:21:23 2010 +0900 @@ -120,31 +120,12 @@ (setplist sym (or count 0)) name)) +(define-abbrev-table 'fundamental-mode-abbrev-table nil) +(and (eq major-mode 'fundamental-mode) + (not local-abbrev-table) + (setq local-abbrev-table fundamental-mode-abbrev-table)) -;; Fixup stuff from bootstrap def of define-abbrev-table in subr.el -(let ((l abbrev-table-name-list)) - (while l - (let ((fixup (car l))) - (if (consp fixup) - (progn - (setq abbrev-table-name-list (delq fixup abbrev-table-name-list)) - (define-abbrev-table (car fixup) (cdr fixup)))) - (setq l (cdr l)))) - ;; These are no longer initialized by C code - (if (not global-abbrev-table) - (progn - (setq global-abbrev-table (make-abbrev-table)) - (setq abbrev-table-name-list (cons 'global-abbrev-table - abbrev-table-name-list)))) - (if (not fundamental-mode-abbrev-table) - (progn - (setq fundamental-mode-abbrev-table (make-abbrev-table)) - (setq abbrev-table-name-list (cons 'fundamental-mode-abbrev-table - abbrev-table-name-list)))) - (and (eq major-mode 'fundamental-mode) - (not local-abbrev-table) - (setq local-abbrev-table fundamental-mode-abbrev-table))) - +(define-abbrev-table 'global-abbrev-table nil) (defun define-global-abbrev (name expansion) "Define ABBREV as a global abbreviation for EXPANSION."
--- a/lisp/backquote.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/backquote.el Mon Oct 18 23:21:23 2010 +0900 @@ -184,19 +184,10 @@ ;;; ---------------------------------------------------------------- -(defun bq-vector-contents (vec) - (let ((contents nil) - (n (length vec))) - (while (> n 0) - (setq n (1- n)) - (setq contents (cons (aref vec n) contents))) - contents)) - ;;; This does the expansion from table 2. (defun bq-process-2 (code) (cond ((vectorp code) - (let* ((dflag-d - (bq-process-2 (bq-vector-contents code)))) + (let* ((dflag-d (bq-process-2 (append code nil)))) (cons 'vector (bq-process-1 (car dflag-d) (cdr dflag-d))))) ((atom code) (cond ((null code) (cons nil nil)) @@ -278,26 +269,7 @@ (list 'quote thing)) ((eq flag 'vector) (list 'apply '(function vector) thing)) - (t (cons (cdr - (assq flag - '((cons . cons) - (list* . bq-list*) - (list . list) - (append . append) - (nconc . nconc)))) - thing)))) - -;;; ---------------------------------------------------------------- - -(defmacro bq-list* (&rest args) - "Return a list of its arguments with last cons a dotted pair." - (setq args (reverse args)) - (let ((result (car args))) - (setq args (cdr args)) - (while args - (setq result (list 'cons (car args) result)) - (setq args (cdr args))) - result)) + (t (cons flag thing)))) (provide 'backquote)
--- a/lisp/behavior.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/behavior.el Mon Oct 18 23:21:23 2010 +0900 @@ -349,15 +349,11 @@ (let ((result (completing-read prompt - (let ((table (let (lis) - (maphash #'(lambda (key val) - (push (cons key val) lis)) - behavior-hash-table) - (nreverse lis)))) - (mapc #'(lambda (aentry) - (setcar aentry (symbol-name (car aentry)))) - table) - table) + (let (list) + (maphash #'(lambda (key value) + (push (cons (symbol-name key) value) list)) + behavior-hash-table) + list) nil must-match initial-contents (or history 'behavior-history) default-value))) (if (and result (stringp result))
--- a/lisp/byte-optimize.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/byte-optimize.el Mon Oct 18 23:21:23 2010 +0900 @@ -1119,17 +1119,26 @@ ;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...). (let ((fn (nth 1 form)) (last (nth (1- (length form)) form))) ; I think this really is fastest - (or (if (or (null last) - (eq (car-safe last) 'quote)) - (if (listp (nth 1 last)) - (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) - (nconc (list 'funcall fn) butlast - (mapcar #'(lambda (x) (list 'quote x)) (nth 1 last)))) - (byte-compile-warn - "last arg to apply can't be a literal atom: %s" - (prin1-to-string last)) - nil)) - form))) + (if (and (eq last (third form)) + (consp last) + (eq 'mapcar (car last)) + (equal fn ''nconc)) + (progn + (byte-compile-warn + "(apply 'nconc (mapcar ..)), use #'mapcan instead: %s" last) + (cons 'mapcan (cdr last))) + (or (if (or (null last) + (eq (car-safe last) 'quote)) + (if (listp (nth 1 last)) + (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) + (nconc (list 'funcall fn) butlast + (mapcar #'(lambda (x) (list 'quote x)) + (nth 1 last)))) + (byte-compile-warn + "last arg to apply can't be a literal atom: %s" + (prin1-to-string last)) + nil)) + form)))) (put 'funcall 'byte-optimizer 'byte-optimize-funcall) (put 'apply 'byte-optimizer 'byte-optimize-apply) @@ -1216,7 +1225,7 @@ ;; coordinates-in-window-p not in XEmacs copy-marker cos count-lines default-boundp default-value denominator documentation downcase - elt exp expt fboundp featurep + elt endp exp expt fboundp featurep file-directory-p file-exists-p file-locked-p file-name-absolute-p file-newer-than-file-p file-readable-p file-symlink-p file-writable-p float floor format
--- a/lisp/bytecomp-runtime.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/bytecomp-runtime.el Mon Oct 18 23:21:23 2010 +0900 @@ -53,30 +53,26 @@ "Cause the named functions to be open-coded when called from compiled code. They will only be compiled open-coded when `byte-optimize' is true." (cons 'eval-and-compile - (apply - 'nconc - (mapcar - #'(lambda (x) - `((or (memq (get ',x 'byte-optimizer) - '(nil byte-compile-inline-expand)) - (error - "%s already has a byte-optimizer, can't make it inline" - ',x)) - (put ',x 'byte-optimizer 'byte-compile-inline-expand))) - fns)))) + (mapcan + #'(lambda (x) + `((or (memq (get ',x 'byte-optimizer) + '(nil byte-compile-inline-expand)) + (error + "%s already has a byte-optimizer, can't make it inline" + ',x)) + (put ',x 'byte-optimizer 'byte-compile-inline-expand))) + fns))) (defmacro proclaim-notinline (&rest fns) "Cause the named functions to no longer be open-coded." (cons 'eval-and-compile - (apply - 'nconc - (mapcar - #'(lambda (x) - `((if (eq (get ',x 'byte-optimizer) - 'byte-compile-inline-expand) - (put ',x 'byte-optimizer nil)))) - fns)))) + (mapcan + #'(lambda (x) + `((if (eq (get ',x 'byte-optimizer) + 'byte-compile-inline-expand) + (put ',x 'byte-optimizer nil)))) + fns))) ;; This has a special byte-hunk-handler in bytecomp.el. (defmacro defsubst (name arglist &rest body) @@ -163,7 +159,7 @@ (put 'eval-when-compile 'lisp-indent-hook 0) (defmacro eval-when-compile (&rest body) - "Like `progn', but evaluates the body at compile time. + "Like `progn', but evaluates BODY at compile time, and when interpeted. The result of the body appears to the compiler as a quoted constant." ;; Not necessary because we have it in b-c-initial-macro-environment ;; (list 'quote (eval (cons 'progn body))) @@ -171,7 +167,8 @@ (put 'eval-and-compile 'lisp-indent-hook 0) (defmacro eval-and-compile (&rest body) - "Like `progn', but evaluates the body at compile time and at load time." + "Like `progn', but evaluates the body at compile time and at load time, +and when interpreted." ;; Remember, it's magic. (cons 'progn body))
--- a/lisp/bytecomp.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/bytecomp.el Mon Oct 18 23:21:23 2010 +0900 @@ -493,13 +493,25 @@ (fset (car elt) (cdr elt))))))) (defconst byte-compile-initial-macro-environment - '((byte-compiler-options . (lambda (&rest forms) - (apply 'byte-compiler-options-handler forms))) - (eval-when-compile . (lambda (&rest body) - (list 'quote (byte-compile-eval (cons 'progn body))))) - (eval-and-compile . (lambda (&rest body) - (byte-compile-eval (cons 'progn body)) - (cons 'progn body)))) + `((byte-compiler-options + . ,#'(lambda (&rest forms) + (apply 'byte-compiler-options-handler forms))) + (eval-when-compile + . ,#'(lambda (&rest body) + (list 'quote (byte-compile-eval (cons 'progn body))))) + (eval-and-compile + . ,#'(lambda (&rest body) + (byte-compile-eval (cons 'progn body)) + (cons 'progn body))) + (the . + ,#'(lambda (type form) + (if (cl-const-expr-p form) + (or (eval (cl-make-type-test form type)) + (byte-compile-warn + "%s is not of type %s" form type))) + (if byte-compile-delete-errors + form + (funcall (cdr (symbol-function 'the)) type form))))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when expanded by the compiler as when expanded by the interpreter.") @@ -1383,7 +1395,7 @@ (defmacro byte-compile-constp (form) ;; Returns non-nil if FORM is a constant. - `(cond ((consp ,form) (eq (car ,form) 'quote)) + `(cond ((consp ,form) (memq (car ,form) '(quote function))) ((symbolp ,form) (byte-compile-constant-symbol-p ,form)) (t))) @@ -3573,10 +3585,13 @@ ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (byte-compile-constant - (cond ((symbolp (nth 1 form)) - (nth 1 form)) - ((byte-compile-lambda (nth 1 form)))))) + (if (cddr form) + (byte-compile-normal-call + `(signal 'wrong-number-of-arguments '(function ,(length (cdr form))))) + (byte-compile-constant + (cond ((symbolp (nth 1 form)) + (nth 1 form)) + ((byte-compile-lambda (nth 1 form))))))) (defun byte-compile-insert (form) (cond ((null (cdr form)) @@ -3706,11 +3721,16 @@ (defun byte-compile-quote (form) - (byte-compile-constant (car (cdr form)))) + (if (cddr form) + (byte-compile-normal-call + `(signal 'wrong-number-of-arguments '(quote ,(length (cdr form))))) + (byte-compile-constant (car (cdr form))))) (defun byte-compile-quote-form (form) - (byte-compile-constant (byte-compile-top-level (nth 1 form)))) - + (if (cddr form) + (byte-compile-normal-call + `(signal 'wrong-number-of-arguments '(quote ,(length (cdr form))))) + (byte-compile-constant (byte-compile-top-level (nth 1 form))))) ;;; control structures
--- a/lisp/cl-extra.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/cl-extra.el Mon Oct 18 23:21:23 2010 +0900 @@ -64,11 +64,11 @@ ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) ;; XEmacs addition character <-> integer coercions ((and (eq type 'character) (char-int-p x)) (int-char x)) - ((and (eq type 'integer) (characterp x)) (char-int x)) + ((and (memq type '(integer fixnum)) (characterp x)) (char-int x)) ((eq type 'float) (float x)) ;; XEmacs addition: enhanced numeric type coercions ((and-fboundp 'coerce-number - (memq type '(integer ratio bigfloat)) + (memq type '(integer ratio bigfloat fixnum)) (coerce-number x type))) ;; XEmacs addition: bit-vector coercion ((or (eq type 'bit-vector) @@ -392,6 +392,7 @@ (vector (apply 'vconcat seqs)) (string (apply 'concat seqs)) (list (apply 'append (append seqs '(nil)))) + (bit-vector (apply 'bvconcat seqs)) (t (error 'invalid-argument "Not a sequence type name" type)))) ;;; List functions. @@ -404,18 +405,17 @@ "Equivalent to (nconc (nreverse X) Y)." (nconc (nreverse x) y)) -(defun list-length (list) - "Return the length of LIST. Return nil if LIST is circular." - (if (listp list) - (condition-case nil (length list) (circular-list)) - ;; Error on not-a-list: - (car list))) - +;; XEmacs; check LIST for type and circularity. (defun tailp (sublist list) "Return true if SUBLIST is a tail of LIST." - (while (and (consp list) (not (eq sublist list))) - (setq list (cdr list))) - (if (numberp sublist) (equal sublist list) (eq sublist list))) + (check-argument-type #'listp list) + (let ((before list) (evenp t)) + (while (and (consp list) (not (eq sublist list))) + (setq list (cdr list) + evenp (not evenp)) + (if evenp (setq before (cdr before))) + (if (eq before list) (error 'circular-list list))) + (eql sublist list))) (defalias 'cl-copy-tree 'copy-tree) @@ -425,17 +425,9 @@ (defalias 'get* 'get) (defalias 'getf 'plist-get) -(defun cl-set-getf (plist tag val) - (let ((p plist)) - (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) - (if p (progn (setcar (cdr p) val) plist) (list* tag val plist)))) - -(defun cl-do-remf (plist tag) - (let ((p (cdr plist))) - (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) - (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) - -;; XEmacs change: we have a builtin remprop +;; XEmacs; these are built-in. +(defalias 'cl-set-getf 'plist-put) +(defalias 'cl-do-remf 'plist-remprop) (defalias 'cl-remprop 'remprop) (defun get-properties (plist indicator-list) @@ -663,6 +655,11 @@ (prog1 (cl-prettyprint form) (message "")))) +;; XEmacs addition; force cl-macs to be available from here on when +;; compiling files to be dumped. This is more reasonable than forcing other +;; files to do the same, multiple times. +(eval-when-compile (or (cl-compiling-file) (load "cl-macs"))) + (run-hooks 'cl-extra-load-hook) ;; XEmacs addition
--- a/lisp/cl-macs.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/cl-macs.el Mon Oct 18 23:21:23 2010 +0900 @@ -1962,7 +1962,19 @@ ;;;###autoload (defmacro locally (&rest body) (cons 'progn body)) ;;;###autoload -(defmacro the (type form) form) +(defmacro the (type form) + "Assert that FORM gives a result of type TYPE, and return that result. + +TYPE is a Common Lisp type specifier. + +If macro expansion of a `the' form happens during byte compilation, and the +byte compiler customization variable `byte-compile-delete-errors' is +non-nil, `the' is equivalent to FORM without any type checks." + (if (cl-safe-expr-p form) + `(prog1 ,form (assert ,(cl-make-type-test form type) t)) + (let ((saved (gensym))) + `(let ((,saved ,form)) + (prog1 ,saved (assert ,(cl-make-type-test saved type) t)))))) (defvar cl-proclaim-history t) ; for future compilers (defvar cl-declare-stack t) ; for future compilers @@ -2395,7 +2407,7 @@ (append (nth 1 method) (list tag def)) (list store-temp) (list 'let (list (list (car (nth 2 method)) - (list 'cl-set-getf (nth 4 method) + (list 'plist-put (nth 4 method) tag-temp store-temp))) (nth 3 method) store-temp) (list 'getf (nth 4 method) tag-temp def-temp)))) @@ -2585,7 +2597,7 @@ (list 'progn (cl-setf-do-store (nth 1 method) (list 'cddr tval)) t) - (list 'cl-do-remf tval ttag))))) + (list 'plist-remprop tval ttag))))) ;;;###autoload (defmacro shiftf (place &rest args) @@ -3751,6 +3763,35 @@ :test #'equal)) ,stack-depth)))) +(define-compiler-macro concatenate (&whole form type &rest seqs) + (if (and (cl-const-expr-p type) (memq (cl-const-expr-val type) + '(vector bit-vector list string))) + (case (cl-const-expr-val type) + (list (append (list 'append) (cddr form) '(nil))) + (vector (cons 'vconcat (cddr form))) + (bit-vector (cons 'bvconcat (cddr form))) + (string (cons 'concat (cddr form)))) + form)) + +(map nil + #'(lambda (function) + ;; There are byte codes for the two-argument versions of these + ;; functions; if the form has more arguments and those arguments + ;; have no side effects, transform to a series of two-argument + ;; calls. + (put function 'cl-compiler-macro + #'(lambda (form &rest arguments) + (if (or (null (nthcdr 3 form)) + (notevery #'cl-safe-expr-p (cdr form))) + form + (cons 'and (mapcon + #'(lambda (rest) + (and (cdr rest) + `((,(car form) ,(pop rest) + ,(car rest))))) + (cdr form))))))) + '(= < > <= >=)) + (mapc #'(lambda (y) (put (car y) 'side-effect-free t) @@ -3764,7 +3805,7 @@ '((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) (endp 'null x) (plusp '> x 0) (minusp '< x 0) + (rest 'cdr x) (plusp '> x 0) (minusp '< x 0) (oddp 'eq (list 'logand x 1) 1) (evenp 'eq (list 'logand x 1) 0) (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr)
--- a/lisp/cl-seq.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/cl-seq.el Mon Oct 18 23:21:23 2010 +0900 @@ -142,48 +142,7 @@ (defvar cl-if) (defvar cl-if-not) (defvar cl-key) -(defun replace (cl-seq1 cl-seq2 &rest cl-keys) - "Replace the elements of SEQ1 with the elements of SEQ2. -SEQ1 is destructively modified, then returned. -Keywords supported: :start1 :end1 :start2 :end2 -:start1 and :end1 specify a subsequence of SEQ1, and :start2 and :end2 a -subsequence of SEQ2; see `search' for more information." - (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () - (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1)) - (or (= cl-start1 cl-start2) - (let* ((cl-len (length cl-seq1)) - (cl-n (min (- (or cl-end1 cl-len) cl-start1) - (- (or cl-end2 cl-len) cl-start2)))) - (while (>= (setq cl-n (1- cl-n)) 0) - (cl-set-elt cl-seq1 (+ cl-start1 cl-n) - (elt cl-seq2 (+ cl-start2 cl-n)))))) - (if (listp cl-seq1) - (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) - (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000))) - (if (listp cl-seq2) - (let ((cl-p2 (nthcdr cl-start2 cl-seq2)) - (cl-n (min cl-n1 - (if cl-end2 (- cl-end2 cl-start2) 4000000)))) - (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0)) - (setcar cl-p1 (car cl-p2)) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))) - (setq cl-end2 (min (or cl-end2 (length cl-seq2)) - (+ cl-start2 cl-n1))) - (while (and cl-p1 (< cl-start2 cl-end2)) - (setcar cl-p1 (aref cl-seq2 cl-start2)) - (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2))))) - (setq cl-end1 (min (or cl-end1 (length cl-seq1)) - (+ cl-start1 (- (or cl-end2 (length cl-seq2)) - cl-start2)))) - (if (listp cl-seq2) - (let ((cl-p2 (nthcdr cl-start2 cl-seq2))) - (while (< cl-start1 cl-end1) - (aset cl-seq1 cl-start1 (car cl-p2)) - (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1)))) - (while (< cl-start1 cl-end1) - (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2)) - (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1)))))) - cl-seq1)) +;; XEmacs; #'replace is in fns.c. (defun remove* (cl-item cl-seq &rest cl-keys) "Remove all occurrences of ITEM in SEQ. @@ -215,8 +174,11 @@ (list :end (1+ cl-i)) (list :start cl-i)) cl-keys)))) - (if (listp cl-seq) cl-res - (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) + (typecase cl-seq + (list cl-res) + (string (concat cl-res)) + (vector (vconcat cl-res)) + (bit-vector (bvconcat cl-res)))) cl-seq)) (setq cl-end (- (or cl-end 8000000) cl-start)) (if (= cl-start 0) @@ -382,7 +344,10 @@ (setq cl-end (1- cl-end) cl-start (1+ cl-start))) cl-seq))) (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) - (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) + (typecase cl-seq + (string (concat cl-res)) + (vector (vconcat cl-res)) + (bit-vector (bvconcat cl-res)))))) (defun substitute (cl-new cl-old cl-seq &rest cl-keys) "Substitute NEW for OLD in SEQ.
--- a/lisp/cl.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/cl.el Mon Oct 18 23:21:23 2010 +0900 @@ -365,7 +365,13 @@ (defalias 'first 'car) (defalias 'rest 'cdr) -(defalias 'endp 'null) + +;; XEmacs change; this needs to error if handed a non-list. +(defun endp (list) + "Return t if LIST is nil, or nil if LIST is a cons. Error otherwise." + (prog1 + (null list) + (and list (atom list) (error 'wrong-type-argument #'listp list)))) ;; XEmacs change: make it a real function (defun second (x) @@ -519,24 +525,28 @@ ;;; `last' is implemented as a C primitive, as of 1998-11 -(defun list* (arg &rest rest) ; See compiler macro in cl-macs.el - "Return a new list with specified args as elements, cons'd to last arg. -Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to -`(cons A (cons B (cons C D)))'." - (cond ((not rest) arg) - ((not (cdr rest)) (cons arg (car rest))) - (t (let* ((n (length rest)) - (copy (copy-sequence rest)) - (last (nthcdr (- n 2) copy))) - (setcdr last (car (cdr last))) - (cons arg copy))))) +;;; XEmacs: `list*' is in subr.el. + +;; XEmacs; handle dotted lists properly, error on circularity and if LIST is +;; not a list. +(defun ldiff (list sublist) + "Return a copy of LIST with the tail SUBLIST removed. -(defun ldiff (list sublist) - "Return a copy of LIST with the tail SUBLIST removed." - (let ((res nil)) - (while (and (consp list) (not (eq list sublist))) - (push (pop list) res)) - (nreverse res))) +If SUBLIST is the same Lisp object as LIST, return nil. If SUBLIST is +not present in the list structure of LIST (that is, it is not the cdr +of some cons making up LIST), this function is equivalent to +`copy-list'. LIST may be dotted." + (check-argument-type #'listp list) + (and list (not (eq list sublist)) + (let ((before list) (evenp t) result) + (prog1 + (setq result (list (car list))) + (while (and (setq list (cdr-safe list)) (not (eql list sublist))) + (setf (cdr result) (if (consp list) (list (car list)) list) + result (cdr result) + evenp (not evenp)) + (if evenp (setq before (cdr before))) + (if (eq before list) (error 'circular-list list))))))) ;;; `copy-list' is implemented as a C primitive, as of 1998-11
--- a/lisp/cmdloop.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/cmdloop.el Mon Oct 18 23:21:23 2010 +0900 @@ -564,12 +564,7 @@ ;; BEGIN SYNCHED WITH FSF 21.2. -(defvar read-quoted-char-radix 8 - "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'. -Legitimate radix values are 8, 10 and 16.") - -(custom-declare-variable-early - 'read-quoted-char-radix 8 +(defcustom read-quoted-char-radix 8 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'. Legitimate radix values are 8, 10 and 16." :type '(choice (const 8) (const 10) (const 16))
--- a/lisp/custom.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/custom.el Mon Oct 18 23:21:23 2010 +0900 @@ -44,12 +44,10 @@ (provide 'custom) (eval-when-compile - (load "cl-macs" nil t) ;; To elude warnings. (require 'cus-face)) (autoload 'custom-declare-face "cus-face") -(autoload 'defun* "cl-macs") (require 'widget) @@ -1056,12 +1054,7 @@ ;;; The End. -;; Process the defcustoms for variables loaded before this file. -;; `custom-declare-variable-list' is defvar'd in subr.el. Utility programs -;; run from temacs that do not load subr.el should defvar it themselves. -;; (As of 21.5.11, make-docfile.el.) -(while custom-declare-variable-list - (apply 'custom-declare-variable (car custom-declare-variable-list)) - (setq custom-declare-variable-list (cdr custom-declare-variable-list))) +;; XEmacs; we order preloaded-file-list such that there's no need for +;; custom-declare-variable-list. ;; custom.el ends here
--- a/lisp/descr-text.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/descr-text.el Mon Oct 18 23:21:23 2010 +0900 @@ -457,98 +457,100 @@ (check-argument-type #'file-readable-p unidata-file-name) (unless unidata-database-format (error 'unimplemented "No (non-SQL) DB support available")) - (let* ((database-format unidata-database-format) - (size (eighth (file-attributes unidata-file-name))) - (database-file-name - (unidata-generate-database-file-name unidata-file-name - size database-format)) - (database-handle (open-database database-file-name database-format - nil "rw+" #o644 'no-conversion-unix)) - (coding-system-for-read 'no-conversion-unix) - (buffer-size 32768) - (offset-start 0) - (offset-end buffer-size) - (range-information (make-range-table 'start-closed-end-closed)) - (range-staging (make-hash-table :test 'equal)) - (message "Initializing UnicodeData database cache: ") - (loop-count 1) - range-startinfo) - (with-temp-buffer - (progress-feedback-with-label 'describe-char-unicodedata-file - "%s" 0 message) - (while (progn - (delete-region (point-min) (point-max)) - (insert-file-contents unidata-file-name nil - offset-start offset-end) - ;; If we've reached the end of the data, pass nil back to - ;; the while loop test. - (not (= (point-min) (point-max)))) + (with-fboundp '(open-database put-database close-database) + (let* ((database-format unidata-database-format) + (size (eighth (file-attributes unidata-file-name))) + (database-file-name + (unidata-generate-database-file-name unidata-file-name + size database-format)) + (database-handle (open-database database-file-name database-format + nil "rw+" #o644 + 'no-conversion-unix)) + (coding-system-for-read 'no-conversion-unix) + (buffer-size 32768) + (offset-start 0) + (offset-end buffer-size) + (range-information (make-range-table 'start-closed-end-closed)) + (range-staging (make-hash-table :test 'equal)) + (message "Initializing UnicodeData database cache: ") + (loop-count 1) + range-startinfo) + (with-temp-buffer + (progress-feedback-with-label 'describe-char-unicodedata-file + "%s" 0 message) + (while (progn + (delete-region (point-min) (point-max)) + (insert-file-contents unidata-file-name nil + offset-start offset-end) + ;; If we've reached the end of the data, pass nil back to + ;; the while loop test. + (not (= (point-min) (point-max)))) - (when (= buffer-size (- (point-max) (point-min))) - ;; If we're in the body of the file, and there's a trailing - ;; incomplete end-line, delete it, and adjust offset-end - ;; appropriately. - (goto-char (point-max)) - (search-backward "\n") - (forward-char) - (delete-region (point) (point-max)) - (setq offset-end (+ offset-start (- (point) (point-min))))) + (when (= buffer-size (- (point-max) (point-min))) + ;; If we're in the body of the file, and there's a trailing + ;; incomplete end-line, delete it, and adjust offset-end + ;; appropriately. + (goto-char (point-max)) + (search-backward "\n") + (forward-char) + (delete-region (point) (point-max)) + (setq offset-end (+ offset-start (- (point) (point-min))))) - (progress-feedback-with-label 'describe-char-unicodedata-file - "%s" (truncate - (* (/ offset-start size) 100)) - (concat message - (make-string - (mod loop-count 39) ?.))) - (incf loop-count) - (goto-char (point-min)) - (while (re-search-forward - #r"^\([0-9A-F]\{4,6\}\);\([^;]*\);.*$" nil t) - (cond - ((and (> (- (match-end 2) (match-beginning 2)) 7) - (equal (substring (match-string 2) -7) - " First>")) - ;; Start of a range. Save the start info in range-staging. - (puthash (substring (match-string 2) 0 -7) - (list (string-to-int (match-string 1) 16) - (+ offset-start (1- (match-beginning 0)))) - range-staging)) - ((and (> (- (match-end 2) (match-beginning 2)) 7) - (equal (substring (match-string 2) -6) - " Last>")) - ;; End of a range. Combine with the start info, save it to the - ;; range-information range table. - (setq range-startinfo - (gethash (substring (match-string 2) 0 -6) range-staging)) - (assert range-startinfo nil - "Unexpected order for range information.") - (put-range-table - (first range-startinfo) - (string-to-int (match-string 1) 16) - (list (second range-startinfo) + (progress-feedback-with-label 'describe-char-unicodedata-file + "%s" (truncate + (* (/ offset-start size) 100)) + (concat message + (make-string + (mod loop-count 39) ?.))) + (incf loop-count) + (goto-char (point-min)) + (while (re-search-forward + #r"^\([0-9A-F]\{4,6\}\);\([^;]*\);.*$" nil t) + (cond + ((and (> (- (match-end 2) (match-beginning 2)) 7) + (equal (substring (match-string 2) -7) + " First>")) + ;; Start of a range. Save the start info in range-staging. + (puthash (substring (match-string 2) 0 -7) + (list (string-to-int (match-string 1) 16) + (+ offset-start (1- (match-beginning 0)))) + range-staging)) + ((and (> (- (match-end 2) (match-beginning 2)) 7) + (equal (substring (match-string 2) -6) + " Last>")) + ;; End of a range. Combine with the start info, save it to the + ;; range-information range table. + (setq range-startinfo + (gethash (substring (match-string 2) 0 -6) range-staging)) + (assert range-startinfo nil + "Unexpected order for range information.") + (put-range-table + (first range-startinfo) + (string-to-int (match-string 1) 16) + (list (second range-startinfo) (+ offset-start (1- (match-end 0)))) - range-information) - (remhash (substring (match-string 2) 0 -6) range-staging)) - (t - ;; Normal character. Save the associated information in the - ;; database directly. - (put-database (match-string 1) - (format "(%d %d)" - (+ offset-start (1- (match-beginning 0))) - (+ offset-start (1- (match-end 0)))) - database-handle)))) - (goto-char (point-min)) - (setq offset-start offset-end - offset-end (+ buffer-size offset-end)))) - ;; Save the range information as such in the database. - (put-database "range-information" - (let ((print-readably t)) - (prin1-to-string range-information)) - database-handle) - (close-database database-handle) - (progress-feedback-with-label 'describe-char-unicodedata-file - "%s" 100 message) - database-file-name)) + range-information) + (remhash (substring (match-string 2) 0 -6) range-staging)) + (t + ;; Normal character. Save the associated information in the + ;; database directly. + (put-database (match-string 1) + (format "(%d %d)" + (+ offset-start (1- (match-beginning 0))) + (+ offset-start (1- (match-end 0)))) + database-handle)))) + (goto-char (point-min)) + (setq offset-start offset-end + offset-end (+ buffer-size offset-end)))) + ;; Save the range information as such in the database. + (put-database "range-information" + (let ((print-readably t)) + (prin1-to-string range-information)) + database-handle) + (close-database database-handle) + (progress-feedback-with-label 'describe-char-unicodedata-file + "%s" 100 message) + database-file-name))) (defun unidata-initialize-unihan-database (unihan-file-name) "Init the berkeley or gdbm lookup table for UNIHAN-FILE-NAME. @@ -562,114 +564,115 @@ (check-argument-type #'file-readable-p unihan-file-name) (unless unidata-database-format (error 'unimplemented "No (non-SQL) DB support available")) - (let* ((database-format unidata-database-format) - (size (eighth (file-attributes unihan-file-name))) - (database-file-name - (unidata-generate-database-file-name unihan-file-name - size database-format)) - (database-handle (open-database database-file-name database-format - nil "rw+" #o644 'no-conversion-unix)) - (coding-system-for-read 'no-conversion-unix) - (buffer-size 65536) - (offset-start 0) - (offset-end buffer-size) - (message "Initializing Unihan database cache: ") - (loop-count 1) - trailing-unicode leading-unicode character-start character-end) - (with-temp-buffer - (progress-feedback-with-label 'describe-char-unihan-file - "%s" 0 message) - (while (progn - (delete-region (point-min) (point-max)) - (insert-file-contents unihan-file-name nil - offset-start offset-end) - ;; If we've reached the end of the data, return nil to the - ;; while. - (not (= (point-min) (point-max)))) + (with-fboundp '(open-database put-database close-database) + (let* ((database-format unidata-database-format) + (size (eighth (file-attributes unihan-file-name))) + (database-file-name + (unidata-generate-database-file-name unihan-file-name + size database-format)) + (database-handle (open-database database-file-name database-format + nil "rw+" #o644 + 'no-conversion-unix)) + (coding-system-for-read 'no-conversion-unix) + (buffer-size 65536) + (offset-start 0) + (offset-end buffer-size) + (message "Initializing Unihan database cache: ") + (loop-count 1) + trailing-unicode leading-unicode character-start character-end) + (with-temp-buffer + (progress-feedback-with-label 'describe-char-unihan-file + "%s" 0 message) + (while (progn + (delete-region (point-min) (point-max)) + (insert-file-contents unihan-file-name nil + offset-start offset-end) + ;; If we've reached the end of the data, return nil to the + ;; while. + (not (= (point-min) (point-max)))) - (incf loop-count) - (progress-feedback-with-label 'describe-char-unihan-file - "%s" (truncate - (* (/ offset-start size) 100)) - (concat message - (make-string - (mod loop-count 44) ?.))) - (block 'dealing-with-chars - (when (= buffer-size (- (point-max) (point-min))) - ;; If we're in the body of the file, we need to delete the - ;; character info for the last character, and set offset-end - ;; appropriately. Otherwise, we may not be able to pick where - ;; the actual description of a character ends and - ;; begins. - ;; - ;; This breaks if any single Unihan character description is - ;; greater than the buffer size in length. - (goto-char (point-max)) - (beginning-of-line) + (incf loop-count) + (progress-feedback-with-label 'describe-char-unihan-file + "%s" (truncate + (* (/ offset-start size) 100)) + (concat message + (make-string + (mod loop-count 44) ?.))) + (block 'dealing-with-chars + (when (= buffer-size (- (point-max) (point-min))) + ;; If we're in the body of the file, we need to delete the + ;; character info for the last character, and set offset-end + ;; appropriately. Otherwise, we may not be able to pick where + ;; the actual description of a character ends and begins. + ;; + ;; This breaks if any single Unihan character description is + ;; greater than the buffer size in length. + (goto-char (point-max)) + (beginning-of-line) - (when (< (- (point-max) (point)) (eval-when-compile - (length "U+ABCDEF\t"))) - ;; If the character ID of the last line may have been cut off, - ;; we need to delete all of that line here. - (delete-region (point) (point-max)) - (forward-line -1)) + (when (< (- (point-max) (point)) (eval-when-compile + (length "U+ABCDEF\t"))) + ;; If the character ID of the last line may have been cut off, + ;; we need to delete all of that line here. + (delete-region (point) (point-max)) + (forward-line -1)) - (when (looking-at "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t") - (setq trailing-unicode (match-string 1) - trailing-unicode - (format "^%s\t" (regexp-quote trailing-unicode))) + (when (looking-at "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t") + (setq trailing-unicode (match-string 1) + trailing-unicode + (format "^%s\t" (regexp-quote trailing-unicode))) - (end-of-line) + (end-of-line) - ;; Go back until we hit a line that doesn't start with this - ;; character info. - (while (re-search-backward trailing-unicode nil t)) + ;; Go back until we hit a line that doesn't start with this + ;; character info. + (while (re-search-backward trailing-unicode nil t)) - ;; The re-search-backward failed, so point is still at the end - ;; of the last match. Move to its beginning. - (beginning-of-line) - (delete-region (point) (point-max)) - (setq offset-end (+ offset-start (- (point) (point-min)))))) - (goto-char (point-min)) - (while t - (when (= (point) (point-max)) - ;; We're at the end of this part of the file. - (return-from 'dealing-with-chars)) + ;; The re-search-backward failed, so point is still at the end + ;; of the last match. Move to its beginning. + (beginning-of-line) + (delete-region (point) (point-max)) + (setq offset-end (+ offset-start (- (point) (point-min)))))) + (goto-char (point-min)) + (while t + (when (= (point) (point-max)) + ;; We're at the end of this part of the file. + (return-from 'dealing-with-chars)) - (unless (re-search-forward "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t" - nil t) - ;; We're probably in the comments at the start of the file. No - ;; need to look for character info. - (return-from 'dealing-with-chars)) + (unless (re-search-forward "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t" + nil t) + ;; We're probably in the comments at the start of the + ;; file. No need to look for character info. + (return-from 'dealing-with-chars)) - ;; Store where the character started. - (beginning-of-line) - (setq character-start (point)) + ;; Store where the character started. + (beginning-of-line) + (setq character-start (point)) - (setq leading-unicode - (format "^%s\t" (regexp-quote (match-string 1)))) + (setq leading-unicode + (format "^%s\t" (regexp-quote (match-string 1)))) - ;; Loop until we get past this entry. - (while (re-search-forward leading-unicode nil t)) + ;; Loop until we get past this entry. + (while (re-search-forward leading-unicode nil t)) - ;; Now, store the information. - (setq leading-unicode - (string-to-number (substring leading-unicode 3) 16) - leading-unicode (format "%04X" leading-unicode) - character-end (prog2 (end-of-line) (point))) - (put-database leading-unicode - (format "(%d %d)" - (+ offset-start (1- character-start)) - (+ offset-start (1- character-end))) - database-handle) - (forward-line))) - (setq offset-start offset-end - offset-end (+ buffer-size offset-end)))) - (close-database database-handle) - (progress-feedback-with-label 'describe-char-unihan-file - "%s" 100 - message) - database-file-name)) + ;; Now, store the information. + (setq leading-unicode + (string-to-number (substring leading-unicode 3) 16) + leading-unicode (format "%04X" leading-unicode) + character-end (prog2 (end-of-line) (point))) + (put-database leading-unicode + (format "(%d %d)" + (+ offset-start (1- character-start)) + (+ offset-start (1- character-end))) + database-handle) + (forward-line))) + (setq offset-start offset-end + offset-end (+ buffer-size offset-end)))) + (close-database database-handle) + (progress-feedback-with-label 'describe-char-unihan-file + "%s" 100 + message) + database-file-name))) ;; End XEmacs additions. (defun describe-char-unicode-data (char) @@ -688,52 +691,55 @@ (with-temp-buffer (let ((coding-system-for-read coding-system-for-read) database-handle key lookup) - (if (and describe-char-use-cache - (prog1 - (setq database-handle - (open-database - (unidata-generate-database-file-name - describe-char-unicodedata-file - (eighth (file-attributes - describe-char-unicodedata-file)) - unidata-database-format) - unidata-database-format - nil "r" - #o644 'no-conversion-unix)) - (unless database-handle - (warn "Could not open %s as a %s database" - (unidata-generate-database-file-name - describe-char-unicodedata-file - (eighth (file-attributes - describe-char-unicodedata-file)) - unidata-database-format) - unidata-database-format)))) - (progn - ;; Use the database info. - (setq coding-system-for-read 'no-conversion-unix - key (format "%04X" char) - lookup (get-database key database-handle)) - (if lookup - ;; Okay, we have information on that character in particular. - (progn (setq lookup (read lookup)) - (insert-file-contents describe-char-unicodedata-file - nil (first lookup) - (second lookup))) - ;; No information on that character in particular. Do we - ;; have range information? If so, load and check for our - ;; desired character. - (setq lookup (get-database "range-information" database-handle) - lookup (if lookup (read lookup)) - lookup (if lookup (get-range-table char lookup))) - (when lookup - (insert-file-contents describe-char-unicodedata-file nil - (first lookup) (second lookup)))) - (close-database database-handle)) - ;; Otherwise, insert the whole file (the FSF approach). - (set-buffer (get-buffer-create " *Unicode Data*")) - (when (zerop (buffer-size)) - ;; Don't use -literally in case of DOS line endings. - (insert-file-contents describe-char-unicodedata-file)))) + (with-fboundp '(open-database get-database close-database) + (if (and describe-char-use-cache + (prog1 + (setq database-handle + (open-database + (unidata-generate-database-file-name + describe-char-unicodedata-file + (eighth (file-attributes + describe-char-unicodedata-file)) + unidata-database-format) + unidata-database-format + nil "r" + #o644 'no-conversion-unix)) + (unless database-handle + (warn "Could not open %s as a %s database" + (unidata-generate-database-file-name + describe-char-unicodedata-file + (eighth (file-attributes + describe-char-unicodedata-file)) + unidata-database-format) + unidata-database-format)))) + (progn + ;; Use the database info. + (setq coding-system-for-read 'no-conversion-unix + key (format "%04X" char) + lookup (get-database key database-handle)) + (if lookup + ;; Okay, we have information on that character in + ;; particular. + (progn (setq lookup (read lookup)) + (insert-file-contents describe-char-unicodedata-file + nil (first lookup) + (second lookup))) + ;; No information on that character in particular. Do we + ;; have range information? If so, load and check for our + ;; desired character. + (setq lookup (get-database "range-information" + database-handle) + lookup (if lookup (read lookup)) + lookup (if lookup (get-range-table char lookup))) + (when lookup + (insert-file-contents describe-char-unicodedata-file nil + (first lookup) (second lookup)))) + (close-database database-handle)) + ;; Otherwise, insert the whole file (the FSF approach). + (set-buffer (get-buffer-create " *Unicode Data*")) + (when (zerop (buffer-size)) + ;; Don't use -literally in case of DOS line endings. + (insert-file-contents describe-char-unicodedata-file))))) (goto-char (point-min)) (let ((hex (format "%04X" char)) found first last unihan-match unihan-info unihan-database-handle @@ -755,14 +761,11 @@ last (<= char last)) (setq found t))) (if found - (let ((fields (mapcar (lambda (elt) - (if (> (length elt) 0) - elt)) - (cdr (split-string - (buffer-substring - (line-beginning-position) - (line-end-position)) - ";"))))) + (let ((fields (cdr (nsubst nil "" (split-string + (buffer-substring + (line-beginning-position) + (line-end-position)) ";") + :test 'equal)))) ;; The length depends on whether the last field was empty. (unless (or (= 13 (length fields)) (= 14 (length fields))) @@ -919,45 +922,46 @@ (if (and (> (length (nth 0 fields)) 13) (equal "<CJK Ideograph" (substring (nth 0 fields) 0 14))) - (if (and describe-char-unihan-file - (setq unihan-database-handle - (open-database - (unidata-generate-database-file-name - describe-char-unihan-file - (eighth (file-attributes - describe-char-unihan-file)) - unidata-database-format) - unidata-database-format - nil "r" #o644 'no-conversion-unix)) - (setq unihan-match - (get-database (format "%04X" char) - unihan-database-handle) - unihan-match - (and unihan-match (read unihan-match)))) - (with-temp-buffer - (insert-file-contents describe-char-unihan-file - nil (first unihan-match) - (second unihan-match)) - (goto-char (point-min)) - (while (re-search-forward - "^U\\+[0-9A-F]+\t\\(k[^\t]+\\)\t\\(.*\\)$" - nil t) - (push - (list - (or (gethash - (match-string 1) - describe-char-unihan-field-descriptions) - (match-string 1)) - (decode-coding-string (match-string 2) 'utf-8)) - unihan-info)) - (close-database unihan-database-handle) - unihan-info) + (with-fboundp '(open-database get-database close-database) + (if (and describe-char-unihan-file + (setq unihan-database-handle + (open-database + (unidata-generate-database-file-name + describe-char-unihan-file + (eighth (file-attributes + describe-char-unihan-file)) + unidata-database-format) + unidata-database-format + nil "r" #o644 'no-conversion-unix)) + (setq unihan-match + (get-database (format "%04X" char) + unihan-database-handle) + unihan-match + (and unihan-match (read unihan-match)))) + (with-temp-buffer + (insert-file-contents describe-char-unihan-file + nil (first unihan-match) + (second unihan-match)) + (goto-char (point-min)) + (while (re-search-forward + "^U\\+[0-9A-F]+\t\\(k[^\t]+\\)\t\\(.*\\)$" + nil t) + (push + (list + (or (gethash + (match-string 1) + describe-char-unihan-field-descriptions) + (match-string 1)) + (decode-coding-string (match-string 2) 'utf-8)) + unihan-info)) + (close-database unihan-database-handle) + unihan-info) ;; It's a Han character, but Unihan.txt is not ;; available. Tell the user. (list '("Unihan" "No Unihan information available; is \ -`describe-char-unihan-file' set, and its cache initialized?"))))))))))) +`describe-char-unihan-file' set, and its cache initialized?")))))))))))) ;; Return information about how CHAR is displayed at the buffer ;; position POS. If the selected frame is on a graphic display, @@ -1030,8 +1034,7 @@ (specifier-instance current-display-table (selected-window))) (disp-table-entry (and display-table (get-display-table char display-table))) - (extents (mapcar #'(lambda (o) (extent-properties o)) - (extents-at pos))) + (extents (mapcar #'extent-properties (extents-at pos))) (char-description (single-key-description char)) (text-props-desc (let ((tmp-buf (generate-new-buffer " *text-props*"))) @@ -1202,9 +1205,9 @@ (describe-char-unicode-data unicode))) (if unicodedata (cons (list "Unicode data" " ") unicodedata))))) - (setq max-width (apply #'max (mapcar #'(lambda (x) - (if (cadr x) (length (car x)) 0)) - item-list))) + (setq max-width + (reduce #'max (remove-if-not #'cadr item-list) :initial-value 0 + :key #'(lambda (object) (length (car object))))) (when (and unicodedata (> max-width max-unicode-description-width)) (setq max-width max-unicode-description-width) (with-temp-buffer
--- a/lisp/device.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/device.el Mon Oct 18 23:21:23 2010 +0900 @@ -45,7 +45,7 @@ (defun device-list () "Return a list of all devices." - (apply 'nconc (mapcar 'console-device-list (console-list)))) + (mapcan 'console-device-list (console-list))) (defun device-type (&optional device) "Return the type of the specified device (e.g. `x' or `tty').
--- a/lisp/dumped-lisp.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/dumped-lisp.el Mon Oct 18 23:21:23 2010 +0900 @@ -23,28 +23,19 @@ "backquote" ; needed for defsubst etc. "bytecomp-runtime" ; define defsubst - "find-paths" - "packages" ; Bootstrap run-time lisp environment - "setup-paths" - - ;; use custom-declare-variable-early, not defcustom, in these files - "subr" ; load the most basic Lisp functions + "cl" + "cl-extra" ; also loads cl-macs if we're running interpreted. + "cl-seq" "post-gc" - "replace" ; match-string used in version.el. - "version" - - "cl" - "cl-extra" - "cl-seq" + "custom" ; Before the world so everything can be customized + "cus-start" ; for customization of builtin variables + "find-paths" + "packages" + "setup-paths" + "replace" "widget" - "custom" ; Before the world so everything can be - ; customized - "cus-start" ; for customization of builtin variables - - ;; OK, you can use defcustom from here on - "cmdloop" "keymap" "syntax" @@ -300,7 +291,4 @@ )) (setq preloaded-file-list - (apply #'nconc - (mapcar #'(lambda (x) - (if (listp x) x (list x))) - preloaded-file-list))) + (mapcan #'(lambda (x) (if (listp x) x (list x))) preloaded-file-list))
--- a/lisp/etags.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/etags.el Mon Oct 18 23:21:23 2010 +0900 @@ -439,8 +439,7 @@ (defun buffer-tag-table-files () "Returns a list of all files referenced by all TAGS tables that this buffer uses." - (apply #'append - (mapcar #'tag-table-files (buffer-tag-table-list)))) + (mapcan #'tag-table-files (buffer-tag-table-list))) ;; Building the completion table
--- a/lisp/extents.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/extents.el Mon Oct 18 23:21:23 2010 +0900 @@ -109,7 +109,7 @@ EXTENT, until no more children can be found." (let ((children (extent-children extent))) (if children - (apply 'nconc (mapcar 'extent-descendants children)) + (mapcan 'extent-descendants children) (list extent)))) (defun set-extent-keymap (extent keymap)
--- a/lisp/faces.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/faces.el Mon Oct 18 23:21:23 2010 +0900 @@ -49,9 +49,7 @@ ;; To elude the warnings for font functions. (Normally autoloaded when ;; font-create-object is called) -(eval-when-compile - (require 'font) - (load "cl-macs")) +(eval-when-compile (require 'font)) (defgroup faces nil "Support for multiple text attributes (fonts, colors, ...)
--- a/lisp/files.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/files.el Mon Oct 18 23:21:23 2010 +0900 @@ -606,15 +606,10 @@ (setq cd-path (or (and trypath (mapcar #'file-name-as-directory trypath)) (list (file-name-as-directory ""))))) - (or (catch 'found - (mapc #'(lambda (x) - (let ((f (expand-file-name (concat x dir)))) - (if (file-directory-p f) - (progn - (cd-absolute f) - (throw 'found t))))) - cd-path) - nil) + (or (some #'(lambda (x) + (let ((f (expand-file-name (concat x dir)))) + (when (file-directory-p f) (cd-absolute f)))) + cd-path) ;; jwz: give a better error message to those of us with the ;; good taste not to use a kludge like $CDPATH. (if (equal cd-path '("./")) @@ -3060,6 +3055,122 @@ (basic-save-buffer-1)) 'continue-save-buffer)) +(defun diff-buffer-with-file (&optional buffer) + "View the differences between BUFFER and its associated file. +This requires the external program `diff' to be in your `exec-path'." + (interactive "bBuffer: ") + (with-current-buffer (get-buffer (or buffer (current-buffer))) + (if (and buffer-file-name + (file-exists-p buffer-file-name)) + (let ((tempfile (make-temp-file "buffer-content-"))) + (unwind-protect + (save-restriction + (widen) + (write-region (point-min) (point-max) tempfile nil 'nomessage) + (diff-files-for-recover "File" + buffer-file-name tempfile buffer-file-name tempfile + buffer-file-coding-system) + (sit-for 0)) + (when (file-exists-p tempfile) + (delete-file tempfile)))) + (message "Buffer %s has no associated file on disc" (buffer-name)) + ;; Display that message for 1 second so that user can read it + ;; in the minibuffer. + (sit-for 1))) + ;; return always nil, so that save-buffers-kill-emacs will not move + ;; over to the next unsaved buffer when calling `d'. + nil) + +(defvar save-some-buffers-action-alist + ;;instead of this we just say "yes all", "no all", etc. + ;;"save all the rest" + ;;"save only this buffer" "save no more buffers") + ;; this is rather bogus. --ben + ;; (it makes the dialog box too big, and you get an error + ;; "wrong type argument: framep, nil" when you hit q after + ;; choosing the option from the dialog box) + + ;; We should fix the dialog box rather than disabling + ;; this! --hniksic + (list (list ?\C-r (lambda (buf) + ;; #### FSF has an EXIT-ACTION argument + ;; to `view-buffer'. + (view-buffer buf +; (function +; (lambda (ignore) +; (exit-recursive-edit)))) + ) + (with-boundp 'view-exit-action + (setq view-exit-action + (lambda (ignore) + (exit-recursive-edit)))) + (recursive-edit) + ;; Return nil to ask about BUF again. + nil) + "%_Display Buffer") + (list ?d (lambda (buf) + (save-window-excursion (diff-buffer-with-file buf)) + (view-buffer (get-buffer-create "*File Diff*") t) + (with-boundp 'view-exit-action + (setq view-exit-action + (lambda (ignore) + (exit-recursive-edit)))) + (recursive-edit) + ;; Return nil to ask about BUF again. + nil) + "View %_Changes in Buffer"))) + +(defun diff-files-for-recover (purpose file-1 file-2 + failed-file-1 failed-file-2 + coding-system) + "Diff two files for recovering or comparing against the last saved version. +PURPOSE is an informational string used for naming the resulting buffer. +FILE-1 and FILE-2 are the two files to compare. +FAILED-FILE-1 and FAILED-FILE-2 are the names of files for which we should +generate directory listings on failure. +CODING-SYSTEM is the coding system of the resulting buffer." + (with-output-to-temp-buffer (concat "*" purpose " Diff*") + (buffer-disable-undo standard-output) + (let ((coding-system-for-read coding-system)) + (condition-case ferr + (progn + (apply #'call-process + recover-file-diff-program + nil standard-output nil + (append + recover-file-diff-arguments + (list file-1 file-2))) + (if (fboundp 'diff-mode) + (save-excursion + (set-buffer standard-output) + (declare-fboundp (diff-mode))))) + (io-error + (save-excursion + (let ((switches + (declare-boundp + dired-listing-switches))) + (if (file-symlink-p failed-file-2) + (setq switches (concat switches "L"))) + (set-buffer standard-output) + ;; XEmacs had the following line, not in FSF. + (setq default-directory (file-name-directory failed-file-2)) + ;; Use insert-directory-safely, + ;; not insert-directory, because + ;; these files might not exist. + ;; In particular, FAILED-FILE-2 might not + ;; exist if the auto-save file + ;; was for a buffer that didn't + ;; visit a file, such as + ;; "*mail*". The code in v20.x + ;; called `ls' directly, so we + ;; need to emulate what `ls' did + ;; in that case. + (insert-directory-safely failed-file-1 switches) + (insert-directory-safely failed-file-2 switches)) + (terpri) + (princ "Error during diff: ") + (display-error ferr standard-output))))))) + (defcustom save-some-buffers-query-display-buffer t "*Non-nil makes `\\[save-some-buffers]' switch to the buffer offered for saving." :type 'boolean @@ -3138,32 +3249,7 @@ (error nil))) (buffer-list) '("buffer" "buffers" "save") - ;;instead of this we just say "yes all", "no all", etc. - ;;"save all the rest" - ;;"save only this buffer" "save no more buffers") - ;; this is rather bogus. --ben - ;; (it makes the dialog box too big, and you get an error - ;; "wrong type argument: framep, nil" when you hit q after - ;; choosing the option from the dialog box) - - ;; We should fix the dialog box rather than disabling - ;; this! --hniksic - (list (list ?\C-r (lambda (buf) - ;; #### FSF has an EXIT-ACTION argument - ;; to `view-buffer'. - (view-buffer buf -; (function -; (lambda (ignore) -; (exit-recursive-edit)))) - ) - (with-boundp 'view-exit-action - (setq view-exit-action - (lambda (ignore) - (exit-recursive-edit)))) - (recursive-edit) - ;; Return nil to ask about BUF again. - nil) - "%_Display Buffer")))) + save-some-buffers-action-alist)) (abbrevs-done (and save-abbrevs abbrevs-changed (progn @@ -3689,44 +3775,7 @@ 'escape-quoted)) (write-region (point-min) (point-max) temp nil 'silent))) - (with-output-to-temp-buffer "*Autosave Diff*" - (buffer-disable-undo standard-output) - (let ((coding-system-for-read - 'escape-quoted)) - (condition-case ferr - (apply #'call-process - recover-file-diff-program - nil standard-output nil - (append - recover-file-diff-arguments - (list temp file-name))) - (io-error - (save-excursion - (let ((switches - (declare-boundp - dired-listing-switches))) - (if (file-symlink-p file) - (setq switches (concat switches "L"))) - (set-buffer standard-output) - ;; XEmacs had the following line, not in FSF. - (setq default-directory (file-name-directory file)) - ;; Use insert-directory-safely, - ;; not insert-directory, because - ;; these files might not exist. - ;; In particular, FILE might not - ;; exist if the auto-save file - ;; was for a buffer that didn't - ;; visit a file, such as - ;; "*mail*". The code in v20.x - ;; called `ls' directly, so we - ;; need to emulate what `ls' did - ;; in that case. - (insert-directory-safely file switches) - (insert-directory-safely file-name switches)) - (terpri) - (princ "Error during diff: ") - (display-error ferr - standard-output))))))) + (diff-files-for-recover "Autosave" temp file-name file file-name 'escape-quoted)) (ignore-errors (kill-buffer buffer)) (ignore-file-errors (delete-file temp))))))))))))))) @@ -4400,9 +4449,10 @@ With prefix arg, silently save all file-visiting buffers, then kill." (interactive "P") (save-some-buffers arg t) - (and (or (not (memq t (mapcar #'(lambda (buf) (and (buffer-file-name buf) - (buffer-modified-p buf))) - (buffer-list)))) + (and (or (not (some #'(lambda (buf) + (and (buffer-file-name buf) + (buffer-modified-p buf))) + (buffer-list))) (yes-or-no-p "Modified buffers exist; exit anyway? ")) (or (not (fboundp 'process-list)) ;; process-list is not defined on VMS.
--- a/lisp/format.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/format.el Mon Oct 18 23:21:23 2010 +0900 @@ -604,9 +604,8 @@ (if (member top-name ans) ;; This annotation is listed, but still have to ;; check if multiple annotations are satisfied - (if (member nil (mapcar (lambda (r) - (assoc r open-ans)) - ans)) + (if (notevery (lambda (r) (assoc r open-ans)) + ans) nil ; multiple ans not satisfied ;; If there are multiple annotations going ;; into one text property, split up the other
--- a/lisp/frame.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/frame.el Mon Oct 18 23:21:23 2010 +0900 @@ -861,7 +861,7 @@ (defun frame-list () "Return a list of all frames on all devices/consoles." ;; Lists are copies, so nconc is safe here. - (apply 'nconc (mapcar 'device-frame-list (device-list)))) + (mapcan #'device-frame-list (device-list))) (defun frame-type (&optional frame) "Return the type of the specified frame (e.g. `x' or `tty').
--- a/lisp/hash-table.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/hash-table.el Mon Oct 18 23:21:23 2010 +0900 @@ -37,34 +37,27 @@ (defun hash-table-key-list (hash-table) "Return a list of all keys in HASH-TABLE." - (let (lis) - (maphash #'(lambda (key val) - (push key lis)) - hash-table) - (nreverse lis))) + (let (list) + (maphash #'(lambda (key value) (push key list)) hash-table) + list)) (defun hash-table-value-list (hash-table) "Return a list of all values in HASH-TABLE." - (let (lis) - (maphash #'(lambda (key val) - (push val lis)) - hash-table) - (nreverse lis))) + (let (list) + (maphash #'(lambda (key value) (push value list)) hash-table) + list)) (defun hash-table-key-value-alist (hash-table) "Return an alist of (KEY . VALUE) for all keys and values in HASH-TABLE." - (let (lis) - (maphash #'(lambda (key val) - (push (cons key val) lis)) + (let (list) + (maphash #'(lambda (key value) (setq list (acons key value list))) hash-table) - (nreverse lis))) + list)) (defun hash-table-key-value-plist (hash-table) "Return a plist for all keys and values in HASH-TABLE. A plist is a simple list containing alternating keys and values." - (let (lis) - (maphash #'(lambda (key val) - (push key lis) - (push val lis)) + (let (list) + (maphash #'(lambda (key value) (setq list (list* key value list))) hash-table) - (nreverse lis))) + list))
--- a/lisp/info.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/info.el Mon Oct 18 23:21:23 2010 +0900 @@ -864,14 +864,13 @@ (if (and Info-dir-contents Info-dir-file-attributes ;; Verify that none of the files we used has changed ;; since we used it. - (eval (cons 'and - (mapcar #'(lambda (elt) - (let ((curr (file-attributes (car elt)))) - ;; Don't compare the access time. - (if curr (setcar (nthcdr 4 curr) 0)) - (setcar (nthcdr 4 (cdr elt)) 0) - (equal (cdr elt) curr))) - Info-dir-file-attributes)))) + (every #'(lambda (elt) + (let ((curr (file-attributes (car elt)))) + ;; Don't compare the access time. + (if curr (setcar (nthcdr 4 curr) 0)) + (setcar (nthcdr 4 (cdr elt)) 0) + (equal (cdr elt) curr))) + Info-dir-file-attributes)) (insert Info-dir-contents) (let ((dirs (reverse Info-directory-list)) buffers lbuffers buffer others nodes dirs-done)
--- a/lisp/minibuf.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/minibuf.el Mon Oct 18 23:21:23 2010 +0900 @@ -1569,12 +1569,13 @@ (defun minibuf-directory-files (dir &optional match-regexp files-only) (let ((want-file (or (eq files-only nil) (eq files-only t))) (want-dirs (or (eq files-only nil) (not (eq files-only t))))) - (delete nil - (mapcar (function (lambda (f) - (if (file-directory-p (expand-file-name f dir)) - (and want-dirs (file-name-as-directory f)) - (and want-file f)))) - (delete "." (directory-files dir nil match-regexp)))))) + (mapcan + #'(lambda (f) + (and (not (equal "." f)) + (if (file-directory-p (expand-file-name f dir)) + (and want-dirs (list (file-name-as-directory f))) + (and want-file (list f))))) + (directory-files dir nil match-regexp)))) (defun read-file-name-2 (history prompt dir default
--- a/lisp/modeline.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/modeline.el Mon Oct 18 23:21:23 2010 +0900 @@ -524,35 +524,31 @@ (cons "Minor Mode Toggles" (sort - (delq nil (mapcar - #'(lambda (x) - (let* ((toggle-sym (car x)) - (toggle-fun (or (get toggle-sym - 'modeline-toggle-function) - (and (commandp toggle-sym) - toggle-sym))) - (menu-tag (symbol-name (if (symbolp toggle-fun) - toggle-fun - toggle-sym)) - ;; Here a function should - ;; maybe be invoked to - ;; beautify the symbol's - ;; menu appearance. - )) - (and toggle-fun - (vector menu-tag - toggle-fun - ;; The following two are wrong - ;; because of possible name - ;; clashes. - ;:active (get toggle-sym :active t) - ;:included (get toggle-sym :included t) - :style 'toggle - :selected (and (boundp toggle-sym) - toggle-sym))))) - minor-mode-alist)) - (lambda (e1 e2) - (string< (aref e1 0) (aref e2 0))))) + (mapcan + #'(lambda (x) + (let* ((toggle-sym (car x)) + (toggle-fun (or (get toggle-sym + 'modeline-toggle-function) + (and (commandp toggle-sym) + toggle-sym))) + (menu-tag (symbol-name (if (symbolp toggle-fun) + toggle-fun + toggle-sym)) + ;; Here a function should maybe be invoked to + ;; beautify the symbol's menu appearance. + )) + (and toggle-fun + (list (vector menu-tag + toggle-fun + ;; The following two are wrong because of + ;; possible name clashes. + ;:active (get toggle-sym :active t) + ;:included (get toggle-sym :included t) + :style 'toggle + :selected (and (boundp toggle-sym) + toggle-sym)))))) + minor-mode-alist) + (lambda (e1 e2) (string< (aref e1 0) (aref e2 0))))) event))) (defvar modeline-minor-mode-map (make-sparse-keymap 'modeline-minor-mode-map)
--- a/lisp/msw-faces.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/msw-faces.el Mon Oct 18 23:21:23 2010 +0900 @@ -268,12 +268,11 @@ (concat (substring font 0 (match-beginning 3)) (substring font (match-end 3) (match-end 0)))) (sort - (delq nil - (mapcar #'(lambda (name) - (and (string-match mswindows-font-regexp name) - (string-to-int (substring name (match-beginning 3) - (match-end 3))))) - (font-list font device))) + (mapcan #'(lambda (name) + (and (string-match mswindows-font-regexp name) + (list (string-to-int (substring name (match-beginning 3) + (match-end 3)))))) + (font-list font device)) #'<)) (defun mswindows-frob-font-size (font up-p device)
--- a/lisp/mule/mule-cmds.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/mule/mule-cmds.el Mon Oct 18 23:21:23 2010 +0900 @@ -789,8 +789,7 @@ (setq string (format "%c" unicode-error-lookup))) ;; Treat control characters specially: (setq first-char (aref string 0)) - (when (or (and (>= first-char #x00) (<= first-char #x1f)) - (and (>= first-char #x80) (<= first-char #x9f))) + (when (or (<= #x00 first-char #x1f) (<= #x80 first-char #x9f)) (setq string (format "^%c" (+ ?@ (aref string 0)))))) (setq glyph (make-glyph (vector 'string :data string))) (set-glyph-face glyph 'unicode-invalid-sequence-warning-face)
--- a/lisp/obsolete.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/obsolete.el Mon Oct 18 23:21:23 2010 +0900 @@ -428,5 +428,10 @@ (define-function 'purecopy 'identity) (make-obsolete 'purecopy "purespace is not available in XEmacs.") +(define-compatible-function-alias 'process-get 'get) +(define-compatible-function-alias 'process-put 'put) +(define-compatible-function-alias 'process-plist 'object-plist) +(define-compatible-function-alias 'set-process-plist 'object-setplist) + (provide 'obsolete) ;;; obsolete.el ends here
--- a/lisp/package-ui.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/package-ui.el Mon Oct 18 23:21:23 2010 +0900 @@ -408,26 +408,25 @@ (let ((tmpbuf "*Required-Packages*") do-select) (if pui-selected-packages (let ((dependencies - (delq nil (mapcar - (lambda (pkg) - (let ((installed - (package-get-key pkg :version)) - (current - (package-get-info-prop - (package-get-info-version - (package-get-info-find-package - package-get-base pkg) nil) - 'version))) - (if (or (null installed) - (< (if (stringp installed) - (string-to-number installed) - installed) - (if (stringp current) - (string-to-number current) - current))) - pkg - nil))) - (package-get-dependencies pui-selected-packages))))) + (mapcan + (lambda (pkg) + (let ((installed + (package-get-key pkg :version)) + (current + (package-get-info-prop + (package-get-info-version + (package-get-info-find-package + package-get-base pkg) nil) + 'version))) + (if (or (null installed) + (< (if (stringp installed) + (string-to-number installed) + installed) + (if (stringp current) + (string-to-number current) + current))) + (list pkg)))) + (package-get-dependencies pui-selected-packages)))) ;; Don't change window config when asking the user if he really ;; wants to add the packages. We do this to avoid messing up ;; the window configuration if errors occur (we don't want to
--- a/lisp/packages.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/packages.el Mon Oct 18 23:21:23 2010 +0900 @@ -31,23 +31,7 @@ ;; This file is dumped with XEmacs. ;; This file provides low level facilities for XEmacs startup -- -;; particularly regarding the package setup. This code has to run in -;; what we call "bare temacs" -- i.e. XEmacs without the usual Lisp -;; environment. Pay special attention: - -;; - not to use the `lambda' macro. Use #'(lambda ...) instead. -;; (this goes for any package loaded before `subr.el'.) -;; -;; - not to use macros, because they are not yet available (and this -;; file must be loadable uncompiled.) Built in macros, such as -;; `when' and `unless' are fine, of course. -;; -;; - not to use `defcustom'. If you must add user-customizable -;; variables here, use `defvar', and add the variable to -;; `cus-start.el'. - -;; Because of all this, make sure that the stuff you put here really -;; belongs here. +;; particularly regarding the package setup. ;; This file requires find-paths.el. @@ -467,13 +451,11 @@ PACKAGE-HIERARCHIES is a list of package hierarchies. SUFFIXES is a list of names of hierarchy subdirectories to look for." (let ((directories - (apply - #'nconc - (mapcar #'(lambda (hierarchy) - (mapcar #'(lambda (suffix) - (file-name-as-directory (concat hierarchy suffix))) - suffixes)) - package-hierarchies)))) + (mapcan #'(lambda (hierarchy) + (mapcar #'(lambda (suffix) + (file-name-as-directory (concat hierarchy suffix))) + suffixes)) + package-hierarchies))) (paths-directories-which-exist directories))) (defun packages-find-package-load-path (package-hierarchies)
--- a/lisp/post-gc.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/post-gc.el Mon Oct 18 23:21:23 2010 +0900 @@ -56,15 +56,8 @@ (defun cleanup-simple-finalizers (alist) "Clean up `simple-finalizer-ephemerons'." - ;; We have to do this by hand because DELETE-IF isn't defined yet. - (let ((current simple-finalizer-ephemerons) - (prev nil)) - (while (not (null current)) - (if (not (ephemeron-ref (car current))) - (if (null prev) - (setq simple-finalizer-ephemerons (cdr current)) - (setcdr prev (cdr current))) - (setq prev current)) - (setq current (cdr current))))) + (and simple-finalizer-ephemerons + (setq simple-finalizer-ephemerons + (delete-if-not #'ephemeron-ref simple-finalizer-ephemerons)))) (add-hook 'post-gc-hook 'cleanup-simple-finalizers)
--- a/lisp/specifier.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/specifier.el Mon Oct 18 23:21:23 2010 +0900 @@ -105,20 +105,23 @@ ;; this will signal an appropriate error. (check-valid-instantiator inst-pair specifier-type))) - ((and (valid-specifier-tag-p (car inst-pair)) - (valid-instantiator-p (cdr inst-pair) specifier-type)) + ((not (valid-instantiator-p (cdr inst-pair) specifier-type)) + (if noerror + t + (check-valid-instantiator (cdr inst-pair) specifier-type))) + + ((valid-specifier-tag-p (car inst-pair)) ;; case (b) (cons (list (car inst-pair)) (cdr inst-pair))) - ((and (valid-specifier-tag-set-p (car inst-pair)) - (valid-instantiator-p (cdr inst-pair) specifier-type)) + ((valid-specifier-tag-set-p (car inst-pair)) ;; case (c) inst-pair) (t (if noerror t - (signal 'error (list "Invalid specifier tag set" - (car inst-pair))))))) + (error 'invalid-argument "Invalid specifier tag set" + (car inst-pair)))))) (defun canonicalize-inst-list (inst-list specifier-type &optional noerror) "Canonicalize the given INST-LIST (a list of inst-pairs). @@ -199,9 +202,14 @@ (if (not (valid-specifier-locale-p (car spec))) ;; invalid locale. - (if noerror t - (signal 'error (list "Invalid specifier locale" (car spec)))) - + (if noerror + t + (if (consp (car spec)) + ;; If it's a cons, they're probably not passing a locale + (error 'invalid-argument + "Not a valid instantiator list" spec) + (error 'invalid-argument + "Invalid specifier locale" (car spec)))) ;; case (b) (let ((result (canonicalize-inst-list (cdr spec) specifier-type noerror))) @@ -513,10 +521,9 @@ varlist))) ;; Bind the appropriate variables. `(let* (,@(mapcan #'(lambda (varel) - (delq nil (mapcar - #'(lambda (varcons) - (and (cdr varcons) varcons)) - varel))) + (mapcan #'(lambda (varcons) + (and (cdr varcons) (list varcons))) + varel)) varlist) ,@oldvallist) (unwind-protect
--- a/lisp/subr.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/subr.el Mon Oct 18 23:21:23 2010 +0900 @@ -39,18 +39,9 @@ ;; BEGIN SYNCHED WITH FSF 21.2 -;;; Code: -(defvar custom-declare-variable-list nil - "Record `defcustom' calls made before `custom.el' is loaded to handle them. -Each element of this list holds the arguments to one call to `defcustom'.") +;; XEmacs; no need for custom-declare-variable-list, preloaded-file-list is +;; ordered to make it unnecessary. -;; Use this, rather than defcustom, in subr.el and other files loaded -;; before custom.el. See dumped-lisp.el. -(defun custom-declare-variable-early (&rest arguments) - (setq custom-declare-variable-list - (cons arguments custom-declare-variable-list))) - - (defun macro-declaration-function (macro decl) "Process a declaration found in a macro definition. This is set as the value of the variable `macro-declaration-function'. @@ -66,7 +57,20 @@ (message "Unknown declaration %s" d))))) (setq macro-declaration-function 'macro-declaration-function) - + +;; XEmacs; this is here because we use it in backquote.el, so it needs to be +;; available the first time a `(...) form is expanded. +(defun list* (first &rest rest) ; See compiler macro in cl-macs.el + "Return a new list with specified args as elements, cons'd to last arg. +Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to +`(cons A (cons B (cons C D)))'." + (cond ((not rest) first) + ((not (cdr rest)) (cons first (car rest))) + (t (let* ((n (length rest)) + (copy (copy-sequence rest)) + (last (nthcdr (- n 2) copy))) + (setcdr last (car (cdr last))) + (cons first copy))))) ;;;; Lisp language features. @@ -1573,19 +1577,6 @@ (define-function 'eval-in-buffer 'with-current-buffer) (make-obsolete 'eval-in-buffer 'with-current-buffer) -;;; The real defn is in abbrev.el but some early callers -;;; (eg lisp-mode-abbrev-table) want this before abbrev.el is loaded... - -(if (not (fboundp 'define-abbrev-table)) - (progn - (setq abbrev-table-name-list '()) - (fset 'define-abbrev-table - (function (lambda (name defs) - ;; These are fixed-up when abbrev.el loads. - (setq abbrev-table-name-list - (cons (cons name defs) - abbrev-table-name-list))))))) - ;;; `functionp' has been moved into C. ;;(defun functionp (object)
--- a/lisp/test-harness.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/test-harness.el Mon Oct 18 23:21:23 2010 +0900 @@ -502,7 +502,7 @@ `(quote ,(car body)) `(quote (progn ,@body))))) `(Skip-Test-Unless (fboundp 'defadvice) "can't defadvice" - expected-message-regexp + ,expected-message-regexp (let ((messages "")) (defadvice message (around collect activate) (defvar messages)
--- a/lisp/update-elc.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/update-elc.el Mon Oct 18 23:21:23 2010 +0900 @@ -367,21 +367,19 @@ ;; load-ignore-elc-files because byte-optimize gets autoloaded ;; from bytecomp. (let ((recompile-bc-bootstrap - (apply #'nconc - (mapcar - #'(lambda (arg) - (when (member arg update-elc-files-to-compile) - (append '("-f" "batch-byte-compile-one-file") - (list arg)))) - bc-bootstrap))) + (mapcan + #'(lambda (arg) + (when (member arg update-elc-files-to-compile) + (append '("-f" "batch-byte-compile-one-file") + (list arg)))) + bc-bootstrap)) (recompile-bootstrap-other - (apply #'nconc - (mapcar - #'(lambda (arg) - (when (member arg update-elc-files-to-compile) - (append '("-f" "batch-byte-compile-one-file") - (list arg)))) - bootstrap-other)))) + (mapcan + #'(lambda (arg) + (when (member arg update-elc-files-to-compile) + (append '("-f" "batch-byte-compile-one-file") + (list arg)))) + bootstrap-other))) (mapc #'(lambda (arg) (setq update-elc-files-to-compile
--- a/lisp/x-compose.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/x-compose.el Mon Oct 18 23:21:23 2010 +0900 @@ -156,7 +156,7 @@ compose-cedilla-map compose-diaeresis-map compose-circumflex-map compose-tilde-map compose-ring-map compose-caron-map compose-macron-map compose-breve-map compose-dot-map compose-doubleacute-map - compose-ogonek-map compose-hook-map compose-horn-map)) + compose-ogonek-map compose-hook-map compose-horn-map compose-stroke-map)) (define-key compose-map 'acute compose-acute-map) (define-key compose-map 'grave compose-grave-map) @@ -171,6 +171,7 @@ (define-key compose-map 'ogonek compose-ogonek-map) (define-key compose-map 'breve compose-breve-map) (define-key compose-map 'abovedot compose-dot-map) +(define-key compose-map 'stroke compose-stroke-map) ;;(define-key function-key-map [multi-key] compose-map) @@ -195,6 +196,7 @@ (define-key compose-map [~] compose-tilde-map) (define-key compose-map [degree] compose-ring-map) (define-key compose-map [?*] compose-ring-map) +(define-key compose-map [stroke] compose-stroke-map) (loop for (keysym character-code map) @@ -564,7 +566,42 @@ (compose-horn-map [?O] #x01A0) ;; CAPITAL O WITH HORN (compose-horn-map [?U] #x01AF) ;; CAPITAL U WITH HORN (compose-horn-map [?o] #x01A1) ;; SMALL O WITH HORN - (compose-horn-map [?u] #x01B0))) ;; SMALL U WITH HORN + (compose-horn-map [?u] #x01B0) ;; SMALL U WITH HORN + (compose-stroke-map [?A] #x023a) ;; CAPITAL A WITH STROKE + (compose-stroke-map [?a] #x2c65) ;; SMALL A WITH STROKE + (compose-stroke-map [?B] #x0243) ;; CAPITAL B WITH STROKE + (compose-stroke-map [?b] #x0180) ;; SMALL B WITH STROKE + (compose-stroke-map [?C] #x023b) ;; CAPITAL C WITH STROKE + (compose-stroke-map [?c] #x023c) ;; SMALL C WITH STROKE + (compose-stroke-map [?D] #x0110) ;; CAPITAL D WITH STROKE + (compose-stroke-map [?d] #x0111) ;; SMALL D WITH STROKE + (compose-stroke-map [?E] #x0246) ;; CAPITAL E WITH STROKE + (compose-stroke-map [?e] #x0247) ;; SMALL E WITH STROKE + (compose-stroke-map [?G] #x01e4) ;; CAPITAL G WITH STROKE + (compose-stroke-map [?g] #x01e5) ;; SMALL G WITH STROKE + (compose-stroke-map [?H] #x0126) ;; CAPITAL H WITH STROKE + (compose-stroke-map [?h] #x0127) ;; SMALL H WITH STROKE + (compose-stroke-map [?I] #x0197) ;; CAPITAL I WITH STROKE + (compose-stroke-map [?i] #x0268) ;; SMALL I WITH STROKE + (compose-stroke-map [?J] #x0248) ;; CAPITAL J WITH STROKE + (compose-stroke-map [?j] #x0249) ;; SMALL J WITH STROKE + (compose-stroke-map [?K] #xa740) ;; CAPITAL K WITH STROKE + (compose-stroke-map [?k] #xa741) ;; SMALL K WITH STROKE + (compose-stroke-map [?L] #x0141) ;; CAPITAL L WITH STROKE + (compose-stroke-map [?l] #x0142) ;; SMALL L WITH STROKE + (compose-stroke-map [?O] #x00d8) ;; CAPITAL O WITH STROKE + (compose-stroke-map [?o] #x00f8) ;; SMALL O WITH STROKE + (compose-stroke-map [?P] #x2c63) ;; CAPITAL P WITH STROKE + (compose-stroke-map [?p] #x1d7d) ;; SMALL P WITH STROKE + (compose-stroke-map [?R] #x024c) ;; CAPITAL R WITH STROKE + (compose-stroke-map [?r] #x024d) ;; SMALL R WITH STROKE + (compose-stroke-map [?T] #x0166) ;; CAPITAL T WITH STROKE + (compose-stroke-map [?t] #x0167) ;; SMALL T WITH STROKE + (compose-stroke-map [?Y] #x024e) ;; CAPITAL Y WITH STROKE + (compose-stroke-map [?y] #x024f) ;; SMALL Y WITH STROKE + (compose-stroke-map [?Z] #x01b5) ;; CAPITAL Z WITH STROKE + (compose-stroke-map [?z] #x01b6) ;; SMALL Z WITH STROKE +)) ;;; The rest of the compose-map. These are the composed characters
--- a/lisp/x-faces.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/x-faces.el Mon Oct 18 23:21:23 2010 +0900 @@ -434,17 +434,17 @@ (concat (substring font 0 (match-beginning 1)) "*" (substring font (match-end 1) (match-end 0)))))) (sort - (delq nil - (mapcar (function - (lambda (name) - (and (string-match x-font-regexp name) - (list - (string-to-int (substring name (match-beginning 5) - (match-end 5))) - (string-to-int (substring name (match-beginning 6) - (match-end 6))) - name)))) - (font-list font device))) + (mapcan (function + (lambda (name) + (and (string-match x-font-regexp name) + (list + (list + (string-to-int (substring name (match-beginning 5) + (match-end 5))) + (string-to-int (substring name (match-beginning 6) + (match-end 6))) + name))))) + (font-list font device)) (function (lambda (x y) (if (= (nth 1 x) (nth 1 y)) (< (nth 0 x) (nth 0 y)) (< (nth 1 x) (nth 1 y)))))))
--- a/lisp/x-init.el Mon Oct 18 23:03:27 2010 +0900 +++ b/lisp/x-init.el Mon Oct 18 23:21:23 2010 +0900 @@ -92,7 +92,7 @@ compose-ring-map compose-caron-map compose-macron-map compose-breve-map compose-dot-map compose-doubleacute-map compose-ogonek-map - compose-hook-map compose-horn-map) + compose-hook-map compose-horn-map compose-stroke-map) do (autoload map "x-compose" nil t 'keymap)) (loop @@ -208,7 +208,8 @@ (dead-doubleacute compose-doubleacute-map) (dead-ogonek compose-ogonek-map) (dead-hook compose-hook-map) - (dead-horn compose-horn-map)) + (dead-horn compose-horn-map) + (dead-stroke compose-stroke-map)) ;; Get the correct value for function-key-map with function-key-map = (symbol-value-in-console 'function-key-map
--- a/man/ChangeLog Mon Oct 18 23:03:27 2010 +0900 +++ b/man/ChangeLog Mon Oct 18 23:21:23 2010 +0900 @@ -1,3 +1,36 @@ +2010-09-02 Aidan Kehoe <kehoea@parhasard.net> + + * lispref/os.texi (Time Conversion): + Document the new #'format-time-string flags for Roman month + numbers. + +2010-08-30 Aidan Kehoe <kehoea@parhasard.net> + + * lispref/eval.texi (Evaluation, Multiple values): + Document our implementation of multiple values; point the reader + to the CLTL or the Hyperspec for details of exactly when values + are discarded. + + * lispref/numbers.texi (Numeric Conversions): Document the + optional DIVISOR arguments to the rounding functions, and + document that they all return multiple values. + (Rounding Operations): Ditto. + + * cl.texi (Multiple Values): + Document that we've moved the multiple values implementation to + core code, and cross-reference to the Lispref. + (Numerical Functions): The various rounding functions are now + identical to the built-in rounding functions, with the exception + that they return lists, not multiple values; document this. + +2010-08-21 Aidan Kehoe <kehoea@parhasard.net> + + * lispref/objects.texi (Character Type): + Go into more detail here on the specific type of error provoked on + overlong hex character escapes and non-Latin-1 octal character + escapes; give details of why the latter may be encountered, and + what to do with such code. + 2010-06-13 Stephen J. Turnbull <stephen@xemacs.org> * external-widget.texi: Correct FSF address in permission notice.
--- a/man/cl.texi Mon Oct 18 23:03:27 2010 +0900 +++ b/man/cl.texi Mon Oct 18 23:21:23 2010 +0900 @@ -2987,44 +2987,8 @@ @node Multiple Values, , Loop Facility, Control Structure @section Multiple Values -@noindent -Common Lisp functions can return zero or more results. Emacs Lisp -functions, by contrast, always return exactly one result. This -package makes no attempt to emulate Common Lisp multiple return -values; Emacs versions of Common Lisp functions that return more -than one value either return just the first value (as in -@code{compiler-macroexpand}) or return a list of values (as in -@code{get-setf-method}). This package @emph{does} define placeholders -for the Common Lisp functions that work with multiple values, but -in Emacs Lisp these functions simply operate on lists instead. -The @code{values} form, for example, is a synonym for @code{list} -in Emacs. - -@defspec multiple-value-bind (var@dots{}) values-form forms@dots{} -This form evaluates @var{values-form}, which must return a list of -values. It then binds the @var{var}s to these respective values, -as if by @code{let}, and then executes the body @var{forms}. -If there are more @var{var}s than values, the extra @var{var}s -are bound to @code{nil}. If there are fewer @var{var}s than -values, the excess values are ignored. -@end defspec - -@defspec multiple-value-setq (var@dots{}) form -This form evaluates @var{form}, which must return a list of values. -It then sets the @var{var}s to these respective values, as if by -@code{setq}. Extra @var{var}s or values are treated the same as -in @code{multiple-value-bind}. -@end defspec - -The older Quiroz package attempted a more faithful (but still -imperfect) emulation of Common Lisp multiple values. The old -method ``usually'' simulated true multiple values quite well, -but under certain circumstances would leave spurious return -values in memory where a later, unrelated @code{multiple-value-bind} -form would see them. - -Since a perfect emulation is not feasible in Emacs Lisp, this -package opts to keep it as simple and predictable as possible. +This functionality has been moved to core XEmacs, and is documented in +the XEmacs Lisp reference, @pxref{(lispref.info)Multiple values}. @node Macros, Declarations, Control Structure, Top @chapter Macros @@ -3506,58 +3470,6 @@ square root of the argument. @end defun -@defun floor* number &optional divisor -This function implements the Common Lisp @code{floor} function. -It is called @code{floor*} to avoid name conflicts with the -simpler @code{floor} function built-in to Emacs 19. - -With one argument, @code{floor*} returns a list of two numbers: -The argument rounded down (toward minus infinity) to an integer, -and the ``remainder'' which would have to be added back to the -first return value to yield the argument again. If the argument -is an integer @var{x}, the result is always the list @code{(@var{x} 0)}. -If the argument is an Emacs 19 floating-point number, the first -result is a Lisp integer and the second is a Lisp float between -0 (inclusive) and 1 (exclusive). - -With two arguments, @code{floor*} divides @var{number} by -@var{divisor}, and returns the floor of the quotient and the -corresponding remainder as a list of two numbers. If -@code{(floor* @var{x} @var{y})} returns @code{(@var{q} @var{r})}, -then @code{@var{q}*@var{y} + @var{r} = @var{x}}, with @var{r} -between 0 (inclusive) and @var{r} (exclusive). Also, note -that @code{(floor* @var{x})} is exactly equivalent to -@code{(floor* @var{x} 1)}. - -This function is entirely compatible with Common Lisp's @code{floor} -function, except that it returns the two results in a list since -Emacs Lisp does not support multiple-valued functions. -@end defun - -@defun ceiling* number &optional divisor -This function implements the Common Lisp @code{ceiling} function, -which is analogous to @code{floor} except that it rounds the -argument or quotient of the arguments up toward plus infinity. -The remainder will be between 0 and minus @var{r}. -@end defun - -@defun truncate* number &optional divisor -This function implements the Common Lisp @code{truncate} function, -which is analogous to @code{floor} except that it rounds the -argument or quotient of the arguments toward zero. Thus it is -equivalent to @code{floor*} if the argument or quotient is -positive, or to @code{ceiling*} otherwise. The remainder has -the same sign as @var{number}. -@end defun - -@defun round* number &optional divisor -This function implements the Common Lisp @code{round} function, -which is analogous to @code{floor} except that it rounds the -argument or quotient of the arguments to the nearest integer. -In the case of a tie (the argument or quotient is exactly -halfway between two integers), it rounds to the even integer. -@end defun - @defun mod* number divisor This function returns the same value as the second return value of @code{floor}. @@ -3568,7 +3480,24 @@ of @code{truncate}. @end defun -These definitions are compatible with those in the Quiroz +@noindent +The following functions are identical to their built-in counterparts, +without the trailing @code{*} in their names, but they return lists +instead of multiple values. @pxref{(lispref.info)Rounding Operations} + +@defun floor* number &optional divisor +@end defun + +@defun ceiling* number &optional divisor +@end defun + +@defun truncate* number &optional divisor +@end defun + +@defun round* number &optional divisor +@end defun + +All the above definitions are compatible with those in the Quiroz @file{cl.el} package, except that this package appends @samp{*} to certain function names to avoid conflicts with existing Emacs 19 functions, and that the mechanism for returning
--- a/man/lispref/eval.texi Mon Oct 18 23:03:27 2010 +0900 +++ b/man/lispref/eval.texi Mon Oct 18 23:21:23 2010 +0900 @@ -24,6 +24,7 @@ * Eval:: How to invoke the Lisp interpreter explicitly. * Forms:: How various sorts of objects are evaluated. * Quoting:: Avoiding evaluation (to put constants in the program). +* Multiple values:: Functions may return more than one result. @end menu @node Intro Eval @@ -708,3 +709,102 @@ Functions}), which causes an anonymous lambda expression written in Lisp to be compiled, and @samp{`} (@pxref{Backquote}), which is used to quote only part of a list, while computing and substituting other parts. + +@node Multiple values +@section Multiple values +@cindex multiple values + +@noindent +Under XEmacs, expressions can return zero or more results, using the +@code{values} and @code{values-list} functions. Results other than the +first are typically discarded, but special operators are provided to +access them. + +@defun values arguments@dots{} +This function returns @var{arguments} as multiple values. Callers will +always receive the first element of @var{arguments}, but must use +various special operators, described below, to access other elements of +@var{arguments}. + +The idiom @code{(values (function-call argument))}, with one +argument, is the normal mechanism to avoid passing multiple values to +the calling form where that is not desired. + +XEmacs implements the Common Lisp specification when it comes to the +exact details of when to discard and when to preserve multiple values; +see Common Lisp the Language or the Common Lisp hyperspec for more +details. The most important thing to keep in mind is when multiple +values are passed as an argument to a function, all but the first are +discarded. +@end defun + +@defun values-list argument +This function returns the elements of the lst @var{argument} as multiple +values. +@end defun + +@defspec multiple-value-bind (var@dots{}) values-form forms@dots{} +This special operator evaluates @var{values-form}, which may return +multiple values. It then binds the @var{var}s to these respective values, +as if by @code{let}, and then executes the body @var{forms}. +If there are more @var{var}s than values, the extra @var{var}s +are bound to @code{nil}. If there are fewer @var{var}s than +values, the excess values are ignored. +@end defspec + +@defspec multiple-value-setq (var@dots{}) form +This special operator evaluates @var{form}, which may return multiple +values. It then sets the @var{var}s to these respective values, as if by +@code{setq}. Extra @var{var}s or values are treated the same as +in @code{multiple-value-bind}. +@end defspec + +@defspec multiple-value-call function forms@dots{} +This special operator evaluates function, discarding any multiple +values. It then evaluates @var{forms}, preserving any multiple values, +and calls @var{function} as a function with the results. Conceptually, this +function is a version of @code{apply'}that by-passes the multiple values +infrastructure, treating multiple values as intercalated lists. +@end defspec + +@defspec multiple-value-list form +This special operator evaluates @var{form} and returns a list of the +multiple values given by it. +@end defspec + +@defspec multiple-value-prog1 first body@dots{} +This special operator evaluates the form @var{first}, then the +forms @var{body}. It returns the value given by @var{first}, preserving +any multiple values. This is identical to @code{prog1}, except that +@code{prog1} always discards multiple values. +@end defspec + +@defspec nth-value n form +This special operator evaluates @var{form} and returns the @var{n}th +value it gave. @var{n} must be an integer of value zero or more. +If @var{form} gave insufficient multiple values, @code{nth-value} +returns @code{nil}. +@end defspec + +@defvar multiple-values-limit +This constant describes the exclusive upper bound on the number of +multiple values that @code{values} accepts and that +@code{multiple-value-bind}, etc. will consume. +@end defvar + +To take full advantage of multiple values, Emacs Lisp code must have +been compiled by XEmacs 21.5 or later, which is not yet true of the +XEmacs packages. Matched @code{values} and @code{multiple-value-bind} +calls will work in code included in the XEmacs packages when run on +21.5, though the following incantation may be necessary at the start of +your file, until appropriate code is included in XEmacs 21.4: + +@example +(eval-when-compile (when (eq 'list (symbol-function 'values)) + (define-compiler-macro values (&rest args) + (cons 'list args)) + (define-compiler-macro values-list (list) list))) +@end example + +Such code cannot, unfortunately, rely on XEmacs to discard multiple +values where that is appropriate.
--- a/man/lispref/numbers.texi Mon Oct 18 23:03:27 2010 +0900 +++ b/man/lispref/numbers.texi Mon Oct 18 23:21:23 2010 +0900 @@ -871,9 +871,15 @@ There are four functions to convert floating point numbers to integers; they differ in how they round. These functions accept integer arguments -also, and return such arguments unchanged. +also, and return such arguments unchanged. They return multiple values, +@pxref{(cl.info)Multiple values}. -@defun truncate number +All these functions take optional @var{divisor} arguments, and if this +argument is specified, the @var{number} argument is divided by +@var{divisor} before the calculation is made. An @code{arith-error} +results if @var{divisor} is 0. + +@defun truncate number &optional divisor This returns @var{number}, converted to an integer by rounding towards zero. @end defun @@ -881,23 +887,21 @@ @defun floor number &optional divisor This returns @var{number}, converted to an integer by rounding downward (towards negative infinity). - -If @var{divisor} is specified, @var{number} is divided by @var{divisor} -before the floor is taken; this is the division operation that -corresponds to @code{mod}. An @code{arith-error} results if -@var{divisor} is 0. @end defun -@defun ceiling number +@defun ceiling number &optional divisor This returns @var{number}, converted to an integer by rounding upward (towards positive infinity). @end defun -@defun round number +@defun round number &optional divisor This returns @var{number}, converted to an integer by rounding towards the -nearest integer. Rounding a value equidistant between two integers -may choose the integer closer to zero, or it may prefer an even integer, -depending on your machine. +nearest integer. + +Rounding a value equidistant between two integers chooses the even +integer. GNU Emacs and older XEmacs did not guarantee this, and the +direction of rounding depended on the underlying machine and the C +implementation. @end defun @node Arithmetic Operations @@ -1154,24 +1158,35 @@ @code{ftruncate}, the nearest integer in the direction towards zero; @code{fround}, the nearest integer. -@defun ffloor number +All these functions take optional @var{divisor} arguments, and if this +argument is specified, the @var{number} argument is divided by +@var{divisor} before the calculation is made. An @code{arith-error} +results if @var{divisor} is 0. Also, they return multiple values, +@pxref{(cl.info)Multiple values}; the second value is the remainder. + +@defun ffloor number &optional divisor This function rounds @var{number} to the next lower integral value, and returns that value as a floating point number. @end defun -@defun fceiling number +@defun fceiling number &optional divisor This function rounds @var{number} to the next higher integral value, and returns that value as a floating point number. @end defun -@defun ftruncate number +@defun ftruncate number &optional divisor This function rounds @var{number} towards zero to an integral value, and returns that value as a floating point number. @end defun -@defun fround number +@defun fround number &optional divisor This function rounds @var{number} to the nearest integral value, and returns that value as a floating point number. + +Rounding a value equidistant between two integral values chooses the +even value. While this is specified by Common Lisp, GNU Emacs and older +XEmacs did not make this guarantee, and the direction of rounding +depended on the underlying machine and the C implementation. @end defun @node Bitwise Operations
--- a/man/lispref/objects.texi Mon Oct 18 23:03:27 2010 +0900 +++ b/man/lispref/objects.texi Mon Oct 18 23:21:23 2010 +0900 @@ -623,6 +623,8 @@ @cindex backslash in character constant @cindex octal character code @cindex hexadecimal character code +@cindex Overlong hex character escape +@cindex Non-ISO-8859-1 octal character escape Finally, there are two read syntaxes involving character codes. It is not possible to represent multibyte or wide characters in this @@ -643,14 +645,21 @@ @samp{?\001} for the character @kbd{C-a}, and @code{?\002} for the character @kbd{C-b}. The reader will finalize the character and start reading the next token when a non-octal-digit is encountered or three -octal digits are read. +octal digits are read. When a given character code is above +@code{#o377}, the Lisp reader signals an @code{invalid-read-syntax} +error. Such errors are typically provoked by code written for older +versions of GNU Emacs, where the absence of the #o octal syntax for +integers made the character syntax convenient for non-character +values. Those older versions of GNU Emacs are long obsolete, so +changing the code to use the #o integer escape is the best +solution. @pxref{Numbers}. The second consists of a question mark followed by a backslash, the character @samp{x}, and the character code in hexadecimal (up to two hexadecimal digits); thus, @samp{?\x41} for the character @kbd{A}, @samp{?\x1} for the character @kbd{C-a}, and @code{?\x2} for the character @kbd{C-b}. If more than two hexadecimal codes are given, the -reader signals an error. +reader signals an @code{invalid-read-syntax} error. @example @group
--- a/man/lispref/os.texi Mon Oct 18 23:03:27 2010 +0900 +++ b/man/lispref/os.texi Mon Oct 18 23:21:23 2010 +0900 @@ -1026,6 +1026,10 @@ This stands for the year with century. @item %Z This stands for the time zone abbreviation. +@item %\xe6 (the ISO-8859-1 lowercase ae character) +This stands for the month as a lowercase Roman number (i-xii) +@item %\xc6 (the ISO-8859-1 uppercase AE character) +This stands for the month as an uppercase Roman number (I-XII) @end table @end defun
--- a/src/ChangeLog Mon Oct 18 23:03:27 2010 +0900 +++ b/src/ChangeLog Mon Oct 18 23:21:23 2010 +0900 @@ -3,11 +3,292 @@ * ui-byhand.c: * gtk-glue.c: Add copyright notice based on internal evidence. - + 2010-06-14 Stephen J. Turnbull <stephen@xemacs.org> * number.h: Another permission consistency fix. +2010-10-14 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (Fnbutlast, Fbutlast): + Tighten up Common Lisp compatibility for these two functions; they + need to operate on dotted lists without erroring. + +2010-10-12 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (list_merge): + Circularity checking here needs to be done independently for each + list, they can't share a loop counter. Thank you for the bug + report, Robert Pluim! + +2010-09-20 Aidan Kehoe <kehoea@parhasard.net> + + * lisp.h (GET_DEFUN_LISP_OBJECT): Make the NEW_GC version of this + work, remove a needless and unhelpful semicolon. + (GET_DEFUN_LISP_OBJECT): Remove a needless semicolon from the + non-NEW_GC version of this. + (PARSE_KEYWORDS): Fix the indentation for the DEBUG_XEMACS + version of this macro. + (PARSE_KEYWORDS): Use GET_DEFUN_LISP_OBJECT() for both the NEW_GC + and non-NEW_GC versions of this macro, when working out the + function's min args. + +2010-09-18 Aidan Kehoe <kehoea@parhasard.net> + + * lisp.h (PARSE_KEYWORDS): + Turns out #elsif is not valid preprocessor syntax, who knew! + +2010-09-18 Aidan Kehoe <kehoea@parhasard.net> + + * lisp.h (PARSE_KEYWORDS): + Correct the NEW_GC non-DEBUG_XEMACS version of this macro; under + such builds S##function is a pointer, not a Lisp_Subr structure. + +2010-09-18 Aidan Kehoe <kehoea@parhasard.net> + + Simplify the API of PARSE_KEYWORDS for callers. + + * lisp.h (PARSE_KEYWORDS): Simply the API, while making the + implementation a little more complex; work out KEYWORDS_OFFSET + from the appropriate Lisp_Subr struct, take the function name as + the C name of the DEFUN rather than a symbol visible as a + Lisp_Object, on debug builds assert that we're actually in the + function so we choke on badly-done copy-and-pasting, + + * lisp.h (PARSE_KEYWORDS_8): New. This is the old PARSE_KEYWORDS. + + * fns.c (Fmerge, FsortX, Ffill, Freduce, Freplace): + Change to use the new PARSE_KEYWORDS syntax. + * elhash.c (Fmake_hash_table): Chance to the new PARSE_KEYWORDS + syntax, rename a define to correspond to what other files use. + + * symbols.c (intern_massaging_name): + * buffer.c (ADD_INT): + Rename intern_converting_underscores_to_dashes() to + intern_massaging_name(), now it does a little more. + +2010-09-18 Aidan Kehoe <kehoea@parhasard.net> + + * termcap.c: + Add a couple of missing includes here, which should fix builds + that use this file. (I have no access to such builds, but Mats' + buildbot shows output that indicates they fail at link time since + DEVICE_BAUD_RATE and IS_DIRECTORY_SEP are available.) + +2010-09-18 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (Freduce): + Move statements outside of the braces surrounding the + EXTERNAL_LIST_LOOP_3 macro, fixing strict C89 builds. Thank you + for the report, Vin! + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (Flist_length): New, moved here from cl-extra.el, needed + by the next function. + (shortest_length_among_sequences): New. + (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) + (Fmap_into, Fsome, Fevery): + Use shortest_length_among_sequences() when working out how many + iterations to do, only giving circular list errors if all + arguments are circular. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (Fsubseq): + Change the string code to better fit in with the rest of this + function (it still uses get_string_range_char(), though, which *may* + diverge algorithmically from what we're doing). + + If dealing with a cons, only call #'length if we have reason to + believe that the START and END arguments are badly specified, and + check for circular lists ourselves when that's appropriate. + + If dealing with a vector, call Fvector() on the appropriate subset + of the old vector's data directly, don't initialise the result + with nil and then copy. + + (Ffill): + Only check the range arguments for a cons SEQUENCE if we have good + reason to think they were badly specified. + + (Freduce): + Handle multiple values properly. Add bounds checking to this + function, as specificied by ANSI Common Lisp. + +2010-09-16 Aidan Kehoe <kehoea@parhasard.net> + + * eval.c (Ffunction, Fquote): + Add argument information in the arguments: () format for these two + special operators. + +2010-09-07 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (Freplace): + Replace an accidental double semi-colon with a single semi-colon, + hopefully fixing Vin's Visual Studio 6 build. (Visual Studio 2005 + had no problem with it, oddly.) + +2010-09-06 Aidan Kehoe <kehoea@parhasard.net> + + Move #'replace to C; add bounds checking to it and to #'fill. + + * fns.c (Fsubseq, Ffill, mapcarX): + Don't #'nreverse in #'subseq, use fill_string_range and check + bounds in #'fill, use replace_string_range() in #'map-into + avoiding quadratic time when modfiying the string. + + * fns.c (check_sequence_range, fill_string_range) + (replace_string_range, replace_string_range_1, Freplace): + New functions; check that arguments fit sequence dimensions, fill + a string range with a given character, replace a string range from + an Ibyte pointer. + +2010-09-05 Aidan Kehoe <kehoea@parhasard.net> + + * chartab.c (char_table_default_for_type, + chartab_default_validate): New. + (print_char_table, Freset_char_table, chartab_default_validate) + (chartab_instantiate, structure_type_create_chartab): + Accept keyword :default in the read syntax for char tables, and + print the default when it is not what was expected for the + time. Makes it a little easier to debug things. + +2010-09-05 Aidan Kehoe <kehoea@parhasard.net> + + * editfns.c (Fformat_time_string): + Use two backslashes so that there is at least one present in the + output of describe function, when describing the Roman month + number syntax in this function's docstring. Thanks for provoking + me to look at this, Stephen Turnbull. + +2010-09-03 Aidan Kehoe <kehoea@parhasard.net> + + * symsinit.h: Declare reinit_process_early() here, fixing the C++ + build; thank you for pointing this out, Adam Sjøgren! + * fontcolor-msw.c (mswindows_string_to_color): + Cast the result of bsearch() to a colormap_t pointer, fixing the + Visual Studio 2005 build. + +2010-09-02 Aidan Kehoe <kehoea@parhasard.net> + + * strftime.c (roman_upper, roman_lower, strftime): + Implement Roman month numbers, as used in central and eastern + Europe. + * editfns.c (Fformat_time_string): + Document two new escapes, to allow uppercase and lowercase Roman + month numbers. Remove documentation of a bug that we didn't + actually have. + * text.h (Qtime_function_encoding): We know the text encoding + coming from strftime(), because we always use the one in + strftime.c. Don't use Qnative. + +2010-09-01 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (list_merge, list_array_merge_into_list) + (list_array_merge_into_array): + Avoid algorithmic complexity surprises when checking for + circularity in these functions. + (Freduce): Fix some formatting, in passing. + + (mapcarX): Drop the SOME_OR_EVERY argument to this function; + instead, take CALLER, a symbol reflecting the Lisp-visible + function that called mapcarX(). Use CALLER with + mapping_interaction_error() when sequences are modified + illegally. Don't cons with #'some, #'every, not even a little. + (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) + (Fmap_into, Fsome, Fevery): Call mapcarX() with its new + arguments. + (Fmapcan): Don't unnecessarily complicate the nconc call. + + (maplist): Take CALLER, a symbol reflecting the Lisp-visible + function that called maplist(), rather than having separate + arguments to indicate mapl vs. mapcon. + Avoid algorithmic complexity surprises when checking for + circularity. In #'mapcon, check a given stretch of + result for well-formedness once, which was not previously the + case, despite what the comments said. + (Fmaplist, Fmapl, Fmapcon): + Call maplist() with its new arguments. + +2010-09-02 Aidan Kehoe <kehoea@parhasard.net> + + * process.c (process_getprop, process_putprop, process_remprop) + (process_plist, process_setplist, reinit_process_early): + Add functions to modify a process's property list. + * process-slots.h (MARKED_SLOT): Add a plist slot. + + * fns.c (Fobject_setplist): New function, analogous to #'setplist, + but more general. + Update the documentation in the other plist functions to reflect + that processes now have property lists. + * emacs.c (main_1): Call reinit_process_early(), now processes have + plist methods that need to be initialised. + * symbols.c (reinit_symbol_objects_early): Fsetplist is the named + setplist method for symbols. + +2010-08-30 Aidan Kehoe <kehoea@parhasard.net> + + * floatfns.c (ceiling_one_mundane_arg, floor_one_mundane_arg) + (round_one_mundane_arg, truncate_one_mundane_arg): + INTEGERP is always available, no need to wrap calls to it with + #ifdef HAVE_BIGNUM. + (Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor) + (Ffround, Fftruncate): + Correct some code formatting here. + * doprnt.c (emacs_doprnt_1): + Remove some needless #ifdef WITH_NUMBER_TYPES, now number.h is + always #included. + +2010-08-26 Adam Sjøgren <asjo@koldfront.dk> + + * glyphs-eimage.c (gif_instantiate): Try harder to find an + appropriate GIF colormap and then flag an error if one can't be + found. + +2010-08-21 Aidan Kehoe <kehoea@parhasard.net> + + * lread.c (read_escape): + Make error messages better reflect the text that was encountered, + when overlong hex character escapes or non-Latin-1 octal character + escapes are encountered. + +2010-08-15 Aidan Kehoe <kehoea@parhasard.net> + + * print.c (print_symbol): + Escape any symbols that look like ratios, in the same way we do + symbols that look like floats or integers. Prevents confusion in + the Lisp reader. + * lread.c (isratio_string): Make this available even on builds + without HAVE_RATIO, so we can print symbols that look like ratios + with the appropriate escapes. + * lisp.h: + Make isratio_string available even if HAVE_RATIO is not defined. + +2010-07-24 Aidan Kehoe <kehoea@parhasard.net> + + * lisp.h (PARSE_KEYWORDS): + Always accept a nil :allow-other-keys keyword argument, as + described in the ALLOW-OTHER-KEYS-NIL Common Lisp issue writeup, + and as necessary for Paul Dietz' tests for #'reduce. + + * fns.c (mapping_interaction_error): New. + (Freduce): Call mapping_interaction_error when KEY or FUNCTION + have modified a string SEQUENCE such that the byte length of the + string has changed, or such that the current cursor pointer + doesn't point to the beginning of a character. + Cf. the MAPPING-DESTRUCTIVE-INTERACTION Common Lisp issue + writeup. + When traversing a list, GCPRO the part of it we still have to + traverse, to avoid any crashes if FUNCTION or KEY amputate it + behind us and force a garbage collection. + +2010-06-05 Marcus Crestani <crestani@informatik.uni-tuebingen.de> + + * gc.c: + * mc-alloc.c: + Document the new allocator and the new garbage collector. + 2010-06-13 Stephen J. Turnbull <stephen@xemacs.org> * elhash.c:
--- a/src/buffer.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/buffer.c Mon Oct 18 23:21:23 2010 +0900 @@ -1819,10 +1819,10 @@ #define ADD_INT(field) \ plist = cons3 (make_int (b->text->field), \ - intern_converting_underscores_to_dashes (#field), plist) + intern_massaging_name (#field), plist) #define ADD_BOOL(field) \ plist = cons3 (b->text->field ? Qt : Qnil, \ - intern_converting_underscores_to_dashes (#field), plist) + intern_massaging_name (#field), plist) ADD_INT (bufz); ADD_INT (z); #ifdef OLD_BYTE_CHAR
--- a/src/chartab.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/chartab.c Mon Oct 18 23:21:23 2010 +0900 @@ -42,7 +42,7 @@ #include "chartab.h" #include "syntax.h" -Lisp_Object Qchar_tablep, Qchar_table; +Lisp_Object Qchar_tablep, Qchar_table, Q_default; Lisp_Object Vall_syntax_tables; @@ -301,6 +301,30 @@ return Qnil; /* not reached */ } +static Lisp_Object +char_table_default_for_type (enum char_table_type type) +{ + switch (type) + { + case CHAR_TABLE_TYPE_CHAR: + return make_char (0); + break; + case CHAR_TABLE_TYPE_DISPLAY: + case CHAR_TABLE_TYPE_GENERIC: +#ifdef MULE + case CHAR_TABLE_TYPE_CATEGORY: +#endif /* MULE */ + return Qnil; + break; + + case CHAR_TABLE_TYPE_SYNTAX: + return make_integer (Sinherit); + break; + } + ABORT(); + return Qzero; +} + struct ptemap { Lisp_Object printcharfun; @@ -336,8 +360,15 @@ arg.printcharfun = printcharfun; arg.first = 1; - write_fmt_string_lisp (printcharfun, "#s(char-table :type %s :data (", - 1, char_table_type_to_symbol (ct->type)); + write_fmt_string_lisp (printcharfun, + "#s(char-table :type %s", 1, + char_table_type_to_symbol (ct->type)); + if (!(EQ (ct->default_, char_table_default_for_type (ct->type)))) + { + write_fmt_string_lisp (printcharfun, " :default %S", 1, ct->default_); + } + + write_ascstring (printcharfun, " :data ("); map_char_table (obj, &range, print_table_entry, &arg); write_ascstring (printcharfun, "))"); @@ -492,37 +523,13 @@ (char_table)) { Lisp_Char_Table *ct; - Lisp_Object def; CHECK_CHAR_TABLE (char_table); ct = XCHAR_TABLE (char_table); - switch (ct->type) - { - case CHAR_TABLE_TYPE_CHAR: - def = make_char (0); - break; - case CHAR_TABLE_TYPE_DISPLAY: - case CHAR_TABLE_TYPE_GENERIC: -#ifdef MULE - case CHAR_TABLE_TYPE_CATEGORY: -#endif /* MULE */ - def = Qnil; - break; - - case CHAR_TABLE_TYPE_SYNTAX: - def = make_int (Sinherit); - break; - - default: - ABORT (); - def = Qnil; - break; - } - /* Avoid doubly updating the syntax table by setting the default ourselves, since set_char_table_default() also updates. */ - ct->default_ = def; + ct->default_ = char_table_default_for_type (ct->type); fill_char_table (ct, Qunbound); return Qnil; @@ -1543,12 +1550,22 @@ return 1; } +static int +chartab_default_validate (Lisp_Object UNUSED (keyword), + Lisp_Object UNUSED (value), + Error_Behavior UNUSED (errb)) +{ + /* We can't yet validate this, since we don't know what the type of the + char table is. We do the validation below in chartab_instantiate(). */ + return 1; +} + static Lisp_Object chartab_instantiate (Lisp_Object plist) { Lisp_Object chartab; Lisp_Object type = Qgeneric; - Lisp_Object dataval = Qnil; + Lisp_Object dataval = Qnil, default_ = Qunbound; if (KEYWORDP (Fcar (plist))) { @@ -1562,6 +1579,10 @@ { type = value; } + else if (EQ (key, Q_default)) + { + default_ = value; + } else if (!KEYWORDP (key)) { signal_error @@ -1598,6 +1619,13 @@ #endif /* NEED_TO_HANDLE_21_4_CODE */ chartab = Fmake_char_table (type); + if (!UNBOUNDP (default_)) + { + 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_); + } while (!NILP (dataval)) { @@ -1872,6 +1900,7 @@ DEFSYMBOL (Qchar_table); DEFSYMBOL_MULTIWORD_PREDICATE (Qchar_tablep); + DEFKEYWORD (Q_default); DEFSUBR (Fchar_table_p); DEFSUBR (Fchar_table_type_list); @@ -1926,6 +1955,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); } void
--- a/src/doprnt.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/doprnt.c Mon Oct 18 23:21:23 2010 +0900 @@ -591,11 +591,7 @@ Lisp_Object obj = largs[spec->argnum - 1]; if (CHARP (obj)) obj = make_int (XCHAR (obj)); -#ifdef WITH_NUMBER_TYPES if (!NUMBERP (obj)) -#else - if (!INT_OR_FLOATP (obj)) -#endif { /* WARNING! This MUST be big enough for the sprintf below */ CIbyte msg[48]; @@ -606,9 +602,10 @@ } else if (strchr (double_converters, ch)) { -#ifdef WITH_NUMBER_TYPES - if (INTP (obj) || FLOATP (obj)) - arg.d = XFLOATINT (obj); + if (INTP (obj)) + arg.d = XINT (obj); + else if (FLOATP (obj)) + arg.d = XFLOAT_DATA (obj); #ifdef HAVE_BIGNUM else if (BIGNUMP (obj)) arg.d = bignum_to_double (XBIGNUM_DATA (obj)); @@ -631,9 +628,6 @@ } } #endif -#else /* !WITH_NUMBER_TYPES */ - arg.d = XFLOATINT (obj); -#endif /* WITH_NUMBER_TYPES */ } else {
--- a/src/editfns.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/editfns.c Mon Oct 18 23:21:23 2010 +0900 @@ -1044,11 +1044,10 @@ %Y is replaced by the year with century. %z is replaced by the time zone as a numeric offset (e.g +0530, -0800 etc.) %Z is replaced by the time zone abbreviation. +%\\xe6 is replaced by the month as a lowercase Roman number (i-xii) +%\\xc6 is replaced by the month as an uppercase Roman number (I-XII) The number of options reflects the `strftime' function. - -BUG: If the charset used by the current locale is not ISO 8859-1, the -characters appearing in the day and month names may be incorrect. */ (format_string, time_)) {
--- a/src/elhash.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/elhash.c Mon Oct 18 23:21:23 2010 +0900 @@ -962,7 +962,7 @@ else if (EQ (key, Qrehash_threshold)) rehash_threshold = value; else if (EQ (key, Qweakness)) weakness = value; else if (EQ (key, Qdata)) data = value; -#ifndef NO_NEED_TO_HANDLE_21_4_CODE +#ifdef NEED_TO_HANDLE_21_4_CODE else if (EQ (key, Qtype))/*obsolete*/ weakness = value; #endif else if (KEYWORDP (key)) @@ -1109,14 +1109,14 @@ */ (int nargs, Lisp_Object *args)) { -#ifdef NO_NEED_TO_HANDLE_21_4_CODE - PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 5, +#ifndef NEED_TO_HANDLE_21_4_CODE + PARSE_KEYWORDS (Fmake_hash_table, nargs, args, 5, (test, size, rehash_size, rehash_threshold, weakness), - NULL, 0); + NULL); #else - PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 6, + PARSE_KEYWORDS (Fmake_hash_table, nargs, args, 6, (test, size, rehash_size, rehash_threshold, weakness, - type), (type = Qunbound, weakness = Qunbound), 0); + type), (type = Qunbound, weakness = Qunbound)); if (EQ (weakness, Qunbound)) {
--- a/src/emacs.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/emacs.c Mon Oct 18 23:21:23 2010 +0900 @@ -1468,6 +1468,7 @@ reinit_alloc_early (); reinit_gc_early (); reinit_symbols_early (); + reinit_process_early (); #ifndef NEW_GC reinit_opaque_early (); #endif /* not NEW_GC */
--- a/src/eval.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/eval.c Mon Oct 18 23:21:23 2010 +0900 @@ -1270,6 +1270,8 @@ object preceded by `''. Thus, `'x' is equivalent to `(quote x)', in all contexts. A print function may use either. Internally the expression is represented as `(quote x)'). + +arguments: (OBJECT) */ (args)) { @@ -1350,6 +1352,8 @@ object preceded by `#''. Thus, #'x is equivalent to (function x), in all contexts. A print function may use either. Internally the expression is represented as `(function x)'). + +arguments: (SYMBOL-OR-LAMBDA) */ (args)) {
--- a/src/floatfns.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/floatfns.c Mon Oct 18 23:21:23 2010 +0900 @@ -1300,11 +1300,7 @@ } else { -#ifdef HAVE_BIGNUM if (INTEGERP (number)) -#else - if (INTP (number)) -#endif { return values2 (number, Qzero); } @@ -1566,11 +1562,7 @@ floor_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, int return_float) { -#ifdef HAVE_BIGNUM if (INTEGERP (number)) -#else - if (INTP (number)) -#endif { if (return_float) { @@ -1971,11 +1963,7 @@ round_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, int return_float) { -#ifdef HAVE_BIGNUM if (INTEGERP (number)) -#else - if (INTP (number)) -#endif { if (return_float) { @@ -2258,11 +2246,7 @@ truncate_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, int return_float) { -#ifdef HAVE_BIGNUM if (INTEGERP (number)) -#else - if (INTP (number)) -#endif { if (return_float) { @@ -2301,7 +2285,7 @@ */ (number, divisor)) { - ROUNDING_CONVERT(ceiling, 0); + ROUNDING_CONVERT (ceiling, 0); } DEFUN ("floor", Ffloor, 1, 2, 0, /* @@ -2316,7 +2300,7 @@ */ (number, divisor)) { - ROUNDING_CONVERT(floor, 0); + ROUNDING_CONVERT (floor, 0); } DEFUN ("round", Fround, 1, 2, 0, /* @@ -2333,7 +2317,7 @@ */ (number, divisor)) { - ROUNDING_CONVERT(round, 0); + ROUNDING_CONVERT (round, 0); } DEFUN ("truncate", Ftruncate, 1, 2, 0, /* @@ -2347,7 +2331,7 @@ */ (number, divisor)) { - ROUNDING_CONVERT(truncate, 0); + ROUNDING_CONVERT (truncate, 0); } /* Float-rounding functions. */ @@ -2364,7 +2348,7 @@ */ (number, divisor)) { - ROUNDING_CONVERT(ceiling, 1); + ROUNDING_CONVERT (ceiling, 1); } DEFUN ("ffloor", Fffloor, 1, 2, 0, /* @@ -2379,7 +2363,7 @@ */ (number, divisor)) { - ROUNDING_CONVERT(floor, 1); + ROUNDING_CONVERT (floor, 1); } DEFUN ("fround", Ffround, 1, 2, 0, /* @@ -2395,7 +2379,7 @@ */ (number, divisor)) { - ROUNDING_CONVERT(round, 1); + ROUNDING_CONVERT (round, 1); } DEFUN ("ftruncate", Fftruncate, 1, 2, 0, /* @@ -2410,7 +2394,7 @@ */ (number, divisor)) { - ROUNDING_CONVERT(truncate, 1); + ROUNDING_CONVERT (truncate, 1); } #ifdef FLOAT_CATCH_SIGILL
--- a/src/fns.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/fns.c Mon Oct 18 23:21:23 2010 +0900 @@ -54,9 +54,12 @@ /* NOTE: This symbol is also used in lread.c */ #define FEATUREP_SYNTAX -Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill; +Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill, Qreplace; Lisp_Object Qidentity; -Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Qreduce, Q_from_end, Q_initial_value; +Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Q_from_end, Q_initial_value; +Lisp_Object Qmapconcat, QmapcarX, Qmapvector, Qmapcan, Qmapc, Qmap, Qmap_into; +Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce; +Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2; Lisp_Object Qbase64_conversion_error; @@ -65,6 +68,26 @@ static int internal_old_equal (Lisp_Object, Lisp_Object, int); Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth); +static DOESNT_RETURN +mapping_interaction_error (Lisp_Object func, Lisp_Object object) +{ + invalid_state_2 ("object modified while traversing it", func, object); +} + +static void +check_sequence_range (Lisp_Object sequence, Lisp_Object start, + Lisp_Object end, Lisp_Object length) +{ + Elemcount starting = XINT (start), ending, len = XINT (length); + + ending = NILP (end) ? XINT (length) : XINT (end); + + if (!(0 <= starting && starting <= ending && ending <= len)) + { + args_out_of_range_3 (sequence, start, make_int (ending)); + } +} + static Lisp_Object mark_bit_vector (Lisp_Object UNUSED (obj)) { @@ -316,6 +339,29 @@ return make_int (len); } +/* This is almost the above, but is defined by Common Lisp. We need it in C + for shortest_length_among_sequences(), below, for the various sequence + functions that can usefully operate on circular lists. */ + +DEFUN ("list-length", Flist_length, 1, 1, 0, /* +Return the length of LIST. Return nil if LIST is circular. +*/ + (list)) +{ + Lisp_Object hare, tortoise; + Elemcount len; + + for (hare = tortoise = list, len = 0; + CONSP (hare) && (! EQ (hare, tortoise) || len == 0); + hare = XCDR (hare), len++) + { + if (len & 1) + tortoise = XCDR (tortoise); + } + + return EQ (hare, tortoise) && len != 0 ? Qnil : make_int (len); +} + /*** string functions. ***/ DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /* @@ -877,7 +923,7 @@ { CHECK_CHAR_COERCE_INT (elt); string_result_ptr += set_itext_ichar (string_result_ptr, - XCHAR (elt)); + XCHAR (elt)); } } if (args_mse) @@ -988,7 +1034,9 @@ DEFUN ("subseq", Fsubseq, 2, 3, 0, /* Return the subsequence of SEQUENCE starting at START and ending before END. END may be omitted; then the subsequence runs to the end of SEQUENCE. -If START or END is negative, it counts from the end. + +If START or END is negative, it counts from the end, in contravention of +Common Lisp. The returned subsequence is always of the same type as SEQUENCE. If SEQUENCE is a string, relevant parts of the string-extent-data are copied to the new string. @@ -998,89 +1046,139 @@ */ (sequence, start, end)) { - EMACS_INT len, s, e; - - if (STRINGP (sequence)) - { - Charcount ccstart, ccend; - Bytecount bstart, blen; - Lisp_Object val; - - CHECK_INT (start); - get_string_range_char (sequence, start, end, &ccstart, &ccend, - GB_HISTORICAL_STRING_BEHAVIOR); - bstart = string_index_char_to_byte (sequence, ccstart); - blen = string_offset_char_to_byte_len (sequence, bstart, ccend - ccstart); - val = make_string (XSTRING_DATA (sequence) + bstart, blen); - /* Copy any applicable extent information into the new string. */ - copy_string_extents (val, sequence, 0, bstart, blen); - return val; - } + Elemcount len, ss, ee = EMACS_INT_MAX, ii; + Lisp_Object result = Qnil; CHECK_SEQUENCE (sequence); - - len = XINT (Flength (sequence)); - CHECK_INT (start); - s = XINT (start); - if (s < 0) - s = len + s; - - if (NILP (end)) - e = len; - else + ss = XINT (start); + + if (!NILP (end)) { CHECK_INT (end); - e = XINT (end); - if (e < 0) - e = len + e; - } - - if (!(0 <= s && s <= e && e <= len)) - args_out_of_range_3 (sequence, make_int (s), make_int (e)); - - if (VECTORP (sequence)) - { - Lisp_Object result = make_vector (e - s, Qnil); - EMACS_INT i; - Lisp_Object *in_elts = XVECTOR_DATA (sequence); - Lisp_Object *out_elts = XVECTOR_DATA (result); - - for (i = s; i < e; i++) - out_elts[i - s] = in_elts[i]; - return result; - } - else if (LISTP (sequence)) - { - Lisp_Object result = Qnil; - EMACS_INT i; - - sequence = Fnthcdr (make_int (s), sequence); - - for (i = s; i < e; i++) - { - result = Fcons (Fcar (sequence), result); + ee = XINT (end); + } + + if (STRINGP (sequence)) + { + Bytecount bstart, blen; + + get_string_range_char (sequence, start, end, &ss, &ee, + GB_HISTORICAL_STRING_BEHAVIOR); + bstart = string_index_char_to_byte (sequence, ss); + blen = string_offset_char_to_byte_len (sequence, bstart, ee - ss); + + result = make_string (XSTRING_DATA (sequence) + bstart, blen); + /* Copy any applicable extent information into the new string. */ + copy_string_extents (result, sequence, 0, bstart, blen); + } + else if (CONSP (sequence)) + { + Lisp_Object result_tail, saved = sequence; + + if (ss < 0 || ee < 0) + { + len = XINT (Flength (sequence)); + if (ss < 0) + { + ss = len + ss; + start = make_integer (ss); + } + + if (ee < 0) + { + ee = len + ee; + end = make_integer (ee); + } + else + { + ee = min (ee, len); + } + } + + if (0 != ss) + { + sequence = Fnthcdr (make_int (ss), sequence); + } + + if (ss < ee && !NILP (sequence)) + { + result = result_tail = Fcons (Fcar (sequence), Qnil); sequence = Fcdr (sequence); - } - - return Fnreverse (result); - } - else if (BIT_VECTORP (sequence)) - { - Lisp_Object result = make_bit_vector (e - s, Qzero); - EMACS_INT i; - - for (i = s; i < e; i++) - set_bit_vector_bit (XBIT_VECTOR (result), i - s, - bit_vector_bit (XBIT_VECTOR (sequence), i)); - return result; + ii = ss + 1; + + { + EXTERNAL_LIST_LOOP_2 (elt, sequence) + { + if (!(ii < ee)) + { + break; + } + + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + ii++; + } + } + } + + if (NILP (result) || (ii < ee && !NILP (end))) + { + /* We were handed a cons, which definitely has elements. nil + result means either ss >= ee or SEQUENCE was nil after the + nthcdr; in both cases that means START and END were incorrectly + specified for this sequence. ii < ee with a non-nil end means + the user handed us a bogus end value. */ + check_sequence_range (saved, start, end, Flength (saved)); + } } else { - ABORT (); /* unreachable, since CHECK_SEQUENCE (sequence) did not - error */ - return Qnil; - } + len = XINT (Flength (sequence)); + if (ss < 0) + { + ss = len + ss; + start = make_integer (ss); + } + + if (ee < 0) + { + ee = len + ee; + end = make_integer (ee); + } + else + { + ee = min (len, ee); + } + + check_sequence_range (sequence, start, end, make_int (len)); + + if (VECTORP (sequence)) + { + result = Fvector (ee - ss, XVECTOR_DATA (sequence) + ss); + } + else if (BIT_VECTORP (sequence)) + { + result = make_bit_vector (ee - ss, Qzero); + + for (ii = ss; ii < ee; ii++) + { + set_bit_vector_bit (XBIT_VECTOR (result), ii - ss, + bit_vector_bit (XBIT_VECTOR (sequence), ii)); + } + } + else if (NILP (sequence)) + { + DO_NOTHING; + } + else + { + /* Won't happen, since CHECK_SEQUENCE didn't error. */ + ABORT (); + } + } + + return result; } DEFUN ("substring-no-properties", Fsubstring_no_properties, 1, 3, 0, /* @@ -1472,72 +1570,99 @@ DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /* Modify LIST to remove the last N (default 1) elements. + If LIST has N or fewer elements, nil is returned and LIST is unmodified. +Otherwise, LIST may be dotted, but not circular. */ (list, n)) { - EMACS_INT int_n; + Elemcount int_n = 1; CHECK_LIST (list); - if (NILP (n)) - int_n = 1; - else + if (!NILP (n)) { CHECK_NATNUM (n); int_n = XINT (n); } - { - Lisp_Object last_cons = list; - - EXTERNAL_LIST_LOOP_1 (list) - { - if (int_n-- < 0) - last_cons = XCDR (last_cons); - } - - if (int_n >= 0) - return Qnil; - - XCDR (last_cons) = Qnil; - return list; - } + if (CONSP (list)) + { + Lisp_Object last_cons = list; + + EXTERNAL_LIST_LOOP_3 (elt, list, tail) + { + if (int_n-- < 0) + { + last_cons = XCDR (last_cons); + } + + if (!CONSP (XCDR (tail))) + { + break; + } + } + + if (int_n >= 0) + { + return Qnil; + } + + XCDR (last_cons) = Qnil; + } + + return list; } DEFUN ("butlast", Fbutlast, 1, 2, 0, /* Return a copy of LIST with the last N (default 1) elements removed. + If LIST has N or fewer elements, nil is returned. +Otherwise, LIST may be dotted, but not circular, and `(butlast LIST 0)' +converts a dotted into a true list. */ (list, n)) { - EMACS_INT int_n; + Lisp_Object retval = Qnil, retval_tail = Qnil; + Elemcount int_n = 1; CHECK_LIST (list); - if (NILP (n)) - int_n = 1; - else + if (!NILP (n)) { CHECK_NATNUM (n); int_n = XINT (n); } - { - Lisp_Object retval = Qnil; - Lisp_Object tail = list; - - EXTERNAL_LIST_LOOP_1 (list) - { - if (--int_n < 0) - { - retval = Fcons (XCAR (tail), retval); - tail = XCDR (tail); - } - } - - return Fnreverse (retval); - } + if (CONSP (list)) + { + Lisp_Object tail = list; + + EXTERNAL_LIST_LOOP_3 (elt, list, list_tail) + { + if (--int_n < 0) + { + if (NILP (retval_tail)) + { + retval = retval_tail = Fcons (XCAR (tail), Qnil); + } + else + { + XSETCDR (retval_tail, Fcons (XCAR (tail), Qnil)); + retval_tail = XCDR (retval_tail); + } + + tail = XCDR (tail); + } + + if (!CONSP (XCDR (list_tail))) + { + break; + } + } + } + + return retval; } DEFUN ("member", Fmember, 2, 2, 0, /* @@ -2057,13 +2182,16 @@ Lisp_Object tail; Lisp_Object tem; Lisp_Object l1, l2; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; - int looped = 0; + Lisp_Object tortoises[2]; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; + int l1_count = 0, l2_count = 0; l1 = org_l1; l2 = org_l2; tail = Qnil; value = Qnil; + tortoises[0] = org_l1; + tortoises[1] = org_l2; if (NULL == c_predicate) { @@ -2075,7 +2203,8 @@ When l1 and l2 are updated, we copy the new values back into the org_ vars. */ - GCPRO4 (org_l1, org_l2, predicate, value); + GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]); + gcpro5.nvars = 2; while (1) { @@ -2101,32 +2230,56 @@ tem = l1; l1 = Fcdr (l1); org_l1 = l1; + + if (l1_count++ > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (l1_count & 1) + { + if (!CONSP (tortoises[0])) + { + mapping_interaction_error (Qmerge, tortoises[0]); + } + + tortoises[0] = XCDR (tortoises[0]); + } + + if (EQ (org_l1, tortoises[0])) + { + signal_circular_list_error (org_l1); + } + } } else { tem = l2; l2 = Fcdr (l2); org_l2 = l2; + + if (l2_count++ > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (l2_count & 1) + { + if (!CONSP (tortoises[1])) + { + mapping_interaction_error (Qmerge, tortoises[1]); + } + + tortoises[1] = XCDR (tortoises[1]); + } + + if (EQ (org_l2, tortoises[1])) + { + signal_circular_list_error (org_l2); + } + } } + if (NILP (tail)) value = tem; else Fsetcdr (tail, tem); + tail = tem; - - if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue; - - /* Just check the lists aren't circular:*/ - { - EXTERNAL_LIST_LOOP_1 (l1) - { - } - } - { - EXTERNAL_LIST_LOOP_1 (l2) - { - } - } } } @@ -2224,12 +2377,12 @@ Lisp_Object predicate, Lisp_Object key_func, Boolint reverse_order) { - Lisp_Object tail = Qnil, value = Qnil; - struct gcpro gcpro1, gcpro2, gcpro3; + Lisp_Object tail = Qnil, value = Qnil, tortoise = list; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; Elemcount array_index = 0; int looped = 0; - GCPRO3 (list, tail, value); + GCPRO4 (list, tail, value, tortoise); while (1) { @@ -2291,13 +2444,18 @@ ++array_index; } - if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue; - - { - EXTERNAL_LIST_LOOP_1 (list) - { - } - } + if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (looped & 1) + { + tortoise = XCDR (tortoise); + } + + if (EQ (list, tortoise)) + { + signal_circular_list_error (list); + } + } } } @@ -2371,7 +2529,7 @@ { if (array_len - array_index != output_len - output_index) { - invalid_state ("List length modified during merge", Qunbound); + mapping_interaction_error (Qmerge, list); } while (array_index < array_len) @@ -2463,7 +2621,7 @@ Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); - PARSE_KEYWORDS (Qmerge, nargs, args, 4, 1, (key), NULL, 0); + PARSE_KEYWORDS (Fmerge, nargs, args, 1, (key), NULL); CHECK_SEQUENCE (sequence_one); CHECK_SEQUENCE (sequence_two); @@ -2715,7 +2873,7 @@ Lisp_Object); Elemcount sequence_len, i; - PARSE_KEYWORDS (QsortX, nargs, args, 2, 1, (key), NULL, 0); + PARSE_KEYWORDS (FsortX, nargs, args, 1, (key), NULL); CHECK_SEQUENCE (sequence); @@ -3523,7 +3681,8 @@ This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'. If there is no such property, return optional third arg DEFAULT \(which defaults to `nil'). OBJECT can be a symbol, string, extent, -face, or glyph. See also `put', `remprop', and `object-plist'. +face, glyph, or process. See also `put', `remprop', `object-plist', and +`object-setplist'. */ (object, property, default_)) { @@ -3567,9 +3726,10 @@ DEFUN ("remprop", Fremprop, 2, 2, 0, /* Remove, from OBJECT's property list, PROPERTY and its corresponding value. -OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil -if the property list was actually modified (i.e. if PROPERTY was present -in the property list). See also `get', `put', and `object-plist'. +OBJECT can be a symbol, string, extent, face, glyph, or process. +Return non-nil if the property list was actually modified (i.e. if PROPERTY +was present in the property list). See also `get', `put', `object-plist', +and `object-setplist'. */ (object, property)) { @@ -3606,6 +3766,26 @@ return Qnil; } +DEFUN ("object-setplist", Fobject_setplist, 2, 2, 0, /* +Set OBJECT's property list to NEWPLIST, and return NEWPLIST. +For a symbol, this is equivalent to `setplist'. + +OBJECT can be a symbol or a process, other objects with visible plists do +not allow their modification with `object-setplist'. +*/ + (object, newplist)) +{ + if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->setplist) + { + return XRECORD_LHEADER_IMPLEMENTATION (object)->setplist (object, + newplist); + } + + invalid_operation ("Not possible to set object's plist", object); + return Qnil; +} + + static Lisp_Object tweaked_internal_equal (Lisp_Object obj1, Lisp_Object obj2, @@ -3828,6 +4008,29 @@ } +static Lisp_Object replace_string_range_1 (Lisp_Object dest, + Lisp_Object start, + Lisp_Object end, + const Ibyte *source, + const Ibyte *source_limit, + Lisp_Object item); + +/* Fill the substring of DEST beginning at START and ending before END with + the character ITEM. If DEST does not have sufficient space for END - + START characters at START, write as many as is possible without changing + the character length of DEST. Update the string modification flag and do + any sledgehammer checks we have turned on. + + START must be a Lisp integer. END can be nil, indicating the length of the + string, or a Lisp integer. The condition (<= 0 START END (length DEST)) + must hold, or fill_string_range() will signal an error. */ +static Lisp_Object +fill_string_range (Lisp_Object dest, Lisp_Object item, Lisp_Object start, + Lisp_Object end) +{ + return replace_string_range_1 (dest, start, end, NULL, NULL, item); +} + DEFUN ("fill", Ffill, 2, MANY, 0, /* Destructively modify SEQUENCE by replacing each element with ITEM. SEQUENCE is a list, vector, bit vector, or string. @@ -3837,21 +4040,20 @@ exclusive upper bound on the elements of SEQUENCE to be modified, and defaults to the length of SEQUENCE. -arguments: (SEQUENCE ITEM &key (START 0) END) +arguments: (SEQUENCE ITEM &key (START 0) (END (length SEQUENCE))) */ (int nargs, Lisp_Object *args)) { Lisp_Object sequence = args[0]; Lisp_Object item = args[1]; - Elemcount starting = 0, ending = EMACS_INT_MAX, ii; - - PARSE_KEYWORDS (Qfill, nargs, args, 2, 2, (start, end), - (start = Qzero, end = Qunbound), 0); + Elemcount starting = 0, ending = EMACS_INT_MAX, ii, len; + + PARSE_KEYWORDS (Ffill, nargs, args, 2, (start, end), (start = Qzero)); CHECK_NATNUM (start); starting = XINT (start); - if (!UNBOUNDP (end)) + if (!NILP (end)) { CHECK_NATNUM (end); ending = XINT (end); @@ -3860,49 +4062,21 @@ retry: if (STRINGP (sequence)) { - Bytecount prefix_bytecount, item_bytecount, delta; - Ibyte item_buf[MAX_ICHAR_LEN]; - Ibyte *p, *pend; - CHECK_CHAR_COERCE_INT (item); - CHECK_LISP_WRITEABLE (sequence); - sledgehammer_check_ascii_begin (sequence); - item_bytecount = set_itext_ichar (item_buf, XCHAR (item)); - - p = XSTRING_DATA (sequence); - p = (Ibyte *) itext_n_addr (p, starting); - prefix_bytecount = p - XSTRING_DATA (sequence); - - ending = min (ending, string_char_length (sequence)); - pend = (Ibyte *) itext_n_addr (p, ending - starting); - delta = ((ending - starting) * item_bytecount) - (pend - p); - - /* Resize the string if the bytecount for the area being modified is - different. */ - if (delta) - { - resize_string (sequence, prefix_bytecount, delta); - /* No need to zero-terminate the string, resize_string has done - that for us. */ - p = XSTRING_DATA (sequence) + prefix_bytecount; - pend = p + ((ending - starting) * item_bytecount); - } - - for (; p < pend; p += item_bytecount) - memcpy (p, item_buf, item_bytecount); - - - init_string_ascii_begin (sequence); - bump_string_modiff (sequence); - sledgehammer_check_ascii_begin (sequence); + + fill_string_range (sequence, item, start, end); } else if (VECTORP (sequence)) { Lisp_Object *p = XVECTOR_DATA (sequence); + CHECK_LISP_WRITEABLE (sequence); - - ending = min (ending, XVECTOR_LENGTH (sequence)); + len = XVECTOR_LENGTH (sequence); + + check_sequence_range (sequence, start, end, make_int (len)); + ending = min (ending, len); + for (ii = starting; ii < ending; ++ii) { p[ii] = item; @@ -3912,11 +4086,15 @@ { Lisp_Bit_Vector *v = XBIT_VECTOR (sequence); int bit; + CHECK_BIT (item); bit = XINT (item); CHECK_LISP_WRITEABLE (sequence); - - ending = min (ending, bit_vector_length (v)); + len = bit_vector_length (v); + + check_sequence_range (sequence, start, end, make_int (len)); + ending = min (ending, len); + for (ii = starting; ii < ending; ++ii) { set_bit_vector_bit (v, ii, bit); @@ -3941,6 +4119,11 @@ } ++counting; } + + if (counting < starting || (counting != ending && !NILP (end))) + { + check_sequence_range (args[0], start, end, Flength (args[0])); + } } else { @@ -4085,6 +4268,24 @@ } +/* Replace the substring of DEST beginning at START and ending before END + with the text at SOURCE, which is END - START characters long and + SOURCE_LIMIT - SOURCE octets long. If DEST does not have sufficient + space for END - START characters at START, write as many as is possible + without changing the length of DEST. Update the string modification flag + and do any sledgehammer checks we have turned on in this build. + + START must be a Lisp integer. END can be nil, indicating the length of the + string, or a Lisp integer. The condition (<= 0 START END (length DEST)) + must hold, or replace_string_range() will signal an error. */ +static Lisp_Object +replace_string_range (Lisp_Object dest, Lisp_Object start, Lisp_Object end, + const Ibyte *source, const Ibyte *source_limit) +{ + return replace_string_range_1 (dest, start, end, source, source_limit, + Qnil); +} + /* This is the guts of several mapping functions. Call FUNCTION CALL_COUNT times, with NSEQUENCES arguments each time, @@ -4099,35 +4300,35 @@ so FUNCTION cannot insert a non-cons into SEQUENCES[0] and throw off mapcarX. - Otherwise, mapcarX signals a wrong-type-error if it encounters a - non-cons, non-array when traversing SEQUENCES. Common Lisp specifies in + Otherwise, mapcarX signals an invalid state error (see + mapping_interaction_error(), above) if it encounters a non-cons, + non-array when traversing SEQUENCES. Common Lisp specifies in MAPPING-DESTRUCTIVE-INTERACTION that it is an error when FUNCTION destructively modifies SEQUENCES in a way that might affect the ongoing traversal operation. - If SOME_OR_EVERY is SOME_OR_EVERY_SOME, return the (possibly multiple) - values given by FUNCTION the first time it is non-nil, and abandon the - iterations. LISP_VALS must be a cons, and the return value will be - stored in its car. If SOME_OR_EVERY is SOME_OR_EVERY_EVERY, store Qnil - in the car of LISP_VALS if FUNCTION gives nil; otherwise leave it - alone. */ - -#define SOME_OR_EVERY_NEITHER 0 -#define SOME_OR_EVERY_SOME 1 -#define SOME_OR_EVERY_EVERY 2 + CALLER is a symbol describing the Lisp-visible function that was called, + and any errors thrown because SEQUENCES was modified will reflect it. + + If CALLER is Qsome, return the (possibly multiple) values given by + FUNCTION the first time it is non-nil, and abandon the iterations. + LISP_VALS must be the result of calling STORE_VOID_IN_LISP on the address + of a Lisp object, and the return value will be stored at that address. + If CALLER is Qevery, LISP_VALS must also reflect a pointer to a Lisp + object, and Qnil will be stored at that address if FUNCTION gives nil; + otherwise it will be left alone. */ static void mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals, Lisp_Object function, int nsequences, Lisp_Object *sequences, - int some_or_every) + Lisp_Object caller) { Lisp_Object called, *args; struct gcpro gcpro1, gcpro2; + Ibyte *lisp_vals_staging, *cursor; int i, j; - enum lrecord_type lisp_vals_type; - - assert (LRECORDP (lisp_vals)); - lisp_vals_type = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type; + + assert ((EQ (caller, Qsome) || EQ (caller, Qevery)) ? vals == NULL : 1); args = alloca_array (Lisp_Object, nsequences + 1); args[0] = function; @@ -4171,12 +4372,27 @@ } else { + enum lrecord_type lisp_vals_type; Binbyte *sequence_types = alloca_array (Binbyte, nsequences); for (j = 0; j < nsequences; ++j) { sequence_types[j] = XRECORD_LHEADER (sequences[j])->type; } + if (!EQ (caller, Qsome) && !EQ (caller, Qevery)) + { + assert (LRECORDP (lisp_vals)); + + lisp_vals_type + = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type; + + if (lrecord_type_string == lisp_vals_type) + { + lisp_vals_staging = cursor + = alloca_ibytes (call_count * MAX_ICHAR_LEN); + } + } + for (i = 0; i < call_count; ++i) { for (j = 0; j < nsequences; ++j) @@ -4187,13 +4403,12 @@ { if (!CONSP (sequences[j])) { - /* This means FUNCTION has probably messed - around with a cons in one of the sequences, - since we checked the type - (CHECK_SEQUENCE()) and the length and + /* This means FUNCTION has messed around with a cons + in one of the sequences, since we checked the + type (CHECK_SEQUENCE()) and the length and structure (with Flength()) correctly in our callers. */ - dead_wrong_type_argument (Qconsp, sequences[j]); + mapping_interaction_error (caller, sequences[j]); } args[j + 1] = XCAR (sequences[j]); sequences[j] = XCDR (sequences[j]); @@ -4226,96 +4441,128 @@ vals[i] = IGNORE_MULTIPLE_VALUES (called); gcpro2.nvars += 1; } - else - { - switch (lisp_vals_type) - { - case lrecord_type_symbol: - break; - case lrecord_type_cons: - { - if (SOME_OR_EVERY_NEITHER == some_or_every) - { - called = IGNORE_MULTIPLE_VALUES (called); - if (!CONSP (lisp_vals)) - { - /* If FUNCTION has inserted a non-cons non-nil - cdr into the list before we've processed the - relevant part, error. */ - dead_wrong_type_argument (Qconsp, lisp_vals); - } - - XSETCAR (lisp_vals, called); - lisp_vals = XCDR (lisp_vals); - break; - } - - if (SOME_OR_EVERY_SOME == some_or_every) - { - if (!NILP (IGNORE_MULTIPLE_VALUES (called))) - { - XCAR (lisp_vals) = called; - UNGCPRO; - return; - } - break; - } - - if (SOME_OR_EVERY_EVERY == some_or_every) - { - called = IGNORE_MULTIPLE_VALUES (called); - if (NILP (called)) - { - XCAR (lisp_vals) = Qnil; - UNGCPRO; - return; - } - break; - } - - goto bad_some_or_every_flag; - } - case lrecord_type_vector: - { - called = IGNORE_MULTIPLE_VALUES (called); - i < XVECTOR_LENGTH (lisp_vals) ? - (XVECTOR_DATA (lisp_vals)[i] = called) : - /* Let #'aset error. */ - Faset (lisp_vals, make_int (i), called); - break; - } - case lrecord_type_string: - { - /* If this ever becomes a code hotspot, we can keep - around pointers into the data of the string, checking - each time that it hasn't been relocated. */ - called = IGNORE_MULTIPLE_VALUES (called); - Faset (lisp_vals, make_int (i), called); - break; - } - case lrecord_type_bit_vector: - { - called = IGNORE_MULTIPLE_VALUES (called); - (BITP (called) && - i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ? - set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i, - XINT (called)) : - (void) Faset (lisp_vals, make_int (i), called); - break; - } - bad_some_or_every_flag: - default: - { - ABORT(); - break; - } - } - } + else if (EQ (Qsome, caller)) + { + if (!NILP (IGNORE_MULTIPLE_VALUES (called))) + { + Lisp_Object *result + = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals); + *result = called; + UNGCPRO; + return; + } + } + else if (EQ (Qevery, caller)) + { + if (NILP (IGNORE_MULTIPLE_VALUES (called))) + { + Lisp_Object *result + = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals); + *result = Qnil; + UNGCPRO; + return; + } + } + else + { + called = IGNORE_MULTIPLE_VALUES (called); + switch (lisp_vals_type) + { + case lrecord_type_symbol: + /* Discard the result of funcall. */ + break; + case lrecord_type_cons: + { + if (!CONSP (lisp_vals)) + { + /* If FUNCTION has inserted a non-cons non-nil + cdr into the list before we've processed the + relevant part, error. */ + mapping_interaction_error (caller, lisp_vals); + } + XSETCAR (lisp_vals, called); + lisp_vals = XCDR (lisp_vals); + break; + } + case lrecord_type_vector: + { + i < XVECTOR_LENGTH (lisp_vals) ? + (XVECTOR_DATA (lisp_vals)[i] = called) : + /* Let #'aset error. */ + Faset (lisp_vals, make_int (i), called); + break; + } + case lrecord_type_string: + { + CHECK_CHAR_COERCE_INT (called); + cursor += set_itext_ichar (cursor, XCHAR (called)); + break; + } + case lrecord_type_bit_vector: + { + (BITP (called) && + i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ? + set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i, + XINT (called)) : + (void) Faset (lisp_vals, make_int (i), called); + break; + } + default: + { + ABORT(); + break; + } + } + } } - } + + if (!EQ (caller, Qsome) && !EQ (caller, Qevery) && + lrecord_type_string == lisp_vals_type) + { + replace_string_range (lisp_vals, Qzero, make_int (call_count), + lisp_vals_staging, cursor); + } + } + UNGCPRO; } +/* Given NSEQUENCES objects at the address pointed to by SEQUENCES, return + the length of the shortest sequence. Error if all are circular, or if any + one of them is not a sequence. */ +static Elemcount +shortest_length_among_sequences (int nsequences, Lisp_Object *sequences) +{ + Elemcount len = EMACS_INT_MAX; + Lisp_Object length; + int i; + + for (i = 0; i < nsequences; ++i) + { + if (CONSP (sequences[i])) + { + length = Flist_length (sequences[i]); + if (!NILP (length)) + { + len = min (len, XINT (length)); + } + } + else + { + CHECK_SEQUENCE (sequences[i]); + length = Flength (sequences[i]); + len = min (len, XINT (length)); + } + } + + if (NILP (length)) + { + signal_circular_list_error (sequences[0]); + } + + return len; +} + DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /* Call FUNCTION on each element of SEQUENCE, and concat results to a string. Between each pair of results, insert SEPARATOR. @@ -4343,11 +4590,7 @@ args[2] = sequence; args[1] = separator; - for (i = 2; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } + len = shortest_length_among_sequences (nargs - 2, args + 2); if (len == 0) return build_ascstring (""); @@ -4367,8 +4610,7 @@ } else { - mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, - SOME_OR_EVERY_NEITHER); + mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmapconcat); } for (i = len - 1; i >= 0; i--) @@ -4395,19 +4637,11 @@ (int nargs, Lisp_Object *args)) { Lisp_Object function = args[0]; - Elemcount len = EMACS_INT_MAX; + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); Lisp_Object *args0; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } args0 = alloca_array (Lisp_Object, len); - mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, - SOME_OR_EVERY_NEITHER); + mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, QmapcarX); return Flist ((int) len, args0); } @@ -4427,26 +4661,16 @@ (int nargs, Lisp_Object *args)) { Lisp_Object function = args[0]; - Elemcount len = EMACS_INT_MAX; - Lisp_Object result; + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + Lisp_Object result = make_vector (len, Qnil); + struct gcpro gcpro1; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - result = make_vector (len, Qnil); GCPRO1 (result); /* Don't pass result as the lisp_object argument, we want mapcarX to protect a single list argument's elements from being garbage-collected. */ mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1, - SOME_OR_EVERY_NEITHER); - UNGCPRO; - - return result; + Qmapvector); + RETURN_UNGCPRO (result); } DEFUN ("mapcan", Fmapcan, 2, MANY, 0, /* @@ -4464,40 +4688,13 @@ */ (int nargs, Lisp_Object *args)) { - Lisp_Object function = args[0], nconcing; - Elemcount len = EMACS_INT_MAX; - Lisp_Object *args0; - struct gcpro gcpro1; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - args0 = alloca_array (Lisp_Object, len + 1); - mapcarX (len, args0 + 1, Qnil, function, nargs - 1, args + 1, - SOME_OR_EVERY_NEITHER); - - if (len < 2) - { - return len ? args0[1] : Qnil; - } - - /* bytecode_nconc2 can signal and return, we need to GCPRO the args, since - mapcarX is no longer doing this for us. */ - args0[0] = Fcons (Qnil, Qnil); - GCPRO1 (args0[0]); - gcpro1.nvars = len + 1; - - for (i = 0; i < len; ++i) - { - nconcing = bytecode_nconc2 (args0 + i); - args0[i + 1] = nconcing; - } - - RETURN_UNGCPRO (XCDR (nconcing)); + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + Lisp_Object function = args[0], *result = alloca_array (Lisp_Object, len); + + mapcarX (len, result, Qnil, function, nargs - 1, args + 1, Qmapcan); + + /* #'nconc GCPROs its args in case of signals and error. */ + return Fnconc (len, result); } DEFUN ("mapc", Fmapc, 2, MANY, 0, /* @@ -4518,23 +4715,14 @@ */ (int nargs, Lisp_Object *args)) { - Elemcount len = EMACS_INT_MAX; + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); Lisp_Object sequence = args[1]; struct gcpro gcpro1; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - /* We need to GCPRO sequence, because mapcarX will modify the elements of the args array handed to it, and this may involve elements of sequence getting garbage collected. */ GCPRO1 (sequence); - mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, - SOME_OR_EVERY_NEITHER); + mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, Qmapc); RETURN_UNGCPRO (sequence); } @@ -4559,23 +4747,15 @@ Lisp_Object function = args[1]; Lisp_Object result = Qnil; Lisp_Object *args0 = NULL; - Elemcount len = EMACS_INT_MAX; - int i; + Elemcount len = shortest_length_among_sequences (nargs - 2, args + 2); struct gcpro gcpro1; - for (i = 2; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - if (!NILP (type)) { args0 = alloca_array (Lisp_Object, len); } - mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, - SOME_OR_EVERY_NEITHER); + mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmap); if (EQ (type, Qnil)) { @@ -4625,22 +4805,17 @@ */ (int nargs, Lisp_Object *args)) { - Elemcount len = EMACS_INT_MAX; + Elemcount len; Lisp_Object result_sequence = args[0]; Lisp_Object function = args[1]; - int i; args[0] = function; args[1] = result_sequence; - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } + len = shortest_length_among_sequences (nargs - 1, args + 1); mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2, - SOME_OR_EVERY_NEITHER); + Qmap_into); return result_sequence; } @@ -4657,23 +4832,13 @@ */ (int nargs, Lisp_Object *args)) { - Lisp_Object result_box = Fcons (Qnil, Qnil); - struct gcpro gcpro1; - Elemcount len = EMACS_INT_MAX; - int i; - - GCPRO1 (result_box); - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1, - SOME_OR_EVERY_SOME); - - RETURN_UNGCPRO (XCAR (result_box)); + Lisp_Object result = Qnil, + result_ptr = STORE_VOID_IN_LISP ((void *) &result); + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + + mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome); + + return result; } DEFUN ("every", Fevery, 2, MANY, 0, /* @@ -4688,43 +4853,35 @@ */ (int nargs, Lisp_Object *args)) { - Lisp_Object result_box = Fcons (Qt, Qnil); - struct gcpro gcpro1; - Elemcount len = EMACS_INT_MAX; - int i; - - GCPRO1 (result_box); - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1, - SOME_OR_EVERY_EVERY); - - RETURN_UNGCPRO (XCAR (result_box)); + Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result); + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + + mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery); + + return result; } /* Call FUNCTION with NLISTS arguments repeatedly, each Nth argument corresponding to the result of calling (nthcdr ITERATION-COUNT LISTS[N]), until that #'nthcdr expression gives nil for some element of LISTS. - If MAPLP is zero, return LISTS[0]. Otherwise, return a list of the return - values from FUNCTION; if NCONCP is non-zero, nconc them together. + CALLER is a symbol reflecting the Lisp-visible function that was called, + and any errors thrown because SEQUENCES was modified will reflect it. + + If CALLER is Qmapl, return LISTS[0]. Otherwise, return a list of the + return values from FUNCTION; if caller is Qmapcan, nconc them together. In contrast to mapcarX, we don't require our callers to check LISTS for well-formedness, we signal wrong-type-argument if it's not a list, or circular-list if it's circular. */ static Lisp_Object -maplist (Lisp_Object function, int nlists, Lisp_Object *lists, int maplp, - int nconcp) -{ - Lisp_Object result = maplp ? lists[0] : Fcons (Qnil, Qnil), funcalled; - Lisp_Object nconcing[2], accum = result, *args; - struct gcpro gcpro1, gcpro2, gcpro3; +maplist (Lisp_Object function, int nlists, Lisp_Object *lists, + Lisp_Object caller) +{ + Lisp_Object nconcing[2], accum = Qnil, *args, *tortoises, funcalled; + Lisp_Object result = EQ (caller, Qmapl) ? lists[0] : Qnil; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; int i, j, continuing = (nlists > 0), called_count = 0; args = alloca_array (Lisp_Object, nlists + 1); @@ -4734,18 +4891,23 @@ args[i] = Qnil; } - if (nconcp) - { - nconcing[0] = result; + tortoises = alloca_array (Lisp_Object, nlists); + memcpy (tortoises, lists, nlists * sizeof (Lisp_Object)); + + if (EQ (caller, Qmapcon)) + { + nconcing[0] = Qnil; nconcing[1] = Qnil; - GCPRO3 (args[0], nconcing[0], result); + GCPRO4 (args[0], nconcing[0], tortoises[0], result); gcpro1.nvars = 1; gcpro2.nvars = 2; + gcpro3.nvars = nlists; } else { - GCPRO2 (args[0], result); + GCPRO3 (args[0], tortoises[0], result); gcpro1.nvars = 1; + gcpro2.nvars = nlists; } while (continuing) @@ -4764,45 +4926,64 @@ } else { - dead_wrong_type_argument (Qlistp, lists[j]); + lists[j] = wrong_type_argument (Qlistp, lists[j]); } } if (!continuing) break; funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args)); - if (!maplp) + + if (EQ (caller, Qmapl)) { - if (nconcp) - { - /* This order of calls means we check that each list is - well-formed once and once only. The last result does - not have to be a list. */ - nconcing[1] = funcalled; - nconcing[0] = bytecode_nconc2 (nconcing); - } - else - { - /* Add to the end, avoiding the need to call nreverse - once we're done: */ - XSETCDR (accum, Fcons (funcalled, Qnil)); - accum = XCDR (accum); - } + DO_NOTHING; + } + else if (EQ (caller, Qmapcon)) + { + nconcing[1] = funcalled; + accum = bytecode_nconc2 (nconcing); + if (NILP (result)) + { + result = accum; + } + /* Only check a given stretch of result for well-formedness + once: */ + nconcing[0] = funcalled; + } + else if (NILP (accum)) + { + accum = result = Fcons (funcalled, Qnil); + } + else + { + /* Add to the end, avoiding the need to call nreverse + once we're done: */ + XSETCDR (accum, Fcons (funcalled, Qnil)); + accum = XCDR (accum); } - if (++called_count % CIRCULAR_LIST_SUSPICION_LENGTH) continue; - - for (j = 0; j < nlists; ++j) - { - EXTERNAL_LIST_LOOP_1 (lists[j]) - { - /* Just check the lists aren't circular, using the - EXTERNAL_LIST_LOOP_1 macro. */ - } - } - } - - if (!maplp) - { - result = XCDR (result); + if (++called_count > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (called_count & 1) + { + for (j = 0; j < nlists; ++j) + { + tortoises[j] = XCDR (tortoises[j]); + if (EQ (lists[j], tortoises[j])) + { + signal_circular_list_error (lists[j]); + } + } + } + else + { + for (j = 0; j < nlists; ++j) + { + if (EQ (lists[j], tortoises[j])) + { + signal_circular_list_error (lists[j]); + } + } + } + } } RETURN_UNGCPRO (result); @@ -4817,7 +4998,7 @@ */ (int nargs, Lisp_Object *args)) { - return maplist (args[0], nargs - 1, args + 1, 0, 0); + return maplist (args[0], nargs - 1, args + 1, Qmaplist); } DEFUN ("mapl", Fmapl, 2, MANY, 0, /* @@ -4827,7 +5008,7 @@ */ (int nargs, Lisp_Object *args)) { - return maplist (args[0], nargs - 1, args + 1, 1, 0); + return maplist (args[0], nargs - 1, args + 1, Qmapl); } DEFUN ("mapcon", Fmapcon, 2, MANY, 0, /* @@ -4840,7 +5021,7 @@ */ (int nargs, Lisp_Object *args)) { - return maplist (args[0], nargs - 1, args + 1, 0, 1); + return maplist (args[0], nargs - 1, args + 1, Qmapcon); } /* Extra random functions */ @@ -4870,16 +5051,19 @@ Lisp_Object function = args[0], sequence = args[1], accum = Qunbound; Elemcount starting, ending = EMACS_INT_MAX, ii = 0; - PARSE_KEYWORDS (Qreduce, nargs, args, 2, 5, + PARSE_KEYWORDS (Freduce, nargs, args, 5, (start, end, from_end, initial_value, key), - (start = Qzero, initial_value = Qunbound), 0); + (start = Qzero, initial_value = Qunbound)); CHECK_SEQUENCE (sequence); CHECK_NATNUM (start); CHECK_KEY_ARGUMENT (key); -#define KEY(key, item) (EQ (key, Qidentity) ? item : call1 (key, item)) +#define KEY(key, item) (EQ (Qidentity, key) ? item : \ + IGNORE_MULTIPLE_VALUES (call1 (key, item))) +#define CALL2(function, accum, item) \ + IGNORE_MULTIPLE_VALUES (call2 (function, accum, item)) starting = XINT (start); if (!NILP (end)) @@ -4888,16 +5072,24 @@ ending = XINT (end); } + if (!(starting <= ending)) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + if (VECTORP (sequence)) { Lisp_Vector *vv = XVECTOR (sequence); + + check_sequence_range (sequence, start, end, make_int (vv->size)); + ending = min (ending, vv->size); if (!UNBOUNDP (initial_value)) { accum = initial_value; } - else if (ending - starting && starting < ending) + else if (ending - starting) { if (NILP (from_end)) { @@ -4915,14 +5107,14 @@ { for (ii = starting; ii < ending; ++ii) { - accum = call2 (function, accum, KEY (key, vv->contents[ii])); + accum = CALL2 (function, accum, KEY (key, vv->contents[ii])); } } else { for (ii = ending - 1; ii >= starting; --ii) { - accum = call2 (function, KEY (key, vv->contents[ii]), accum); + accum = CALL2 (function, KEY (key, vv->contents[ii]), accum); } } } @@ -4930,13 +5122,15 @@ { Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence); + check_sequence_range (sequence, start, end, make_int (bv->size)); + ending = min (ending, bv->size); if (!UNBOUNDP (initial_value)) { accum = initial_value; } - else if (ending - starting && starting < ending) + else if (ending - starting) { if (NILP (from_end)) { @@ -4954,7 +5148,7 @@ { for (ii = starting; ii < ending; ++ii) { - accum = call2 (function, accum, + accum = CALL2 (function, accum, KEY (key, make_int (bit_vector_bit (bv, ii)))); } } @@ -4962,13 +5156,12 @@ { for (ii = ending - 1; ii >= starting; --ii) { - accum = call2 (function, KEY (key, + accum = CALL2 (function, KEY (key, make_int (bit_vector_bit (bv, ii))), accum); } } - } else if (STRINGP (sequence)) { @@ -4989,38 +5182,56 @@ { accum = initial_value; } - else if (ending - starting && starting < ending) + else if (ending - starting) { accum = KEY (key, make_char (itext_ichar (cursor))); starting++; startp = XSTRING_DATA (sequence); cursor = startp + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qreduce, sequence); + } + INC_IBYTEPTR (cursor); cursor_offset = cursor - startp; } - while (cursor_offset < byte_len && starting < ending) + while (cursor_offset < byte_len && ii < ending) { - if (cursor_offset > XSTRING_LENGTH (sequence)) + accum = CALL2 (function, accum, + KEY (key, make_char (itext_ichar (cursor)))); + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) { - invalid_state ("sequence modified during reduce", sequence); + mapping_interaction_error (Qreduce, sequence); } - startp = XSTRING_DATA (sequence); - cursor = startp + cursor_offset; - accum = call2 (function, accum, - KEY (key, make_char (itext_ichar (cursor)))); INC_IBYTEPTR (cursor); cursor_offset = cursor - startp; - ++starting; + ++ii; } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + ABORT (); + } } else { Elemcount len = string_char_length (sequence); - Bytecount cursor_offset; + Bytecount cursor_offset, byte_len = XSTRING_LENGTH (sequence); const Ibyte *cursor; + check_sequence_range (sequence, start, end, make_int (len)); + ending = min (ending, len); cursor = string_char_addr (sequence, ending - 1); cursor_offset = cursor - XSTRING_DATA (sequence); @@ -5029,12 +5240,19 @@ { accum = initial_value; } - else if (ending - starting && starting < ending) + else if (ending - starting) { accum = KEY (key, make_char (itext_ichar (cursor))); ending--; if (ending > 0) { + cursor = XSTRING_DATA (sequence) + cursor_offset; + + if (!valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qreduce, sequence); + } + DEC_IBYTEPTR (cursor); cursor_offset = cursor - XSTRING_DATA (sequence); } @@ -5042,18 +5260,19 @@ for (ii = ending - 1; ii >= starting; --ii) { - if (cursor_offset > XSTRING_LENGTH (sequence)) - { - invalid_state ("sequence modified during reduce", sequence); - } - - cursor = XSTRING_DATA (sequence) + cursor_offset; - accum = call2 (function, KEY (key, + accum = CALL2 (function, KEY (key, make_char (itext_ichar (cursor))), accum); - if (ii > 1) + if (ii > 0) { cursor = XSTRING_DATA (sequence) + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qreduce, sequence); + } + DEC_IBYTEPTR (cursor); cursor_offset = cursor - XSTRING_DATA (sequence); } @@ -5064,45 +5283,64 @@ { if (NILP (from_end)) { + struct gcpro gcpro1; + Lisp_Object tailed = Qnil; + + GCPRO1 (tailed); + if (!UNBOUNDP (initial_value)) { accum = initial_value; } - else if (ending - starting && starting < ending) + else if (ending - starting) { - Elemcount counting = 0; EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { - if (counting == starting) + /* KEY may amputate the list behind us; make sure what + remains to be processed is still reachable. */ + tailed = tail; + if (ii == starting) { accum = KEY (key, elt); starting++; break; } - ++counting; + ++ii; } } - if (ending - starting && starting < ending) + ii = 0; + + if (ending - starting) { - Elemcount counting = 0; - EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { - if (counting >= starting) + /* KEY or FUNCTION may amputate the list behind us; make + sure what remains to be processed is still + reachable. */ + tailed = tail; + if (ii >= starting) { - if (counting < ending) + if (ii < ending) { - accum = call2 (function, accum, KEY (key, elt)); + accum = CALL2 (function, accum, KEY (key, elt)); } - else if (counting == ending) + else if (ii == ending) { break; } } - ++counting; + ++ii; } } + + UNGCPRO; + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + ABORT (); + } } else { @@ -5111,10 +5349,9 @@ Elemcount counting = 0, len = 0; struct gcpro gcpro1; - if (ending - starting && starting < ending && EMACS_INT_MAX == ending) - { - ending = XINT (Flength (sequence)); - } + len = XINT (Flength (sequence)); + check_sequence_range (sequence, start, end, make_int (len)); + ending = min (ending, len); /* :from-end with a list; make an alloca copy of the relevant list data, attempting to go backwards isn't worth the trouble. */ @@ -5171,7 +5408,7 @@ for (ii = len; ii != 0;) { --ii; - accum = call2 (function, KEY (key, subsequence[ii]), accum); + accum = CALL2 (function, KEY (key, subsequence[ii]), accum); } if (subsequence != NULL) @@ -5186,7 +5423,7 @@ arguments. */ if (UNBOUNDP (accum)) { - accum = call0 (function); + accum = IGNORE_MULTIPLE_VALUES (call0 (function)); } return accum; @@ -5232,6 +5469,588 @@ return old; } +/* This function is the implementation of fill_string_range() and + replace_string_range(); see the comments for those functions. */ +static Lisp_Object +replace_string_range_1 (Lisp_Object dest, Lisp_Object start, Lisp_Object end, + const Ibyte *source, const Ibyte *source_limit, + Lisp_Object item) +{ + Ibyte *destp = XSTRING_DATA (dest), *p = destp, + *pend = p + XSTRING_LENGTH (dest), *pcursor, item_buf[MAX_ICHAR_LEN]; + Bytecount prefix_bytecount, source_len = source_limit - source; + Charcount ii = 0, starting = XINT (start), ending, len; + Elemcount delta; + + while (ii < starting && p < pend) + { + INC_IBYTEPTR (p); + ii++; + } + + pcursor = p; + + if (NILP (end)) + { + while (pcursor < pend) + { + INC_IBYTEPTR (pcursor); + ii++; + } + + ending = len = ii; + } + else + { + ending = XINT (end); + while (ii < ending && pcursor < pend) + { + INC_IBYTEPTR (pcursor); + ii++; + } + } + + if (pcursor == pend) + { + /* We have the length, check it for our callers. */ + check_sequence_range (dest, start, end, make_int (ii)); + } + + if (!(p == pend || p == pcursor)) + { + prefix_bytecount = p - destp; + + if (!NILP (item)) + { + assert (source == NULL && source_limit == NULL); + source_len = set_itext_ichar (item_buf, XCHAR (item)); + delta = (source_len * (ending - starting)) - (pcursor - p); + } + else + { + assert (source != NULL && source_limit != NULL); + delta = source_len - (pcursor - p); + } + + if (delta) + { + resize_string (dest, prefix_bytecount, delta); + destp = XSTRING_DATA (dest); + pcursor = destp + prefix_bytecount + (pcursor - p); + p = destp + prefix_bytecount; + } + + if (CHARP (item)) + { + while (starting < ending) + { + memcpy (p, item_buf, source_len); + p += source_len; + starting++; + } + } + else + { + while (starting < ending && source < source_limit) + { + source_len = itext_copy_ichar (source, p); + p += source_len, source += source_len; + } + } + + init_string_ascii_begin (dest); + bump_string_modiff (dest); + sledgehammer_check_ascii_begin (dest); + } + + return dest; +} + +DEFUN ("replace", Freplace, 2, MANY, 0, /* +Replace the elements of SEQUENCE-ONE with the elements of SEQUENCE-TWO. + +SEQUENCE-ONE is destructively modified, and returned. Its length is not +changed. + +Keywords :start1 and :end1 specify a subsequence of SEQUENCE-ONE, and +:start2 and :end2 a subsequence of SEQUENCE-TWO. See `search' for more +information. + +arguments: (SEQUENCE-ONE SEQUENCE-TWO &key (START1 0) (END1 (length SEQUENCE-ONE)) (START2 0) (END2 (length SEQUENCE-TWO))) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence1 = args[0], sequence2 = args[1], + result = sequence1; + Elemcount starting1, ending1 = EMACS_INT_MAX, starting2; + Elemcount ending2 = EMACS_INT_MAX, counting = 0, startcounting; + Boolint sequence1_listp, sequence2_listp, + overwriting = EQ (sequence1, sequence2); + + PARSE_KEYWORDS (Freplace, nargs, args, 4, (start1, end1, start2, end2), + (start1 = start2 = Qzero)); + + CHECK_SEQUENCE (sequence1); + CHECK_LISP_WRITEABLE (sequence1); + + CHECK_SEQUENCE (sequence2); + + CHECK_NATNUM (start1); + starting1 = XINT (start1); + CHECK_NATNUM (start2); + starting2 = XINT (start2); + + if (!NILP (end1)) + { + CHECK_NATNUM (end1); + ending1 = XINT (end1); + + if (!(starting1 <= ending1)) + { + args_out_of_range_3 (sequence1, start1, end1); + } + } + + if (!NILP (end2)) + { + CHECK_NATNUM (end2); + ending2 = XINT (end2); + + if (!(starting2 <= ending2)) + { + args_out_of_range_3 (sequence1, start2, end2); + } + } + + sequence1_listp = LISTP (sequence1); + sequence2_listp = LISTP (sequence2); + + overwriting = overwriting && starting2 <= starting1; + + if (sequence1_listp && !ZEROP (start1)) + { + sequence1 = Fnthcdr (start1, sequence1); + + if (NILP (sequence1)) + { + check_sequence_range (args[0], start1, end1, Flength (args[0])); + /* Give up early here. */ + return result; + } + + ending1 -= starting1; + starting1 = 0; + } + + if (sequence2_listp && !ZEROP (start2)) + { + sequence2 = Fnthcdr (start2, sequence2); + + if (NILP (sequence2)) + { + check_sequence_range (args[1], start1, end1, Flength (args[1])); + /* Nothing available to replace sequence1's contents. */ + return result; + } + + ending2 -= starting2; + starting2 = 0; + } + + if (overwriting) + { + if (EQ (start1, start2)) + { + return result; + } + + /* Our ranges may overlap. Save the data that might be overwritten. */ + + if (CONSP (sequence2)) + { + Elemcount len = XINT (Flength (sequence2)); + Lisp_Object *subsequence + = alloca_array (Lisp_Object, min (ending2, len)); + Elemcount ii = 0; + + LIST_LOOP_2 (elt, sequence2) + { + if (counting == ending2) + { + break; + } + + subsequence[ii++] = elt; + counting++; + } + + check_sequence_range (sequence1, start1, end1, + /* The XINT (start2) is intentional here; we + called #'length after doing (nthcdr + start2 sequence2). */ + make_int (XINT (start2) + len)); + check_sequence_range (sequence2, start2, end2, + make_int (XINT (start2) + len)); + + while (starting1 < ending1 + && starting2 < ending2 && !NILP (sequence1)) + { + XSETCAR (sequence1, subsequence[starting2]); + sequence1 = XCDR (sequence1); + starting1++; + starting2++; + } + } + else if (STRINGP (sequence2)) + { + Ibyte *p = XSTRING_DATA (sequence2), + *pend = p + XSTRING_LENGTH (sequence2), *pcursor, + *staging; + Bytecount ii = 0; + + while (ii < starting2 && p < pend) + { + INC_IBYTEPTR (p); + ii++; + } + + pcursor = p; + + while (ii < ending2 && starting1 < ending1 && pcursor < pend) + { + INC_IBYTEPTR (pcursor); + starting1++; + ii++; + } + + if (pcursor == pend) + { + check_sequence_range (sequence1, start1, end1, make_int (ii)); + check_sequence_range (sequence2, start2, end2, make_int (ii)); + } + else + { + assert ((pcursor - p) > 0); + staging = alloca_ibytes (pcursor - p); + memcpy (staging, p, pcursor - p); + replace_string_range (result, start1, + make_int (starting1), + staging, staging + (pcursor - p)); + } + } + else + { + Elemcount seq_len = XINT (Flength (sequence2)), ii = 0, + subseq_len = min (min (ending1 - starting1, seq_len - starting1), + min (ending2 - starting2, seq_len - starting2)); + Lisp_Object *subsequence = alloca_array (Lisp_Object, subseq_len); + + check_sequence_range (sequence1, start1, end1, make_int (seq_len)); + check_sequence_range (sequence2, start2, end2, make_int (seq_len)); + + while (starting2 < ending2 && ii < seq_len) + { + subsequence[ii] = Faref (sequence2, make_int (starting2)); + ii++, starting2++; + } + + ii = 0; + + while (starting1 < ending1 && ii < seq_len) + { + Faset (sequence1, make_int (starting1), subsequence[ii]); + ii++, starting1++; + } + } + } + else if (sequence1_listp && sequence2_listp) + { + Lisp_Object sequence1_tortoise = sequence1, + sequence2_tortoise = sequence2; + Elemcount shortest_len = 0; + + counting = startcounting = min (ending1, ending2); + + while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2)) + { + XSETCAR (sequence1, + CONSP (sequence2) ? XCAR (sequence2) + : Fcar (sequence2)); + sequence1 = CONSP (sequence1) ? XCDR (sequence1) + : Fcdr (sequence1); + sequence2 = CONSP (sequence2) ? XCDR (sequence2) + : Fcdr (sequence2); + + shortest_len++; + + if (startcounting - counting > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (counting & 1) + { + sequence1_tortoise = XCDR (sequence1_tortoise); + sequence2_tortoise = XCDR (sequence2_tortoise); + } + + if (EQ (sequence1, sequence1_tortoise)) + { + signal_circular_list_error (sequence1); + } + + if (EQ (sequence2, sequence2_tortoise)) + { + signal_circular_list_error (sequence2); + } + } + } + + if (NILP (sequence1)) + { + check_sequence_range (sequence1, start1, end1, + make_int (XINT (start1) + shortest_len)); + } + else if (NILP (sequence2)) + { + check_sequence_range (sequence2, start2, end2, + make_int (XINT (start2) + shortest_len)); + } + } + else if (sequence1_listp) + { + if (STRINGP (sequence2)) + { + Ibyte *s2_data = XSTRING_DATA (sequence2), + *s2_end = s2_data + XSTRING_LENGTH (sequence2); + Elemcount char_count = 0; + Lisp_Object character; + + while (char_count < starting2 && s2_data < s2_end) + { + INC_IBYTEPTR (s2_data); + char_count++; + } + + while (starting1 < ending1 && starting2 < ending2 + && s2_data < s2_end && !NILP (sequence1)) + { + character = make_char (itext_ichar (s2_data)); + CONSP (sequence1) ? + XSETCAR (sequence1, character) + : Fsetcar (sequence1, character); + sequence1 = XCDR (sequence1); + starting1++; + starting2++; + char_count++; + INC_IBYTEPTR (s2_data); + } + + if (NILP (sequence1)) + { + check_sequence_range (sequence1, start1, end1, + make_int (XINT (start1) + starting1)); + } + + if (s2_data == s2_end) + { + check_sequence_range (sequence2, start2, end2, + make_int (char_count)); + } + } + else + { + Elemcount len2 = XINT (Flength (sequence2)); + check_sequence_range (sequence2, start2, end2, make_int (len2)); + + ending2 = min (ending2, len2); + while (starting2 < ending2 + && starting1 < ending1 && !NILP (sequence1)) + { + CHECK_CONS (sequence1); + XSETCAR (sequence1, Faref (sequence2, make_int (starting2))); + sequence1 = XCDR (sequence1); + starting1++; + starting2++; + } + + if (NILP (sequence1)) + { + check_sequence_range (sequence1, start1, end1, + make_int (XINT (start1) + starting1)); + } + } + } + else if (sequence2_listp) + { + if (STRINGP (sequence1)) + { + Elemcount ii = 0, count, len = string_char_length (sequence1); + Ibyte *staging, *cursor; + Lisp_Object obj; + + check_sequence_range (sequence1, start1, end1, make_int (len)); + ending1 = min (ending1, len); + count = ending1 - starting1; + staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN); + + while (ii < count && !NILP (sequence2)) + { + obj = CONSP (sequence2) ? XCAR (sequence2) + : Fcar (sequence2); + + CHECK_CHAR_COERCE_INT (obj); + cursor += set_itext_ichar (cursor, XCHAR (obj)); + ii++; + sequence2 = XCDR (sequence2); + } + + if (NILP (sequence2)) + { + check_sequence_range (sequence2, start2, end2, + make_int (XINT (start2) + ii)); + } + + replace_string_range (result, start1, make_int (XINT (start1) + ii), + staging, cursor); + } + else + { + Elemcount len = XINT (Flength (sequence1)); + + check_sequence_range (sequence1, start2, end1, make_int (len)); + ending1 = min (ending2, min (ending1, len)); + + while (starting1 < ending1 && !NILP (sequence2)) + { + Faset (sequence1, make_int (starting1), + CONSP (sequence2) ? XCAR (sequence2) + : Fcar (sequence2)); + sequence2 = XCDR (sequence2); + starting1++; + starting2++; + } + + if (NILP (sequence2)) + { + check_sequence_range (sequence2, start2, end2, + make_int (XINT (start2) + starting2)); + } + } + } + else + { + if (STRINGP (sequence1) && STRINGP (sequence2)) + { + Ibyte *p2 = XSTRING_DATA (sequence2), + *p2end = p2 + XSTRING_LENGTH (sequence2), *p2cursor; + Charcount ii = 0, len1 = string_char_length (sequence1); + + while (ii < starting2 && p2 < p2end) + { + INC_IBYTEPTR (p2); + ii++; + } + + p2cursor = p2; + ending1 = min (ending1, len1); + + while (ii < ending2 && starting1 < ending1 && p2cursor < p2end) + { + INC_IBYTEPTR (p2cursor); + ii++; + starting1++; + } + + if (p2cursor == p2end) + { + check_sequence_range (sequence2, start2, end2, make_int (ii)); + } + + /* This isn't great; any error message won't necessarily reflect + the END1 that was supplied to #'replace. */ + replace_string_range (result, start1, make_int (starting1), + p2, p2cursor); + } + else if (STRINGP (sequence1)) + { + Ibyte *staging, *cursor; + Elemcount count, len1 = string_char_length (sequence1); + Elemcount len2 = XINT (Flength (sequence2)), ii = 0; + Lisp_Object obj; + + check_sequence_range (sequence1, start1, end1, make_int (len1)); + check_sequence_range (sequence2, start2, end2, make_int (len2)); + + ending1 = min (ending1, len1); + ending2 = min (ending2, len2); + count = min (ending1 - starting1, ending2 - starting2); + staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN); + + ii = 0; + while (ii < count) + { + obj = Faref (sequence2, make_int (starting2)); + + CHECK_CHAR_COERCE_INT (obj); + cursor += set_itext_ichar (cursor, XCHAR (obj)); + starting2++, ii++; + } + + replace_string_range (result, start1, + make_int (XINT (start1) + count), + staging, cursor); + } + else if (STRINGP (sequence2)) + { + Ibyte *p2 = XSTRING_DATA (sequence2), + *p2end = p2 + XSTRING_LENGTH (sequence2); + Elemcount len1 = XINT (Flength (sequence1)), ii = 0; + + check_sequence_range (sequence1, start1, end1, make_int (len1)); + ending1 = min (ending1, len1); + + while (ii < starting2 && p2 < p2end) + { + INC_IBYTEPTR (p2); + ii++; + } + + while (p2 < p2end && starting1 < ending1 && starting2 < ending2) + { + Faset (sequence1, make_int (starting1), + make_char (itext_ichar (p2))); + INC_IBYTEPTR (p2); + starting1++; + starting2++; + ii++; + } + + if (p2 == p2end) + { + check_sequence_range (sequence2, start2, end2, make_int (ii)); + } + } + else + { + Elemcount len1 = XINT (Flength (sequence1)), + len2 = XINT (Flength (sequence2)); + + check_sequence_range (sequence1, start1, end1, make_int (len1)); + check_sequence_range (sequence2, start2, end2, make_int (len2)); + + ending1 = min (ending1, len1); + ending2 = min (ending2, len2); + + while (starting1 < ending1 && starting2 < ending2) + { + Faset (sequence1, make_int (starting1), + Faref (sequence2, make_int (starting2))); + starting1++; + starting2++; + } + } + } + + return result; +} Lisp_Object add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string) @@ -5877,9 +6696,27 @@ DEFSYMBOL (Qbit_vector); defsymbol (&QsortX, "sort*"); DEFSYMBOL (Qreduce); + DEFSYMBOL (Qreplace); + + DEFSYMBOL (Qmapconcat); + defsymbol (&QmapcarX, "mapcar*"); + DEFSYMBOL (Qmapvector); + DEFSYMBOL (Qmapcan); + DEFSYMBOL (Qmapc); + DEFSYMBOL (Qmap); + DEFSYMBOL (Qmap_into); + DEFSYMBOL (Qsome); + DEFSYMBOL (Qevery); + DEFSYMBOL (Qmaplist); + DEFSYMBOL (Qmapl); + DEFSYMBOL (Qmapcon); DEFKEYWORD (Q_from_end); DEFKEYWORD (Q_initial_value); + DEFKEYWORD (Q_start1); + DEFKEYWORD (Q_start2); + DEFKEYWORD (Q_end1); + DEFKEYWORD (Q_end2); DEFSYMBOL (Qyes_or_no_p); @@ -5889,6 +6726,7 @@ DEFSUBR (Frandom); DEFSUBR (Flength); DEFSUBR (Fsafe_length); + DEFSUBR (Flist_length); DEFSUBR (Fstring_equal); DEFSUBR (Fcompare_strings); DEFSUBR (Fstring_lessp); @@ -5954,6 +6792,7 @@ DEFSUBR (Fput); DEFSUBR (Fremprop); DEFSUBR (Fobject_plist); + DEFSUBR (Fobject_setplist); DEFSUBR (Fequal); DEFSUBR (Fequalp); DEFSUBR (Fold_equal); @@ -5978,6 +6817,7 @@ DEFSUBR (Freduce); DEFSUBR (Freplace_list); + DEFSUBR (Freplace); DEFSUBR (Fload_average); DEFSUBR (Ffeaturep); DEFSUBR (Frequire);
--- a/src/fontcolor-msw.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/fontcolor-msw.c Mon Oct 18 23:21:23 2010 +0900 @@ -1022,10 +1022,10 @@ } *c = '\0'; - if ((res = bsearch (&key, mswindows_X_color_map, - countof (mswindows_X_color_map), - sizeof (mswindows_X_color_map[0]), - colormap_t_compare)) != NULL) + if ((res = (colormap_t *) bsearch (&key, mswindows_X_color_map, + countof (mswindows_X_color_map), + sizeof (mswindows_X_color_map[0]), + colormap_t_compare)) != NULL) { return res->colorref; }
--- a/src/gc.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/gc.c Mon Oct 18 23:21:23 2010 +0900 @@ -21,6 +21,318 @@ /* Synched up with: Not in FSF. */ +/* + Garbage Collectors in XEmacs + + Currently, XEmacs comes with two garbage collectors: + + - The "old garbage collector": a simple mark and sweep collector, + its implementation is mainly spread out over gc.c and alloc.c. + It is used by the default configuration or if you configure + `--with-newgc=no'. + + - The "new garbage collector": an incremental mark and sweep collector, + its implementation is in gc.c. It is used if you configure + `--with-newgc'. It comes with a new allocator, see mc-alloc.c, and + with the KKCC mark algorith, see below. + + Additionally, the old garbage collectors comes with two mark algorithms: + + - The "recursive mark algorithm" marks live objects by recursively + calling mark_* functions on live objects. It is the default mark + algorithm of the old garbage collector. + + - The "KKCC mark algorithm" uses an explicit stack that to keep + track of the current progress of traversal and uses memory layout + descriptions (that are also used by the portable dumper) instead + of the mark_* functions. The old garbage collector uses it if + you configure `--with-kkcc'. It is the default and only mark + algorithm of the new garbage collector. + + + The New Incremental Garbage Collector + + An incremental garbage collector keeps garbage collection pause + times short by interleaving small amounts of collection work with + program execution, it does that by instrumenting write barrier + algorithms that essentially allow interrupting the mark phase. + + + Write Barrier + + A write barrier is the most important prerequisite for fancy + garbage collection techniques. We implement a "Virtual Dirty Bit + (short: vdb) Write Barrier" that makes uses of the operating + system's memory-protection mechanisms: The write barrier + write-protects memory pages containing heap objects. If the + mutator tries to modify these objects by writing into the + write-protected page, the operating system generates a fault. The + write barrier catches this fault, reads out the error-causing + address and can thus identify the updated object and page. + + Not all environments and operating systems provide the mechanism to + write-protect memory, catch resulting write faults, and read out + the faulting address. But luckily, most of today's operating + systems provide the features needed for the write-barrier + implementation. Currently, XEmacs includes write-barrier + implementations for the following platforms: + + - POSIX-compliant platforms like up-to-date UNIX, Linux, Solaris, + etc. use the system call `mprotect' for memory protection, + `sigaction' for signal handling and get the faulting address from + `struct siginfo'. See file vdb-posix.c. + + - Mach-based systems like Mac OS X use "Mach Exception Handlers". + See file vdb-mach.c. + + - Windows systems like native Windows and Cygwin use Microsoft's + so-called "Structured Exception Handling". See file vdb-win32.c. + + The configure script determines which write barrier implementation + to use for a system. If no write barrier implementation is working + on that system, a fall-back "fake" implementation is used: This + implementation simply turns of the incremental write barrier at + runtime and does not allow any incremental collection (see + vdb-fake.c). The garbage collector then acts like a traditional + mark-and-sweep garbage collector. Generally, the incremental + garbage collector can be turned of at runtime by the user or by + applications, see below. + + + Memory Protection and Object Layout + + Implementations of a memory-protection mechanism may restrict the + size and the alignment of the memory region to be on page-size + boundaries. All objects subject to be covered by the write barrier + have to be allocated on logical memory pages, so that they meet the + requirement to be write-protected. The new allocator mc-alloc is + aware of a system page size---it allocates all Lisp objects on + logical memory pages and is therefore defaulted to on when the new + garbage collector is enabled. + + Unfortunately, the Lisp object layout that works with the old + collector leads to holes in the write barrier: Not all data + structures containing pointers to Lisp objects are allocated on the + Lisp heap. Some Lisp objects do not carry all their information in + the object itself. External parts are kept in separately allocated + memory blocks that are not managed by the new Lisp allocator. + Examples for these objects are hash tables and dynamic arrays, two + objects that can dynamically grow and shrink. The separate memory + blocks are not guaranteed to reside on page boundaries, and thus + cannot be watched by the write barrier. + + Moreover, the separate parts can contain live pointers to other Lisp + objects. These pointers are not covered by the write barrier and + modifications by the client during garbage collection do escape. In + this case, the client changes the connectivity of the reachability + graph behind the collector's back, which eventually leads to + erroneous collection of live objects. To solve this problem, I + transformed the separately allocated parts to fully qualified Lisp + objects that are managed by the allocator and thus are covered by + the write barrier. This also removes a lot of special allocation + and removal code for the out-sourced parts. Generally, allocating + all data structures that contain pointers to Lisp objects on one + heap makes the whole memory layout more consistent. + + + Debugging + + The virtual-dirty-bit write barrier provokes signals on purpose, + namely SIGSEGV and SIGBUS. When debugging XEmacs with this write + barrier running, the debugger always breaks whenever a signal + occurs. This behavior is generally desired: A debugger has to break + on signals, to allow the user to examine the cause of the + signal---especially for illegal memory access, which is a common + programming error. But the debugger should not break for signals + caused by the write barrier. Therefore, most debuggers provide the + ability to turn of their fault handling for specific signals. The + configure script generates the debugger's settings .gdbinit and + .dbxrc, adding code to turn of signal handling for SIGSEGV and + SIGBUS, if the new garbage collector is used. + + But what happens if a bug in XEmacs causes an illegal memory access? + To maintain basic debugging abilities, we use another signal: First, + the write-barrier signal handler has to determine if the current + error situation is caused by the write-barrier memory protection or + not. Therefore, the signal handler checks if the faulting address + has been write-protected before. If it has not, the fault is caused + by a bug; the debugger has to break in this situation. To achieve + this, the signal handler raises SIGABRT to abort the program. Since + SIGABRT is not masked out by the debugger, XEmacs aborts and allows + the user to examine the problem. + + + Incremental Garbage Collection + + The new garbage collector is still a mark-and-sweep collector, but + now the mark phase no longer runs in one atomic action, it is + interleaved with program execution. The incremental garbage + collector needs an explicit mark stack to store the state of the + incremental traversal: the KKCC mark algorithm is a prerequisite and + is enabled by default when the new garbage collector is on. + + Garbage collection is invoked as before: After `gc-cons-threshold' + bytes have been allocated since the last garbage collection (or + after `gc-cons-percentage' percentage of the total amount of memory + used for Lisp data has been allocated since the last garbage + collection) a collection starts. After some initialization, the + marking begins. + + The variable `gc-incremental-traversal-threshold' contains how many + steps of incremental work have to be executed in one incremental + traversal cycle. After that many steps have been made, the mark + phase is interrupted and the client resumes. Now, the Lisp memory + is write-protected and the write barrier records modified objects. + Incremental traversal is resumed after + `gc-cons-incremental-threshold' bytes have been allocated since the + interruption of garbage collection. Then, the objects recorded by + the write-barrier have to be re-examined by the traversal, i.e. they + are re-pushed onto the mark stack and processed again. Once the + mark stack is empty, the traversal is done. + + A full incremental collection is slightly slower than a full garbage + collection before: There is an overhead for storing pointers into + objects when the write barrier is running, and an overhead for + repeated traversal of modified objects. However, the new + incremental garbage collector reduces client pause times to + one-third, so even when a garbage collection is running, XEmacs + stays reactive. + + + Tricolor Marking: White, Black, and Grey Mark Bits + + Garbage collection traverses the graph of reachable objects and + colors them. The objects subject to garbage collection are white at + the beginning. By the end of the collection, those that will be + retained are colored black. When there are no reachable objects left + to blacken, the traversal of live data structures is finished. In + traditional mark-and-sweep collectors, this black and white coloring + is sufficient. + + In an incremental collector, the intermediate state of the traversal + is im- portant because of ongoing mutator activity: the mutator + cannot be allowed to change things in such way that the collector + will fail to find all reachable objects. To understand and prevent + such interactions between the mutator and the collector, it is + useful to introduce a third color, grey. + + Grey objects have been reached by the traversal, but its descendants + may not have been. White objects are changed to grey when they are + reached by the traversal. Grey objects mark the current state of the + traversal: traversal pro- ceeds by processing the grey objects. The + KKCC mark stack holds all the currently grey-colored objects. + Processing a grey object means following its outgoing pointers, and + coloring it black afterwards. + + Intuitively, the traversal proceeds in a wavefront of grey objects + that separates the unreached objects, which are colored white, from + the already processed black objects. + + The allocator takes care of storing the mark bits: The mark bits are + kept in a tree like structure, for details see mc-alloc.c. + + + Internal States of the Incremental Garbage Collector + + To keep track of its current state, the collector holds it's current + phase in the global `gc_state' variable. A collector phase is one + of the following: + + NONE No incremental or full collection is currently running. + + INIT_GC The collector prepares for a new collection, e.g. sets some + global variables. + + PUSH_ROOT_SET The collector pushes the root set on the mark stack + to start the traversal of live objects. + + MARK The traversal of live objects colors the reachable objects + white, grey, or black, according to their lifeness. The mark + phase can be interrupted by the incremental collection algorithm: + Before the client (i.e. the non collector part of XEmacs) resumes, + the write barrier has to be installed so that the collector knows + what objects get modified during the collector's pause. + Installing a write barrier means protecting pages that only + contain black objects and recording write access to these objects. + Pages with white or grey objects do not need to be protected, + since these pages are due to marking anyways when the collector + resumes. Once the collector resumes, it has to re-scan all + objects that have been modified during the collector pause and + have been caught by the write barrier. The mark phase is done when + there are no more grey objects on the heap, i.e. the KKCC mark stack + is empty. + + REPUSH_ROOT_SET After the mark phase is done, the collector has to + traverse the root set pointers again, since modifications to the + objects in the root set can not all be covered by the write barrier + (e.g. root set objects that are on the call stack). Therefore, the + collector has to traverse the root set again without interruption. + + FINISH_MARK After the mark phase is finished, some objects with + special liveness semantics have to be treated separately, e.g. + ephemerons and the various flavors of weak objects. + + FINALIZE The collector registers all objects that have finalizers + for finalization. Finalizations happens asynchronously sometimes + after the collection has finished. + + SWEEP The allocator scans the entire heap and frees all white marked + objects. The freed memory is recycled and can be re-used for future + allocations. The sweep phase is carried out atomically. + + FINISH_GC The collector cleans up after the garbage collection by + resetting some global variables. + + + Lisp Interface + + The new garbage collector can be accessed directly from Emacs Lisp. + Basically, two functions invoke the garbage collector: + + (gc-full) starts a full garbage collection. If an incremental + garbage collection is already running, it is finished without + further interruption. This function guarantees that unused + objects have been freed when it returns. + + (gc-incremental) starts an incremental garbage collection. If an + incremental garbage collection is already running, the next cycle + of incremental traversal is started. The garbage collection is + finished if the traversal completes. Note that this function does + not necessarily free any memory. It only guarantees that the + traversal of the heap makes progress. + + The old garbage collector uses the function (garbage-collect) to + invoke a garbage collection. This function is still in use by some + applications that explicitly want to invoke a garbage collection. + Since these applications may expect that unused memory has really + been freed when (garbage-collect) returns, it maps to (gc-full). + + The new garbage collector is highly customizable during runtime; it + can even be switched back to the traditional mark-and-sweep garbage + collector: The variable allow-incremental-gc controls whether + garbage collections may be interrupted or if they have to be carried + out in one atomic action. Setting allow-incremental-gc to nil + prevents incremental garbage collection, and the garbage collector + then only does full collects, even if (gc-incremental) is called. + Non-nil allows incremental garbage collection. + + This way applications can freely decide what garbage collection + algorithm is best for the upcoming memory usage. How frequently a + garbage collection occurs and how much traversal work is done in one + incremental cycle can also be modified during runtime. See + + M-x customize RET alloc RET + + for an overview of all settings. + + + More Information + + More details can be found in + http://crestani.de/xemacs/pdf/thesis-newgc.pdf . + +*/ + #include <config.h> #include "lisp.h" @@ -50,8 +362,14 @@ #include "vdb.h" +/* Number of bytes of consing since gc before a full gc should happen. */ #define GC_CONS_THRESHOLD 2000000 + +/* Number of bytes of consing since gc before another cycle of the gc + should happen in incremental mode. */ #define GC_CONS_INCREMENTAL_THRESHOLD 200000 + +/* Number of elements marked in one cycle of incremental GC. */ #define GC_INCREMENTAL_TRAVERSAL_THRESHOLD 100000 /* Number of bytes of consing done since the last GC. */
--- a/src/glyphs-eimage.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/glyphs-eimage.c Mon Oct 18 23:21:23 2010 +0900 @@ -694,7 +694,7 @@ /* 3. Now create the EImage(s) */ { - ColorMapObject *cmo = unwind.giffile->SColorMap; + ColorMapObject *cmo = (unwind.giffile->Image.ColorMap ? unwind.giffile->Image.ColorMap : unwind.giffile->SColorMap); int i, j, row, pass, interlace, slice; UINT_64_BIT pixels_sq; Binbyte *eip; @@ -703,6 +703,9 @@ static int InterlacedOffset[] = { 0, 4, 2, 1 }; static int InterlacedJumps[] = { 8, 8, 4, 2 }; + if (cmo == NULL) + signal_image_error ("GIF image has no color map", instantiator); + height = unwind.giffile->SHeight; width = unwind.giffile->SWidth; pixels_sq = (UINT_64_BIT) width * (UINT_64_BIT) height;
--- a/src/lisp.h Mon Oct 18 23:03:27 2010 +0900 +++ b/src/lisp.h Mon Oct 18 23:21:23 2010 +0900 @@ -3404,7 +3404,7 @@ static struct Lisp_Subr *S##Fname; \ DOESNT_RETURN_TYPE (Lisp_Object) Fname (DEFUN_##max_args arglist) #define GET_DEFUN_LISP_OBJECT(Fname) \ - wrap_subr (S##Fname); + wrap_subr (&MC_ALLOC_S##Fname) #else /* not NEW_GC */ #define DEFUN(lname, Fname, min_args, max_args, prompt, arglist) \ Lisp_Object Fname (EXFUN_##max_args); \ @@ -3444,7 +3444,7 @@ }; \ DOESNT_RETURN_TYPE (Lisp_Object) Fname (DEFUN_##max_args arglist) #define GET_DEFUN_LISP_OBJECT(Fname) \ - wrap_subr (&S##Fname); + wrap_subr (&S##Fname) #endif /* not NEW_GC */ /* Heavy ANSI C preprocessor hackery to get DEFUN to declare a @@ -3494,17 +3494,21 @@ /************************************************************************/ /* 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. + PARSE_KEYWORDS call must come before any statements. Equivalently, it + can appear within braces. + + FUNCTION is the C name of the current DEFUN. If there is no current + DEFUN, use the PARSE_KEYWORDS_8 macro, not PARSE_KEYWORDS. If the + current DEFUN has optional arguments that are not keywords, you also need + to use the PARSE_KEYWORDS_8 macro. This is also the case if there are + optional arguments that come before the keywords, as Common Lisp + specifies for #'parse-integer. 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. @@ -3516,11 +3520,6 @@ 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. @@ -3534,26 +3533,71 @@ 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) \ +#if defined (DEBUG_XEMACS) && defined (__STDC_VERSION__) && \ + __STDC_VERSION__ >= 199901L + +/* This version has the advantage that DEFUN without DEFSUBR still provokes + a defined but not used warning, and it provokes an assertion failure at + runtime if someone has copied and pasted the PARSE_KEYWORDS macro from + another function without changing FUNCTION; that would lead to an + incorrect determination of KEYWORDS_OFFSET. */ + +#define PARSE_KEYWORDS(function, nargs, args, keyword_count, keywords, \ + keyword_defaults) \ + PARSE_KEYWORDS_8 (intern_massaging_name (1 + #function), nargs, args, \ + keyword_count, keywords, keyword_defaults, \ + /* Can't XSUBR (Fsymbol_function (...))->min_args, \ + the function may be advised. */ \ + XINT (Ffunction_min_args \ + (intern_massaging_name (1 + #function))), \ + 0); \ + assert (0 == strcmp (__func__, #function)) +#else /* defined (DEBUG_XEMACS) && ... */ +#define PARSE_KEYWORDS(function, nargs, args, keyword_count, keywords, \ + keyword_defaults) \ + PARSE_KEYWORDS_8 (intern (subr_name (XSUBR \ + (GET_DEFUN_LISP_OBJECT (function)))), \ + nargs, args, keyword_count, keywords, \ + keyword_defaults, \ + XSUBR (GET_DEFUN_LISP_OBJECT (function))->min_args, \ + 0) +#endif /* defined (DEBUG_XEMACS) && defined (__STDC_VERSION__) ... */ + +/* PARSE_KEYWORDS_8 is a more fine-grained version of PARSE_KEYWORDS. The + differences are as follows: + + FUNC_SYM is a symbol reflecting the name of the function for which + keywords are being parsed. In PARSE_KEYWORDS, it is the Lisp-visible + name of C_FUNC, interned as a symbol in obarray. + + KEYWORDS_OFFSET is the offset into ARGS where the keyword arguments + start. In PARSE_KEYWORDS, this is the index of the first optional + argument, determined from the information known about C_FUNC. + + 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. In PARSE_KEYWORDS, ALLOW_OTHER_KEYS is always 0. */ + +#define PARSE_KEYWORDS_8(func_sym, nargs, args, \ + keyword_count, keywords, keyword_defaults, \ + keywords_offset, allow_other_keys) \ DECLARE_N_KEYWORDS_##keyword_count keywords; \ \ do \ { \ Lisp_Object pk_key, pk_value; \ - Elemcount pk_i = nargs - 1; \ + Elemcount pk_i = nargs - 1, pk_offset = keywords_offset; \ Boolint pk_allow_other_keys = allow_other_keys; \ \ - if ((nargs - keywords_offset) & 1) \ + if ((nargs - pk_offset) & 1) \ { \ if (!allow_other_keys \ && !(pk_allow_other_keys \ - = non_nil_allow_other_keys_p (keywords_offset, \ + = non_nil_allow_other_keys_p (pk_offset, \ nargs, args))) \ { \ - signal_wrong_number_of_arguments_error (function, nargs); \ + signal_wrong_number_of_arguments_error (func_sym, nargs); \ } \ else \ { \ @@ -3566,7 +3610,7 @@ (void)(keyword_defaults); \ \ /* Start from the end, because the leftmost element overrides. */ \ - while (pk_i > keywords_offset) \ + while (pk_i > pk_offset) \ { \ pk_value = args[pk_i--]; \ pk_key = args[pk_i--]; \ @@ -3577,11 +3621,20 @@ { \ continue; \ } \ - else if (!(pk_allow_other_keys \ - = non_nil_allow_other_keys_p (keywords_offset, \ - nargs, args))) \ + else if ((pk_allow_other_keys \ + = non_nil_allow_other_keys_p (pk_offset, \ + nargs, args))) \ { \ - invalid_keyword_argument (function, pk_key); \ + continue; \ + } \ + else if (EQ (pk_key, Q_allow_other_keys) && \ + NILP (pk_value)) \ + { \ + continue; \ + } \ + else \ + { \ + invalid_keyword_argument (func_sym, pk_key); \ } \ } \ } while (0) @@ -5346,9 +5399,7 @@ int locate_file (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object *, int); EXFUN (Flocate_file_clear_hashing, 1); int isfloat_string (const char *); -#ifdef HAVE_RATIO int isratio_string (const char *); -#endif /* Well, I've decided to enable this. -- ben */ /* And I've decided to make it work right. -- sb */ @@ -5642,7 +5693,7 @@ unsigned int hash_string (const Ibyte *, Bytecount); Lisp_Object intern_istring (const Ibyte *str); MODULE_API Lisp_Object intern (const CIbyte *str); -Lisp_Object intern_converting_underscores_to_dashes (const CIbyte *str); +Lisp_Object intern_massaging_name (const CIbyte *str); Lisp_Object oblookup (Lisp_Object, const Ibyte *, Bytecount); void map_obarray (Lisp_Object, int (*) (Lisp_Object, void *), void *); Lisp_Object indirect_function (Lisp_Object, int);
--- a/src/lread.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/lread.c Mon Oct 18 23:21:23 2010 +0900 @@ -1818,8 +1818,12 @@ } } if (i >= 0400) - syntax_error ("Non-ISO-8859-1 character specified with octal escape", - make_int (i)); + { + read_syntax_error ((Ascbyte *) emacs_sprintf_malloc + (NULL, + "Non-ISO-8859-1 octal character escape, " + "?\\%.3o", i)); + } return i; } @@ -1827,13 +1831,23 @@ /* A hex escape, as in ANSI C, except that we only allow latin-1 characters to be read this way. What is "\x4e03" supposed to mean, anyways, if the internal representation is hidden? - This is also consistent with the treatment of octal escapes. */ + This is also consistent with the treatment of octal escapes. + + Note that we don't accept ?\XAB as specifying the character with + numeric value 171; it must be ?\xAB. */ { +#define OVERLONG_INFO "Overlong hex character escape, ?\\x" + REGISTER Ichar i = 0; REGISTER int count = 0; + Ascbyte seen[] = OVERLONG_INFO "\0\0\0\0\0"; + REGISTER Ascbyte *seenp = seen + sizeof (OVERLONG_INFO) - 1; + +#undef OVERLONG_INFO + while (++count <= 2) { - c = readchar (readcharfun); + c = readchar (readcharfun), *seenp = c, ++seenp; /* Remember, can't use isdigit(), isalpha() etc. on Ichars */ if (c >= '0' && c <= '9') i = (i << 4) + (c - '0'); else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10; @@ -1847,21 +1861,12 @@ if (count == 3) { - c = readchar (readcharfun); + c = readchar (readcharfun), *seenp = c, ++seenp; if ((c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')) { - Lisp_Object args[2]; - - if (c >= '0' && c <= '9') i = (i << 4) + (c - '0'); - else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10; - else if (c >= 'A' && c <= 'F') i = (i << 4) + (c - 'A') + 10; - - args[0] = build_ascstring ("?\\x%x"); - args[1] = make_int (i); - syntax_error ("Overlong hex character escape", - Fformat (2, args)); + read_syntax_error (seen); } unreadchar (readcharfun, c); } @@ -2876,7 +2881,6 @@ || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT))); } -#ifdef HAVE_RATIO int isratio_string (const char *cp) { @@ -2907,7 +2911,7 @@ return *cp == '\0' || *cp == ' ' || *cp =='\t' || *cp == '\n' || *cp == '\r' || *cp == '\f'; } -#endif + static void * sequence_reader (Lisp_Object readcharfun,
--- a/src/lrecord.h Mon Oct 18 23:03:27 2010 +0900 +++ b/src/lrecord.h Mon Oct 18 23:21:23 2010 +0900 @@ -525,6 +525,7 @@ int (*putprop) (Lisp_Object obj, Lisp_Object prop, Lisp_Object val); int (*remprop) (Lisp_Object obj, Lisp_Object prop); Lisp_Object (*plist) (Lisp_Object obj); + Lisp_Object (*setplist) (Lisp_Object obj, Lisp_Object newplist); /* `disksave' is called at dump time. It is used for objects that contain pointers or handles to objects created in external libraries,
--- a/src/mc-alloc.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/mc-alloc.c Mon Oct 18 23:21:23 2010 +0900 @@ -21,6 +21,227 @@ /* Synched up with: Not in FSF. */ +/* + The New Allocator + + The ideas and algorithms are based on the allocator of the + Boehm-Demers-Weiser conservative garbage collector. See + http://www.hpl.hp.com/personal/Hans_ Boehm/gc/index.html. + + The new allocator is enabled when the new garbage collector + is enabled (with `--with-newgc'). The implementation of + the new garbage collector is in gc.c. + + The new allocator takes care of: + - allocating objects in a write-barrier-friendly way + - manage object's mark bits + + Three-Level Allocation + + The new allocator efficiently manages the allocation of Lisp + objects by minimizing the number of times malloc() and free() are + called. The allocation process has three layers of abstraction: + + 1. It allocates memory in very large chunks called heap sections. + + 2. The heap sections are subdivided into pages. The page size is + determined by the constant PAGE_SIZE. It holds the size of a page + in bytes. + + 3. One page consists of one or more cells. Each cell represents + a memory location for an object. The cells on one page all have + the same size, thus every page only contains equal-sized + objects. + + If an object is bigger than page size, it is allocated on a + multi-page. Then there is only one cell on a multi-page (the cell + covers the full multi-page). Is an object smaller than 1/2 PAGE_SIZE, + a page contains several objects and several cells. There + is only one cell on a page for object sizes from 1/2 PAGE_SIZE to + PAGE_SIZE (whereas multi-pages always contain 2 only one + cell). Only in layer one malloc() and free() are called. + + + Size Classes and Page Lists + + Meta-information about every page and multi-page is kept in a page + header. The page header contains some bookkeeping information like + number of used and free cells, and pointers to other page + headers. The page headers are linked in a page list. + + Every page list builds a size class. A size class contains all + pages (linked via page headers) for objects of the same size. The + new allocator does not group objects based on their type, it groups + objects based on their sizes. + + Here is an example: A cons contains a lrecord_header, a car and cdr + field. Altogether it uses 12 bytes of memory (on 32 bits + machines). All conses are allocated on pages with a cell size of 12 + bytes. All theses pages are kept together in a page list, which + represents the size class for 12 bytes objects. But this size class + is not exclusively for conses only. Other objects, which are also + 12 bytes big (e.g. weak-boxes), are allocated in the same size + class and on the same pages. + + The number of size classes is customizable, so is the size step + between successive size classes. + + + Used and Unused Heap + + The memory which is managed by the allocator can be divided in two + logical parts: + + The used heap contains pages, on which objects are allocated. These + pages are com- pletely or partially occupied. In the used heap, it + is important to quickly find a free spot for a new + object. Therefore the size classes of the used heap are defined by + the size of the cells on the pages. The size classes should match + common object sizes, to avoid wasting memory. + + The unused heap only contains completely empty pages. They have + never been used or have been freed completely again. In the unused + heap, the size of consecutive memory tips the scales. A page is the + smallest entity which is asked for. Therefore, the size classes of + the unused heap are defined by the number of consecutive pages. + + The parameters for the different size classes can be adjusted + independently, see `configurable values' below. + + + The Allocator's Data Structures + + The struct `mc_allocator_globals holds' all the data structures + that the new allocator uses (lists of used and unused pages, mark + bits, etc.). + + + Mapping of Heap Pointers to Page Headers + + For caching benefits, the page headers and mark bits are stored + separately from their associated page. During garbage collection + (i.e. for marking and freeing objects) it is important to identify + the page header which is responsible for a given Lisp object. + + To do this task quickly, I added a two level search tree: the upper + 10 bits of the heap pointer are the index of the first level. This + entry of the first level links to the second level, where the next + 10 bits of the heap pointer are used to identify the page + header. The remaining bits point to the object relative to the + page. + + On architectures with more than 32 bits pointers, a hash value of + the upper bits is used to index into the first level. + + + Mark Bits + + For caching purposes, the mark bits are no longer kept within the + objects, they are kept in a separate bit field. + + Every page header has a field for the mark bits of the objects on + the page. If there are less cells on the page than there fit bits + in the integral data type EMACS_INT, the mark bits are stored + directly in this EMACS_INT. + + Otherwise, the mark bits are written in a separate space, with the + page header pointing to this space. This happens to pages with + rather small objects: many cells fit on a page, thus many mark bits + are needed. + + + Allocate Memory + + Use + void *mc_alloc (size_t size) + to request memory from the allocator. This returns a pointer to a + newly allocated block of memory of given size. + + This is how the new allocator allocates memory: + 1. Determine the size class of the object. + 2. Is there already a page in this size class and is there a free + cell on this page? + * YES + 3. Unlink free cell from free list, return address of free cell. + DONE. + * NO + 3. Is there a page in the unused heap? + * YES + 4. Move unused page to used heap. + 5. Initialize page header, free list, and mark bits. + 6. Unlink first cell from free list, return address of cell. + DONE. + * NO + 4. Expand the heap, add new memory to unused heap + [go back to 3. and proceed with the YES case]. + + The allocator puts partially filled pages to the front of the page + list, completely filled ones to the end. That guarantees a fast + terminating search for free cells. Are there two successive full + pages at the front of the page list, the complete size class is + full, a new page has to be added. + + + Expand Heap + + To expand the heap, a big chunk of contiguous memory is allocated + using malloc(). These pieces are called heap sections. How big a new + heap section is (and thus the growth of the heap) is adjustable: See + MIN_HEAP_INCREASE, MAX_HEAP_INCREASE, and HEAP_GROWTH_DIVISOR below. + + + Free Memory + + One optimization in XEmacs is that locally used Lisp objects are + freed manually (the memory is not wasted till the next garbage + collection). Therefore the new allocator provides this function: + void mc_free (void *ptr) + That frees the object pointed to by ptr. + + This function is also used internally during sweep phase of the + garbage collection. This is how it works in detail: + + 1. Use pointer to identify page header + (use lookup mechanism described above). + 2. Mark cell as free and hook it into free list. + 3. Is the page completely empty? + * YES + 4. Unlink page from page list. + 5. Remove page header, free list, and mark bits. + 6. Move page to unused heap. + * NO + 4. Move page to front of size class (to speed up allocation + of objects). + + If the last object of a page is freed, the empty page is returned to + the unused heap. The allocator tries to coalesce adjacent pages, to + gain a big piece of contiguous memory. The resulting chunk is hooked + into the according size class of the unused heap. If this created a + complete heap section, the heap section is returned to the operating + system by using free(). + + + Allocator and Garbage Collector + + The new allocator simplifies the interface to the Garbage Collector: + * mark live objects: MARK_[WHITE|GREY|BLACK] (ptr) + * sweep heap: EMACS_INT mc_sweep (void) + * run finalizers: EMACS_INT mc_finalize (void) + + + Allocator and Dumper + + The new allocator provides special finalization for the portable + dumper (to save disk space): EMACS_INT mc_finalize_for_disksave (void) + + + More Information + + More details can be found in + http://crestani.de/xemacs/pdf/mc-alloc.pdf . + +*/ + #include <config.h> #include "lisp.h"
--- a/src/print.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/print.c Mon Oct 18 23:21:23 2010 +0900 @@ -2027,7 +2027,7 @@ for (; confusing < size; confusing++) { - if (!isdigit (data[confusing])) + if (!isdigit (data[confusing]) && '/' != data[confusing]) { confusing = 0; break; @@ -2039,7 +2039,8 @@ /* #### Ugh, this is needlessly complex and slow for what we need here. It might be a good idea to copy equivalent code from FSF. --hniksic */ - confusing = isfloat_string ((char *) data); + confusing = isfloat_string ((char *) data) + || isratio_string ((char *) data); if (confusing) write_ascstring (printcharfun, "\\"); }
--- a/src/process-slots.h Mon Oct 18 23:03:27 2010 +0900 +++ b/src/process-slots.h Mon Oct 18 23:21:23 2010 +0900 @@ -68,4 +68,6 @@ all of the Lisp objects, including in process-type-specific data. */ MARKED_SLOT (tty_name) + MARKED_SLOT (plist) + #undef MARKED_SLOT
--- a/src/process.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/process.c Mon Oct 18 23:21:23 2010 +0900 @@ -170,6 +170,42 @@ write_ascstring (printcharfun, ">"); } } +/* Process plists are directly accessible, so we need to protect against + invalid property list structure */ + +static Lisp_Object +process_getprop (Lisp_Object process, Lisp_Object property) +{ + return external_plist_get (&XPROCESS (process)->plist, property, 0, + ERROR_ME); +} + +static int +process_putprop (Lisp_Object process, Lisp_Object property, Lisp_Object value) +{ + external_plist_put (&XPROCESS (process)->plist, property, value, 0, + ERROR_ME); + return 1; +} + +static int +process_remprop (Lisp_Object process, Lisp_Object property) +{ + return external_remprop (&XPROCESS (process)->plist, property, 0, ERROR_ME); +} + +static Lisp_Object +process_plist (Lisp_Object process) +{ + return XPROCESS (process)->plist; +} + +static Lisp_Object +process_setplist (Lisp_Object process, Lisp_Object newplist) +{ + XPROCESS (process)->plist = newplist; + return newplist; +} #ifdef HAVE_WINDOW_SYSTEM extern void debug_process_finalization (Lisp_Process *p); @@ -2405,6 +2441,16 @@ } +void +reinit_process_early (void) +{ + OBJECT_HAS_METHOD (process, getprop); + OBJECT_HAS_METHOD (process, putprop); + OBJECT_HAS_METHOD (process, remprop); + OBJECT_HAS_METHOD (process, plist); + OBJECT_HAS_METHOD (process, setplist); +} + /* This is not named init_process in order to avoid a conflict with NS 3.3 */ void init_xemacs_process (void) @@ -2481,6 +2527,8 @@ Vshell_file_name = build_istring (shell); } + + reinit_process_early (); } void
--- a/src/strftime.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/strftime.c Mon Oct 18 23:21:23 2010 +0900 @@ -132,6 +132,16 @@ "July", "August", "September", "October", "November", "December" }; +static char const * const roman_upper[] = +{ + "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX", "X", "XI", "XII" +}; + +static char const * const roman_lower[] = +{ + "i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix", "x", "xi", "xii" +}; + /* Add character C to STRING and increment LENGTH, unless LENGTH would exceed MAX. */ @@ -601,6 +611,16 @@ add_num3 (&string[length], (1900 + tm->tm_year) % 1000, max - length, zero); break; + case '\xe6': + length += + add_str (&string[length], roman_lower[tm->tm_mon], + max - length); + break; + case '\xC6': + length += + add_str (&string[length], roman_upper[tm->tm_mon], + max - length); + break; } } }
--- a/src/symbols.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/symbols.c Mon Oct 18 23:21:23 2010 +0900 @@ -198,15 +198,23 @@ } Lisp_Object -intern_converting_underscores_to_dashes (const CIbyte *str) +intern_massaging_name (const CIbyte *str) { Bytecount len = strlen (str); CIbyte *tmp = alloca_extbytes (len + 1); Bytecount i; strcpy (tmp, str); for (i = 0; i < len; i++) - if (tmp[i] == '_') - tmp[i] = '-'; + { + if (tmp[i] == '_') + { + tmp[i] = '-'; + } + else if (tmp[i] == 'X') + { + tmp[i] = '*'; + } + } return intern_istring ((Ibyte *) tmp); } @@ -3530,6 +3538,7 @@ OBJECT_HAS_METHOD (symbol, putprop); OBJECT_HAS_METHOD (symbol, remprop); OBJECT_HAS_NAMED_METHOD (symbol, plist, Fsymbol_plist); + OBJECT_HAS_NAMED_METHOD (symbol, setplist, Fsetplist); } void
--- a/src/symeval.h Mon Oct 18 23:03:27 2010 +0900 +++ b/src/symeval.h Mon Oct 18 23:21:23 2010 +0900 @@ -294,6 +294,9 @@ #define DEFSUBR(Fname) \ do { \ + /* #### As far as I can see, this has no upside compared to the non-NEW_GC \ + code. The MC_ALLOC_S##Fname structure is also in the dumped \ + XEmacs. Aidan Kehoe, Mon Sep 20 23:14:01 IST 2010 */ \ DEFSUBR_MC_ALLOC (Fname); \ defsubr (S##Fname); \ } while (0)
--- a/src/symsinit.h Mon Oct 18 23:03:27 2010 +0900 +++ b/src/symsinit.h Mon Oct 18 23:21:23 2010 +0900 @@ -54,6 +54,7 @@ void init_errors_once_early (void); void reinit_opaque_early (void); void init_opaque_once_early (void); +void reinit_process_early (void); void reinit_symbols_early (void); void init_symbols_once_early (void);
--- a/src/termcap.c Mon Oct 18 23:03:27 2010 +0900 +++ b/src/termcap.c Mon Oct 18 23:21:23 2010 +0900 @@ -25,7 +25,10 @@ #ifdef emacs #include <config.h> #include "lisp.h" /* For encapsulated open, close, read */ -#include "device.h" /* For DEVICE_BAUD_RATE */ +#include "device.h" +#include "device-impl.h" /* For DEVICE_BAUD_RATE */ +#include "sysfile.h" +#include "process.h" #else /* not emacs */ #include <stdlib.h>
--- a/src/text.h Mon Oct 18 23:03:27 2010 +0900 +++ b/src/text.h Mon Oct 18 23:21:23 2010 +0900 @@ -3095,7 +3095,7 @@ #endif #define Qunix_host_name_encoding Qnative #define Qunix_service_name_encoding Qnative -#define Qtime_function_encoding Qnative +#define Qtime_function_encoding Qbinary #define Qtime_zone_encoding Qtime_function_encoding #define Qmswindows_host_name_encoding Qmswindows_multibyte #define Qmswindows_service_name_encoding Qmswindows_multibyte
--- a/tests/ChangeLog Mon Oct 18 23:03:27 2010 +0900 +++ b/tests/ChangeLog Mon Oct 18 23:21:23 2010 +0900 @@ -18,6 +18,38 @@ * reproduce-crashes.el: Amend "this file" to "XEmacs is free...". +2010-10-14 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el (x): + Test #'nbutlast, #'butlast with dotted lists. + Check that #'ldiff and #'tailp don't hang on circular lists; check + that #'tailp returns t with circular lists when that is + appropriate. Test them both with dotted lists. + +2010-10-12 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + Make sure circularity checking with #'merge is sane. + +2010-08-15 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + (not, not, invalid-argument, invalid-argument): + Check that error messages from the image specifier instantiator + code are clearer than they used to be. + +2010-08-15 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + Test that symbols with names that look like ratios are printed + distinctly from the equivalent ratios. + +2010-07-24 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + Test a couple of things #'reduce was just made more careful + about. + 2010-06-13 Stephen J. Turnbull <stephen@xemacs.org> * gtk/event-stream-tests.el:
--- a/tests/automated/lisp-tests.el Mon Oct 18 23:03:27 2010 +0900 +++ b/tests/automated/lisp-tests.el Mon Oct 18 23:21:23 2010 +0900 @@ -200,6 +200,14 @@ (Assert (equal y '(0 1 2 3))) (Assert (equal z y))) +(let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c))) + (y (butlast x 0)) + (z (nbutlast x 0))) + (Assert (eq z x)) + (Assert (not (eq y x))) + (Assert (equal y '(0 1 2 3 4 5 6.0 ?7 ?8))) + (Assert (equal z y))) + (Assert (eq (butlast '(x)) nil)) (Assert (eq (nbutlast '(x)) nil)) (Assert (eq (butlast '()) nil)) @@ -219,6 +227,58 @@ (Assert (and (equal x y) (not (eq x y)))))) ;;----------------------------------------------------- +;; Test `ldiff' +;;----------------------------------------------------- +(Check-Error wrong-type-argument (ldiff 'foo pi)) +(Check-Error wrong-number-of-arguments (ldiff)) +(Check-Error wrong-number-of-arguments (ldiff '(1 2))) +(Check-Error circular-list (ldiff (make-circular-list 1) nil)) +(Check-Error circular-list (ldiff (make-circular-list 2000) nil)) +(Assert (eq '() (ldiff '() pi))) +(dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) + (let ((y (ldiff x nil))) + (Assert (and (equal x y) (not (eq x y)))))) + +(let* ((vector (vector 'foo)) + (dotted `(1 2 3 ,pi 40 50 . ,vector)) + (dotted-pi `(1 2 3 . ,pi)) + without-vector without-pi) + (Assert (equal dotted (ldiff dotted nil)) + "checking ldiff handles dotted lists properly") + (Assert (equal (butlast dotted 0) (ldiff dotted vector)) + "checking ldiff discards dotted elements correctly") + (Assert (equal (butlast dotted-pi 0) (ldiff dotted-pi (* 4 (atan 1)))) + "checking ldiff handles float equivalence correctly")) + +;;----------------------------------------------------- +;; Test `tailp' +;;----------------------------------------------------- +(Check-Error wrong-type-argument (tailp pi 'foo)) +(Check-Error wrong-number-of-arguments (tailp)) +(Check-Error wrong-number-of-arguments (tailp '(1 2))) +(Check-Error circular-list (tailp nil (make-circular-list 1))) +(Check-Error circular-list (tailp nil (make-circular-list 2000))) +(Assert (null (tailp pi '())) + "checking pi is not a tail of the list nil") +(Assert (tailp 3 '(1 2 . 3)) + "checking #'tailp works with a dotted integer.") +(Assert (tailp pi `(1 2 . ,(* 4 (atan 1)))) + "checking tailp works with non-eq dotted floats.") +(let ((list (make-list 2048 nil))) + (Assert (tailp (nthcdr 2000 list) (nconc list list)) + "checking #'tailp succeeds with circular LIST containing SUBLIST")) + +;;----------------------------------------------------- +;; Test `endp' +;;----------------------------------------------------- +(Check-Error wrong-type-argument (endp 'foo)) +(Check-Error wrong-number-of-arguments (endp)) +(Check-Error wrong-number-of-arguments (endp '(1 2) 'foo)) +(Assert (endp nil) "checking nil is recognized as the end of a list") +(Assert (not (endp (list 200 200 4 0 9))) + "checking a cons is not recognised as the end of a list") + +;;----------------------------------------------------- ;; Arithmetic operations ;;----------------------------------------------------- @@ -2341,4 +2401,78 @@ (gethash hashed-bignum hashing)) "checking hashing works correctly with #'eql tests and bignums")))) +;; +(when (decode-char 'ucs #x0192) + (Check-Error + invalid-state + (let ((str "aaaaaaaaaaaaa") + (called 0) + modified) + (reduce #'+ str + :key #'(lambda (object) + (prog1 + object + (incf called) + (or modified + (and (> called 5) + (setq modified + (fill str (read #r"?\u0192"))))))))))) + +(Assert + (eql 55 + (let ((sequence '(1 2 3 4 5 6 7 8 9 10)) + (called 0) + modified) + (reduce #'+ + sequence + :key + #'(lambda (object) (prog1 + object + (incf called) + (and (eql called 5) + (setcdr (nthcdr 3 sequence) nil)) + (garbage-collect)))))) + "checking we can amputate lists without crashing #'reduce") + +(Assert (not (eq t (canonicalize-inst-list + `(((mswindows) . [string :data ,(make-string 20 0)]) + ((tty) . [string :data " "])) 'image t))) + "checking mswindows is always available as a specifier tag") + +(Assert (not (eq t (canonicalize-inst-list + `(((mswindows) . [nothing]) + ((tty) . [string :data " "])) + 'image t))) + "checking the correct syntax for a nothing image specifier works") + +(Check-Error-Message invalid-argument "^Invalid specifier tag set" + (canonicalize-inst-list + `(((,(gensym)) . [nothing]) + ((tty) . [string :data " "])) + 'image)) + +(Check-Error-Message invalid-argument "^Unrecognized keyword" + (canonicalize-inst-list + `(((mswindows) . [nothing :data "hi there"]) + ((tty) . [string :data " "])) 'image)) + +;; If we combine both the specifier inst list problems, we get the +;; unrecognized keyword error first, not the invalid specifier tag set +;; error. This is a little unintuitive; the specifier tag set thing is +;; processed first, and would seem to be more important. But anyone writing +;; code needs to solve both problems, it's reasonable to ask them to do it +;; in series rather than in parallel. + +(when (featurep 'ratio) + (Assert (not (eql '1/2 (read (prin1-to-string (intern "1/2"))))) + "checking symbols with ratio-like names are printed distinctly") + (Assert (not (eql '1/5 (read (prin1-to-string (intern "2/10"))))) + "checking symbol named \"2/10\" not eql to ratio 1/5 on read")) + +(let* ((count 0) + (list (map-into (make-list 2048 nil) #'(lambda () (decf count)))) + (expected (append list '(1)))) + (Assert (equal expected (merge 'list list '(1) #'<)) + "checking merge's circularity checks are sane")) + ;;; end of lisp-tests.el