From: John Wiegley Date: Tue, 12 Jan 2016 06:48:07 +0000 (-0800) Subject: Merge from origin/emacs-25 X-Git-Tag: emacs-26.0.90~2819^2~15 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=1dd4f26ab6c1f14628d9fcf03b0cca7e54d52302;p=emacs.git Merge from origin/emacs-25 ef33bc7 Spelling and grammar fixes 9c3dbab Fix copyright years by hand 0e96320 Update copyright year to 2016 --- 1dd4f26ab6c1f14628d9fcf03b0cca7e54d52302 diff --cc doc/misc/texinfo.tex index 34fd353a9dc,0ad0e85a005..0f301a2a716 --- a/doc/misc/texinfo.tex +++ b/doc/misc/texinfo.tex @@@ -3,12 -3,9 +3,9 @@@ % Load plain if necessary, i.e., if running under initex. \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi % -\def\texinfoversion{2015-12-20.12} +\def\texinfoversion{2015-12-17.20} % - % Copyright 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995, - % 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - % 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 - % Free Software Foundation, Inc. + % Copyright 1985-1986, 1988, 1990-2016 Free Software Foundation, Inc. % % This texinfo.tex file is free software: you can redistribute it and/or % modify it under the terms of the GNU General Public License as diff --cc lisp/emacs-lisp/let-alist.el index 0b647a028ca,e400b499036..3507a395436 --- a/lisp/emacs-lisp/let-alist.el +++ b/lisp/emacs-lisp/let-alist.el @@@ -1,9 -1,9 +1,9 @@@ ;;; let-alist.el --- Easily let-bind values of an assoc-list by their names -*- lexical-binding: t; -*- - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. + ;; Copyright (C) 2014-2016 Free Software Foundation, Inc. -;; Author: Artur Malabarba -;; Maintainer: Artur Malabarba +;; Author: Artur Malabarba +;; Package-Requires: ((emacs "24.1")) ;; Version: 1.0.4 ;; Keywords: extensions lisp ;; Prefix: let-alist diff --cc lisp/progmodes/which-func.el index 7e289b3ff5b,d883d4fc4dd..2fc24a8cb3d --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@@ -1,6 -1,6 +1,6 @@@ -;;; which-func.el --- print current function in mode line +;;; which-func.el --- print current function in mode line -*- lexical-binding:t -*- - ;; Copyright (C) 1994, 1997-1998, 2001-2015 Free Software Foundation, + ;; Copyright (C) 1994, 1997-1998, 2001-2016 Free Software Foundation, ;; Inc. ;; Author: Alex Rezinsky diff --cc test/Makefile.in index 1e76675ac76,00000000000..db386cebe29 mode 100644,000000..100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@@ -1,165 -1,0 +1,165 @@@ +### @configure_input@ + - # Copyright (C) 2010-2015 Free Software Foundation, Inc. ++# Copyright (C) 2010-2016 Free Software Foundation, Inc. + +# This file is part of GNU Emacs. + +# GNU Emacs is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# GNU Emacs is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GNU Emacs. If not, see . + +### Commentary: + +## Some targets: +## check: re-run all tests, writing to .log files. +## check-maybe: run all tests whose .log file needs updating +## filename.log: run tests from filename.el(c) if .log file needs updating +## filename: re-run tests from filename.el(c), with no logging + +### Code: + +SHELL = @SHELL@ + +srcdir = @srcdir@ +VPATH = $(srcdir) + +SEPCHAR = @SEPCHAR@ + +# We never change directory before running Emacs, so a relative file +# name is fine, and makes life easier. If we need to change +# directory, we can use emacs --chdir. +EMACS = ../src/emacs + +EMACS_EXTRAOPT= + +# Command line flags for Emacs. +# Apparently MSYS bash would convert "-L :" to "-L ;" anyway, +# but we might as well be explicit. +EMACSOPT = -batch --no-site-file --no-site-lisp -L "$(SEPCHAR)$(srcdir)" $(EMACS_EXTRAOPT) + +# Prevent any settings in the user environment causing problems. +unexport EMACSDATA EMACSDOC EMACSPATH GREP_OPTIONS + +## To run tests under a debugger, set this to eg: "gdb --args". +GDB = + +# The locale to run tests under. Tests should work if this is set to +# any supported locale. Use the C locale by default, as it should be +# supported everywhere. +TEST_LOCALE = C + +# The actual Emacs command run in the targets below. +# Prevent any setting of EMACSLOADPATH in user environment causing problems. +emacs = EMACSLOADPATH= LC_ALL=$(TEST_LOCALE) EMACS_TEST_DIRECTORY=$(srcdir) \ + $(GDB) "$(EMACS)" $(EMACSOPT) + +.PHONY: all check + +all: check + +%.elc: %.el + @echo Compiling $< + @$(emacs) -f batch-byte-compile $< + +## Ignore any test errors so we can continue to test other files. +## But compilation errors are always fatal. +WRITE_LOG = > $@ 2>&1 || { stat=ERROR; cat $@; }; echo $$stat: $@ + +## I'd prefer to use -emacs -f ert-run-tests-batch-and-exit rather +## than || true, since the former makes problems more obvious. +## I'd also prefer to @-hide the grep part and not the +## ert-run-tests-batch-and-exit part. +## +## We need to use $loadfile because: +## i) -L :$srcdir -l basename does not work, because we have files whose +## basename duplicates a file in lisp/ (eg eshell.el). +## ii) Although -l basename will automatically load .el or .elc, +## -l ./basename treats basename as a literal file (it would be nice +## to change this; bug#17848 - if that gets done, this can be simplified). +## +## Beware: it approximates 'no-byte-compile', so watch out for false-positives! +%.log: %.el + @if grep '^;.*no-byte-compile: t' $< > /dev/null; then \ + loadfile=$<; \ + else \ + loadfile=$ $@ +# Makefile ends here. diff --cc test/lisp/abbrev-tests.el index 37917ec5353,00000000000..0d93e268a99 mode 100644,000000..100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@@ -1,127 -1,0 +1,127 @@@ +;;; abbrev-tests.el --- Test suite for abbrevs -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Eli Zaretskii +;; Keywords: abbrevs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; `kill-all-abbrevs-test' will remove all user *and* system abbrevs +;; if called noninteractively with the init file loaded. + +;;; Code: + +(require 'ert) +(require 'abbrev) +(require 'seq) + +;; set up test abbrev table and abbrev entry +(defun setup-test-abbrev-table () + (defvar ert-test-abbrevs nil) + (define-abbrev-table 'ert-test-abbrevs '(("a-e-t" "abbrev-ert-test"))) + (abbrev-table-put ert-test-abbrevs :ert-test "ert-test-value") + ert-test-abbrevs) + +(ert-deftest abbrev-table-p-test () + (should-not (abbrev-table-p 42)) + (should-not (abbrev-table-p "aoeu")) + (should-not (abbrev-table-p '())) + (should-not (abbrev-table-p [])) + ;; Missing :abbrev-table-modiff counter: + (should-not (abbrev-table-p (obarray-make))) + (let* ((table (obarray-make))) + (abbrev-table-put table :abbrev-table-modiff 42) + (should (abbrev-table-p table)))) + +(ert-deftest abbrev-make-abbrev-table-test () + ;; Table without properties: + (let ((table (make-abbrev-table))) + (should (abbrev-table-p table)) + (should (= (length table) obarray-default-size))) + ;; Table with one property 'foo with value 'bar: + (let ((table (make-abbrev-table '(foo bar)))) + (should (abbrev-table-p table)) + (should (= (length table) obarray-default-size)) + (should (eq (abbrev-table-get table 'foo) 'bar)))) + +(ert-deftest abbrev-table-get-put-test () + (let ((table (make-abbrev-table))) + (should-not (abbrev-table-get table 'foo)) + (should (= (abbrev-table-put table 'foo 42) 42)) + (should (= (abbrev-table-get table 'foo) 42)) + (should (eq (abbrev-table-put table 'foo 'bar) 'bar)) + (should (eq (abbrev-table-get table 'foo) 'bar)))) + +(ert-deftest copy-abbrev-table-test () + (defvar foo-abbrev-table nil) ; Avoid compiler warning + (define-abbrev-table 'foo-abbrev-table + '()) + (should (abbrev-table-p foo-abbrev-table)) + ;; Bug 21828 + (let ((new-foo-abbrev-table + (condition-case nil + (copy-abbrev-table foo-abbrev-table) + (error nil)))) + (should (abbrev-table-p new-foo-abbrev-table))) + (should-not (string-equal (buffer-name) "*Backtrace*"))) + +(ert-deftest kill-all-abbrevs-test () + "Test undefining all defined abbrevs" + (unless noninteractive + (ert-skip "Cannot test kill-all-abbrevs in interactive mode")) + + (let ((num-tables 0)) + ;; ensure at least one abbrev exists + (should (abbrev-table-p (setup-test-abbrev-table))) + (setf num-tables (length abbrev-table-name-list)) + (kill-all-abbrevs) + + ;; no tables should have been removed/added + (should (= num-tables (length abbrev-table-name-list))) + ;; number of empty tables should be the same as number of tables + (should (= num-tables (length (seq-filter + (lambda (table) + (abbrev-table-empty-p (symbol-value table))) + abbrev-table-name-list)))))) + +(ert-deftest abbrev-table-name-test () + "Test returning name of abbrev-table" + (let ((ert-test-abbrevs (setup-test-abbrev-table)) + (no-such-table nil)) + (should (equal 'ert-test-abbrevs (abbrev-table-name ert-test-abbrevs))) + (should (equal nil (abbrev-table-name no-such-table))))) + +(ert-deftest clear-abbrev-table-test () + "Test clearing single abbrev table" + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (should (equal "a-e-t" (symbol-name + (abbrev-symbol "a-e-t" ert-test-abbrevs)))) + (should (equal "abbrev-ert-test" (symbol-value + (abbrev-symbol "a-e-t" ert-test-abbrevs)))) + + (clear-abbrev-table ert-test-abbrevs) + + (should (equal "nil" (symbol-name + (abbrev-symbol "a-e-t" ert-test-abbrevs)))) + (should (equal nil (symbol-value + (abbrev-symbol "a-e-t" ert-test-abbrevs)))) + (should (equal t (abbrev-table-empty-p ert-test-abbrevs))))) + +(provide 'abbrev-tests) +;;; abbrev-tests.el ends here diff --cc test/lisp/autorevert-tests.el index 043f80de49e,00000000000..b37850054fa mode 100644,000000..100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@@ -1,256 -1,0 +1,256 @@@ +;;; auto-revert-tests.el --- Tests of auto-revert + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; A whole test run can be performed calling the command `auto-revert-test-all'. + +;;; Code: + +(require 'ert) +(require 'autorevert) +(setq auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded" + auto-revert-stop-on-user-input nil) + +(defconst auto-revert--timeout 10 + "Time to wait until a message appears in the *Messages* buffer.") + +(defun auto-revert--wait-for-revert (buffer) + "Wait until the *Messages* buffer reports reversion of BUFFER." + (with-timeout (auto-revert--timeout nil) + (with-current-buffer "*Messages*" + (while + (null (string-match + (format-message "Reverting buffer `%s'." (buffer-name buffer)) + (buffer-string))) + (if (with-current-buffer buffer auto-revert-use-notify) + (read-event nil nil 0.1) + (sleep-for 0.1)))))) + +(ert-deftest auto-revert-test00-auto-revert-mode () + "Check autorevert for a file." + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let ((tmpfile (make-temp-file "auto-revert-test")) + buf) + (unwind-protect + (progn + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (write-region "any text" nil tmpfile nil 'no-message) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-mode 1) + (should auto-revert-mode) + + ;; Modify file. We wait for a second, in order to have + ;; another timestamp. + (sleep-for 1) + (write-region "another text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string))) + + ;; When the buffer is modified, it shall not be reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (set-buffer-modified-p t) + (sleep-for 1) + (write-region "any text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer hasn't been reverted. + (auto-revert--wait-for-revert buf) + (should-not (string-match "any text" (buffer-string))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmpfile))))) + +;; This is inspired by Bug#21841. +(ert-deftest auto-revert-test01-auto-revert-several-files () + "Check autorevert for several files at once." + (skip-unless (executable-find "cp")) + + (let* ((cp (executable-find "cp")) + (tmpdir1 (make-temp-file "auto-revert-test" 'dir)) + (tmpdir2 (make-temp-file "auto-revert-test" 'dir)) + (tmpfile1 + (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) + (tmpfile2 + (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) + buf1 buf2) + (unwind-protect + (progn + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (write-region "any text" nil tmpfile1 nil 'no-message) + (setq buf1 (find-file-noselect tmpfile1)) + (write-region "any text" nil tmpfile2 nil 'no-message) + (setq buf2 (find-file-noselect tmpfile2)) + + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (sleep-for 1) + (auto-revert-mode 1) + (should auto-revert-mode))) + + ;; Modify files. We wait for a second, in order to have + ;; another timestamp. + (sleep-for 1) + (write-region + "another text" nil + (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) + nil 'no-message) + (write-region + "another text" nil + (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) + nil 'no-message) + ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) + ;; Strange, that `copy-directory' does not work as expected. + ;; The following shell command is not portable on all + ;; platforms, unfortunately. + (shell-command (format "%s %s/* %s" cp tmpdir2 tmpdir1)) + + ;; Check, that the buffers have been reverted. + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string)))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))) + (ignore-errors (delete-directory tmpdir1 'recursive)) + (ignore-errors (delete-directory tmpdir2 'recursive))))) + +(ert-deftest auto-revert-test02-auto-revert-tail-mode () + "Check autorevert tail mode." + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let ((tmpfile (make-temp-file "auto-revert-test")) + buf) + (unwind-protect + (progn + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (write-region "any text" nil tmpfile nil 'no-message) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-tail-mode 1) + (should auto-revert-tail-mode) + (erase-buffer) + (insert "modified text\n") + (set-buffer-modified-p nil) + + ;; Modify file. We wait for a second, in order to have + ;; another timestamp. + (sleep-for 1) + (write-region "another text" nil tmpfile 'append 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should + (string-match "modified text\nanother text" (buffer-string))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors (kill-buffer buf)) + (ignore-errors (delete-file tmpfile))))) + +(ert-deftest auto-revert-test03-auto-revert-mode-dired () + "Check autorevert for dired." + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let* ((tmpfile (make-temp-file "auto-revert-test")) + (name (file-name-nondirectory tmpfile)) + buf) + (unwind-protect + (progn + (setq buf (dired-noselect temporary-file-directory)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-mode 1) + (should auto-revert-mode) + (should + (string-match name (substring-no-properties (buffer-string)))) + + ;; Delete file. We wait for a second, in order to have + ;; another timestamp. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 1) + (delete-file tmpfile) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should-not + (string-match name (substring-no-properties (buffer-string)))) + + ;; Make dired buffer modified. Check, that the buffer has + ;; been still reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (set-buffer-modified-p t) + (sleep-for 1) + (write-region "any text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should + (string-match name (substring-no-properties (buffer-string)))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmpfile))))) + +(defun auto-revert-test-all (&optional interactive) + "Run all tests for \\[auto-revert]." + (interactive "p") + (if interactive + (ert-run-tests-interactively "^auto-revert-") + (ert-run-tests-batch "^auto-revert-"))) + +(provide 'auto-revert-tests) +;;; auto-revert-tests.el ends here diff --cc test/lisp/calc/calc-tests.el index d5252ea62a9,00000000000..c1fb1695c78 mode 100644,000000..100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@@ -1,94 -1,0 +1,94 @@@ +;;; calc-tests.el --- tests for calc -*- lexical-binding: t; -*- + - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Leo Liu +;; Keywords: maint + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) +(require 'ert) +(require 'calc) +(require 'calc-ext) +(require 'calc-units) + +;; XXX The order in which calc libraries (in particular calc-units) +;; are loaded influences whether a calc integer in an expression +;; involving units is represented as a lisp integer or a calc float, +;; see bug#19582. Until this will be fixed the following function can +;; be used to compare such calc expressions. +(defun calc-tests-equal (a b) + "Like `equal' but allow for different representations of numbers. +For example: (calc-tests-equal 10 '(float 1 1)) => t. +A and B should be calc expressions." + (cond ((math-numberp a) + (and (math-numberp b) + (math-equal a b))) + ((atom a) + (equal a b)) + ((consp b) + ;; Can't be dotted or circular. + (and (= (length a) (length b)) + (equal (car a) (car b)) + (cl-every #'calc-tests-equal (cdr a) (cdr b)))))) + +(defun calc-tests-simple (fun string &rest args) + "Push STRING on the calc stack, then call FUN and return the new top. +The result is a calc (i.e., lisp) expression, not its string representation. +Also pop the entire stack afterwards. +An existing calc stack is reused, otherwise a new one is created." + (calc-eval string 'push) + (prog1 + (ignore-errors + (apply fun args) + (calc-top-n 1)) + (calc-pop 0))) + +(ert-deftest test-math-bignum () + ;; bug#17556 + (let ((n (math-bignum most-negative-fixnum))) + (should (math-negp n)) + (should (cl-notany #'cl-minusp (cdr n))))) + +(ert-deftest test-calc-remove-units () + (should (calc-tests-equal (calc-tests-simple #'calc-remove-units "-1 m") -1))) + +(ert-deftest test-calc-extract-units () + (should (calc-tests-equal (calc-tests-simple #'calc-extract-units "-1 m") + '(var m var-m))) + (should (calc-tests-equal (calc-tests-simple #'calc-extract-units "-1 m*cm") + '(* (float 1 -2) (^ (var m var-m) 2))))) + +(ert-deftest test-calc-convert-units () + ;; Used to ask for `(The expression is unitless when simplified) Old Units: '. + (should (calc-tests-equal (calc-tests-simple #'calc-convert-units "-1 m" nil "cm") + '(* -100 (var cm var-cm)))) + ;; Gave wrong result. + (should (calc-tests-equal (calc-tests-simple #'calc-convert-units "-1 m" + (math-read-expr "1m") "cm") + '(* -100 (var cm var-cm))))) + +(provide 'calc-tests) +;;; calc-tests.el ends here + +;; Local Variables: +;; bug-reference-url-format: "http://debbugs.gnu.org/%s" +;; End: diff --cc test/lisp/calendar/icalendar-tests.el index 829cbf2d765,00000000000..2c13a363213 mode 100644,000000..100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@@ -1,2293 -1,0 +1,2293 @@@ +;; icalendar-tests.el --- Test suite for icalendar.el + - ;; Copyright (C) 2005, 2008-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2005, 2008-2016 Free Software Foundation, Inc. + +;; Author: Ulf Jasper +;; Created: March 2005 +;; Keywords: calendar +;; Human-Keywords: calendar, diary, iCalendar, vCalendar + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; TODO: +;; - Add more unit tests for functions, timezone etc. + +;; Note: Watch the trailing blank that is added on import. + +;;; Code: + +(require 'ert) +(require 'icalendar) + +;; ====================================================================== +;; Helpers +;; ====================================================================== + +(defun icalendar-tests--get-ical-event (ical-string) + "Return iCalendar event for ICAL-STRING." + (save-excursion + (with-temp-buffer + (insert ical-string) + (goto-char (point-min)) + (car (icalendar--read-element nil nil))))) + +(defun icalendar-tests--trim (string) + "Remove leading and trailing whitespace from STRING." + (replace-regexp-in-string "[ \t\n]+\\'" "" + (replace-regexp-in-string "\\`[ \t\n]+" "" string))) + +;; ====================================================================== +;; Tests of functions +;; ====================================================================== + +(ert-deftest icalendar--create-uid () + "Test for `icalendar--create-uid'." + (let* ((icalendar-uid-format "xxx-%t-%c-%h-%u-%s") + t-ct + (icalendar--uid-count 77) + (entry-full "30.06.1964 07:01 blahblah") + (hash (format "%d" (abs (sxhash entry-full)))) + (contents "DTSTART:19640630T070100\nblahblah") + (username (or user-login-name "UNKNOWN_USER")) + ) + (fset 't-ct (symbol-function 'current-time)) + (unwind-protect + (progn + (fset 'current-time (lambda () '(1 2 3))) + (should (= 77 icalendar--uid-count)) + (should (string= (concat "xxx-123-77-" hash "-" username "-19640630") + (icalendar--create-uid entry-full contents))) + (should (= 78 icalendar--uid-count))) + ;; restore 'current-time + (fset 'current-time (symbol-function 't-ct))) + (setq contents "blahblah") + (setq icalendar-uid-format "yyy%syyy") + (should (string= (concat "yyyDTSTARTyyy") + (icalendar--create-uid entry-full contents))))) + +(ert-deftest icalendar-convert-anniversary-to-ical () + "Test method for `icalendar--convert-anniversary-to-ical'." + (let* ((calendar-date-style 'iso) + result) + (setq result (icalendar--convert-anniversary-to-ical + "" "%%(diary-anniversary 1964 6 30) g")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:19640630" + "\nDTEND;VALUE=DATE:19640701" + "\nRRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=06;BYMONTHDAY=30") + (car result))) + (should (string= "g" (cdr result))))) + +(ert-deftest icalendar--convert-cyclic-to-ical () + "Test method for `icalendar--convert-cyclic-to-ical'." + (let* ((calendar-date-style 'iso) + result) + (setq result (icalendar--convert-block-to-ical + "" "%%(diary-block 2004 7 19 2004 8 27) Sommerferien")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:20040719" + "\nDTEND;VALUE=DATE:20040828") + (car result))) + (should (string= "Sommerferien" (cdr result))))) + +(ert-deftest icalendar--convert-block-to-ical () + "Test method for `icalendar--convert-block-to-ical'." + (let* ((calendar-date-style 'iso) + result) + (setq result (icalendar--convert-block-to-ical + "" "%%(diary-block 2004 7 19 2004 8 27) Sommerferien")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:20040719" + "\nDTEND;VALUE=DATE:20040828") + (car result))) + (should (string= "Sommerferien" (cdr result))))) + +(ert-deftest icalendar--convert-yearly-to-ical () + "Test method for `icalendar--convert-yearly-to-ical'." + (let* ((calendar-date-style 'iso) + result + (calendar-month-name-array + ["January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December"])) + (setq result (icalendar--convert-yearly-to-ical "" "May 1 Tag der Arbeit")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:19000501" + "\nDTEND;VALUE=DATE:19000502" + "\nRRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=5;BYMONTHDAY=1") + (car result))) + (should (string= "Tag der Arbeit" (cdr result))))) + +(ert-deftest icalendar--convert-weekly-to-ical () + "Test method for `icalendar--convert-weekly-to-ical'." + (let* ((calendar-date-style 'iso) + result + (calendar-day-name-array + ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday"])) + (setq result (icalendar--convert-weekly-to-ical "" "Monday 8:30 subject")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20050103T083000" + "\nDTEND;VALUE=DATE-TIME:20050103T093000" + "\nRRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO") + (car result))) + (should (string= "subject" (cdr result))))) + +(ert-deftest icalendar--convert-sexp-to-ical () + "Test method for `icalendar--convert-sexp-to-ical'." + (let* (result + (icalendar-export-sexp-enumeration-days 3)) + ;; test case %%(diary-hebrew-date) + (setq result (icalendar--convert-sexp-to-ical "" "%%(diary-hebrew-date)")) + (should (consp result)) + (should (eq icalendar-export-sexp-enumeration-days (length result))) + (mapc (lambda (i) + (should (consp i)) + (should (string-match "Hebrew date (until sunset): .*" (cdr i)))) + result))) + +(ert-deftest icalendar--convert-to-ical () + "Test method for `icalendar--convert-to-ical'." + (let* (result + (icalendar-export-sexp-enumerate-all t) + (icalendar-export-sexp-enumeration-days 3) + (calendar-date-style 'iso)) + ;; test case: %%(diary-anniversary 1642 12 25) Newton + ;; forced enumeration not matching the actual day --> empty + (setq result (icalendar--convert-sexp-to-ical + "" "%%(diary-anniversary 1642 12 25) Newton's birthday" + (encode-time 1 1 1 6 12 2014))) + (should (null result)) + ;; test case: %%(diary-anniversary 1642 12 25) Newton + ;; enumeration does match the actual day --> + (setq result (icalendar--convert-sexp-to-ical + "" "%%(diary-anniversary 1642 12 25) Newton's birthday" + (encode-time 1 1 1 24 12 2014))) + (should (= 1 (length result))) + (should (consp (car result))) + (should (string-match + "\nDTSTART;VALUE=DATE:20141225\nDTEND;VALUE=DATE:20141226" + (car (car result)))) + (should (string-match "Newton's birthday" (cdr (car result)))))) + +(ert-deftest icalendar--parse-vtimezone () + "Test method for `icalendar--parse-vtimezone'." + (let (vtimezone result) + (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE +TZID:thename +BEGIN:STANDARD +DTSTART:16010101T040000 +TZOFFSETFROM:+0300 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=10 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T030000 +TZOFFSETFROM:+0200 +TZOFFSETTO:+0300 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=3 +END:DAYLIGHT +END:VTIMEZONE +")) + (setq result (icalendar--parse-vtimezone vtimezone)) + (should (string= "thename" (car result))) + (message (cdr result)) + (should (string= "STD-02:00DST-03:00,M3.5.0/03:00:00,M10.5.0/04:00:00" + (cdr result))) + (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE +TZID:anothername, with a comma +BEGIN:STANDARD +DTSTART:16010101T040000 +TZOFFSETFROM:+0300 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=2MO;BYMONTH=10 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T030000 +TZOFFSETFROM:+0200 +TZOFFSETTO:+0300 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=2MO;BYMONTH=3 +END:DAYLIGHT +END:VTIMEZONE +")) + (setq result (icalendar--parse-vtimezone vtimezone)) + (should (string= "anothername, with a comma" (car result))) + (message (cdr result)) + (should (string= "STD-02:00DST-03:00,M3.2.1/03:00:00,M10.2.1/04:00:00" + (cdr result))) + ;; offsetfrom = offsetto + (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE +TZID:Kolkata, Chennai, Mumbai, New Delhi +X-MICROSOFT-CDO-TZID:23 +BEGIN:STANDARD +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:DAYLIGHT +END:VTIMEZONE +")) + (setq result (icalendar--parse-vtimezone vtimezone)) + (should (string= "Kolkata, Chennai, Mumbai, New Delhi" (car result))) + (message (cdr result)) + (should (string= "STD-05:30DST-05:30,M1.1.1/00:00:00,M1.1.1/00:00:00" + (cdr result))))) + +(ert-deftest icalendar--convert-ordinary-to-ical () + "Test method for `icalendar--convert-ordinary-to-ical'." + (let* ((calendar-date-style 'iso) + result) + ;; without time + (setq result (icalendar--convert-ordinary-to-ical "&?" "2010 2 15 subject")) + (should (consp result)) + (should (string= "\nDTSTART;VALUE=DATE:20100215\nDTEND;VALUE=DATE:20100216" + (car result))) + (should (string= "subject" (cdr result))) + + ;; with start time + (setq result (icalendar--convert-ordinary-to-ical + "&?" "&2010 2 15 12:34 s")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T123400" + "\nDTEND;VALUE=DATE-TIME:20100215T133400") + (car result))) + (should (string= "s" (cdr result))) + + ;; with time + (setq result (icalendar--convert-ordinary-to-ical + "&?" "&2010 2 15 12:34-23:45 s")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T123400" + "\nDTEND;VALUE=DATE-TIME:20100215T234500") + (car result))) + (should (string= "s" (cdr result))) + + ;; with time, again -- test bug#5549 + (setq result (icalendar--convert-ordinary-to-ical + "x?" "x2010 2 15 0:34-1:45 s")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T003400" + "\nDTEND;VALUE=DATE-TIME:20100215T014500") + (car result))) + (should (string= "s" (cdr result))))) + +(ert-deftest icalendar--diarytime-to-isotime () + "Test method for `icalendar--diarytime-to-isotime'." + (should (string= "T011500" + (icalendar--diarytime-to-isotime "01:15" ""))) + (should (string= "T011500" + (icalendar--diarytime-to-isotime "1:15" ""))) + (should (string= "T000100" + (icalendar--diarytime-to-isotime "0:01" ""))) + (should (string= "T010000" + (icalendar--diarytime-to-isotime "0100" ""))) + (should (string= "T010000" + (icalendar--diarytime-to-isotime "0100" "am"))) + (should (string= "T130000" + (icalendar--diarytime-to-isotime "0100" "pm"))) + (should (string= "T120000" + (icalendar--diarytime-to-isotime "1200" ""))) + (should (string= "T171700" + (icalendar--diarytime-to-isotime "17:17" ""))) + (should (string= "T000000" + (icalendar--diarytime-to-isotime "1200" "am"))) + (should (string= "T000100" + (icalendar--diarytime-to-isotime "1201" "am"))) + (should (string= "T005900" + (icalendar--diarytime-to-isotime "1259" "am"))) + (should (string= "T120000" + (icalendar--diarytime-to-isotime "1200" "pm"))) + (should (string= "T120100" + (icalendar--diarytime-to-isotime "1201" "pm"))) + (should (string= "T125900" + (icalendar--diarytime-to-isotime "1259" "pm"))) + (should (string= "T150000" + (icalendar--diarytime-to-isotime "3" "pm")))) + +(ert-deftest icalendar--datetime-to-diary-date () + "Test method for `icalendar--datetime-to-diary-date'." + (let* ((datetime '(59 59 23 31 12 2008)) + (calendar-date-style 'iso)) + (should (string= "2008 12 31" + (icalendar--datetime-to-diary-date datetime))) + (setq calendar-date-style 'european) + (should (string= "31 12 2008" + (icalendar--datetime-to-diary-date datetime))) + (setq calendar-date-style 'american) + (should (string= "12 31 2008" + (icalendar--datetime-to-diary-date datetime))))) + +(ert-deftest icalendar--datestring-to-isodate () + "Test method for `icalendar--datestring-to-isodate'." + (let ((calendar-date-style 'iso)) + ;; numeric iso + (should (string= "20080511" + (icalendar--datestring-to-isodate "2008 05 11"))) + (should (string= "20080531" + (icalendar--datestring-to-isodate "2008 05 31"))) + (should (string= "20080602" + (icalendar--datestring-to-isodate "2008 05 31" 2))) + + ;; numeric european + (setq calendar-date-style 'european) + (should (string= "20080511" + (icalendar--datestring-to-isodate "11 05 2008"))) + (should (string= "20080531" + (icalendar--datestring-to-isodate "31 05 2008"))) + (should (string= "20080602" + (icalendar--datestring-to-isodate "31 05 2008" 2))) + + ;; numeric american + (setq calendar-date-style 'american) + (should (string= "20081105" + (icalendar--datestring-to-isodate "11 05 2008"))) + (should (string= "20081230" + (icalendar--datestring-to-isodate "12 30 2008"))) + (should (string= "20090101" + (icalendar--datestring-to-isodate "12 30 2008" 2))) + + ;; non-numeric + (setq calendar-date-style nil) ;not necessary for conversion + (should (string= "20081105" + (icalendar--datestring-to-isodate "Nov 05 2008"))) + (should (string= "20081105" + (icalendar--datestring-to-isodate "05 Nov 2008"))) + (should (string= "20081105" + (icalendar--datestring-to-isodate "2008 Nov 05"))))) + +(ert-deftest icalendar--first-weekday-of-year () + "Test method for `icalendar-first-weekday-of-year'." + (should (eq 1 (icalendar-first-weekday-of-year "TU" 2008))) + (should (eq 3 (icalendar-first-weekday-of-year "WE" 2007))) + (should (eq 5 (icalendar-first-weekday-of-year "TH" 2006))) + (should (eq 7 (icalendar-first-weekday-of-year "FR" 2005))) + (should (eq 3 (icalendar-first-weekday-of-year "SA" 2004))) + (should (eq 5 (icalendar-first-weekday-of-year "SU" 2003))) + (should (eq 7 (icalendar-first-weekday-of-year "MO" 2002))) + (should (eq 3 (icalendar-first-weekday-of-year "MO" 2000))) + (should (eq 1 (icalendar-first-weekday-of-year "TH" 1970)))) + +(ert-deftest icalendar--import-format-sample () + "Test method for `icalendar-import-format-sample'." + (should (string= (concat "SUMMARY='a' DESCRIPTION='b' LOCATION='c' " + "ORGANIZER='d' STATUS='' URL='' CLASS=''") + (icalendar-import-format-sample + (icalendar-tests--get-ical-event "BEGIN:VEVENT +DTSTAMP:20030509T043439Z +DTSTART:20030509T103000 +SUMMARY:a +ORGANIZER:d +LOCATION:c +DTEND:20030509T153000 +DESCRIPTION:b +END:VEVENT +"))))) + +(ert-deftest icalendar--format-ical-event () + "Test `icalendar--format-ical-event'." + (let ((icalendar-import-format "%s%d%l%o%t%u%c") + (icalendar-import-format-summary "SUM %s") + (icalendar-import-format-location " LOC %s") + (icalendar-import-format-description " DES %s") + (icalendar-import-format-organizer " ORG %s") + (icalendar-import-format-status " STA %s") + (icalendar-import-format-url " URL %s") + (icalendar-import-format-class " CLA %s") + (event (icalendar-tests--get-ical-event "BEGIN:VEVENT +DTSTAMP:20030509T043439Z +DTSTART:20030509T103000 +SUMMARY:sum +ORGANIZER:org +LOCATION:loc +DTEND:20030509T153000 +DESCRIPTION:des +END:VEVENT +"))) + (should (string= "SUM sum DES des LOC loc ORG org" + (icalendar--format-ical-event event))) + (setq icalendar-import-format (lambda (&rest ignore) + "helloworld")) + (should (string= "helloworld" (icalendar--format-ical-event event))) + (setq icalendar-import-format + (lambda (e) + (format "-%s-%s-%s-%s-%s-%s-%s-" + (icalendar--get-event-property event 'SUMMARY) + (icalendar--get-event-property event 'DESCRIPTION) + (icalendar--get-event-property event 'LOCATION) + (icalendar--get-event-property event 'ORGANIZER) + (icalendar--get-event-property event 'STATUS) + (icalendar--get-event-property event 'URL) + (icalendar--get-event-property event 'CLASS)))) + (should (string= "-sum-des-loc-org-nil-nil-nil-" + (icalendar--format-ical-event event))))) + +(ert-deftest icalendar--parse-summary-and-rest () + "Test `icalendar--parse-summary-and-rest'." + (let ((icalendar-import-format "%s%d%l%o%t%u%c") + (icalendar-import-format-summary "SUM %s") + (icalendar-import-format-location " LOC %s") + (icalendar-import-format-description " DES %s") + (icalendar-import-format-organizer " ORG %s") + (icalendar-import-format-status " STA %s") + (icalendar-import-format-url " URL %s") + (icalendar-import-format-class " CLA %s") + (result)) + (setq result (icalendar--parse-summary-and-rest "SUM sum ORG org")) + (should (string= "org" (cdr (assoc 'org result)))) + + (setq result (icalendar--parse-summary-and-rest + "SUM sum DES des LOC loc ORG org STA sta URL url CLA cla")) + (should (string= "des" (cdr (assoc 'des result)))) + (should (string= "loc" (cdr (assoc 'loc result)))) + (should (string= "org" (cdr (assoc 'org result)))) + (should (string= "sta" (cdr (assoc 'sta result)))) + (should (string= "cla" (cdr (assoc 'cla result)))) + + (setq icalendar-import-format (lambda () "Hello world")) + (setq result (icalendar--parse-summary-and-rest + "blah blah ")) + (should (not result)) + )) + +(ert-deftest icalendar--decode-isodatetime () + "Test `icalendar--decode-isodatetime'." + (let ((tz (getenv "TZ")) + result) + (unwind-protect + (progn + ;; Use Eastern European Time (UTC+2, UTC+3 daylight saving) + (setenv "TZ" "EET-2EEST,M3.5.0/3,M10.5.0/4") + + (message "%s" (current-time-zone (encode-time 0 0 10 1 1 2013 0))) + (message "%s" (current-time-zone (encode-time 0 0 10 1 8 2013 0))) + + ;; testcase: no time zone in input -> keep time as is + ;; 1 Jan 2013 10:00 + (should (equal '(0 0 10 1 1 2013 2 nil 7200) + (icalendar--decode-isodatetime "20130101T100000"))) + ;; 1 Aug 2013 10:00 (DST) + (should (equal '(0 0 10 1 8 2013 4 t 10800) + (icalendar--decode-isodatetime "20130801T100000"))) + + ;; testcase: UTC time zone specifier in input -> convert to local time + ;; 31 Dec 2013 23:00 UTC -> 1 Jan 2013 01:00 EET + (should (equal '(0 0 1 1 1 2014 3 nil 7200) + (icalendar--decode-isodatetime "20131231T230000Z"))) + ;; 1 Aug 2013 10:00 UTC -> 1 Aug 2013 13:00 EEST + (should (equal '(0 0 13 1 8 2013 4 t 10800) + (icalendar--decode-isodatetime "20130801T100000Z"))) + + ) + ;; restore time-zone even if something went terribly wrong + (setenv "TZ" tz))) ) + +;; ====================================================================== +;; Export tests +;; ====================================================================== + +(defun icalendar-tests--test-export (input-iso input-european input-american + expected-output &optional alarms) + "Perform an export test. +Argument INPUT-ISO iso style diary string. +Argument INPUT-EUROPEAN european style diary string. +Argument INPUT-AMERICAN american style diary string. +Argument EXPECTED-OUTPUT expected iCalendar result string. +Optional argument ALARMS the value of `icalendar-export-alarms' for this test. + +European style input data must use german month names. American +and ISO style input data must use english month names." + (let ((tz (getenv "TZ")) + (calendar-date-style 'iso) + (icalendar-recurring-start-year 2000) + (icalendar-export-alarms alarms)) + (unwind-protect + (progn +;;; (message "Current time zone: %s" (current-time-zone)) + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") +;;; (message "Current time zone: %s" (current-time-zone)) + (when input-iso + (let ((calendar-month-name-array + ["January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December"]) + (calendar-day-name-array + ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday"])) + (setq calendar-date-style 'iso) + (icalendar-tests--do-test-export input-iso expected-output))) + (when input-european + (let ((calendar-month-name-array + ["Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" + "September" "Oktober" "November" "Dezember"]) + (calendar-day-name-array + ["Sonntag" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" + "Samstag"])) + (setq calendar-date-style 'european) + (icalendar-tests--do-test-export input-european expected-output))) + (when input-american + (let ((calendar-month-name-array + ["January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December"]) + (calendar-day-name-array + ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday"])) + (setq calendar-date-style 'american) + (icalendar-tests--do-test-export input-american expected-output)))) + ;; restore time-zone even if something went terribly wrong + (setenv "TZ" tz)))) + +(defun icalendar-tests--do-test-export (input expected-output) + "Actually perform export test. +Argument INPUT input diary string. +Argument EXPECTED-OUTPUT expected iCalendar result string." + (let ((temp-file (make-temp-file "icalendar-tests-ics"))) + (unwind-protect + (progn + (with-temp-buffer + (insert input) + (icalendar-export-region (point-min) (point-max) temp-file)) + (save-excursion + (find-file temp-file) + (goto-char (point-min)) + (cond (expected-output + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +UID:emacs[0-9]+ +\\(\\(.\\|\n\\)+\\) +END:VEVENT +END:VCALENDAR +\\s-*$" + nil t)) + (should (string-match + (concat "^\\s-*" + (regexp-quote (buffer-substring-no-properties + (match-beginning 1) (match-end 1))) + "\\s-*$") + expected-output))) + (t + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +END:VCALENDAR +\\s-*$" + nil t)))))) + ;; cleanup!! + (kill-buffer (find-buffer-visiting temp-file)) + (delete-file temp-file)))) + +(ert-deftest icalendar-export-ordinary-no-time () + "Perform export test." + + (let ((icalendar-export-hidden-diary-entries nil)) + (icalendar-tests--test-export + "&2000 Oct 3 ordinary no time " + "&3 Okt 2000 ordinary no time " + "&Oct 3 2000 ordinary no time " + nil)) + + (icalendar-tests--test-export + "2000 Oct 3 ordinary no time " + "3 Okt 2000 ordinary no time " + "Oct 3 2000 ordinary no time " + "DTSTART;VALUE=DATE:20001003 +DTEND;VALUE=DATE:20001004 +SUMMARY:ordinary no time +")) + +(ert-deftest icalendar-export-ordinary () + "Perform export test." + + (icalendar-tests--test-export + "2000 Oct 3 16:30 ordinary with time" + "3 Okt 2000 16:30 ordinary with time" + "Oct 3 2000 16:30 ordinary with time" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:ordinary with time +") + (icalendar-tests--test-export + "2000 10 3 16:30 ordinary with time 2" + "3 10 2000 16:30 ordinary with time 2" + "10 3 2000 16:30 ordinary with time 2" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:ordinary with time 2 +") + + (icalendar-tests--test-export + "2000/10/3 16:30 ordinary with time 3" + "3/10/2000 16:30 ordinary with time 3" + "10/3/2000 16:30 ordinary with time 3" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:ordinary with time 3 +")) + +(ert-deftest icalendar-export-multiline () + "Perform export test." + + ;; multiline -- FIXME!!! + (icalendar-tests--test-export + "2000 October 3 16:30 multiline + 17:30 multiline continued FIXME" + "3 Oktober 2000 16:30 multiline + 17:30 multiline continued FIXME" + "October 3 2000 16:30 multiline + 17:30 multiline continued FIXME" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:multiline +DESCRIPTION: + 17:30 multiline continued FIXME +")) + +(ert-deftest icalendar-export-weekly-by-day () + "Perform export test." + + ;; weekly by day + (icalendar-tests--test-export + "Monday 1:30pm weekly by day with start time" + "Montag 13:30 weekly by day with start time" + "Monday 1:30pm weekly by day with start time" + "DTSTART;VALUE=DATE-TIME:20000103T133000 +DTEND;VALUE=DATE-TIME:20000103T143000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:weekly by day with start time +") + + (icalendar-tests--test-export + "Monday 13:30-15:00 weekly by day with start and end time" + "Montag 13:30-15:00 weekly by day with start and end time" + "Monday 01:30pm-03:00pm weekly by day with start and end time" + "DTSTART;VALUE=DATE-TIME:20000103T133000 +DTEND;VALUE=DATE-TIME:20000103T150000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:weekly by day with start and end time +")) + +(ert-deftest icalendar-export-yearly () + "Perform export test." + ;; yearly + (icalendar-tests--test-export + "may 1 yearly no time" + "1 Mai yearly no time" + "may 1 yearly no time" + "DTSTART;VALUE=DATE:19000501 +DTEND;VALUE=DATE:19000502 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=5;BYMONTHDAY=1 +SUMMARY:yearly no time +")) + +(ert-deftest icalendar-export-anniversary () + "Perform export test." + ;; anniversaries + (icalendar-tests--test-export + "%%(diary-anniversary 1989 10 3) anniversary no time" + "%%(diary-anniversary 3 10 1989) anniversary no time" + "%%(diary-anniversary 10 3 1989) anniversary no time" + "DTSTART;VALUE=DATE:19891003 +DTEND;VALUE=DATE:19891004 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=10;BYMONTHDAY=03 +SUMMARY:anniversary no time +") + (icalendar-tests--test-export + "%%(diary-anniversary 1989 10 3) 19:00-20:00 anniversary with time" + "%%(diary-anniversary 3 10 1989) 19:00-20:00 anniversary with time" + "%%(diary-anniversary 10 3 1989) 19:00-20:00 anniversary with time" + "DTSTART;VALUE=DATE-TIME:19891003T190000 +DTEND;VALUE=DATE-TIME:19891004T200000 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=10;BYMONTHDAY=03 +SUMMARY:anniversary with time +")) + +(ert-deftest icalendar-export-block () + "Perform export test." + ;; block + (icalendar-tests--test-export + "%%(diary-block 2001 6 18 2001 7 6) block no time" + "%%(diary-block 18 6 2001 6 7 2001) block no time" + "%%(diary-block 6 18 2001 7 6 2001) block no time" + "DTSTART;VALUE=DATE:20010618 +DTEND;VALUE=DATE:20010707 +SUMMARY:block no time +") + (icalendar-tests--test-export + "%%(diary-block 2001 6 18 2001 7 6) 13:00-17:00 block with time" + "%%(diary-block 18 6 2001 6 7 2001) 13:00-17:00 block with time" + "%%(diary-block 6 18 2001 7 6 2001) 13:00-17:00 block with time" + "DTSTART;VALUE=DATE-TIME:20010618T130000 +DTEND;VALUE=DATE-TIME:20010618T170000 +RRULE:FREQ=DAILY;INTERVAL=1;UNTIL=20010706 +SUMMARY:block with time +") + (icalendar-tests--test-export + "%%(diary-block 2001 6 18 2001 7 6) 13:00 block no end time" + "%%(diary-block 18 6 2001 6 7 2001) 13:00 block no end time" + "%%(diary-block 6 18 2001 7 6 2001) 13:00 block no end time" + "DTSTART;VALUE=DATE-TIME:20010618T130000 +DTEND;VALUE=DATE-TIME:20010618T140000 +RRULE:FREQ=DAILY;INTERVAL=1;UNTIL=20010706 +SUMMARY:block no end time +")) + +(ert-deftest icalendar-export-alarms () + "Perform export test with different settings for exporting alarms." + ;; no alarm + (icalendar-tests--test-export + "2014 Nov 17 19:30 no alarm" + "17 Nov 2014 19:30 no alarm" + "Nov 17 2014 19:30 no alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:no alarm +" + nil) + + ;; 10 minutes in advance, audio + (icalendar-tests--test-export + "2014 Nov 17 19:30 audio alarm" + "17 Nov 2014 19:30 audio alarm" + "Nov 17 2014 19:30 audio alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:audio alarm +BEGIN:VALARM +ACTION:AUDIO +TRIGGER:-PT10M +END:VALARM +" + '(10 ((audio)))) + + ;; 20 minutes in advance, display + (icalendar-tests--test-export + "2014 Nov 17 19:30 display alarm" + "17 Nov 2014 19:30 display alarm" + "Nov 17 2014 19:30 display alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:display alarm +BEGIN:VALARM +ACTION:DISPLAY +TRIGGER:-PT20M +DESCRIPTION:display alarm +END:VALARM +" + '(20 ((display)))) + + ;; 66 minutes in advance, email + (icalendar-tests--test-export + "2014 Nov 17 19:30 email alarm" + "17 Nov 2014 19:30 email alarm" + "Nov 17 2014 19:30 email alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:email alarm +BEGIN:VALARM +ACTION:EMAIL +TRIGGER:-PT66M +DESCRIPTION:email alarm +SUMMARY:email alarm +ATTENDEE:MAILTO:att.one@email.com +ATTENDEE:MAILTO:att.two@email.com +END:VALARM +" + '(66 ((email ("att.one@email.com" "att.two@email.com"))))) + + ;; 2 minutes in advance, all alarms + (icalendar-tests--test-export + "2014 Nov 17 19:30 all alarms" + "17 Nov 2014 19:30 all alarms" + "Nov 17 2014 19:30 all alarms" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:all alarms +BEGIN:VALARM +ACTION:EMAIL +TRIGGER:-PT2M +DESCRIPTION:all alarms +SUMMARY:all alarms +ATTENDEE:MAILTO:att.one@email.com +ATTENDEE:MAILTO:att.two@email.com +END:VALARM +BEGIN:VALARM +ACTION:AUDIO +TRIGGER:-PT2M +END:VALARM +BEGIN:VALARM +ACTION:DISPLAY +TRIGGER:-PT2M +DESCRIPTION:all alarms +END:VALARM +" + '(2 ((email ("att.one@email.com" "att.two@email.com")) (audio) (display))))) + +;; ====================================================================== +;; Import tests +;; ====================================================================== + +(defun icalendar-tests--test-import (input expected-iso expected-european + expected-american) + "Perform import test. +Argument INPUT icalendar event string. +Argument EXPECTED-ISO expected iso style diary string. +Argument EXPECTED-EUROPEAN expected european style diary string. +Argument EXPECTED-AMERICAN expected american style diary string. +During import test the timezone is set to Central European Time." + (let ((timezone (getenv "TZ"))) + (unwind-protect + (progn + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") + (with-temp-buffer + (if (string-match "^BEGIN:VCALENDAR" input) + (insert input) + (insert "BEGIN:VCALENDAR\nPRODID:-//Emacs//NONSGML icalendar.el//EN\n") + (insert "VERSION:2.0\nBEGIN:VEVENT\n") + (insert input) + (unless (eq (char-before) ?\n) + (insert "\n")) + (insert "END:VEVENT\nEND:VCALENDAR\n")) + (let ((icalendar-import-format "%s%d%l%o%t%u%c%U") + (icalendar-import-format-summary "%s") + (icalendar-import-format-location "\n Location: %s") + (icalendar-import-format-description "\n Desc: %s") + (icalendar-import-format-organizer "\n Organizer: %s") + (icalendar-import-format-status "\n Status: %s") + (icalendar-import-format-url "\n URL: %s") + (icalendar-import-format-class "\n Class: %s") + (icalendar-import-format-uid "\n UID: %s") + calendar-date-style) + (when expected-iso + (setq calendar-date-style 'iso) + (icalendar-tests--do-test-import input expected-iso)) + (when expected-european + (setq calendar-date-style 'european) + (icalendar-tests--do-test-import input expected-european)) + (when expected-american + (setq calendar-date-style 'american) + (icalendar-tests--do-test-import input expected-american))))) + (setenv "TZ" timezone)))) + +(defun icalendar-tests--do-test-import (input expected-output) + "Actually perform import test. +Argument INPUT input icalendar string. +Argument EXPECTED-OUTPUT expected diary string." + (let ((temp-file (make-temp-file "icalendar-test-diary"))) + ;; Test the Catch-the-mysterious-coding-header logic below. + ;; Ruby-mode adds an after-save-hook which inserts the header! + ;; (save-excursion + ;; (find-file temp-file) + ;; (ruby-mode)) + (icalendar-import-buffer temp-file t t) + (save-excursion + (find-file temp-file) + ;; Check for the mysterious "# coding: ..." header, remove it + ;; and give a shout + (goto-char (point-min)) + (when (re-search-forward "# coding: .*?\n" nil t) + (message (concat "%s\n" + "Found mysterious \"# coding ...\" header! Removing it.\n" + "Current Modes: %s, %s\n" + "Current test: %s\n" + "%s") + (make-string 70 ?*) + major-mode + minor-mode-list + (ert-running-test) + (make-string 70 ?*)) + (buffer-disable-undo) + (replace-match "") + (set-buffer-modified-p nil)) + + (let ((result (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= expected-output result))) + (kill-buffer (find-buffer-visiting temp-file)) + (delete-file temp-file)))) + +(ert-deftest icalendar-import-non-recurring () + "Perform standard import tests." + (icalendar-tests--test-import + "SUMMARY:non-recurring +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000" + "&2003/9/19 09:00-11:30 non-recurring\n" + "&19/9/2003 09:00-11:30 non-recurring\n" + "&9/19/2003 09:00-11:30 non-recurring\n") + (icalendar-tests--test-import + "SUMMARY:non-recurring allday +DTSTART;VALUE=DATE-TIME:20030919" + "&2003/9/19 non-recurring allday\n" + "&19/9/2003 non-recurring allday\n" + "&9/19/2003 non-recurring allday\n") + (icalendar-tests--test-import + ;; Checkdoc removes trailing blanks. Therefore: format! + (format "%s\n%s\n%s" "SUMMARY:long " " summary" + "DTSTART;VALUE=DATE:20030919") + "&2003/9/19 long summary\n" + "&19/9/2003 long summary\n" + "&9/19/2003 long summary\n") + (icalendar-tests--test-import + "UID:748f2da0-0d9b-11d8-97af-b4ec8686ea61 +SUMMARY:Sommerferien +STATUS:TENTATIVE +CLASS:PRIVATE +X-MOZILLA-ALARM-DEFAULT-UNITS:Minuten +X-MOZILLA-RECUR-DEFAULT-INTERVAL:0 +DTSTART;VALUE=DATE:20040719 +DTEND;VALUE=DATE:20040828 +DTSTAMP:20031103T011641Z +" + "&%%(and (diary-block 2004 7 19 2004 8 27)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 +" + "&%%(and (diary-block 19 7 2004 27 8 2004)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 +" + "&%%(and (diary-block 7 19 2004 8 27 2004)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 +") + (icalendar-tests--test-import + "UID + :04979712-3902-11d9-93dd-8f9f4afe08da +SUMMARY + :folded summary +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T140000 +DTEND + :20041123T143000 +DTSTAMP + :20041118T013430Z +LAST-MODIFIED + :20041118T013640Z +" + "&2004/11/23 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n" + "&23/11/2004 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n" + "&11/23/2004 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n") + + (icalendar-tests--test-import + "UID + :6161a312-3902-11d9-b512-f764153bb28b +SUMMARY + :another example +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T144500 +DTEND + :20041123T154500 +DTSTAMP + :20041118T013641Z +" + "&2004/11/23 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b\n" + "&23/11/2004 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b\n" + "&11/23/2004 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b\n")) + +(ert-deftest icalendar-import-rrule () + (icalendar-tests--test-import + "SUMMARY:rrule daily +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY; +" + "&%%(and (diary-cyclic 1 2003 9 19)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 1 19 9 2003)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 1 9 19 2003)) 09:00-11:30 rrule daily\n") + ;; RRULE examples + (icalendar-tests--test-import + "SUMMARY:rrule daily +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;INTERVAL=2 +" + "&%%(and (diary-cyclic 2 2003 9 19)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 2 19 9 2003)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 2 9 19 2003)) 09:00-11:30 rrule daily\n") + (icalendar-tests--test-import + "SUMMARY:rrule daily with exceptions +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;INTERVAL=2 +EXDATE:20030921,20030925 +" + "&%%(and (not (diary-date 2003 9 25)) (not (diary-date 2003 9 21)) (diary-cyclic 2 2003 9 19)) 09:00-11:30 rrule daily with exceptions\n" + "&%%(and (not (diary-date 25 9 2003)) (not (diary-date 21 9 2003)) (diary-cyclic 2 19 9 2003)) 09:00-11:30 rrule daily with exceptions\n" + "&%%(and (not (diary-date 9 25 2003)) (not (diary-date 9 21 2003)) (diary-cyclic 2 9 19 2003)) 09:00-11:30 rrule daily with exceptions\n") + (icalendar-tests--test-import + "SUMMARY:rrule weekly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=WEEKLY; +" + "&%%(and (diary-cyclic 7 2003 9 19)) 09:00-11:30 rrule weekly\n" + "&%%(and (diary-cyclic 7 19 9 2003)) 09:00-11:30 rrule weekly\n" + "&%%(and (diary-cyclic 7 9 19 2003)) 09:00-11:30 rrule weekly\n") + (icalendar-tests--test-import + "SUMMARY:rrule monthly no end +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY; +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 9999 1 1)) 09:00-11:30 rrule monthly no end\n" + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 1 1 9999)) 09:00-11:30 rrule monthly no end\n" + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 1 1 9999)) 09:00-11:30 rrule monthly no end\n") + (icalendar-tests--test-import + "SUMMARY:rrule monthly with end +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;UNTIL=20050819; +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2005 8 19)) 09:00-11:30 rrule monthly with end\n" + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 8 2005)) 09:00-11:30 rrule monthly with end\n" + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 8 19 2005)) 09:00-11:30 rrule monthly with end\n") + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20040815 +DTEND;VALUE=DATE:20040816 +SUMMARY:Maria Himmelfahrt +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=8 +" + "&%%(and (diary-anniversary 2004 8 15)) Maria Himmelfahrt\n" + "&%%(and (diary-anniversary 15 8 2004)) Maria Himmelfahrt\n" + "&%%(and (diary-anniversary 8 15 2004)) Maria Himmelfahrt\n") + (icalendar-tests--test-import + "SUMMARY:rrule yearly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=2 +" + "&%%(and (diary-anniversary 2003 9 19)) 09:00-11:30 rrule yearly\n" ;FIXME + "&%%(and (diary-anniversary 19 9 2003)) 09:00-11:30 rrule yearly\n" ;FIXME + "&%%(and (diary-anniversary 9 19 2003)) 09:00-11:30 rrule yearly\n") ;FIXME + (icalendar-tests--test-import + "SUMMARY:rrule count daily short +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;COUNT=1;INTERVAL=1 +" + "&%%(and (diary-cyclic 1 2003 9 19) (diary-block 2003 9 19 2003 9 19)) 09:00-11:30 rrule count daily short\n" + "&%%(and (diary-cyclic 1 19 9 2003) (diary-block 19 9 2003 19 9 2003)) 09:00-11:30 rrule count daily short\n" + "&%%(and (diary-cyclic 1 9 19 2003) (diary-block 9 19 2003 9 19 2003)) 09:00-11:30 rrule count daily short\n") + (icalendar-tests--test-import + "SUMMARY:rrule count daily long +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;COUNT=14;INTERVAL=1 +" + "&%%(and (diary-cyclic 1 2003 9 19) (diary-block 2003 9 19 2003 10 2)) 09:00-11:30 rrule count daily long\n" + "&%%(and (diary-cyclic 1 19 9 2003) (diary-block 19 9 2003 2 10 2003)) 09:00-11:30 rrule count daily long\n" + "&%%(and (diary-cyclic 1 9 19 2003) (diary-block 9 19 2003 10 2 2003)) 09:00-11:30 rrule count daily long\n") + (icalendar-tests--test-import + "SUMMARY:rrule count bi-weekly 3 times +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=WEEKLY;COUNT=3;INTERVAL=2 +" + "&%%(and (diary-cyclic 14 2003 9 19) (diary-block 2003 9 19 2003 10 31)) 09:00-11:30 rrule count bi-weekly 3 times\n" + "&%%(and (diary-cyclic 14 19 9 2003) (diary-block 19 9 2003 31 10 2003)) 09:00-11:30 rrule count bi-weekly 3 times\n" + "&%%(and (diary-cyclic 14 9 19 2003) (diary-block 9 19 2003 10 31 2003)) 09:00-11:30 rrule count bi-weekly 3 times\n") + (icalendar-tests--test-import + "SUMMARY:rrule count monthly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;INTERVAL=1;COUNT=5 +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2004 1 19)) 09:00-11:30 rrule count monthly\n" + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 1 2004)) 09:00-11:30 rrule count monthly\n" + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 1 19 2004)) 09:00-11:30 rrule count monthly\n") + (icalendar-tests--test-import + "SUMMARY:rrule count every second month +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;INTERVAL=2;COUNT=5 +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2004 5 19)) 09:00-11:30 rrule count every second month\n" ;FIXME + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 5 2004)) 09:00-11:30 rrule count every second month\n" ;FIXME + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 5 19 2004)) 09:00-11:30 rrule count every second month\n") ;FIXME + (icalendar-tests--test-import + "SUMMARY:rrule count yearly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=1;COUNT=5 +" + "&%%(and (diary-date t 9 19) (diary-block 2003 9 19 2007 9 19)) 09:00-11:30 rrule count yearly\n" + "&%%(and (diary-date 19 9 t) (diary-block 19 9 2003 19 9 2007)) 09:00-11:30 rrule count yearly\n" + "&%%(and (diary-date 9 19 t) (diary-block 9 19 2003 9 19 2007)) 09:00-11:30 rrule count yearly\n") + (icalendar-tests--test-import + "SUMMARY:rrule count every second year +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=2;COUNT=5 +" + "&%%(and (diary-date t 9 19) (diary-block 2003 9 19 2011 9 19)) 09:00-11:30 rrule count every second year\n" ;FIXME!!! + "&%%(and (diary-date 19 9 t) (diary-block 19 9 2003 19 9 2011)) 09:00-11:30 rrule count every second year\n" ;FIXME!!! + "&%%(and (diary-date 9 19 t) (diary-block 9 19 2003 9 19 2011)) 09:00-11:30 rrule count every second year\n") ;FIXME!!! +) + +(ert-deftest icalendar-import-duration () + ;; duration + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20050217 +SUMMARY:duration +DURATION:P7D +" + "&%%(and (diary-block 2005 2 17 2005 2 23)) duration\n" + "&%%(and (diary-block 17 2 2005 23 2 2005)) duration\n" + "&%%(and (diary-block 2 17 2005 2 23 2005)) duration\n") + (icalendar-tests--test-import + "UID:20041127T183329Z-18215-1001-4536-49109@andromeda +DTSTAMP:20041127T183315Z +LAST-MODIFIED:20041127T183329 +SUMMARY:Urlaub +DTSTART;VALUE=DATE:20011221 +DTEND;VALUE=DATE:20011221 +RRULE:FREQ=DAILY;UNTIL=20011229;INTERVAL=1;WKST=SU +CLASS:PUBLIC +SEQUENCE:1 +CREATED:20041127T183329 +" + "&%%(and (diary-cyclic 1 2001 12 21) (diary-block 2001 12 21 2001 12 29)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n" + "&%%(and (diary-cyclic 1 21 12 2001) (diary-block 21 12 2001 29 12 2001)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n" + "&%%(and (diary-cyclic 1 12 21 2001) (diary-block 12 21 2001 12 29 2001)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n")) + +(ert-deftest icalendar-import-bug-6766 () + ;;bug#6766 -- multiple byday values in a weekly rrule + (icalendar-tests--test-import +"CLASS:PUBLIC +DTEND;TZID=America/New_York:20100421T120000 +DTSTAMP:20100525T141214Z +DTSTART;TZID=America/New_York:20100421T113000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO,WE,TH,FR +SEQUENCE:1 +STATUS:CONFIRMED +SUMMARY:Scrum +TRANSP:OPAQUE +UID:8814e3f9-7482-408f-996c-3bfe486a1262 +END:VEVENT +BEGIN:VEVENT +CLASS:PUBLIC +DTSTAMP:20100525T141214Z +DTSTART;VALUE=DATE:20100422 +DTEND;VALUE=DATE:20100423 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU,TH +SEQUENCE:1 +SUMMARY:Tues + Thurs thinking +TRANSP:OPAQUE +UID:8814e3f9-7482-408f-996c-3bfe486a1263 +" +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 2010 4 21)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 2010 4 22)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 +" +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 21 4 2010)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 22 4 2010)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 +" +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 4 21 2010)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 4 22 2010)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 +")) + +(ert-deftest icalendar-import-multiple-vcalendars () + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20110723 +SUMMARY:event-1 +" + "&2011/7/23 event-1\n" + "&23/7/2011 event-1\n" + "&7/23/2011 event-1\n") + + (icalendar-tests--test-import + "BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0\nBEGIN:VEVENT +DTSTART;VALUE=DATE:20110723 +SUMMARY:event-1 +END:VEVENT +END:VCALENDAR +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110724 +SUMMARY:event-2 +END:VEVENT +END:VCALENDAR +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110725 +SUMMARY:event-3a +END:VEVENT +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110725 +SUMMARY:event-3b +END:VEVENT +END:VCALENDAR +" + "&2011/7/23 event-1\n&2011/7/24 event-2\n&2011/7/25 event-3a\n&2011/7/25 event-3b\n" + "&23/7/2011 event-1\n&24/7/2011 event-2\n&25/7/2011 event-3a\n&25/7/2011 event-3b\n" + "&7/23/2011 event-1\n&7/24/2011 event-2\n&7/25/2011 event-3a\n&7/25/2011 event-3b\n")) + +(ert-deftest icalendar-import-with-uid () + "Perform import test with uid." + (icalendar-tests--test-import + "UID:1234567890uid +SUMMARY:non-recurring +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000" + "&2003/9/19 09:00-11:30 non-recurring\n UID: 1234567890uid\n" + "&19/9/2003 09:00-11:30 non-recurring\n UID: 1234567890uid\n" + "&9/19/2003 09:00-11:30 non-recurring\n UID: 1234567890uid\n")) + +(ert-deftest icalendar-import-with-timezone () + ;; This is known to fail on MS-Windows, because the test assumes + ;; Posix features of specifying DST rules. + :expected-result (if (memq system-type '(windows-nt ms-dos)) + :failed + :passed) + ;; bug#11473 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +BEGIN:VTIMEZONE +TZID:fictional, nonexistent, arbitrary +BEGIN:STANDARD +DTSTART:20100101T000000 +TZOFFSETFROM:+0200 +TZOFFSETTO:-0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=01 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:20101201T000000 +TZOFFSETFROM:-0200 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=11 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +SUMMARY:standardtime +DTSTART;TZID=\"fictional, nonexistent, arbitrary\":20120115T120000 +DTEND;TZID=\"fictional, nonexistent, arbitrary\":20120115T123000 +END:VEVENT +BEGIN:VEVENT +SUMMARY:daylightsavingtime +DTSTART;TZID=\"fictional, nonexistent, arbitrary\":20121215T120000 +DTEND;TZID=\"fictional, nonexistent, arbitrary\":20121215T123000 +END:VEVENT +END:VCALENDAR" + ;; "standardtime" begins first sunday in january and is 4 hours behind CET + ;; "daylightsavingtime" begins first sunday in november and is 1 hour before CET + "&2012/1/15 15:00-15:30 standardtime +&2012/12/15 11:00-11:30 daylightsavingtime +" + nil + nil) + ) +;; ====================================================================== +;; Cycle +;; ====================================================================== +(defun icalendar-tests--test-cycle (input) + "Perform cycle test. +Argument INPUT icalendar event string." + (with-temp-buffer + (if (string-match "^BEGIN:VCALENDAR" input) + (insert input) + (insert "BEGIN:VCALENDAR\nPRODID:-//Emacs//NONSGML icalendar.el//EN\n") + (insert "VERSION:2.0\nBEGIN:VEVENT\n") + (insert input) + (unless (eq (char-before) ?\n) + (insert "\n")) + (insert "END:VEVENT\nEND:VCALENDAR\n")) + (let ((icalendar-import-format "%s%d%l%o%t%u%c%U") + (icalendar-import-format-summary "%s") + (icalendar-import-format-location "\n Location: %s") + (icalendar-import-format-description "\n Desc: %s") + (icalendar-import-format-organizer "\n Organizer: %s") + (icalendar-import-format-status "\n Status: %s") + (icalendar-import-format-url "\n URL: %s") + (icalendar-import-format-class "\n Class: %s") + (icalendar-import-format-class "\n UID: %s") + (icalendar-export-alarms nil)) + (dolist (calendar-date-style '(iso european american)) + (icalendar-tests--do-test-cycle))))) + +(defun icalendar-tests--do-test-cycle () + "Actually perform import/export cycle test." + (let ((temp-diary (make-temp-file "icalendar-test-diary")) + (temp-ics (make-temp-file "icalendar-test-ics")) + (org-input (buffer-substring-no-properties (point-min) (point-max)))) + + (unwind-protect + (progn + ;; step 1: import + (icalendar-import-buffer temp-diary t t) + + ;; step 2: export what was just imported + (save-excursion + (find-file temp-diary) + (icalendar-export-region (point-min) (point-max) temp-ics)) + + ;; compare the output of step 2 with the input of step 1 + (save-excursion + (find-file temp-ics) + (goto-char (point-min)) + ;;(when (re-search-forward "\nUID:.*\n" nil t) + ;;(replace-match "\n")) + (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= org-input cycled))))) + ;; clean up + (kill-buffer (find-buffer-visiting temp-diary)) + (with-current-buffer (find-buffer-visiting temp-ics) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (delete-file temp-diary) + (delete-file temp-ics)))) + +(ert-deftest icalendar-cycle () + "Perform cycling tests. +Take care to avoid auto-generated UIDs here." + (icalendar-tests--test-cycle + "UID:dummyuid +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +SUMMARY:Cycletest +") + (icalendar-tests--test-cycle + "UID:blah +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +SUMMARY:Cycletest +DESCRIPTION:beschreibung! +LOCATION:nowhere +ORGANIZER:ulf +") + (icalendar-tests--test-cycle + "UID:4711 +DTSTART;VALUE=DATE:19190909 +DTEND;VALUE=DATE:19190910 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=09;BYMONTHDAY=09 +SUMMARY:and diary-anniversary +")) + +;; ====================================================================== +;; Real world +;; ====================================================================== +(ert-deftest icalendar-real-world () + "Perform real-world tests, as gathered from problem reports." + ;; This is known to fail on MS-Windows, since it doesn't support DST + ;; specification with month and day. + :expected-result (if (memq system-type '(windows-nt ms-dos)) + :failed + :passed) + ;; 2003-05-29 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft CDO for Microsoft Exchange +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:Kolkata, Chennai, Mumbai, New Delhi +X-MICROSOFT-CDO-TZID:23 +BEGIN:STANDARD +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20030509T043439Z +DTSTART;TZID=\"Kolkata, Chennai, Mumbai, New Delhi\":20030509T103000 +SUMMARY:On-Site Interview +UID:040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000 + 010000000DB823520692542408ED02D7023F9DFF9 +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Xxxxx + xxx Xxxxxxxxxxxx\":MAILTO:xxxxxxxx@xxxxxxx.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Yyyyyyy Y + yyyy\":MAILTO:yyyyyyy@yyyyyyy.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Zzzz Zzzz + zz\":MAILTO:zzzzzz@zzzzzzz.com +ORGANIZER;CN=\"Aaaaaa Aaaaa\":MAILTO:aaaaaaa@aaaaaaa.com +LOCATION:Cccc +DTEND;TZID=\"Kolkata, Chennai, Mumbai, New Delhi\":20030509T153000 +DESCRIPTION:10:30am - Blah +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030509T043439Z +LAST-MODIFIED:20030509T043459Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:126441427 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM +END:VEVENT +END:VCALENDAR" + nil + "&9/5/2003 07:00-12:00 On-Site Interview + Desc: 10:30am - Blah + Location: Cccc + Organizer: MAILTO:aaaaaaa@aaaaaaa.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 +" + "&5/9/2003 07:00-12:00 On-Site Interview + Desc: 10:30am - Blah + Location: Cccc + Organizer: MAILTO:aaaaaaa@aaaaaaa.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 +") + + ;; created with http://apps.marudot.com/ical/ + (icalendar-tests--test-import + "BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//www.marudot.com//iCal Event Maker +X-WR-CALNAME:Test +CALSCALE:GREGORIAN +BEGIN:VTIMEZONE +TZID:Asia/Tehran +TZURL:http://tzurl.org/zoneinfo-outlook/Asia/Tehran +X-LIC-LOCATION:Asia/Tehran +BEGIN:STANDARD +TZOFFSETFROM:+0330 +TZOFFSETTO:+0330 +TZNAME:IRST +DTSTART:19700101T000000 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20141116T171439Z +UID:20141116T171439Z-678877132@marudot.com +DTSTART;TZID=\"Asia/Tehran\":20141116T070000 +DTEND;TZID=\"Asia/Tehran\":20141116T080000 +SUMMARY:NoDST +DESCRIPTION:Test event from timezone without DST +LOCATION:Everywhere +END:VEVENT +END:VCALENDAR" + nil + "&16/11/2014 04:30-05:30 NoDST + Desc: Test event from timezone without DST + Location: Everywhere + UID: 20141116T171439Z-678877132@marudot.com +" + "&11/16/2014 04:30-05:30 NoDST + Desc: Test event from timezone without DST + Location: Everywhere + UID: 20141116T171439Z-678877132@marudot.com +") + + + ;; 2003-06-18 a + (icalendar-tests--test-import + "DTSTAMP:20030618T195512Z +DTSTART;TZID=\"Mountain Time (US & Canada)\":20030623T110000 +SUMMARY:Dress Rehearsal for XXXX-XXXX +UID:040000008200E00074C5B7101A82E00800000000608AA7DA9835C301000000000000000 + 0100000007C3A6D65EE726E40B7F3D69A23BD567E +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"AAAAA,AAA + AA (A-AAAAAAA,ex1)\":MAILTO:aaaaa_aaaaa@aaaaa.com +ORGANIZER;CN=\"ABCD,TECHTRAINING + (A-Americas,exgen1)\":MAILTO:xxx@xxxxx.com +LOCATION:555 or TN 555-5555 ID 5555 & NochWas (see below) +DTEND;TZID=\"Mountain Time (US & Canada)\":20030623T120000 +DESCRIPTION:753 Zeichen hier radiert +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030618T195518Z +LAST-MODIFIED:20030618T195527Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:1022519251 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM" + nil + "&23/6/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX + Desc: 753 Zeichen hier radiert + Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) + Organizer: MAILTO:xxx@xxxxx.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +" + "&6/23/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX + Desc: 753 Zeichen hier radiert + Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) + Organizer: MAILTO:xxx@xxxxx.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +") + ;; 2003-06-18 b -- uses timezone + (icalendar-tests--test-import + "BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft CDO for Microsoft Exchange +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:Mountain Time (US & Canada) +X-MICROSOFT-CDO-TZID:12 +BEGIN:STANDARD +DTSTART:16010101T020000 +TZOFFSETFROM:-0600 +TZOFFSETTO:-0700 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=10;BYDAY=-1SU +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T020000 +TZOFFSETFROM:-0700 +TZOFFSETTO:-0600 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=4;BYDAY=1SU +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20030618T230323Z +DTSTART;TZID=\"Mountain Time (US & Canada)\":20030623T090000 +SUMMARY:Updated: Dress Rehearsal for ABC01-15 +UID:040000008200E00074C5B7101A82E00800000000608AA7DA9835C301000000000000000 + 0100000007C3A6D65EE726E40B7F3D69A23BD567E +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;X-REPLYTIME=20030618T20 + 0700Z;RSVP=TRUE;CN=\"AAAAA,AAAAAA +\(A-AAAAAAA,ex1)\":MAILTO:aaaaaa_aaaaa@aaaaa + .com +ORGANIZER;CN=\"ABCD,TECHTRAINING +\(A-Americas,exgen1)\":MAILTO:bbb@bbbbb.com +LOCATION:123 or TN 123-1234 ID abcd & SonstWo (see below) +DTEND;TZID=\"Mountain Time (US & Canada)\":20030623T100000 +DESCRIPTION:Viele Zeichen standen hier früher +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030618T230326Z +LAST-MODIFIED:20030618T230335Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:1022519251 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM +END:VEVENT +END:VCALENDAR" + nil + "&23/6/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 + Desc: Viele Zeichen standen hier früher + Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) + Organizer: MAILTO:bbb@bbbbb.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +" + "&6/23/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 + Desc: Viele Zeichen standen hier früher + Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) + Organizer: MAILTO:bbb@bbbbb.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +") + ;; export 2004-10-28 block entries + (icalendar-tests--test-export + nil + nil + "-*- mode: text; fill-column: 256;-*- + +>>> block entries: + +%%(diary-block 11 8 2004 11 10 2004) Nov 8-10 aa +" + "DTSTART;VALUE=DATE:20041108 +DTEND;VALUE=DATE:20041111 +SUMMARY:Nov 8-10 aa") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 12 13 2004 12 17 2004) Dec 13-17 bb" + "DTSTART;VALUE=DATE:20041213 +DTEND;VALUE=DATE:20041218 +SUMMARY:Dec 13-17 bb") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 2 3 2005 2 4 2005) Feb 3-4 cc" + "DTSTART;VALUE=DATE:20050203 +DTEND;VALUE=DATE:20050205 +SUMMARY:Feb 3-4 cc") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 4 24 2005 4 29 2005) April 24-29 dd" + "DTSTART;VALUE=DATE:20050424 +DTEND;VALUE=DATE:20050430 +SUMMARY:April 24-29 dd +") + (icalendar-tests--test-export + nil + nil + "%%(diary-block 5 30 2005 6 1 2005) may 30 - June 1: ee" + "DTSTART;VALUE=DATE:20050530 +DTEND;VALUE=DATE:20050602 +SUMMARY:may 30 - June 1: ee") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 6 6 2005 6 8 2005) ff" + "DTSTART;VALUE=DATE:20050606 +DTEND;VALUE=DATE:20050609 +SUMMARY:ff") + + ;; export 2004-10-28 anniversary entries + (icalendar-tests--test-export + nil + nil + " +>>> anniversaries: + +%%(diary-anniversary 3 28 1991) aa birthday (%d years old)" + "DTSTART;VALUE=DATE:19910328 +DTEND;VALUE=DATE:19910329 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=03;BYMONTHDAY=28 +SUMMARY:aa birthday (%d years old) +") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 5 17 1957) bb birthday (%d years old)" + "DTSTART;VALUE=DATE:19570517 +DTEND;VALUE=DATE:19570518 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=05;BYMONTHDAY=17 +SUMMARY:bb birthday (%d years old)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 6 8 1997) cc birthday (%d years old)" + "DTSTART;VALUE=DATE:19970608 +DTEND;VALUE=DATE:19970609 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=06;BYMONTHDAY=08 +SUMMARY:cc birthday (%d years old)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 7 22 1983) dd (%d years ago...!)" + "DTSTART;VALUE=DATE:19830722 +DTEND;VALUE=DATE:19830723 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=07;BYMONTHDAY=22 +SUMMARY:dd (%d years ago...!)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 8 1 1988) ee birthday (%d years old)" + "DTSTART;VALUE=DATE:19880801 +DTEND;VALUE=DATE:19880802 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=08;BYMONTHDAY=01 +SUMMARY:ee birthday (%d years old)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 9 21 1957) ff birthday (%d years old)" + "DTSTART;VALUE=DATE:19570921 +DTEND;VALUE=DATE:19570922 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=09;BYMONTHDAY=21 +SUMMARY:ff birthday (%d years old)") + + + ;; FIXME! + + ;; export 2004-10-28 monthly, weekly entries + + ;; (icalendar-tests--test-export + ;; nil + ;; " + ;; >>> ------------ monthly: + + ;; */27/* 10:00 blah blah" + ;; "xxx") + + (icalendar-tests--test-export + nil + nil + ">>> ------------ my week: + +Monday 13:00 MAC" + "DTSTART;VALUE=DATE-TIME:20000103T130000 +DTEND;VALUE=DATE-TIME:20000103T140000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:MAC") + + (icalendar-tests--test-export + nil + nil + "Monday 15:00 a1" + "DTSTART;VALUE=DATE-TIME:20000103T150000 +DTEND;VALUE=DATE-TIME:20000103T160000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:a1") + + + (icalendar-tests--test-export + nil + nil + "Monday 16:00-17:00 a2" + "DTSTART;VALUE=DATE-TIME:20000103T160000 +DTEND;VALUE=DATE-TIME:20000103T170000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:a2") + + (icalendar-tests--test-export + nil + nil + "Tuesday 11:30-13:00 a3" + "DTSTART;VALUE=DATE-TIME:20000104T113000 +DTEND;VALUE=DATE-TIME:20000104T130000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU +SUMMARY:a3") + + (icalendar-tests--test-export + nil + nil + "Tuesday 15:00 a4" + "DTSTART;VALUE=DATE-TIME:20000104T150000 +DTEND;VALUE=DATE-TIME:20000104T160000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU +SUMMARY:a4") + + (icalendar-tests--test-export + nil + nil + "Wednesday 13:00 a5" + "DTSTART;VALUE=DATE-TIME:20000105T130000 +DTEND;VALUE=DATE-TIME:20000105T140000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=WE +SUMMARY:a5") + + (icalendar-tests--test-export + nil + nil + "Wednesday 11:30-13:30 a6" + "DTSTART;VALUE=DATE-TIME:20000105T113000 +DTEND;VALUE=DATE-TIME:20000105T133000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=WE +SUMMARY:a6") + + (icalendar-tests--test-export + nil + nil + "Wednesday 15:00 s1" + "DTSTART;VALUE=DATE-TIME:20000105T150000 +DTEND;VALUE=DATE-TIME:20000105T160000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=WE +SUMMARY:s1") + + + ;; export 2004-10-28 regular entries + (icalendar-tests--test-export + nil + nil + " +>>> regular diary entries: + +Oct 12 2004, 14:00 Tue: [2004-10-12] q1" + "DTSTART;VALUE=DATE-TIME:20041012T140000 +DTEND;VALUE=DATE-TIME:20041012T150000 +SUMMARY:Tue: [2004-10-12] q1") + + ;; 2004-11-19 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +VERSION + :2.0 +PRODID + :-//Mozilla.org/NONSGML Mozilla Calendar V1.0//EN +BEGIN:VEVENT +SUMMARY + :Jjjjj & Wwwww +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T140000 +DTEND + :20041123T143000 +DTSTAMP + :20041118T013430Z +LAST-MODIFIED + :20041118T013640Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :BB Aaaaaaaa Bbbbb +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T144500 +DTEND + :20041123T154500 +DTSTAMP + :20041118T013641Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Hhhhhhhh +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T110000 +DTEND + :20041123T120000 +DTSTAMP + :20041118T013831Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :MMM Aaaaaaaaa +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +X-MOZILLA-RECUR-DEFAULT-INTERVAL + :2 +RRULE + :FREQ=WEEKLY;INTERVAL=2;BYDAY=FR +DTSTART + :20041112T140000 +DTEND + :20041112T183000 +DTSTAMP + :20041118T014117Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Rrrr/Cccccc ii Aaaaaaaa +DESCRIPTION + :Vvvvv Rrrr aaa Cccccc +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + ;VALUE=DATE + :20041119 +DTEND + ;VALUE=DATE + :20041120 +DTSTAMP + :20041118T013107Z +LAST-MODIFIED + :20041118T014203Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Wwww aa hhhh +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +RRULE + :FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +DTSTART + ;VALUE=DATE + :20041101 +DTEND + ;VALUE=DATE + :20041102 +DTSTAMP + :20041118T014045Z +LAST-MODIFIED + :20041118T023846Z +END:VEVENT +END:VCALENDAR +" + nil + "&23/11/2004 14:00-14:30 Jjjjj & Wwwww + Status: TENTATIVE + Class: PRIVATE +&23/11/2004 14:45-15:45 BB Aaaaaaaa Bbbbb + Status: TENTATIVE + Class: PRIVATE +&23/11/2004 11:00-12:00 Hhhhhhhh + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 14 12 11 2004)) 14:00-18:30 MMM Aaaaaaaaa + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-block 19 11 2004 19 11 2004)) Rrrr/Cccccc ii Aaaaaaaa + Desc: Vvvvv Rrrr aaa Cccccc + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 7 1 11 2004)) Wwww aa hhhh + Status: TENTATIVE + Class: PRIVATE +" + "&11/23/2004 14:00-14:30 Jjjjj & Wwwww + Status: TENTATIVE + Class: PRIVATE +&11/23/2004 14:45-15:45 BB Aaaaaaaa Bbbbb + Status: TENTATIVE + Class: PRIVATE +&11/23/2004 11:00-12:00 Hhhhhhhh + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 14 11 12 2004)) 14:00-18:30 MMM Aaaaaaaaa + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-block 11 19 2004 11 19 2004)) Rrrr/Cccccc ii Aaaaaaaa + Desc: Vvvvv Rrrr aaa Cccccc + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 7 11 1 2004)) Wwww aa hhhh + Status: TENTATIVE + Class: PRIVATE +") + + ;; 2004-09-09 pg + (icalendar-tests--test-export + "%%(diary-block 1 1 2004 4 1 2004) Urlaub" + nil + nil + "DTSTART;VALUE=DATE:20040101 +DTEND;VALUE=DATE:20040105 +SUMMARY:Urlaub") + + ;; 2004-10-25 pg + (icalendar-tests--test-export + nil + "5 11 2004 Bla Fasel" + nil + "DTSTART;VALUE=DATE:20041105 +DTEND;VALUE=DATE:20041106 +SUMMARY:Bla Fasel") + + ;; 2004-10-30 pg + (icalendar-tests--test-export + nil + "2 Nov 2004 15:00-16:30 Zahnarzt" + nil + "DTSTART;VALUE=DATE-TIME:20041102T150000 +DTEND;VALUE=DATE-TIME:20041102T163000 +SUMMARY:Zahnarzt") + + ;; 2005-02-07 lt + (icalendar-tests--test-import + "UID + :b60d398e-1dd1-11b2-a159-cf8cb05139f4 +SUMMARY + :Waitangi Day +DESCRIPTION + :abcdef +CATEGORIES + :Public Holiday +STATUS + :CONFIRMED +CLASS + :PRIVATE +DTSTART + ;VALUE=DATE + :20050206 +DTEND + ;VALUE=DATE + :20050207 +DTSTAMP + :20050128T011209Z" + nil + "&%%(and (diary-block 6 2 2005 6 2 2005)) Waitangi Day + Desc: abcdef + Status: CONFIRMED + Class: PRIVATE + UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 +" + "&%%(and (diary-block 2 6 2005 2 6 2005)) Waitangi Day + Desc: abcdef + Status: CONFIRMED + Class: PRIVATE + UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 +") + + ;; 2005-03-01 lt + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20050217 +SUMMARY:Hhhhhh Aaaaa ii Aaaaaaaa +UID:6AFA7558-6994-11D9-8A3A-000A95A0E830-RID +DTSTAMP:20050118T210335Z +DURATION:P7D" + nil + "&%%(and (diary-block 17 2 2005 23 2 2005)) Hhhhhh Aaaaa ii Aaaaaaaa + UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID\n" + "&%%(and (diary-block 2 17 2005 2 23 2005)) Hhhhhh Aaaaa ii Aaaaaaaa + UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID\n") + + ;; 2005-03-23 lt + (icalendar-tests--test-export + nil + "&%%(diary-cyclic 7 8 2 2005) 16:00-16:45 [WORK] Pppp" + nil + "DTSTART;VALUE=DATE-TIME:20050208T160000 +DTEND;VALUE=DATE-TIME:20050208T164500 +RRULE:FREQ=DAILY;INTERVAL=7 +SUMMARY:[WORK] Pppp +") + + ;; 2005-05-27 eu + (icalendar-tests--test-export + nil + nil + ;; FIXME: colon not allowed! + ;;"Nov 1: NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30" + "Nov 1 NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30" + "DTSTART;VALUE=DATE:19001101 +DTEND;VALUE=DATE:19001102 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=11;BYMONTHDAY=1 +SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 +") + + ;; bug#11473 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft Exchange Server 2007 +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna +BEGIN:STANDARD +DTSTART:16010101T030000 +TZOFFSETFROM:+0200 +TZOFFSETTO:+0100 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=10 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T020000 +TZOFFSETFROM:+0100 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=3 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +ORGANIZER;CN=\"A. Luser\":MAILTO:a.luser@foo.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Luser, Oth + er\":MAILTO:other.luser@foo.com +DESCRIPTION;LANGUAGE=en-US:\nWhassup?\n\n +SUMMARY;LANGUAGE=en-US:Query +DTSTART;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna\" + :20120515T150000 +DTEND;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna\":2 + 0120515T153000 +UID:040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000 + 010000000575268034ECDB649A15349B1BF240F15 +RECURRENCE-ID;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, V + ienna\":20120515T170000 +CLASS:PUBLIC +PRIORITY:5 +DTSTAMP:20120514T153645Z +TRANSP:OPAQUE +STATUS:CONFIRMED +SEQUENCE:15 +LOCATION;LANGUAGE=en-US:phone +X-MICROSOFT-CDO-APPT-SEQUENCE:15 +X-MICROSOFT-CDO-OWNERAPPTID:1907632092 +X-MICROSOFT-CDO-BUSYSTATUS:TENTATIVE +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-INSTTYPE:3 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT15M +END:VALARM +END:VEVENT +END:VCALENDAR" + nil + "&15/5/2012 15:00-15:30 Query + Location: phone + Organizer: MAILTO:a.luser@foo.com + Status: CONFIRMED + Class: PUBLIC + UID: 040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000010000000575268034ECDB649A15349B1BF240F15 +" nil) + + ;; 2015-12-05, mixed line endings and empty lines, see Bug#22092. + (icalendar-tests--test-import + "BEGIN:VCALENDAR\r +PRODID:-//www.norwegian.no//iCalendar MIMEDIR//EN\r +VERSION:2.0\r +METHOD:REQUEST\r +BEGIN:VEVENT\r +UID:RFCALITEM1\r +SEQUENCE:1512040950\r +DTSTAMP:20141204T095043Z\r +ORGANIZER:noreply@norwegian.no\r +DTSTART:20141208T173000Z\r + +DTEND:20141208T215500Z\r + +LOCATION:Stavanger-Sola\r + +DESCRIPTION:Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390\r + +X-ALT-DESC;FMTTYPE=text/html:Reisereferanse

+SUMMARY:Norwegian til Tromsoe-Langnes -\r + +CATEGORIES:Appointment\r + + +PRIORITY:5\r + +CLASS:PUBLIC\r + +TRANSP:OPAQUE\r +END:VEVENT\r +END:VCALENDAR +" +"&2014/12/8 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 +" +"&8/12/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 +" +"&12/8/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 +" +) + ) + +(provide 'icalendar-tests) +;;; icalendar-tests.el ends here diff --cc test/lisp/character-fold-tests.el index c0568625649,00000000000..c611217712e mode 100644,000000..100644 --- a/test/lisp/character-fold-tests.el +++ b/test/lisp/character-fold-tests.el @@@ -1,124 -1,0 +1,124 @@@ +;;; character-fold-tests.el --- Tests for character-fold.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) +(require 'character-fold) + +(defun character-fold--random-word (n) + (mapconcat (lambda (_) (string (+ 9 (random 117)))) + (make-list n nil) "")) + +(defun character-fold--test-search-with-contents (contents string) + (with-temp-buffer + (insert contents) + (goto-char (point-min)) + (should (search-forward-regexp (character-fold-to-regexp string) nil 'noerror)) + (goto-char (point-min)) + (should (character-fold-search-forward string nil 'noerror)) + (should (character-fold-search-backward string nil 'noerror)))) + + +(ert-deftest character-fold--test-consistency () + (dotimes (n 30) + (let ((w (character-fold--random-word n))) + ;; A folded string should always match the original string. + (character-fold--test-search-with-contents w w)))) + +(ert-deftest character-fold--test-lax-whitespace () + (dotimes (n 40) + (let ((w1 (character-fold--random-word n)) + (w2 (character-fold--random-word n)) + (search-spaces-regexp "\\s-+")) + (character-fold--test-search-with-contents + (concat w1 "\s\n\s\t\f\t\n\r\t" w2) + (concat w1 " " w2)) + (character-fold--test-search-with-contents + (concat w1 "\s\n\s\t\f\t\n\r\t" w2) + (concat w1 (make-string 10 ?\s) w2))))) + +(defun character-fold--test-match-exactly (string &rest strings-to-match) + (let ((re (concat "\\`" (character-fold-to-regexp string) "\\'"))) + (dolist (it strings-to-match) + (should (string-match re it))) + ;; Case folding + (let ((case-fold-search t)) + (dolist (it strings-to-match) + (should (string-match (upcase re) (downcase it))) + (should (string-match (downcase re) (upcase it))))))) + +(ert-deftest character-fold--test-some-defaults () + (dolist (it '(("ffl" . "ffl") ("ffi" . "ffi") + ("fi" . "fi") ("ff" . "ff") + ("ä" . "ä"))) + (character-fold--test-search-with-contents (cdr it) (car it)) + (let ((multi (char-table-extra-slot character-fold-table 0)) + (character-fold-table (make-char-table 'character-fold-table))) + (set-char-table-extra-slot character-fold-table 0 multi) + (character-fold--test-match-exactly (car it) (cdr it))))) + +(ert-deftest character-fold--test-fold-to-regexp () + (let ((character-fold-table (make-char-table 'character-fold-table)) + (multi (make-char-table 'character-fold-table))) + (set-char-table-extra-slot character-fold-table 0 multi) + (aset character-fold-table ?a "xx") + (aset character-fold-table ?1 "44") + (aset character-fold-table ?\s "-!-") + (character-fold--test-match-exactly "a1a1" "xx44xx44") + (character-fold--test-match-exactly "a1 a 1" "xx44-!--!-xx-!-44") + (aset multi ?a '(("1" . "99") + ("2" . "88") + ("12" . "77"))) + (character-fold--test-match-exactly "a" "xx") + (character-fold--test-match-exactly "a1" "xx44" "99") + (character-fold--test-match-exactly "a12" "77" "xx442" "992") + (character-fold--test-match-exactly "a2" "88") + (aset multi ?1 '(("2" . "yy"))) + (character-fold--test-match-exactly "a1" "xx44" "99") + (character-fold--test-match-exactly "a12" "77" "xx442" "992") + ;; Support for this case is disabled. See function definition or: + ;; https://lists.gnu.org/archive/html/emacs-devel/2015-11/msg02562.html + ;; (character-fold--test-match-exactly "a12" "xxyy") + )) + +(ert-deftest character-fold--speed-test () + (dolist (string (append '("tty-set-up-initial-frame-face" + "tty-set-up-initial-frame-face-frame-faceframe-faceframe-faceframe-face") + (mapcar #'character-fold--random-word '(10 50 100 + 50 100)))) + (message "Testing %s" string) + ;; Make sure we didn't just fallback on the trivial search. + (should-not (string= (regexp-quote string) + (character-fold-to-regexp string))) + (with-temp-buffer + (save-excursion (insert string)) + (let ((time (time-to-seconds (current-time)))) + ;; Our initial implementation of case-folding in char-folding + ;; created a lot of redundant paths in the regexp. Because of + ;; that, if a really long string "almost" matches, the regexp + ;; engine took a long time to realize that it doesn't match. + (should-not (character-fold-search-forward (concat string "c") nil 'noerror)) + ;; Ensure it took less than a second. + (should (< (- (time-to-seconds (current-time)) + time) + 1)))))) + +(provide 'character-fold-tests) +;;; character-fold-tests.el ends here diff --cc test/lisp/comint-tests.el index 53f0a0dac0d,00000000000..576be238408 mode 100644,000000..100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@@ -1,54 -1,0 +1,54 @@@ +;;; comint-testsuite.el + - ;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2010-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Tests for comint and related modes. + +;;; Code: + +(require 'comint) +(require 'ert) + +(defvar comint-testsuite-password-strings + '("foo@example.net's password: " ; ssh + "Password for foo@example.org: " ; kinit + "Please enter the password for foo@example.org: " ; kinit + "Kerberos password for devnull/root GNU.ORG: " ; ksu + "Enter passphrase: " ; ssh-add + "Enter passphrase (empty for no passphrase): " ; ssh-keygen + "Enter same passphrase again: " ; ssh-keygen + "Passphrase for key root@GNU.ORG: " ; plink + "[sudo] password for user:" ; Ubuntu sudo + "Password (again):" + "Enter password:" + "Mot de Passe:" ; localized + "Passwort:") ; localized + "List of strings that should match `comint-password-prompt-regexp'.") + +(ert-deftest comint-test-password-regexp () + "Test `comint-password-prompt-regexp' against common password strings." + (dolist (str comint-testsuite-password-strings) + (should (string-match comint-password-prompt-regexp str)))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; comint-testsuite.el ends here diff --cc test/lisp/descr-text-tests.el index 81ae727f076,00000000000..9e851c3a119 mode 100644,000000..100644 --- a/test/lisp/descr-text-tests.el +++ b/test/lisp/descr-text-tests.el @@@ -1,94 -1,0 +1,94 @@@ +;;; descr-text-test.el --- ERT tests for descr-text.el -*- lexical-binding: t -*- + - ;; Copyright (C) 2014 Free Software Foundation, Inc. ++;; Copyright (C) 2014, 2016 Free Software Foundation, Inc. + +;; Author: Michal Nazarewicz + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This package defines regression tests for the descr-text package. + +;;; Code: + +(require 'ert) +(require 'descr-text) + + +(ert-deftest descr-text-test-truncate () + "Tests describe-char-eldoc--truncate function." + (should (equal "" + (describe-char-eldoc--truncate " \t \n" 100))) + (should (equal "foo" + (describe-char-eldoc--truncate "foo" 1))) + (should (equal "foo..." + (describe-char-eldoc--truncate "foo wilma fred" 0))) + (should (equal "foo..." + (describe-char-eldoc--truncate + "foo wilma fred" (length "foo wilma")))) + (should (equal "foo wilma..." + (describe-char-eldoc--truncate + "foo wilma fred" (+ 3 (length "foo wilma"))))) + (should (equal "foo wilma..." + (describe-char-eldoc--truncate + "foo wilma fred" (1- (length "foo wilma fred"))))) + (should (equal "foo wilma fred" + (describe-char-eldoc--truncate + "foo wilma fred" (length "foo wilma fred")))) + (should (equal "foo wilma fred" + (describe-char-eldoc--truncate + " foo\t wilma \nfred\t " (length "foo wilma fred"))))) + +(ert-deftest descr-text-test-format-desc () + "Tests describe-char-eldoc--format function." + (should (equal "U+2026: Horizontal ellipsis (Po: Punctuation, Other)" + (describe-char-eldoc--format ?…))) + (should (equal "U+2026: Horizontal ellipsis (Punctuation, Other)" + (describe-char-eldoc--format ?… 51))) + (should (equal "U+2026: Horizontal ellipsis (Po)" + (describe-char-eldoc--format ?… 40))) + (should (equal "Horizontal ellipsis (Po)" + (describe-char-eldoc--format ?… 30))) + (should (equal "Horizontal ellipsis" + (describe-char-eldoc--format ?… 20))) + (should (equal "Horizontal..." + (describe-char-eldoc--format ?… 10)))) + +(ert-deftest descr-text-test-desc () + "Tests describe-char-eldoc function." + (with-temp-buffer + (insert "a…") + (goto-char (point-min)) + (should (eq ?a (following-char))) ; make sure we are where we think we are + ;; Function should return nil for an ASCII character. + (should (not (describe-char-eldoc))) + + (goto-char (1+ (point))) + (should (eq ?… (following-char))) + (let ((eldoc-echo-area-use-multiline-p t)) + ;; Function should return description of an Unicode character. + (should (equal "U+2026: Horizontal ellipsis (Po: Punctuation, Other)" + (describe-char-eldoc)))) + + (goto-char (point-max)) + ;; At the end of the buffer, function should return nil and not blow up. + (should (not (describe-char-eldoc))))) + + +(provide 'descr-text-test) + +;;; descr-text-test.el ends here diff --cc test/lisp/electric-tests.el index b675989c072,00000000000..107b2e79fb6 mode 100644,000000..100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@@ -1,588 -1,0 +1,588 @@@ +;;; electric-tests.el --- tests for electric.el + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: João Távora +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Tests for Electric Pair mode. +;; TODO: Add tests for other Electric-* functionality + +;;; Code: +(require 'ert) +(require 'ert-x) +(require 'electric) +(require 'elec-pair) +(require 'cl-lib) + +(defun call-with-saved-electric-modes (fn) + (let ((saved-electric (if electric-pair-mode 1 -1)) + (saved-layout (if electric-layout-mode 1 -1)) + (saved-indent (if electric-indent-mode 1 -1))) + (electric-pair-mode -1) + (electric-layout-mode -1) + (electric-indent-mode -1) + (unwind-protect + (funcall fn) + (electric-pair-mode saved-electric) + (electric-indent-mode saved-indent) + (electric-layout-mode saved-layout)))) + +(defmacro save-electric-modes (&rest body) + (declare (indent defun) (debug t)) + `(call-with-saved-electric-modes #'(lambda () ,@body))) + +(defun electric-pair-test-for (fixture where char expected-string + expected-point mode bindings fixture-fn) + (with-temp-buffer + (funcall mode) + (insert fixture) + (save-electric-modes + (let ((last-command-event char) + (transient-mark-mode 'lambda)) + (goto-char where) + (funcall fixture-fn) + (cl-progv + (mapcar #'car bindings) + (mapcar #'cdr bindings) + (call-interactively (key-binding `[,last-command-event]))))) + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + expected-string)) + (should (equal (point) + expected-point)))) + +(eval-when-compile + (defun electric-pair-define-test-form (name fixture + char + pos + expected-string + expected-point + skip-pair-string + prefix + suffix + extra-desc + mode + bindings + fixture-fn) + (let* ((expected-string-and-point + (if skip-pair-string + (with-temp-buffer + (cl-progv + ;; FIXME: avoid `eval' + (mapcar #'car (eval bindings)) + (mapcar #'cdr (eval bindings)) + (funcall mode) + (insert fixture) + (goto-char (1+ pos)) + (insert char) + (cond ((eq (aref skip-pair-string pos) + ?p) + (insert (cadr (electric-pair-syntax-info char))) + (backward-char 1)) + ((eq (aref skip-pair-string pos) + ?s) + (delete-char -1) + (forward-char 1))) + (list + (buffer-substring-no-properties (point-min) (point-max)) + (point)))) + (list expected-string expected-point))) + (expected-string (car expected-string-and-point)) + (expected-point (cadr expected-string-and-point)) + (fixture (format "%s%s%s" prefix fixture suffix)) + (expected-string (format "%s%s%s" prefix expected-string suffix)) + (expected-point (+ (length prefix) expected-point)) + (pos (+ (length prefix) pos))) + `(ert-deftest ,(intern (format "electric-pair-%s-at-point-%s-in-%s%s" + name + (1+ pos) + mode + extra-desc)) + () + ,(format "With |%s|, try input %c at point %d. \ +Should %s |%s| and point at %d" + fixture + char + (1+ pos) + (if (string= fixture expected-string) + "stay" + "become") + (replace-regexp-in-string "\n" "\\\\n" expected-string) + expected-point) + (electric-pair-test-for ,fixture + ,(1+ pos) + ,char + ,expected-string + ,expected-point + ',mode + ,bindings + ,fixture-fn))))) + +(cl-defmacro define-electric-pair-test + (name fixture + input + &key + skip-pair-string + expected-string + expected-point + bindings + (modes '(quote (ruby-mode c++-mode))) + (test-in-comments t) + (test-in-strings t) + (test-in-code t) + (fixture-fn #'(lambda () + (electric-pair-mode 1)))) + `(progn + ,@(cl-loop + for mode in (eval modes) ;FIXME: avoid `eval' + append + (cl-loop + for (prefix suffix extra-desc) in + (append (if test-in-comments + `((,(with-temp-buffer + (funcall mode) + (insert "z") + (comment-region (point-min) (point-max)) + (buffer-substring-no-properties (point-min) + (1- (point-max)))) + "" + "-in-comments"))) + (if test-in-strings + `(("\"" "\"" "-in-strings"))) + (if test-in-code + `(("" "" "")))) + append + (cl-loop + for char across input + for pos from 0 + unless (eq char ?-) + collect (electric-pair-define-test-form + name + fixture + (aref input pos) + pos + expected-string + expected-point + skip-pair-string + prefix + suffix + extra-desc + mode + bindings + fixture-fn)))))) + +;;; Basic pairs and skips +;;; +(define-electric-pair-test balanced-situation + " (()) " "(((((((" :skip-pair-string "ppppppp" + :modes '(ruby-mode)) + +(define-electric-pair-test too-many-openings + " ((()) " "(((((((" :skip-pair-string "ppppppp") + +(define-electric-pair-test too-many-closings + " (())) " "(((((((" :skip-pair-string "------p") + +(define-electric-pair-test too-many-closings-2 + "() ) " "---(---" :skip-pair-string "-------") + +(define-electric-pair-test too-many-closings-3 + ")() " "(------" :skip-pair-string "-------") + +(define-electric-pair-test balanced-autoskipping + " (()) " "---))--" :skip-pair-string "---ss--") + +(define-electric-pair-test too-many-openings-autoskipping + " ((()) " "----))-" :skip-pair-string "-------") + +(define-electric-pair-test too-many-closings-autoskipping + " (())) " "---)))-" :skip-pair-string "---sss-") + + +;;; Mixed parens +;;; +(define-electric-pair-test mixed-paren-1 + " ()] " "-(-(---" :skip-pair-string "-p-p---") + +(define-electric-pair-test mixed-paren-2 + " [() " "-(-()--" :skip-pair-string "-p-ps--") + +(define-electric-pair-test mixed-paren-3 + " (]) " "-(-()--" :skip-pair-string "---ps--") + +(define-electric-pair-test mixed-paren-4 + " ()] " "---)]--" :skip-pair-string "---ss--") + +(define-electric-pair-test mixed-paren-5 + " [() " "----(--" :skip-pair-string "----p--") + +(define-electric-pair-test find-matching-different-paren-type + " ()] " "-[-----" :skip-pair-string "-------") + +(define-electric-pair-test find-matching-different-paren-type-inside-list + "( ()]) " "-[-----" :skip-pair-string "-------") + +(define-electric-pair-test ignore-different-nonmatching-paren-type + "( ()]) " "-(-----" :skip-pair-string "-p-----") + +(define-electric-pair-test autopair-keep-least-amount-of-mixed-unbalance + "( ()] " "-(-----" :skip-pair-string "-p-----") + +(define-electric-pair-test dont-autopair-to-resolve-mixed-unbalance + "( ()] " "-[-----" :skip-pair-string "-------") + +(define-electric-pair-test autopair-so-as-not-to-worsen-unbalance-situation + "( (]) " "-[-----" :skip-pair-string "-p-----") + +(define-electric-pair-test skip-over-partially-balanced + " [([]) " "-----)---" :skip-pair-string "-----s---") + +(define-electric-pair-test only-skip-over-at-least-partially-balanced-stuff + " [([()) " "-----))--" :skip-pair-string "-----s---") + + + + +;;; Quotes +;;; +(define-electric-pair-test pair-some-quotes-skip-others + " \"\" " "-\"\"-----" :skip-pair-string "-ps------" + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test skip-single-quotes-in-ruby-mode + " '' " "--'-" :skip-pair-string "--s-" + :modes '(ruby-mode) + :test-in-comments nil + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test leave-unbalanced-quotes-alone + " \"' " "-\"'-" :skip-pair-string "----" + :modes '(ruby-mode) + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test leave-unbalanced-quotes-alone-2 + " \"\\\"' " "-\"--'-" :skip-pair-string "------" + :modes '(ruby-mode) + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test leave-unbalanced-quotes-alone-3 + " foo\\''" "'------" :skip-pair-string "-------" + :modes '(ruby-mode) + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test inhibit-if-strings-mismatched + "\"foo\"\"bar" "\"" + :expected-string "\"\"foo\"\"bar" + :expected-point 2 + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test inhibit-in-mismatched-string-inside-ruby-comments + "foo\"\" +# +# \"bar\" +# \" \" +# \" +# +baz\"\"" + "\"" + :modes '(ruby-mode) + :test-in-strings nil + :test-in-comments nil + :expected-point 19 + :expected-string + "foo\"\" +# +# \"bar\"\" +# \" \" +# \" +# +baz\"\"" + :fixture-fn #'(lambda () (goto-char (point-min)) (search-forward "bar"))) + +(define-electric-pair-test inhibit-in-mismatched-string-inside-c-comments + "foo\"\"/* + \"bar\" + \" \" + \" +*/baz\"\"" + "\"" + :modes '(c-mode) + :test-in-strings nil + :test-in-comments nil + :expected-point 18 + :expected-string + "foo\"\"/* + \"bar\"\" + \" \" + \" +*/baz\"\"" + :fixture-fn #'(lambda () (goto-char (point-min)) (search-forward "bar"))) + + +;;; More quotes, but now don't bind `electric-pair-text-syntax-table' +;;; to `prog-mode-syntax-table'. Use the defaults for +;;; `electric-pair-pairs' and `electric-pair-text-pairs'. +;;; +(define-electric-pair-test pairing-skipping-quotes-in-code + " \"\" " "-\"\"-----" :skip-pair-string "-ps------" + :test-in-strings nil + :test-in-comments nil) + +(define-electric-pair-test skipping-quotes-in-comments + " \"\" " "--\"-----" :skip-pair-string "--s------" + :test-in-strings nil) + + +;;; Skipping over whitespace +;;; +(define-electric-pair-test whitespace-jumping + " ( ) " "--))))---" :expected-string " ( ) " :expected-point 8 + :bindings '((electric-pair-skip-whitespace . t))) + +(define-electric-pair-test whitespace-chomping + " ( ) " "--)------" :expected-string " () " :expected-point 4 + :bindings '((electric-pair-skip-whitespace . chomp))) + +(define-electric-pair-test whitespace-chomping-2 + " ( \n\t\t\n ) " "--)------" :expected-string " () " :expected-point 4 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-comments nil) + +(define-electric-pair-test whitespace-chomping-dont-cross-comments + " ( \n\t\t\n ) " "--)------" :expected-string " () \n\t\t\n ) " + :expected-point 4 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code nil + :test-in-comments t) + +(define-electric-pair-test whitespace-skipping-for-quotes-not-outside + " \" \"" "\"-----" :expected-string "\"\" \" \"" + :expected-point 2 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code t + :test-in-comments nil) + +(define-electric-pair-test whitespace-skipping-for-quotes-only-inside + " \" \"" "---\"--" :expected-string " \"\"" + :expected-point 5 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code t + :test-in-comments nil) + +(define-electric-pair-test whitespace-skipping-quotes-not-without-proper-syntax + " \" \"" "---\"--" :expected-string " \"\"\" \"" + :expected-point 5 + :modes '(text-mode) + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code t + :test-in-comments nil) + + +;;; Pairing arbitrary characters +;;; +(define-electric-pair-test angle-brackets-everywhere + "<>" "<>" :skip-pair-string "ps" + :bindings '((electric-pair-pairs . ((?\< . ?\>))))) + +(define-electric-pair-test angle-brackets-everywhere-2 + "(<>" "-<>" :skip-pair-string "-ps" + :bindings '((electric-pair-pairs . ((?\< . ?\>))))) + +(defvar electric-pair-test-angle-brackets-table + (let ((table (make-syntax-table prog-mode-syntax-table))) + (modify-syntax-entry ?\< "(>" table) + (modify-syntax-entry ?\> ")<`" table) + table)) + +(define-electric-pair-test angle-brackets-pair + "<>" "<" :expected-string "<><>" :expected-point 2 + :test-in-code nil + :bindings `((electric-pair-text-syntax-table + . ,electric-pair-test-angle-brackets-table))) + +(define-electric-pair-test angle-brackets-skip + "<>" "->" :expected-string "<>" :expected-point 3 + :test-in-code nil + :bindings `((electric-pair-text-syntax-table + . ,electric-pair-test-angle-brackets-table))) + +(define-electric-pair-test pair-backtick-and-quote-in-comments + ";; " "---`" :expected-string ";; `'" :expected-point 5 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test skip-backtick-and-quote-in-comments + ";; `foo'" "-------'" :expected-string ";; `foo'" :expected-point 9 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test pair-backtick-and-quote-in-strings + "\"\"" "-`" :expected-string "\"`'\"" :expected-point 3 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test skip-backtick-and-quote-in-strings + "\"`'\"" "--'" :expected-string "\"`'\"" :expected-point 4 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test skip-backtick-and-quote-in-strings-2 + " \"`'\"" "----'" :expected-string " \"`'\"" :expected-point 6 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + + +;;; `js-mode' has `electric-layout-rules' for '{ and '} +;;; +(define-electric-pair-test js-mode-braces + "" "{" :expected-string "{}" :expected-point 2 + :modes '(js-mode) + :fixture-fn #'(lambda () + (electric-pair-mode 1))) + +(define-electric-pair-test js-mode-braces-with-layout + "" "{" :expected-string "{\n\n}" :expected-point 3 + :modes '(js-mode) + :test-in-comments nil + :test-in-strings nil + :fixture-fn #'(lambda () + (electric-layout-mode 1) + (electric-pair-mode 1))) + +(define-electric-pair-test js-mode-braces-with-layout-and-indent + "" "{" :expected-string "{\n \n}" :expected-point 7 + :modes '(js-mode) + :test-in-comments nil + :test-in-strings nil + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (electric-indent-mode 1) + (electric-layout-mode 1))) + + +;;; Backspacing +;;; TODO: better tests +;;; +(ert-deftest electric-pair-backspace-1 () + (save-electric-modes + (with-temp-buffer + (insert "()") + (goto-char 2) + (electric-pair-delete-pair 1) + (should (equal "" (buffer-string)))))) + + +;;; Electric newlines between pairs +;;; TODO: better tests +(ert-deftest electric-pair-open-extra-newline () + (save-electric-modes + (with-temp-buffer + (c-mode) + (electric-pair-mode 1) + (electric-indent-mode 1) + (insert "int main {}") + (backward-char 1) + (let ((c-basic-offset 4)) + (newline 1 t) + (should (equal "int main {\n \n}" + (buffer-string))) + (should (equal (point) (- (point-max) 2))))))) + + + +;;; Autowrapping +;;; +(define-electric-pair-test autowrapping-1 + "foo" "(" :expected-string "(foo)" :expected-point 2 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (mark-sexp 1))) + +(define-electric-pair-test autowrapping-2 + "foo" ")" :expected-string "(foo)" :expected-point 6 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (mark-sexp 1))) + +(define-electric-pair-test autowrapping-3 + "foo" ")" :expected-string "(foo)" :expected-point 6 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(define-electric-pair-test autowrapping-4 + "foo" "(" :expected-string "(foo)" :expected-point 2 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(define-electric-pair-test autowrapping-5 + "foo" "\"" :expected-string "\"foo\"" :expected-point 2 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (mark-sexp 1))) + +(define-electric-pair-test autowrapping-6 + "foo" "\"" :expected-string "\"foo\"" :expected-point 6 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(define-electric-pair-test autowrapping-7 + "foo" "\"" :expected-string "``foo''" :expected-point 8 + :modes '(tex-mode) + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(provide 'electric-tests) +;;; electric-tests.el ends here diff --cc test/lisp/emacs-lisp/cl-generic-tests.el index 2703b44dee5,00000000000..dee10fe285e mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@@ -1,223 -1,0 +1,223 @@@ +;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'ert)) ;Don't indirectly require cl-lib at run-time. +(require 'cl-generic) + +(fmakunbound 'cl--generic-1) +(cl-defgeneric cl--generic-1 (x y)) +(cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.") + +(ert-deftest cl-generic-test-00 () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (should (equal (cl--generic-1 'a 'b) '(a . b)))) + +(ert-deftest cl-generic-test-01-eql () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (eql 5)) _y) + (cons "cinq" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (eql 6)) y) + (cons "six" (cl-call-next-method 'a y))) + (should (equal (cl--generic-1 'a nil) '(a))) + (should (equal (cl--generic-1 4 nil) '("quatre" 4))) + (should (equal (cl--generic-1 5 nil) '("cinq" 5))) + (should (equal (cl--generic-1 6 nil) '("six" a)))) + +(cl-defstruct cl-generic-struct-parent a b) +(cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c) +(cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1)) d) +(cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e) + +(ert-deftest cl-generic-test-02-struct () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 ((x t) y) "Doc 1." (cons x y)) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent) y) + "Doc 2." (cons "parent" (cl-call-next-method 'a y))) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1) _y) + (cons "child1" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :around ((_x t) _y) + (cons "around" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :around ((_x cl-generic-struct-child11) _y) + (cons "child11" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2) _y) + (cons "child2" (cl-call-next-method))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil) + '("around" "child1" "parent" a))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil) + '("around""child2" "parent" a))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil) + '("child11" "around""child1" "parent" a)))) + +;; I don't know how to put this inside an `ert-test'. This tests that `setf' +;; can be used directly inside the body of the setf method. +(cl-defmethod (setf cl--generic-2) (v (y integer) z) + (setf (cl--generic-2 (nth y z) z) v)) + +(ert-deftest cl-generic-test-03-setf () + (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z)) + (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z)) + (should (equal (setf (cl--generic-1 'a 'b) 'v) '(v a b))) + (should (equal (setf (cl--generic-1 4 'b) 'v) '(v "four" b))) + (let ((x ())) + (should (equal (setf (cl--generic-1 (progn (push 1 x) 'a) + (progn (push 2 x) 'b)) + (progn (push 3 x) 'v)) + '(v a b))) + (should (equal x '(3 2 1))))) + +(ert-deftest cl-generic-test-04-overlapping-tagcodes () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 ((y t) z) (list y z)) + (cl-defmethod cl--generic-1 ((_y (eql 4)) _z) + (cons "four" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_y integer) _z) + (cons "integer" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_y number) _z) + (cons "number" (cl-call-next-method))) + (should (equal (cl--generic-1 'a 'b) '(a b))) + (should (equal (cl--generic-1 1 'b) '("integer" "number" 1 b))) + (should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b)))) + +(ert-deftest cl-generic-test-05-alias () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (defalias 'cl--generic-2 #'cl--generic-1) + (cl-defmethod cl--generic-1 ((y t) z) (list y z)) + (cl-defmethod cl--generic-2 ((_y (eql 4)) _z) + (cons "four" (cl-call-next-method))) + (should (equal (cl--generic-1 4 'b) '("four" 4 b)))) + +(ert-deftest cl-generic-test-06-multiple-dispatch () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 (x y) (list x y)) + (cl-defmethod cl--generic-1 (_x (_y integer)) + (cons "y-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "x-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) (_y integer)) + (cons "x&y-int" (cl-call-next-method))) + (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2)))) + +(ert-deftest cl-generic-test-07-apo () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) + (:documentation "My doc.") (:argument-precedence-order y x)) + (cl-defmethod cl--generic-1 (x y) (list x y)) + (cl-defmethod cl--generic-1 (_x (_y integer)) + (cons "y-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "x-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) (_y integer)) + (cons "x&y-int" (cl-call-next-method))) + (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2)))) + +(ert-deftest cl-generic-test-08-after/before () + (let ((log ())) + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((_x t) y) (cons y log)) + (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :after (x _y) + (push (list :after x) log)) + (cl-defmethod cl--generic-1 :before (x _y) + (push (list :before x) log)) + (should (equal (cl--generic-1 4 6) '("quatre" 6 (:before 4)))) + (should (equal log '((:after 4) (:before 4)))))) + +(defun cl--generic-test-advice (&rest args) (cons "advice" (apply args))) + +(ert-deftest cl-generic-test-09-advice () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 (x y) (list x y)) + (advice-add 'cl--generic-1 :around #'cl--generic-test-advice) + (should (equal (cl--generic-1 4 5) '("advice" 4 5))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "integer" (cl-call-next-method))) + (should (equal (cl--generic-1 4 5) '("advice" "integer" 4 5))) + (advice-remove 'cl--generic-1 #'cl--generic-test-advice) + (should (equal (cl--generic-1 4 5) '("integer" 4 5)))) + +(ert-deftest cl-generic-test-10-weird () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x &rest r) "My doc.") + (cl-defmethod cl--generic-1 (x &rest r) (cons x r)) + ;; This kind of definition is not valid according to CLHS, but it does show + ;; up in EIEIO's tests for no-next-method, so we should either + ;; detect it and signal an error or do something meaningful with it. + (cl-defmethod cl--generic-1 (x (y integer) &rest r) + `("integer" ,y ,x ,@r)) + (should (equal (cl--generic-1 'a 'b) '(a b))) + (should (equal (cl--generic-1 1 2) '("integer" 2 1)))) + +(ert-deftest cl-generic-test-11-next-method-p () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) + (list x y (cl-next-method-p))) + (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) + (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method))) + (should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil)))) + +(ert-deftest cl-generic-test-12-context () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 ()) + (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql t))) + (list 'is-t (cl-call-next-method))) + (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql nil))) + (list 'is-nil (cl-call-next-method))) + (cl-defmethod cl--generic-1 () 'any) + (should (equal (list (let ((overwrite-mode t)) (cl--generic-1)) + (let ((overwrite-mode nil)) (cl--generic-1)) + (let ((overwrite-mode 1)) (cl--generic-1))) + '((is-t any) (is-nil any) any)))) + +(ert-deftest cl-generic-test-13-head () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (cl-defmethod cl--generic-1 ((_x (head 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (head 5)) _y) + (cons "cinq" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (head 6)) y) + (cons "six" (cl-call-next-method 'a y))) + (should (equal (cl--generic-1 'a nil) '(a))) + (should (equal (cl--generic-1 '(4) nil) '("quatre" (4)))) + (should (equal (cl--generic-1 '(5) nil) '("cinq" (5)))) + (should (equal (cl--generic-1 '(6) nil) '("six" a)))) + +(provide 'cl-generic-tests) +;;; cl-generic-tests.el ends here diff --cc test/lisp/emacs-lisp/cl-lib-tests.el index e2429b7de37,00000000000..cbaf70fc4bb mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@@ -1,496 -1,0 +1,496 @@@ +;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el -*- lexical-binding:t -*- + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; Extracted from ert-tests.el, back when ert used to reimplement some +;; cl functions. + +;;; Code: + +(require 'cl-lib) +(require 'ert) + +(ert-deftest cl-lib-test-remprop () + (let ((x (cl-gensym))) + (should (equal (symbol-plist x) '())) + ;; Remove nonexistent property on empty plist. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '())) + (put x 'a 1) + (should (equal (symbol-plist x) '(a 1))) + ;; Remove nonexistent property on nonempty plist. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '(a 1))) + (put x 'b 2) + (put x 'c 3) + (put x 'd 4) + (should (equal (symbol-plist x) '(a 1 b 2 c 3 d 4))) + ;; Remove property that is neither first nor last. + (cl-remprop x 'c) + (should (equal (symbol-plist x) '(a 1 b 2 d 4))) + ;; Remove last property from a plist of length >1. + (cl-remprop x 'd) + (should (equal (symbol-plist x) '(a 1 b 2))) + ;; Remove first property from a plist of length >1. + (cl-remprop x 'a) + (should (equal (symbol-plist x) '(b 2))) + ;; Remove property when there is only one. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '())))) + +(ert-deftest cl-lib-test-remove-if-not () + (let ((list (list 'a 'b 'c 'd)) + (i 0)) + (let ((result (cl-remove-if-not (lambda (x) + (should (eql x (nth i list))) + (cl-incf i) + (member i '(2 3))) + list))) + (should (equal i 4)) + (should (equal result '(b c))) + (should (equal list '(a b c d))))) + (should (equal '() + (cl-remove-if-not (lambda (_x) (should nil)) '())))) + +(ert-deftest cl-lib-test-remove () + (let ((list (list 'a 'b 'c 'd)) + (key-index 0) + (test-index 0)) + (let ((result + (cl-remove 'foo list + :key (lambda (x) + (should (eql x (nth key-index list))) + (prog1 + (list key-index x) + (cl-incf key-index))) + :test + (lambda (a b) + (should (eql a 'foo)) + (should (equal b (list test-index + (nth test-index list)))) + (cl-incf test-index) + (member test-index '(2 3)))))) + (should (equal key-index 4)) + (should (equal test-index 4)) + (should (equal result '(a d))) + (should (equal list '(a b c d))))) + (let ((x (cons nil nil)) + (y (cons nil nil))) + (should (equal (cl-remove x (list x y)) + ;; or (list x), since we use `equal' -- the + ;; important thing is that only one element got + ;; removed, this proves that the default test is + ;; `eql', not `equal' + (list y))))) + + +(ert-deftest cl-lib-test-set-functions () + (let ((c1 (cons nil nil)) + (c2 (cons nil nil)) + (sym (make-symbol "a"))) + (let ((e '()) + (a (list 'a 'b sym nil "" "x" c1 c2)) + (b (list c1 'y 'b sym 'x))) + (should (equal (cl-set-difference e e) e)) + (should (equal (cl-set-difference a e) a)) + (should (equal (cl-set-difference e a) e)) + (should (equal (cl-set-difference a a) e)) + (should (equal (cl-set-difference b e) b)) + (should (equal (cl-set-difference e b) e)) + (should (equal (cl-set-difference b b) e)) + ;; Note: this test (and others) is sensitive to the order of the + ;; result, which is not documented. + (should (equal (cl-set-difference a b) (list 'a nil "" "x" c2))) + (should (equal (cl-set-difference b a) (list 'y 'x))) + + ;; We aren't testing whether this is really using `eq' rather than `eql'. + (should (equal (cl-set-difference e e :test 'eq) e)) + (should (equal (cl-set-difference a e :test 'eq) a)) + (should (equal (cl-set-difference e a :test 'eq) e)) + (should (equal (cl-set-difference a a :test 'eq) e)) + (should (equal (cl-set-difference b e :test 'eq) b)) + (should (equal (cl-set-difference e b :test 'eq) e)) + (should (equal (cl-set-difference b b :test 'eq) e)) + (should (equal (cl-set-difference a b :test 'eq) (list 'a nil "" "x" c2))) + (should (equal (cl-set-difference b a :test 'eq) (list 'y 'x))) + + (should (equal (cl-union e e) e)) + (should (equal (cl-union a e) a)) + (should (equal (cl-union e a) a)) + (should (equal (cl-union a a) a)) + (should (equal (cl-union b e) b)) + (should (equal (cl-union e b) b)) + (should (equal (cl-union b b) b)) + (should (equal (cl-union a b) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) + + (should (equal (cl-union b a) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) + + (should (equal (cl-intersection e e) e)) + (should (equal (cl-intersection a e) e)) + (should (equal (cl-intersection e a) e)) + (should (equal (cl-intersection a a) a)) + (should (equal (cl-intersection b e) e)) + (should (equal (cl-intersection e b) e)) + (should (equal (cl-intersection b b) b)) + (should (equal (cl-intersection a b) (list sym 'b c1))) + (should (equal (cl-intersection b a) (list sym 'b c1)))))) + +(ert-deftest cl-lib-test-gensym () + ;; Since the expansion of `should' calls `cl-gensym' and thus has a + ;; side-effect on `cl--gensym-counter', we have to make sure all + ;; macros in our test body are expanded before we rebind + ;; `cl--gensym-counter' and run the body. Otherwise, the test would + ;; fail if run interpreted. + (let ((body (byte-compile + '(lambda () + (should (equal (symbol-name (cl-gensym)) "G0")) + (should (equal (symbol-name (cl-gensym)) "G1")) + (should (equal (symbol-name (cl-gensym)) "G2")) + (should (equal (symbol-name (cl-gensym "foo")) "foo3")) + (should (equal (symbol-name (cl-gensym "bar")) "bar4")) + (should (equal cl--gensym-counter 5)))))) + (let ((cl--gensym-counter 0)) + (funcall body)))) + +(ert-deftest cl-lib-test-coerce-to-vector () + (let* ((a (vector)) + (b (vector 1 a 3)) + (c (list)) + (d (list b a))) + (should (eql (cl-coerce a 'vector) a)) + (should (eql (cl-coerce b 'vector) b)) + (should (equal (cl-coerce c 'vector) (vector))) + (should (equal (cl-coerce d 'vector) (vector b a))))) + +(ert-deftest cl-lib-test-string-position () + (should (eql (cl-position ?x "") nil)) + (should (eql (cl-position ?a "abc") 0)) + (should (eql (cl-position ?b "abc") 1)) + (should (eql (cl-position ?c "abc") 2)) + (should (eql (cl-position ?d "abc") nil)) + (should (eql (cl-position ?A "abc") nil))) + +(ert-deftest cl-lib-test-mismatch () + (should (eql (cl-mismatch "" "") nil)) + (should (eql (cl-mismatch "" "a") 0)) + (should (eql (cl-mismatch "a" "a") nil)) + (should (eql (cl-mismatch "ab" "a") 1)) + (should (eql (cl-mismatch "Aa" "aA") 0)) + (should (eql (cl-mismatch '(a b c) '(a b d)) 2))) + +(ert-deftest cl-lib-test-loop () + (should (eql (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) + +(ert-deftest cl-lib-keyword-names-versus-values () + (should (equal + (funcall (cl-function (lambda (&key a b) (list a b))) + :b :a :a 42) + '(42 :a)))) + +(cl-defstruct (mystruct + (:constructor cl-lib--con-1 (&aux (abc 1))) + (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) + "General docstring." + (abc 5 :readonly t) (def nil)) +(ert-deftest cl-lib-struct-accessors () + (let ((x (make-mystruct :abc 1 :def 2))) + (should (eql (cl-struct-slot-value 'mystruct 'abc x) 1)) + (should (eql (cl-struct-slot-value 'mystruct 'def x) 2)) + (setf (cl-struct-slot-value 'mystruct 'def x) -1) + (should (eql (cl-struct-slot-value 'mystruct 'def x) -1)) + (should (eql (cl-struct-slot-offset 'mystruct 'abc) 1)) + (should-error (cl-struct-slot-offset 'mystruct 'marypoppins)) + (should (pcase (cl-struct-slot-info 'mystruct) + (`((cl-tag-slot) (abc 5 :readonly t) + (def . ,(or `nil `(nil)))) + t))))) +(ert-deftest cl-lib-struct-constructors () + (should (string-match "\\`Constructor docstring." + (documentation 'cl-lib--con-2 t))) + (should (mystruct-p (cl-lib--con-1))) + (should (mystruct-p (cl-lib--con-2)))) + +(ert-deftest cl-lib-arglist-performance () + ;; An `&aux' should not cause lambda's arglist to be turned into an &rest + ;; that's parsed by hand. + (should (equal () (help-function-arglist 'cl-lib--con-1))) + (should (pcase (help-function-arglist 'cl-lib--con-2) + (`(&optional ,_) t)))) + +(ert-deftest cl-the () + (should (eql (cl-the integer 42) 42)) + (should-error (cl-the integer "abc")) + (let ((side-effect 0)) + (should (= (cl-the integer (cl-incf side-effect)) 1)) + (should (= side-effect 1)))) + +(ert-deftest cl-lib-test-plusp () + (should-not (cl-plusp -1.0e+INF)) + (should-not (cl-plusp -1.5e2)) + (should-not (cl-plusp -3.14)) + (should-not (cl-plusp -1)) + (should-not (cl-plusp -0.0)) + (should-not (cl-plusp 0)) + (should-not (cl-plusp 0.0)) + (should-not (cl-plusp -0.0e+NaN)) + (should-not (cl-plusp 0.0e+NaN)) + (should (cl-plusp 1)) + (should (cl-plusp 3.14)) + (should (cl-plusp 1.5e2)) + (should (cl-plusp 1.0e+INF)) + (should-error (cl-plusp "42") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-minusp () + (should (cl-minusp -1.0e+INF)) + (should (cl-minusp -1.5e2)) + (should (cl-minusp -3.14)) + (should (cl-minusp -1)) + (should-not (cl-minusp -0.0)) + (should-not (cl-minusp 0)) + (should-not (cl-minusp 0.0)) + (should-not (cl-minusp -0.0e+NaN)) + (should-not (cl-minusp 0.0e+NaN)) + (should-not (cl-minusp 1)) + (should-not (cl-minusp 3.14)) + (should-not (cl-minusp 1.5e2)) + (should-not (cl-minusp 1.0e+INF)) + (should-error (cl-minusp "-42") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-oddp () + (should (cl-oddp -3)) + (should (cl-oddp 3)) + (should-not (cl-oddp -2)) + (should-not (cl-oddp 0)) + (should-not (cl-oddp 2)) + (should-error (cl-oddp 3.0e+NaN) :type 'wrong-type-argument) + (should-error (cl-oddp 3.0) :type 'wrong-type-argument) + (should-error (cl-oddp "3") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-evenp () + (should (cl-evenp -2)) + (should (cl-evenp 0)) + (should (cl-evenp 2)) + (should-not (cl-evenp -3)) + (should-not (cl-evenp 3)) + (should-error (cl-evenp 2.0e+NaN) :type 'wrong-type-argument) + (should-error (cl-evenp 2.0) :type 'wrong-type-argument) + (should-error (cl-evenp "2") :type 'wrong-type-argument)) + +(ert-deftest cl-digit-char-p () + (should (eql 3 (cl-digit-char-p ?3))) + (should (eql 10 (cl-digit-char-p ?a 11))) + (should (eql 10 (cl-digit-char-p ?A 11))) + (should-not (cl-digit-char-p ?a)) + (should (eql 32 (cl-digit-char-p ?w 36))) + (should-error (cl-digit-char-p ?a 37) :type 'args-out-of-range) + (should-error (cl-digit-char-p ?a 1) :type 'args-out-of-range)) + +(ert-deftest cl-lib-test-first () + (should (null (cl-first '()))) + (should (= 4 (cl-first '(4)))) + (should (= 4 (cl-first '(4 2)))) + (should-error (cl-first "42") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-second () + (should (null (cl-second '()))) + (should (null (cl-second '(4)))) + (should (= 2 (cl-second '(1 2)))) + (should (= 2 (cl-second '(1 2 3)))) + (should-error (cl-second "1 2 3") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-third () + (should (null (cl-third '()))) + (should (null (cl-third '(1 2)))) + (should (= 3 (cl-third '(1 2 3)))) + (should (= 3 (cl-third '(1 2 3 4)))) + (should-error (cl-third "123") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-fourth () + (should (null (cl-fourth '()))) + (should (null (cl-fourth '(1 2 3)))) + (should (= 4 (cl-fourth '(1 2 3 4)))) + (should (= 4 (cl-fourth '(1 2 3 4 5)))) + (should-error (cl-fourth "1234") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-fifth () + (should (null (cl-fifth '()))) + (should (null (cl-fifth '(1 2 3 4)))) + (should (= 5 (cl-fifth '(1 2 3 4 5)))) + (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) + (should-error (cl-fifth "12345") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-fifth () + (should (null (cl-fifth '()))) + (should (null (cl-fifth '(1 2 3 4)))) + (should (= 5 (cl-fifth '(1 2 3 4 5)))) + (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) + (should-error (cl-fifth "12345") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-sixth () + (should (null (cl-sixth '()))) + (should (null (cl-sixth '(1 2 3 4 5)))) + (should (= 6 (cl-sixth '(1 2 3 4 5 6)))) + (should (= 6 (cl-sixth '(1 2 3 4 5 6 7)))) + (should-error (cl-sixth "123456") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-seventh () + (should (null (cl-seventh '()))) + (should (null (cl-seventh '(1 2 3 4 5 6)))) + (should (= 7 (cl-seventh '(1 2 3 4 5 6 7)))) + (should (= 7 (cl-seventh '(1 2 3 4 5 6 7 8)))) + (should-error (cl-seventh "1234567") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-eighth () + (should (null (cl-eighth '()))) + (should (null (cl-eighth '(1 2 3 4 5 6 7)))) + (should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8)))) + (should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8 9)))) + (should-error (cl-eighth "12345678") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-ninth () + (should (null (cl-ninth '()))) + (should (null (cl-ninth '(1 2 3 4 5 6 7 8)))) + (should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9)))) + (should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9 10)))) + (should-error (cl-ninth "123456789") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-tenth () + (should (null (cl-tenth '()))) + (should (null (cl-tenth '(1 2 3 4 5 6 7 8 9)))) + (should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10)))) + (should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10 11)))) + (should-error (cl-tenth "1234567890") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-endp () + (should (cl-endp '())) + (should-not (cl-endp '(1))) + (should-error (cl-endp 1) :type 'wrong-type-argument) + (should-error (cl-endp [1]) :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-nth-value () + (let ((vals (cl-values 2 3))) + (should (= (cl-nth-value 0 vals) 2)) + (should (= (cl-nth-value 1 vals) 3)) + (should (null (cl-nth-value 2 vals))) + (should-error (cl-nth-value 0.0 vals) :type 'wrong-type-argument))) + +(ert-deftest cl-lib-nth-value-test-multiple-values () + "While CL multiple values are an alias to list, these won't work." + :expected-result :failed + (should (eq (cl-nth-value 0 '(2 3)) '(2 3))) + (should (= (cl-nth-value 0 1) 1)) + (should (null (cl-nth-value 1 1))) + (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range) + (should (string= (cl-nth-value 0 "only lists") "only lists"))) + +(ert-deftest cl-test-caaar () + (should (null (cl-caaar '()))) + (should (null (cl-caaar '(() (2))))) + (should (null (cl-caaar '((() (2)) (a b))))) + (should-error (cl-caaar '(1 2)) :type 'wrong-type-argument) + (should-error (cl-caaar '((1 2))) :type 'wrong-type-argument) + (should (= 1 (cl-caaar '(((1 2) (3 4)))))) + (should (null (cl-caaar '((() (3 4))))))) + +(ert-deftest cl-test-caadr () + (should (null (cl-caadr '()))) + (should (null (cl-caadr '(1)))) + (should-error (cl-caadr '(1 2)) :type 'wrong-type-argument) + (should (= 2 (cl-caadr '(1 (2 3))))) + (should (equal '((2) (3)) (cl-caadr '((1) (((2) (3))) (4)))))) + +(ert-deftest cl-test-ldiff () + (let ((l '(1 2 3))) + (should (null (cl-ldiff '() '()))) + (should (null (cl-ldiff '() l))) + (should (null (cl-ldiff l l))) + (should (equal l (cl-ldiff l '()))) + ;; must be part of the list + (should (equal l (cl-ldiff l '(2 3)))) + (should (equal '(1) (cl-ldiff l (nthcdr 1 l)))) + ;; should return a copy + (should-not (eq (cl-ldiff l '()) l)))) + +(ert-deftest cl-lib-adjoin-test () + (let ((nums '(1 2)) + (myfn-p '=)) + ;; add non-existing item to the front + (should (equal '(3 1 2) (cl-adjoin 3 nums))) + ;; just add - don't copy rest + (should (eq nums (cdr (cl-adjoin 3 nums)))) + ;; add only when not already there + (should (eq nums (cl-adjoin 2 nums))) + (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2))))) + ;; default test function is eql + (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums))) + ;; own :test function - returns true if match + (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test nil))) ;defaults to eql + (should (eq nums (cl-adjoin 2 nums :test myfn-p))) ;match + (should (equal '(3 1 2) (cl-adjoin 3 nums :test myfn-p))) ;no match + ;; own :test-not function - returns false if match + (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test-not nil))) ;defaults to eql + (should (equal '(2 2) (cl-adjoin 2 '(2) :test-not myfn-p))) ; no match + (should (eq nums (cl-adjoin 2 nums :test-not myfn-p))) ; 1 matches + (should (eq nums (cl-adjoin 3 nums :test-not myfn-p))) ; 1 and 2 matches + + ;; according to CLtL2 passing both :test and :test-not should signal error + ;;(should-error (cl-adjoin 3 nums :test 'myfn-p :test-not myfn-p)) + + ;; own :key fn + (should (eq nums (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (1+ x) x))))) + (should (equal '(3 1 2) (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (+ 2 x) x))))) + + ;; convert using :key, then compare with :test + (should (eq nums (cl-adjoin 1 nums :key 'int-to-string :test 'string=))) + (should (equal '(3 1 2) (cl-adjoin 3 nums :key 'int-to-string :test 'string=))) + (should-error (cl-adjoin 3 nums :key 'int-to-string :test myfn-p) + :type 'wrong-type-argument) + + ;; convert using :key, then compare with :test-not + (should (eq nums (cl-adjoin 3 nums :key 'int-to-string :test-not 'string=))) + (should (equal '(1 1) (cl-adjoin 1 '(1) :key 'int-to-string :test-not 'string=))) + (should-error (cl-adjoin 1 nums :key 'int-to-string :test-not myfn-p) + :type 'wrong-type-argument))) + +(ert-deftest cl-parse-integer () + (should-error (cl-parse-integer "abc")) + (should (null (cl-parse-integer "abc" :junk-allowed t))) + (should (null (cl-parse-integer "" :junk-allowed t))) + (should (= 342391 (cl-parse-integer "0123456789" :radix 8 :junk-allowed t))) + (should-error (cl-parse-integer "0123456789" :radix 8)) + (should (= -239 (cl-parse-integer "-efz" :radix 16 :junk-allowed t))) + (should-error (cl-parse-integer "efz" :radix 16)) + (should (= 239 (cl-parse-integer "zzef" :radix 16 :start 2))) + (should (= -123 (cl-parse-integer " -123 ")))) + +(ert-deftest cl-loop-destructuring-with () + (should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) + +(ert-deftest cl-flet-test () + (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5))) + +(ert-deftest cl-lib-test-typep () + (cl-deftype cl-lib-test-type (&optional x) `(member ,x)) + ;; Make sure we correctly implement the rule that deftype's optional args + ;; default to `*' rather than to nil. + (should (cl-typep '* 'cl-lib-test-type)) + (should-not (cl-typep 1 'cl-lib-test-type))) + +;;; cl-lib.el ends here diff --cc test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index 557f031d181,00000000000..eb26047da2f mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@@ -1,402 -1,0 +1,402 @@@ +;;; eieio-testsinvoke.el -- eieio tests for method invocation + - ;; Copyright (C) 2005, 2008, 2010, 2013-2015 Free Software Foundation, ++;; Copyright (C) 2005, 2008, 2010, 2013-2016 Free Software Foundation, +;; Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Test method invocation order. From the common lisp reference +;; manual: +;; +;; QUOTE: +;; - All the :before methods are called, in most-specific-first +;; order. Their values are ignored. An error is signaled if +;; call-next-method is used in a :before method. +;; +;; - The most specific primary method is called. Inside the body of a +;; primary method, call-next-method may be used to call the next +;; most specific primary method. When that method returns, the +;; previous primary method can execute more code, perhaps based on +;; the returned value or values. The generic function no-next-method +;; is invoked if call-next-method is used and there are no more +;; applicable primary methods. The function next-method-p may be +;; used to determine whether a next method exists. If +;; call-next-method is not used, only the most specific primary +;; method is called. +;; +;; - All the :after methods are called, in most-specific-last order. +;; Their values are ignored. An error is signaled if +;; call-next-method is used in a :after method. +;; +;; +;; Also test behavior of `call-next-method'. From clos.org: +;; +;; QUOTE: +;; When call-next-method is called with no arguments, it passes the +;; current method's original arguments to the next method. + +(require 'eieio) +(require 'ert) + +(defvar eieio-test-method-order-list nil + "List of symbols stored during method invocation.") + +(defun eieio-test-method-store (&rest args) + "Store current invocation class symbol in the invocation order list." + (push args eieio-test-method-order-list)) + +(defun eieio-test-match (rightanswer) + "Do a test match." + (if (equal rightanswer eieio-test-method-order-list) + t + (error "eieio-test-methodinvoke.el: Test Failed: %S != %S" + rightanswer eieio-test-method-order-list))) + +(defvar eieio-test-call-next-method-arguments nil + "List of passed to methods during execution of `call-next-method'.") + +(defun eieio-test-arguments-for (class) + "Returns arguments passed to method of CLASS during `call-next-method'." + (cdr (assoc class eieio-test-call-next-method-arguments))) + +(defclass eitest-A () ()) +(defclass eitest-AA (eitest-A) ()) +(defclass eitest-AAA (eitest-AA) ()) +(defclass eitest-B-base1 () ()) +(defclass eitest-B-base2 () ()) +(defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) + +(defmethod eitest-F :BEFORE ((p eitest-B-base1)) + (eieio-test-method-store :BEFORE 'eitest-B-base1)) + +(defmethod eitest-F :BEFORE ((p eitest-B-base2)) + (eieio-test-method-store :BEFORE 'eitest-B-base2)) + +(defmethod eitest-F :BEFORE ((p eitest-B)) + (eieio-test-method-store :BEFORE 'eitest-B)) + +(defmethod eitest-F ((p eitest-B)) + (eieio-test-method-store :PRIMARY 'eitest-B) + (call-next-method)) + +(defmethod eitest-F ((p eitest-B-base1)) + (eieio-test-method-store :PRIMARY 'eitest-B-base1) + (call-next-method)) + +(defmethod eitest-F ((p eitest-B-base2)) + (eieio-test-method-store :PRIMARY 'eitest-B-base2) + (when (next-method-p) + (call-next-method)) + ) + +(defmethod eitest-F :AFTER ((p eitest-B-base1)) + (eieio-test-method-store :AFTER 'eitest-B-base1)) + +(defmethod eitest-F :AFTER ((p eitest-B-base2)) + (eieio-test-method-store :AFTER 'eitest-B-base2)) + +(defmethod eitest-F :AFTER ((p eitest-B)) + (eieio-test-method-store :AFTER 'eitest-B)) + +(ert-deftest eieio-test-method-order-list-3 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:BEFORE eitest-B) + (:BEFORE eitest-B-base1) + (:BEFORE eitest-B-base2) + + (:PRIMARY eitest-B) + (:PRIMARY eitest-B-base1) + (:PRIMARY eitest-B-base2) + + (:AFTER eitest-B-base2) + (:AFTER eitest-B-base1) + (:AFTER eitest-B) + ))) + (eitest-F (eitest-B nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Test static invocation +;; +(defmethod eitest-H :STATIC ((class eitest-A)) + "No need to do work in here." + 'moose) + +(ert-deftest eieio-test-method-order-list-4 () + ;; Both of these situations should succeed. + (should (eitest-H 'eitest-A)) + (should (eitest-H (eitest-A nil)))) + +;;; Return value from :PRIMARY +;; +(defmethod eitest-I :BEFORE ((a eitest-A)) + (eieio-test-method-store :BEFORE 'eitest-A) + ":before") + +(defmethod eitest-I :PRIMARY ((a eitest-A)) + (eieio-test-method-store :PRIMARY 'eitest-A) + ":primary") + +(defmethod eitest-I :AFTER ((a eitest-A)) + (eieio-test-method-store :AFTER 'eitest-A) + ":after") + +(ert-deftest eieio-test-method-order-list-5 () + (let ((eieio-test-method-order-list nil) + (ans (eitest-I (eitest-A nil)))) + (should (string= ans ":primary")))) + +;;; Multiple inheritance and the 'constructor' method. +;; +;; Constructor is a static method, so this is really testing +;; static method invocation and multiple inheritance. +;; +(defclass C-base1 () ()) +(defclass C-base2 () ()) +(defclass C (C-base1 C-base2) ()) + +;; Just use the obsolete name once, to make sure it also works. +(defmethod constructor :STATIC ((p C-base1) &rest args) + (eieio-test-method-store :STATIC 'C-base1) + (if (next-method-p) (call-next-method)) + ) + +(defmethod make-instance :STATIC ((p C-base2) &rest args) + (eieio-test-method-store :STATIC 'C-base2) + (if (next-method-p) (call-next-method)) + ) + +(cl-defmethod make-instance ((p (subclass C)) &rest args) + (eieio-test-method-store :STATIC 'C) + (cl-call-next-method) + ) + +(ert-deftest eieio-test-method-order-list-6 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:STATIC C) + (:STATIC C-base1) + (:STATIC C-base2) + ))) + (C nil) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Diamond Test +;; +;; For a diamond shaped inheritance structure, (call-next-method) can break. +;; As such, there are two possible orders. + +(defclass D-base0 () () :method-invocation-order :depth-first) +(defclass D-base1 (D-base0) () :method-invocation-order :depth-first) +(defclass D-base2 (D-base0) () :method-invocation-order :depth-first) +(defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) + +(defmethod eitest-F ((p D)) + "D" + (eieio-test-method-store :PRIMARY 'D) + (call-next-method)) + +(defmethod eitest-F ((p D-base0)) + "D-base0" + (eieio-test-method-store :PRIMARY 'D-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) + +(defmethod eitest-F ((p D-base1)) + "D-base1" + (eieio-test-method-store :PRIMARY 'D-base1) + (call-next-method)) + +(defmethod eitest-F ((p D-base2)) + "D-base2" + (eieio-test-method-store :PRIMARY 'D-base2) + (when (next-method-p) + (call-next-method)) + ) + +(ert-deftest eieio-test-method-order-list-7 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:PRIMARY D) + (:PRIMARY D-base1) + ;; (:PRIMARY D-base2) + (:PRIMARY D-base0) + ))) + (eitest-F (D nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Other invocation order + +(defclass E-base0 () () :method-invocation-order :breadth-first) +(defclass E-base1 (E-base0) () :method-invocation-order :breadth-first) +(defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) +(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) + +(defmethod eitest-F ((p E)) + (eieio-test-method-store :PRIMARY 'E) + (call-next-method)) + +(defmethod eitest-F ((p E-base0)) + (eieio-test-method-store :PRIMARY 'E-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) + +(defmethod eitest-F ((p E-base1)) + (eieio-test-method-store :PRIMARY 'E-base1) + (call-next-method)) + +(defmethod eitest-F ((p E-base2)) + (eieio-test-method-store :PRIMARY 'E-base2) + (when (next-method-p) + (call-next-method)) + ) + +(ert-deftest eieio-test-method-order-list-8 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:PRIMARY E) + (:PRIMARY E-base1) + (:PRIMARY E-base2) + (:PRIMARY E-base0) + ))) + (eitest-F (E nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Jan's methodinvoke order w/ multiple inheritance and :after methods. +;; +(defclass eitest-Ja () + ()) + +(defmethod initialize-instance :after ((this eitest-Ja) &rest slots) + ;(message "+Ja") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;(message "-Ja") + ) + +(defclass eitest-Jb () + ()) + +(defmethod initialize-instance :after ((this eitest-Jb) &rest slots) + ;(message "+Jb") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;(message "-Jb") + ) + +(defclass eitest-Jc (eitest-Jb) + ()) + +(defclass eitest-Jd (eitest-Jc eitest-Ja) + ()) + +(defmethod initialize-instance ((this eitest-Jd) &rest slots) + ;(message "+Jd") + (when (next-method-p) + (call-next-method)) + ;(message "-Jd") + ) + +(ert-deftest eieio-test-method-order-list-9 () + (should (eitest-Jd "test"))) + +;;; call-next-method with replacement arguments across a simple class hierarchy. +;; + +(defclass CNM-0 () + ()) + +(defclass CNM-1-1 (CNM-0) + ()) + +(defclass CNM-1-2 (CNM-0) + ()) + +(defclass CNM-2 (CNM-1-1 CNM-1-2) + ()) + +(defmethod CNM-M ((this CNM-0) args) + (push (cons 'CNM-0 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-0 args)))) + +(defmethod CNM-M ((this CNM-1-1) args) + (push (cons 'CNM-1-1 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-1-1 args)))) + +(defmethod CNM-M ((this CNM-1-2) args) + (push (cons 'CNM-1-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method))) + +(defmethod CNM-M ((this CNM-2) args) + (push (cons 'CNM-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-2 args)))) + +(ert-deftest eieio-test-method-order-list-10 () + (let ((eieio-test-call-next-method-arguments nil)) + (CNM-M (CNM-2 "") '(INIT)) + (should (equal (eieio-test-arguments-for 'CNM-0) + '(CNM-1-1 CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-1-1) + '(CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-1-2) + '(CNM-1-1 CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-2) + '(INIT))))) + +;;; Check cl-generic integration. + +(cl-defgeneric eieio-test--1 (x y)) + +(ert-deftest eieio-test-cl-generic-1 () + (cl-defgeneric eieio-test--1 (x y)) + (cl-defmethod eieio-test--1 (x y) (list x y)) + (cl-defmethod eieio-test--1 ((_x CNM-0) y) + (cons "CNM-0" (cl-call-next-method 7 y))) + (cl-defmethod eieio-test--1 ((_x CNM-1-1) _y) + (cons "CNM-1-1" (cl-call-next-method))) + (cl-defmethod eieio-test--1 ((_x CNM-1-2) _y) + (cons "CNM-1-2" (cl-call-next-method))) + (cl-defmethod eieio-test--1 ((_x (subclass CNM-1-2)) _y) + (cons "subclass CNM-1-2" (cl-call-next-method))) + (should (equal (eieio-test--1 4 5) '(4 5))) + (should (equal (eieio-test--1 (make-instance 'CNM-0) 5) + '("CNM-0" 7 5))) + (should (equal (eieio-test--1 (make-instance 'CNM-2) 5) + '("CNM-1-1" "CNM-1-2" "CNM-0" 7 5))) + (should (equal (eieio-test--1 'CNM-2 6) '("subclass CNM-1-2" CNM-2 6)))) diff --cc test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el index 9b21b730385,00000000000..2f8d65e512e mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@@ -1,219 -1,0 +1,219 @@@ +;;; eieio-persist.el --- Tests for eieio-persistent class + - ;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; The eieio-persistent base-class provides a vital service, that +;; could be used to accidentally load in malicious code. As such, +;; something as simple as calling eval on the generated code can't be +;; used. These tests exercises various flavors of data that might be +;; in a persistent object, and tries to save/load them. + +;;; Code: +(require 'eieio) +(require 'eieio-base) +(require 'ert) + +(defun eieio--attribute-to-initarg (class attribute) + "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. +This is usually a symbol that starts with `:'." + (let ((tuple (rassoc attribute (eieio--class-initarg-tuples class)))) + (if tuple + (car tuple) + nil))) + +(defun persist-test-save-and-compare (original) + "Compare the object ORIGINAL against the one read fromdisk." + + (eieio-persistent-save original) + + (let* ((file (oref original file)) + (class (eieio-object-class original)) + (fromdisk (eieio-persistent-read file class)) + (cv (cl--find-class class)) + (slots (eieio--class-slots cv)) + ) + (unless (object-of-class-p fromdisk class) + (error "Persistent class %S != original class %S" + (eieio-object-class fromdisk) + class)) + + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (oneslot (cl--slot-descriptor-name slot)) + (origvalue (eieio-oref original oneslot)) + (fromdiskvalue (eieio-oref fromdisk oneslot)) + (initarg-p (eieio--attribute-to-initarg + (cl--find-class class) oneslot)) + ) + + (if initarg-p + (unless (equal origvalue fromdiskvalue) + (error "Slot %S Original Val %S != Persistent Val %S" + oneslot origvalue fromdiskvalue)) + ;; Else !initarg-p + (unless (equal (cl--slot-descriptor-initform slot) fromdiskvalue) + (error "Slot %S Persistent Val %S != Default Value %S" + oneslot fromdiskvalue (cl--slot-descriptor-initform slot)))) + )))) + +;;; Simple Case +;; +;; Simplest case is a mix of slots with and without initargs. + +(defclass persist-simple (eieio-persistent) + ((slot1 :initarg :slot1 + :type symbol + :initform moose) + (slot2 :initarg :slot2 + :initform "foo") + (slot3 :initform 2)) + "A Persistent object with two initializable slots, and one not.") + +(ert-deftest eieio-test-persist-simple-1 () + (let ((persist-simple-1 + (persist-simple "simple 1" :slot1 'goose :slot2 "testing" + :file (concat default-directory "test-ps1.pt")))) + (should persist-simple-1) + + ;; When the slot w/out an initarg has not been changed + (persist-test-save-and-compare persist-simple-1) + + ;; When the slot w/out an initarg HAS been changed + (oset persist-simple-1 slot3 3) + (persist-test-save-and-compare persist-simple-1) + (delete-file (oref persist-simple-1 file)))) + +;;; Slot Writers +;; +;; Replica of the test in eieio-tests.el - + +(defclass persist-:printer (eieio-persistent) + ((slot1 :initarg :slot1 + :initform 'moose + :printer PO-slot1-printer) + (slot2 :initarg :slot2 + :initform "foo")) + "A Persistent object with two initializable slots.") + +(defun PO-slot1-printer (slotvalue) + "Print the slot value SLOTVALUE to stdout. +Assume SLOTVALUE is a symbol of some sort." + (princ "'") + (princ (symbol-name slotvalue)) + (princ " ;; RAN PRINTER") + nil) + +(ert-deftest eieio-test-persist-printer () + (let ((persist-:printer-1 + (persist-:printer "persist" :slot1 'goose :slot2 "testing" + :file (concat default-directory "test-ps2.pt")))) + (should persist-:printer-1) + (persist-test-save-and-compare persist-:printer-1) + + (let* ((find-file-hook nil) + (tbuff (find-file-noselect "test-ps2.pt")) + ) + (condition-case nil + (unwind-protect + (with-current-buffer tbuff + (goto-char (point-min)) + (re-search-forward "RAN PRINTER")) + (kill-buffer tbuff)) + (error "persist-:printer-1's Slot1 printer function didn't work."))) + (delete-file (oref persist-:printer-1 file)))) + +;;; Slot with Object +;; +;; A slot that contains another object that isn't persistent +(defclass persist-not-persistent () + ((slot1 :initarg :slot1 + :initform 1) + (slot2 :initform 2)) + "Class for testing persistent saving of an object that isn't +persistent. This class is instead used as a slot value in a +persistent class.") + +(defclass persistent-with-objs-slot (eieio-persistent) + ((pnp :initarg :pnp + :type (or null persist-not-persistent) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-non-persistent-as-slot () + (let ((persist-wos + (persistent-with-objs-slot + "persist wos 1" + :pnp (persist-not-persistent "pnp 1" :slot1 3) + :file (concat default-directory "test-ps3.pt")))) + + (persist-test-save-and-compare persist-wos) + (delete-file (oref persist-wos file)))) + +;;; Slot with Object child of :type +;; +;; A slot that contains another object that isn't persistent +(defclass persist-not-persistent-subclass (persist-not-persistent) + ((slot3 :initarg :slot1 + :initform 1) + (slot4 :initform 2)) + "Class for testing persistent saving of an object subclass that isn't +persistent. This class is instead used as a slot value in a +persistent class.") + +(defclass persistent-with-objs-slot-subs (eieio-persistent) + ((pnp :initarg :pnp + :type (or null persist-not-persistent) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-non-persistent-as-slot-child () + (let ((persist-woss + (persistent-with-objs-slot-subs + "persist woss 1" + :pnp (persist-not-persistent-subclass "pnps 1" :slot1 3) + :file (concat default-directory "test-ps4.pt")))) + + (persist-test-save-and-compare persist-woss) + (delete-file (oref persist-woss file)))) + +;;; Slot with a list of Objects +;; +;; A slot that contains another object that isn't persistent +(defclass persistent-with-objs-list-slot (eieio-persistent) + ((pnp :initarg :pnp + :type (list-of persist-not-persistent) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-slot-with-list-of-objects () + (let ((persist-wols + (persistent-with-objs-list-slot + "persist wols 1" + :pnp (list (persist-not-persistent "pnp 1" :slot1 3) + (persist-not-persistent "pnp 2" :slot1 4) + (persist-not-persistent "pnp 3" :slot1 5)) + :file (concat default-directory "test-ps5.pt")))) + + (persist-test-save-and-compare persist-wols) + (delete-file (oref persist-wols file)))) + +;;; eieio-test-persist.el ends here diff --cc test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 3a181be5071,00000000000..9665beb490e mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@@ -1,906 -1,0 +1,906 @@@ +;;; eieio-tests.el -- eieio tests routines + - ;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software ++;; Copyright (C) 1999-2003, 2005-2010, 2012-2016 Free Software +;; Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Test the various features of EIEIO. + +(require 'ert) +(require 'eieio) +(require 'eieio-base) +(require 'eieio-opt) + +(eval-when-compile (require 'cl-lib)) + +;;; Code: +;; Set up some test classes +(defclass class-a () + ((water :initarg :water + :initform h20 + :type symbol + :documentation "Detail about water.") + (classslot :initform penguin + :type symbol + :documentation "A class allocated slot." + :allocation :class) + (test-tag :initform nil + :documentation "Used to make sure methods are called.") + (self :initform nil + :type (or null class-a) + :documentation "Test self referencing types.") + ) + "Class A") + +(defclass class-b () + ((land :initform "Sc" + :type string + :documentation "Detail about land.")) + "Class B") + +(defclass class-ab (class-a class-b) + ((amphibian :initform "frog" + :documentation "Detail about amphibian on land and water.")) + "Class A and B combined.") + +(defclass class-c () + ((slot-1 :initarg :moose + :initform moose + :type symbol + :allocation :instance + :documentation "First slot testing slot arguments." + :custom symbol + :label "Wild Animal" + :group borg + :protection :public) + (slot-2 :initarg :penguin + :initform "penguin" + :type string + :allocation :instance + :documentation "Second slot testing slot arguments." + :custom string + :label "Wild bird" + :group vorlon + :accessor get-slot-2 + :protection :private) + (slot-3 :initarg :emu + :initform emu + :type symbol + :allocation :class + :documentation "Third slot test class allocated accessor" + :custom symbol + :label "Fuzz" + :group tokra + :accessor get-slot-3 + :protection :private) + ) + (:custom-groups (foo)) + "A class for testing slot arguments." + ) + +(defclass class-subc (class-c) + ((slot-1 ;; :initform moose - don't override this + ) + (slot-2 :initform "linux" ;; Do override this one + :protection :private + )) + "A class for testing slot arguments.") + +;;; Defining a class with a slot tag error +;; +;; Temporarily disable this test because of macro expansion changes in +;; current Emacs trunk. It can be re-enabled when we have moved +;; `eieio-defclass' into the `defclass' macro and the +;; `eval-and-compile' there is removed. + +;; (let ((eieio-error-unsupported-class-tags t)) +;; (condition-case nil +;; (progn +;; (defclass class-error () +;; ((error-slot :initarg :error-slot +;; :badslottag 1)) +;; "A class with a bad slot tag.") +;; (error "No error was thrown for badslottag")) +;; (invalid-slot-type nil))) + +;; (let ((eieio-error-unsupported-class-tags nil)) +;; (condition-case nil +;; (progn +;; (defclass class-error () +;; ((error-slot :initarg :error-slot +;; :badslottag 1)) +;; "A class with a bad slot tag.")) +;; (invalid-slot-type +;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil") +;; ))) + +(ert-deftest eieio-test-01-mix-alloc-initarg () + ;; Only run this test if the message framework thingy works. + (when (and (message "foo") (string= "foo" (current-message))) + + ;; Defining this class should generate a warning(!) message that + ;; you should not mix :initarg with class allocated slots. + (defclass class-alloc-initarg () + ((throwwarning :initarg :throwwarning + :allocation :class)) + "Throw a warning mixing allocation class and an initarg.") + + ;; Check that message is there + (should (current-message)) + (should (string-match "Class allocated slots do not need :initarg" + (current-message))))) + +(defclass abstract-class () + ((some-slot :initarg :some-slot + :initform nil + :documentation "A slot.")) + :documentation "An abstract class." + :abstract t) + +(ert-deftest eieio-test-02-abstract-class () + ;; Abstract classes cannot be instantiated, so this should throw an + ;; error + (should-error (abstract-class))) + +(defgeneric generic1 () "First generic function") + +(ert-deftest eieio-test-03-generics () + (defun anormalfunction () "A plain function for error testing." nil) + (should-error + (progn + (defgeneric anormalfunction () + "Attempt to turn it into a generic."))) + + ;; Check that generic-p works + (should (generic-p 'generic1)) + + (defmethod generic1 ((c class-a)) + "Method on generic1." + 'monkey) + + (defmethod generic1 (not-an-object) + "Method generic1 that can take a non-object." + not-an-object) + + (let ((ans-obj (generic1 (class-a))) + (ans-num (generic1 666))) + (should (eq ans-obj 'monkey)) + (should (eq ans-num 666)))) + +(defclass static-method-class () + ((some-slot :initform nil + :allocation :class + :documentation "A slot.")) + :documentation "A class used for testing static methods.") + +(defmethod static-method-class-method :STATIC ((c static-method-class) value) + "Test static methods. +Argument C is the class bound to this static method." + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot value)) + +(ert-deftest eieio-test-04-static-method () + ;; Call static method on a class and see if it worked + (static-method-class-method 'static-method-class 'class) + (should (eq (oref-default 'static-method-class some-slot) 'class)) + (static-method-class-method (static-method-class) 'object) + (should (eq (oref-default 'static-method-class some-slot) 'object))) + +(ert-deftest eieio-test-05-static-method-2 () + (defclass static-method-class-2 (static-method-class) + () + "A second class after the previous for static methods.") + + (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) + "Test static methods. +Argument C is the class bound to this static method." + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) + + (static-method-class-method 'static-method-class-2 'class) + (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class)) + (static-method-class-method (static-method-class-2) 'object) + (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-object))) + + +;;; Perform method testing +;; + +;;; Multiple Inheritance, and method signal testing +;; +(defvar eitest-ab nil) +(defvar eitest-a nil) +(defvar eitest-b nil) +(ert-deftest eieio-test-06-allocate-objects () + ;; allocate an object to use + (should (setq eitest-ab (class-ab))) + (should (setq eitest-a (class-a))) + (should (setq eitest-b (class-b)))) + +(ert-deftest eieio-test-07-make-instance () + (should (make-instance 'class-ab)) + (should (make-instance 'class-a :water 'cho)) + (should (make-instance 'class-b))) + +(defmethod class-cn ((a class-a)) + "Try calling `call-next-method' when there isn't one. +Argument A is object of type symbol `class-a'." + (call-next-method)) + +(defmethod no-next-method ((a class-a) &rest args) + "Override signal throwing for variable `class-a'. +Argument A is the object of class variable `class-a'." + 'moose) + +(ert-deftest eieio-test-08-call-next-method () + ;; Play with call-next-method + (should (eq (class-cn eitest-ab) 'moose))) + +(defmethod no-applicable-method ((b class-b) method &rest args) + "No need. +Argument B is for booger. +METHOD is the method that was attempting to be called." + 'moose) + +(ert-deftest eieio-test-09-no-applicable-method () + ;; Non-existing methods. + (should (eq (class-cn eitest-b) 'moose))) + +(defmethod class-fun ((a class-a)) + "Fun with class A." + 'moose) + +(defmethod class-fun ((b class-b)) + "Fun with class B." + (error "Class B fun should not be called") + ) + +(defmethod class-fun-foo ((b class-b)) + "Foo Fun with class B." + 'moose) + +(defmethod class-fun2 ((a class-a)) + "More fun with class A." + 'moose) + +(defmethod class-fun2 ((b class-b)) + "More fun with class B." + (error "Class B fun2 should not be called") + ) + +(defmethod class-fun2 ((ab class-ab)) + "More fun with class AB." + (call-next-method)) + +;; How about if B is the only slot? +(defmethod class-fun3 ((b class-b)) + "Even More fun with class B." + 'moose) + +(defmethod class-fun3 ((ab class-ab)) + "Even More fun with class AB." + (call-next-method)) + +(ert-deftest eieio-test-10-multiple-inheritance () + ;; play with methods and mi + (should (eq (class-fun eitest-ab) 'moose)) + (should (eq (class-fun-foo eitest-ab) 'moose)) + ;; Play with next-method and mi + (should (eq (class-fun2 eitest-ab) 'moose)) + (should (eq (class-fun3 eitest-ab) 'moose))) + +(ert-deftest eieio-test-11-self () + ;; Try the self referencing test + (should (oset eitest-a self eitest-a)) + (should (oset eitest-ab self eitest-ab))) + + +(defvar class-fun-value-seq '()) +(defmethod class-fun-value :BEFORE ((a class-a)) + "Return `before', and push `before' in `class-fun-value-seq'." + (push 'before class-fun-value-seq) + 'before) + +(defmethod class-fun-value :PRIMARY ((a class-a)) + "Return `primary', and push `primary' in `class-fun-value-seq'." + (push 'primary class-fun-value-seq) + 'primary) + +(defmethod class-fun-value :AFTER ((a class-a)) + "Return `after', and push `after' in `class-fun-value-seq'." + (push 'after class-fun-value-seq) + 'after) + +(ert-deftest eieio-test-12-generic-function-call () + ;; Test value of a generic function call + ;; + (let* ((class-fun-value-seq nil) + (value (class-fun-value eitest-a))) + ;; Test if generic function call returns the primary method's value + (should (eq value 'primary)) + ;; Make sure :before and :after methods were run + (should (equal class-fun-value-seq '(after primary before))))) + +;;; Test initialization methods +;; + +(ert-deftest eieio-test-13-init-methods () + (defmethod initialize-instance ((a class-a) &rest slots) + "Initialize the slots of class-a." + (call-next-method) + (if (/= (oref a test-tag) 1) + (error "shared-initialize test failed.")) + (oset a test-tag 2)) + + (defmethod shared-initialize ((a class-a) &rest slots) + "Shared initialize method for class-a." + (call-next-method) + (oset a test-tag 1)) + + (let ((ca (class-a))) + (should-not (/= (oref ca test-tag) 2)))) + + +;;; Perform slot testing +;; +(ert-deftest eieio-test-14-slots () + ;; Check slot existence + (should (oref eitest-ab water)) + (should (oref eitest-ab land)) + (should (oref eitest-ab amphibian))) + +(ert-deftest eieio-test-15-slot-missing () + + (defmethod slot-missing ((ab class-ab) &rest foo) + "If a slot in AB is unbound, return something cool. FOO." + 'moose) + + (should (eq (oref eitest-ab ooga-booga) 'moose)) + (should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name)) + +(ert-deftest eieio-test-16-slot-makeunbound () + (slot-makeunbound eitest-a 'water) + ;; Should now be unbound + (should-not (slot-boundp eitest-a 'water)) + ;; But should still exist + (should (slot-exists-p eitest-a 'water)) + (should-not (slot-exists-p eitest-a 'moose)) + ;; oref of unbound slot must fail + (should-error (oref eitest-a water) :type 'unbound-slot)) + +(defvar eitest-vsca nil) +(defvar eitest-vscb nil) +(defclass virtual-slot-class () + ((base-value :initarg :base-value)) + "Class has real slot :base-value and simulated slot :derived-value.") +(defmethod slot-missing ((vsc virtual-slot-class) + slot-name operation &optional new-value) + "Simulate virtual slot derived-value." + (cond + ((or (eq slot-name :derived-value) + (eq slot-name 'derived-value)) + (with-slots (base-value) vsc + (if (eq operation 'oref) + (+ base-value 1) + (setq base-value (- new-value 1))))) + (t (call-next-method)))) + +(ert-deftest eieio-test-17-virtual-slot () + (setq eitest-vsca (virtual-slot-class :base-value 1)) + ;; Check slot values + (should (= (oref eitest-vsca base-value) 1)) + (should (= (oref eitest-vsca :derived-value) 2)) + + (oset eitest-vsca derived-value 3) + (should (= (oref eitest-vsca base-value) 2)) + (should (= (oref eitest-vsca :derived-value) 3)) + + (oset eitest-vsca base-value 3) + (should (= (oref eitest-vsca base-value) 3)) + (should (= (oref eitest-vsca :derived-value) 4)) + + ;; should also be possible to initialize instance using virtual slot + + (setq eitest-vscb (virtual-slot-class :derived-value 5)) + (should (= (oref eitest-vscb base-value) 4)) + (should (= (oref eitest-vscb :derived-value) 5))) + +(ert-deftest eieio-test-18-slot-unbound () + + (defmethod slot-unbound ((a class-a) &rest foo) + "If a slot in A is unbound, ignore FOO." + 'moose) + + (should (eq (oref eitest-a water) 'moose)) + + ;; Check if oset of unbound works + (oset eitest-a water 'moose) + (should (eq (oref eitest-a water) 'moose)) + + ;; oref/oref-default comparison + (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; oset-default -> oref/oref-default comparison + (oset-default (eieio-object-class eitest-a) water 'moose) + (should (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; After setting 'water to 'moose, make sure a new object has + ;; the right stuff. + (oset-default (eieio-object-class eitest-a) water 'penguin) + (should (eq (oref (class-a) water) 'penguin)) + + ;; Revert the above + (defmethod slot-unbound ((a class-a) &rest foo) + "If a slot in A is unbound, ignore FOO." + ;; Disable the old slot-unbound so we can run this test + ;; more than once + (call-next-method))) + +(ert-deftest eieio-test-19-slot-type-checking () + ;; Slot type checking + ;; We should not be able to set a string here + (should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type) + (should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type) + (should-error (class-a :water "a string not a symbol") :type 'invalid-slot-type)) + +(ert-deftest eieio-test-20-class-allocated-slots () + ;; Test out class allocated slots + (defvar eitest-aa nil) + (setq eitest-aa (class-a)) + + ;; Make sure class slots do not track between objects + (let ((newval 'moose)) + (oset eitest-aa classslot newval) + (should (eq (oref eitest-a classslot) newval)) + (should (eq (oref eitest-aa classslot) newval))) + + ;; Slot should be bound + (should (slot-boundp eitest-a 'classslot)) + (should (slot-boundp 'class-a 'classslot)) + + (slot-makeunbound eitest-a 'classslot) + + (should-not (slot-boundp eitest-a 'classslot)) + (should-not (slot-boundp 'class-a 'classslot))) + + +(defvar eieio-test-permuting-value nil) +(defvar eitest-pvinit nil) +(eval-and-compile + (setq eieio-test-permuting-value 1)) + +(defclass inittest nil + ((staticval :initform 1) + (symval :initform eieio-test-permuting-value) + (evalval :initform (symbol-value 'eieio-test-permuting-value)) + (evalnow :initform (symbol-value 'eieio-test-permuting-value) + :allocation :class) + ) + "Test initforms that eval.") + +(ert-deftest eieio-test-21-eval-at-construction-time () + ;; initforms that need to be evalled at construction time. + (setq eieio-test-permuting-value 2) + (setq eitest-pvinit (inittest)) + + (should (eq (oref eitest-pvinit staticval) 1)) + (should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value)) + (should (eq (oref eitest-pvinit evalval) 2)) + (should (eq (oref eitest-pvinit evalnow) 1))) + +(defvar eitest-tests nil) + +(ert-deftest eieio-test-22-init-forms-dont-match-runnable () + ;; Init forms with types that don't match the runnable. + (defclass eitest-subordinate nil + ((text :initform "" :type string)) + "Test class that will be a calculated value.") + + (defclass eitest-superior nil + ((sub :initform (eitest-subordinate) + :type eitest-subordinate)) + "A class with an initform that creates a class.") + + (should (setq eitest-tests (eitest-superior))) + + (should-error + (eval + '(defclass broken-init nil + ((broken :initform 1 + :type string)) + "This class should break.")) + :type 'invalid-slot-type)) + +(ert-deftest eieio-test-23-inheritance-check () + (should (child-of-class-p 'class-ab 'class-a)) + (should (child-of-class-p 'class-ab 'class-b)) + (should (object-of-class-p eitest-a 'class-a)) + (should (object-of-class-p eitest-ab 'class-a)) + (should (object-of-class-p eitest-ab 'class-b)) + (should (object-of-class-p eitest-ab 'class-ab)) + (should (eq (eieio-class-parents 'class-a) nil)) + (should (equal (eieio-class-parents 'class-ab) + (mapcar #'find-class '(class-a class-b)))) + (should (same-class-p eitest-a 'class-a)) + (should (class-a-p eitest-a)) + (should (not (class-a-p eitest-ab))) + (should (cl-typep eitest-a 'class-a)) + (should (cl-typep eitest-ab 'class-a)) + (should (not (class-a-p "foo"))) + (should (not (cl-typep "foo" 'class-a)))) + +(ert-deftest eieio-test-24-object-predicates () + (let ((listooa (list (class-ab) (class-a))) + (listoob (list (class-ab) (class-b)))) + (should (cl-typep listooa '(list-of class-a))) + (should (cl-typep listoob '(list-of class-b))) + (should-not (cl-typep listooa '(list-of class-b))) + (should-not (cl-typep listoob '(list-of class-a))))) + +(defvar eitest-t1 nil) +(ert-deftest eieio-test-25-slot-tests () + (setq eitest-t1 (class-c)) + ;; Slot initialization + (should (eq (oref eitest-t1 slot-1) 'moose)) + ;; Accessing via the initarg name is deprecated! + ;; (should (eq (oref eitest-t1 :moose) 'moose)) + ;; Don't pass reference of private slot + ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name) + ;; Check private slot accessor + (should (string= (get-slot-2 eitest-t1) "penguin")) + ;; Pass string instead of symbol + (should-error (class-c :moose "not a symbol") :type 'invalid-slot-type) + (should (eq (get-slot-3 eitest-t1) 'emu)) + (should (eq (get-slot-3 'class-c) 'emu)) + ;; Check setf + (setf (get-slot-3 eitest-t1) 'setf-emu) + (should (eq (get-slot-3 eitest-t1) 'setf-emu)) + ;; Roll back + (setf (get-slot-3 eitest-t1) 'emu)) + +(defvar eitest-t2 nil) +(ert-deftest eieio-test-26-default-inheritance () + ;; See previous test, nor for subclass + (setq eitest-t2 (class-subc)) + (should (eq (oref eitest-t2 slot-1) 'moose)) + ;; Accessing via the initarg name is deprecated! + ;;(should (eq (oref eitest-t2 :moose) 'moose)) + (should (string= (get-slot-2 eitest-t2) "linux")) + ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name) + (should (string= (get-slot-2 eitest-t2) "linux")) + (should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type)) + +;;(ert-deftest eieio-test-27-inherited-new-value () + ;;; HACK ALERT: The new value of a class slot is inherited by the + ;; subclass! This is probably a bug. We should either share the slot + ;; so sets on the baseclass change the subclass, or we should inherit + ;; the original value. +;; (should (eq (get-slot-3 eitest-t2) 'emu)) +;; (should (eq (get-slot-3 class-subc) 'emu)) +;; (setf (get-slot-3 eitest-t2) 'setf-emu) +;; (should (eq (get-slot-3 eitest-t2) 'setf-emu))) + +;; Slot protection +(defclass prot-0 () + () + "Protection testing baseclass.") + +(defmethod prot0-slot-2 ((s2 prot-0)) + "Try to access slot-2 from this class which doesn't have it. +The object S2 passed in will be of class prot-1, which does have +the slot. This could be allowed, and currently is in EIEIO. +Needed by the eieio persistent base class." + (oref s2 slot-2)) + +(defclass prot-1 (prot-0) + ((slot-1 :initarg :slot-1 + :initform nil + :protection :public) + (slot-2 :initarg :slot-2 + :initform nil + :protection :protected) + (slot-3 :initarg :slot-3 + :initform nil + :protection :private)) + "A class for testing the :protection option.") + +(defclass prot-2 (prot-1) + nil + "A class for testing the :protection option.") + +(defmethod prot1-slot-2 ((s2 prot-1)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) + +(defmethod prot1-slot-2 ((s2 prot-2)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) + +(defmethod prot1-slot-3-only ((s2 prot-1)) + "Try to access slot-3 in S2. +Do not override for `prot-2'." + (oref s2 slot-3)) + +(defmethod prot1-slot-3 ((s2 prot-1)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) + +(defmethod prot1-slot-3 ((s2 prot-2)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) + +(defvar eitest-p1 nil) +(defvar eitest-p2 nil) +(ert-deftest eieio-test-28-slot-protection () + (setq eitest-p1 (prot-1)) + (setq eitest-p2 (prot-2)) + ;; Access public slots + (oref eitest-p1 slot-1) + (oref eitest-p2 slot-1) + ;; Accessing protected slot out of context used to fail, but we dropped this + ;; feature, since it was underused and no one noticed that the check was + ;; incorrect (much too loose). + ;;PROTECTED (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name) + ;; Access protected slot in method + (prot1-slot-2 eitest-p1) + ;; Protected slot in subclass method + (prot1-slot-2 eitest-p2) + ;; Protected slot from parent class method + (prot0-slot-2 eitest-p1) + ;; Accessing private slot out of context used to fail, but we dropped this + ;; feature, since it was not used. + ;;PRIVATE (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name) + ;; Access private slot in method + (prot1-slot-3 eitest-p1) + ;; Access private slot in subclass method must fail + ;;PRIVATE (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name) + ;; Access private slot by same class + (prot1-slot-3-only eitest-p1) + ;; Access private slot by subclass in sameclass method + (prot1-slot-3-only eitest-p2)) + +;;; eieio-instance-inheritor +;; Test to make sure this works. +(defclass II (eieio-instance-inheritor) + ((slot1 :initform 1) + (slot2) + (slot3)) + "Instance Inheritor test class.") + +(defvar eitest-II1 nil) +(defvar eitest-II2 nil) +(defvar eitest-II3 nil) +(ert-deftest eieio-test-29-instance-inheritor () + (setq eitest-II1 (II "II Test.")) + (oset eitest-II1 slot2 'cat) + (setq eitest-II2 (clone eitest-II1 "eitest-II2 Test.")) + (oset eitest-II2 slot1 'moose) + (setq eitest-II3 (clone eitest-II2 "eitest-II3 Test.")) + (oset eitest-II3 slot3 'penguin) + + ;; Test level 1 inheritance + (should (eq (oref eitest-II3 slot1) 'moose)) + ;; Test level 2 inheritance + (should (eq (oref eitest-II3 slot2) 'cat)) + ;; Test level 0 inheritance + (should (eq (oref eitest-II3 slot3) 'penguin))) + +(defclass slotattr-base () + ((initform :initform init) + (type :type list) + (initarg :initarg :initarg) + (protection :protection :private) + (custom :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :documentation + "Replace the doc-string for this property.") + (printer :printer printer1) + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.") + +(defclass slotattr-ok (slotattr-base) + ((initform :initform no-init) + (initarg :initarg :initblarg) + (custom :custom string + :label "One String" + :group cow) + (docstring :documentation + "A better doc string for this class.") + (printer :printer printer2) + ) + "This class should allow overriding of various slot attributes.") + + +(ert-deftest eieio-test-30-slot-attribute-override () + ;; Subclass should not override :protection slot attribute + ;;PROTECTION is gone. + ;;(should-error + ;; (eval + ;; '(defclass slotattr-fail (slotattr-base) + ;; ((protection :protection :public) + ;; ) + ;; "This class should throw an error."))) + + ;; Subclass should not override :type slot attribute + (should-error + (eval + '(defclass slotattr-fail (slotattr-base) + ((type :type string) + ) + "This class should throw an error."))) + + ;; Initform should override instance allocation + (let ((obj (slotattr-ok))) + (should (eq (oref obj initform) 'no-init)))) + +(defclass slotattr-class-base () + ((initform :allocation :class + :initform init) + (type :allocation :class + :type list) + (initarg :allocation :class + :initarg :initarg) + (protection :allocation :class + :protection :private) + (custom :allocation :class + :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :allocation :class + :documentation + "Replace the doc-string for this property.") + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.") + +(defclass slotattr-class-ok (slotattr-class-base) + ((initform :initform no-init) + (initarg :initarg :initblarg) + (custom :custom string + :label "One String" + :group cow) + (docstring :documentation + "A better doc string for this class.") + ) + "This class should allow overriding of various slot attributes.") + + +(ert-deftest eieio-test-31-slot-attribute-override-class-allocation () + ;; Same as test-30, but with class allocation + ;;PROTECTION is gone. + ;;(should-error + ;; (eval + ;; '(defclass slotattr-fail (slotattr-class-base) + ;; ((protection :protection :public) + ;; ) + ;; "This class should throw an error."))) + (should-error + (eval + '(defclass slotattr-fail (slotattr-class-base) + ((type :type string) + ) + "This class should throw an error."))) + (should (eq (oref-default 'slotattr-class-ok initform) 'no-init))) + +(ert-deftest eieio-test-32-slot-attribute-override-2 () + (let* ((cv (cl--find-class 'slotattr-ok)) + (slots (eieio--class-slots cv)) + (args (eieio--class-initarg-tuples cv))) + ;; :initarg should override for subclass + (should (assoc :initblarg args)) + + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (props (cl--slot-descriptor-props slot))) + (cond + ((eq (cl--slot-descriptor-name slot) 'custom) + ;; Custom slot attributes must override + (should (eq (alist-get :custom props) 'string)) + ;; Custom label slot attribute must override + (should (string= (alist-get :label props) "One String")) + (let ((grp (alist-get :group props))) + ;; Custom group slot attribute must combine + (should (and (memq 'moose grp) (memq 'cow grp))))) + (t nil)))))) + +(defvar eitest-CLONETEST1 nil) +(defvar eitest-CLONETEST2 nil) + +(ert-deftest eieio-test-32-test-clone-boring-objects () + ;; A simple make instance with EIEIO extension + (should (setq eitest-CLONETEST1 (make-instance 'class-a))) + (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))) + + ;; CLOS form of make-instance + (should (setq eitest-CLONETEST1 (make-instance 'class-a))) + (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))) + +(defclass IT (eieio-instance-tracker) + ((tracking-symbol :initform IT-list) + (slot1 :initform 'die)) + "Instance Tracker test object.") + +(ert-deftest eieio-test-33-instance-tracker () + (let (IT-list IT1) + (should (setq IT1 (IT))) + ;; The instance tracker must find this + (should (eieio-instance-tracker-find 'die 'slot1 'IT-list)) + ;; Test deletion + (delete-instance IT1) + (should-not (eieio-instance-tracker-find 'die 'slot1 'IT-list)))) + +(defclass SINGLE (eieio-singleton) + ((a-slot :initarg :a-slot :initform t)) + "A Singleton test object.") + +(ert-deftest eieio-test-34-singletons () + (let ((obj1 (SINGLE)) + (obj2 (SINGLE))) + (should (eieio-object-p obj1)) + (should (eieio-object-p obj2)) + (should (eq obj1 obj2)) + (should (oref obj1 a-slot)))) + +(defclass NAMED (eieio-named) + ((some-slot :initform nil) + ) + "A class inheriting from eieio-named.") + +(ert-deftest eieio-test-35-named-object () + (let (N) + (should (setq N (NAMED :object-name "Foo"))) + (should (string= "Foo" (oref N object-name))) + (should-error (oref N missing-slot) :type 'invalid-slot-name) + (oset N object-name "NewName") + (should (string= "NewName" (oref N object-name))))) + +(defclass opt-test1 () + () + "Abstract base class" + :abstract t) + +(defclass opt-test2 (opt-test1) + () + "Instantiable child") + +(ert-deftest eieio-test-36-build-class-alist () + (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) + (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1))) + +(defclass eieio--testing () ()) + +(defmethod constructor :static ((_x eieio--testing) newname &rest _args) + (list newname 2)) + +(ert-deftest eieio-test-37-obsolete-name-in-constructor () + (should (equal (eieio--testing "toto") '("toto" 2)))) + +(ert-deftest eieio-autoload () + "Tests to see whether reftex-auc has been autoloaded" + (should + (fboundp 'eieio--defalias))) + + +(provide 'eieio-tests) + +;;; eieio-tests.el ends here diff --cc test/lisp/emacs-lisp/ert-tests.el index 5382c400962,00000000000..5d3675553d7 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@@ -1,843 -1,0 +1,843 @@@ +;;; ert-tests.el --- ERT's self-tests -*- lexical-binding: t -*- + - ;; Copyright (C) 2007-2008, 2010-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc. + +;; Author: Christian Ohler + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; This file is part of ERT, the Emacs Lisp Regression Testing tool. +;; See ert.el or the texinfo manual for more details. + +;;; Code: + +(require 'cl-lib) +(require 'ert) + +;;; Self-test that doesn't rely on ERT, for bootstrapping. + +;; This is used to test that bodies actually run. +(defvar ert--test-body-was-run) +(ert-deftest ert-test-body-runs () + (setq ert--test-body-was-run t)) + +(defun ert-self-test () + "Run ERT's self-tests and make sure they actually ran." + (let ((window-configuration (current-window-configuration))) + (let ((ert--test-body-was-run nil)) + ;; The buffer name chosen here should not compete with the default + ;; results buffer name for completion in `switch-to-buffer'. + (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) + (cl-assert ert--test-body-was-run) + (if (zerop (ert-stats-completed-unexpected stats)) + ;; Hide results window only when everything went well. + (set-window-configuration window-configuration) + (error "ERT self-test failed")))))) + +(defun ert-self-test-and-exit () + "Run ERT's self-tests and exit Emacs. + +The exit code will be zero if the tests passed, nonzero if they +failed or if there was a problem." + (unwind-protect + (progn + (ert-self-test) + (kill-emacs 0)) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 1)))) + + +;;; Further tests are defined using ERT. + +(ert-deftest ert-test-nested-test-body-runs () + "Test that nested test bodies run." + (let ((was-run nil)) + (let ((test (make-ert-test :body (lambda () + (setq was-run t))))) + (cl-assert (not was-run)) + (ert-run-test test) + (cl-assert was-run)))) + + +;;; Test that pass/fail works. +(ert-deftest ert-test-pass () + (let ((test (make-ert-test :body (lambda ())))) + (let ((result (ert-run-test test))) + (cl-assert (ert-test-passed-p result))))) + +(ert-deftest ert-test-fail () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed "failure message")) + t)))) + +(ert-deftest ert-test-fail-debug-with-condition-case () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (condition-case condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (cl-assert (equal condition '(ert-test-failed "failure message")) t))))) + +(ert-deftest ert-test-fail-debug-with-debugger-1 () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (let ((debugger (lambda (&rest _args) + (cl-assert nil)))) + (let ((ert-debug-on-error nil)) + (ert-run-test test))))) + +(ert-deftest ert-test-fail-debug-with-debugger-2 () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (cl-block nil + (let ((debugger (lambda (&rest _args) + (cl-return-from nil nil)))) + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil))))) + +(ert-deftest ert-test-fail-debug-nested-with-debugger () + (let ((test (make-ert-test :body (lambda () + (let ((ert-debug-on-error t)) + (ert-fail "failure message")))))) + (let ((debugger (lambda (&rest _args) + (cl-assert nil nil "Assertion a")))) + (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda () + (let ((ert-debug-on-error nil)) + (ert-fail "failure message")))))) + (cl-block nil + (let ((debugger (lambda (&rest _args) + (cl-return-from nil nil)))) + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil nil "Assertion b"))))) + +(ert-deftest ert-test-error () + (let ((test (make-ert-test :body (lambda () (error "Error message"))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(error "Error message")) + t)))) + +(ert-deftest ert-test-error-debug () + (let ((test (make-ert-test :body (lambda () (error "Error message"))))) + (condition-case condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (cl-assert (equal condition '(error "Error message")) t))))) + + +;;; Test that `should' works. +(ert-deftest ert-test-should () + (let ((test (make-ert-test :body (lambda () (should nil))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should nil) :form nil :value nil))) + t))) + (let ((test (make-ert-test :body (lambda () (should t))))) + (let ((result (ert-run-test test))) + (cl-assert (ert-test-passed-p result) t)))) + +(ert-deftest ert-test-should-value () + (should (eql (should 'foo) 'foo)) + (should (eql (should 'bar) 'bar))) + +(ert-deftest ert-test-should-not () + (let ((test (make-ert-test :body (lambda () (should-not t))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should-not t) :form t :value t))) + t))) + (let ((test (make-ert-test :body (lambda () (should-not nil))))) + (let ((result (ert-run-test test))) + (cl-assert (ert-test-passed-p result))))) + + +(ert-deftest ert-test-should-with-macrolet () + (let ((test (make-ert-test :body (lambda () + (cl-macrolet ((foo () `(progn t nil))) + (should (foo))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should (foo)) + :form (progn t nil) + :value nil))))))) + +(ert-deftest ert-test-should-error () + ;; No error. + (let ((test (make-ert-test :body (lambda () (should-error (progn)))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-failed-p result)) + (should (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (progn)) + :form (progn) + :value nil + :fail-reason "did not signal an error")))))) + ;; A simple error. + (should (equal (should-error (error "Foo")) + '(error "Foo"))) + ;; Error of unexpected type. + (let ((test (make-ert-test :body (lambda () + (should-error (error "Foo") + :type 'singularity-error))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (error "Foo") :type 'singularity-error) + :form (error "Foo") + :condition (error "Foo") + :fail-reason + "the error signaled did not have the expected type")))))) + ;; Error of the expected type. + (let* ((error nil) + (test (make-ert-test + :body (lambda () + (setq error + (should-error (signal 'singularity-error nil) + :type 'singularity-error)))))) + (let ((result (ert-run-test test))) + (should (ert-test-passed-p result)) + (should (equal error '(singularity-error)))))) + +(ert-deftest ert-test-should-error-subtypes () + (should-error (signal 'singularity-error nil) + :type 'singularity-error + :exclude-subtypes t) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'arith-error nil) + :type 'singularity-error))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'arith-error nil) + :type 'singularity-error) + :form (signal arith-error nil) + :condition (arith-error) + :fail-reason + "the error signaled did not have the expected type")))))) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'arith-error nil) + :type 'singularity-error + :exclude-subtypes t))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'arith-error nil) + :type 'singularity-error + :exclude-subtypes t) + :form (signal arith-error nil) + :condition (arith-error) + :fail-reason + "the error signaled did not have the expected type")))))) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'singularity-error nil) + :type 'arith-error + :exclude-subtypes t))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'singularity-error nil) + :type 'arith-error + :exclude-subtypes t) + :form (signal singularity-error nil) + :condition (singularity-error) + :fail-reason + "the error signaled was a subtype of the expected type"))))) + )) + +(ert-deftest ert-test-skip-unless () + ;; Don't skip. + (let ((test (make-ert-test :body (lambda () (skip-unless t))))) + (let ((result (ert-run-test test))) + (should (ert-test-passed-p result)))) + ;; Skip. + (let ((test (make-ert-test :body (lambda () (skip-unless nil))))) + (let ((result (ert-run-test test))) + (should (ert-test-skipped-p result)))) + ;; Skip in case of error. + (let ((test (make-ert-test :body (lambda () (skip-unless (error "Foo")))))) + (let ((result (ert-run-test test))) + (should (ert-test-skipped-p result))))) + +(defmacro ert--test-my-list (&rest args) + "Don't use this. Instead, call `list' with ARGS, it does the same thing. + +This macro is used to test if macroexpansion in `should' works." + `(list ,@args)) + +(ert-deftest ert-test-should-failure-debugging () + "Test that `should' errors contain the information we expect them to." + (cl-loop + for (body expected-condition) in + `((,(lambda () (let ((x nil)) (should x))) + (ert-test-failed ((should x) :form x :value nil))) + (,(lambda () (let ((x t)) (should-not x))) + (ert-test-failed ((should-not x) :form x :value t))) + (,(lambda () (let ((x t)) (should (not x)))) + (ert-test-failed ((should (not x)) :form (not t) :value nil))) + (,(lambda () (let ((x nil)) (should-not (not x)))) + (ert-test-failed ((should-not (not x)) :form (not nil) :value t))) + (,(lambda () (let ((x t) (y nil)) (should-not + (ert--test-my-list x y)))) + (ert-test-failed + ((should-not (ert--test-my-list x y)) + :form (list t nil) + :value (t nil)))) + (,(lambda () (let ((_x t)) (should (error "Foo")))) + (error "Foo"))) + do + (let ((test (make-ert-test :body body))) + (condition-case actual-condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (should (equal actual-condition expected-condition))))))) + +(ert-deftest ert-test-deftest () + ;; FIXME: These tests don't look very good. What is their intent, i.e. what + ;; are they really testing? The precise generated code shouldn't matter, so + ;; we should either test the behavior of the code, or else try to express the + ;; kind of efficiency guarantees we're looking for. + (should (equal (macroexpand '(ert-deftest abc () "foo" :tags '(bar))) + '(progn + (ert-set-test 'abc + (progn + "Constructor for objects of type `ert-test'." + (vector 'cl-struct-ert-test 'abc "foo" + #'(lambda nil) + nil ':passed + '(bar)))) + (setq current-load-list + (cons + '(ert-deftest . abc) + current-load-list)) + 'abc))) + (should (equal (macroexpand '(ert-deftest def () + :expected-result ':passed)) + '(progn + (ert-set-test 'def + (progn + "Constructor for objects of type `ert-test'." + (vector 'cl-struct-ert-test 'def nil + #'(lambda nil) + nil ':passed 'nil))) + (setq current-load-list + (cons + '(ert-deftest . def) + current-load-list)) + 'def))) + ;; :documentation keyword is forbidden + (should-error (macroexpand '(ert-deftest ghi () + :documentation "foo")))) + +(ert-deftest ert-test-record-backtrace () + (let ((test (make-ert-test :body (lambda () (ert-fail "foo"))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (with-temp-buffer + (ert--print-backtrace (ert-test-failed-backtrace result)) + (goto-char (point-min)) + (end-of-line) + (let ((first-line (buffer-substring-no-properties (point-min) (point)))) + (should (equal first-line " (closure (ert--test-body-was-run t) nil (ert-fail \"foo\"))()"))))))) + +(ert-deftest ert-test-messages () + :tags '(:causes-redisplay) + (let* ((message-string "Test message") + (messages-buffer (get-buffer-create "*Messages*")) + (test (make-ert-test :body (lambda () (message "%s" message-string))))) + (with-current-buffer messages-buffer + (let ((result (ert-run-test test))) + (should (equal (concat message-string "\n") + (ert-test-result-messages result))))))) + +(ert-deftest ert-test-running-tests () + (let ((outer-test (ert-get-test 'ert-test-running-tests))) + (should (equal (ert-running-test) outer-test)) + (let (test1 test2 test3) + (setq test1 (make-ert-test + :name "1" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test1 test2 test3 + outer-test))))) + test2 (make-ert-test + :name "2" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test3 test2 outer-test))) + (ert-run-test test1))) + test3 (make-ert-test + :name "3" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test3 outer-test))) + (ert-run-test test2)))) + (should (ert-test-passed-p (ert-run-test test3)))))) + +(ert-deftest ert-test-test-result-expected-p () + "Test `ert-test-result-expected-p' and (implicitly) `ert-test-result-type-p'." + ;; passing test + (let ((test (make-ert-test :body (lambda ())))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; unexpected failure + (let ((test (make-ert-test :body (lambda () (ert-fail "failed"))))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + ;; expected failure + (let ((test (make-ert-test :body (lambda () (ert-fail "failed")) + :expected-result-type ':failed))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; `not' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(not :failed)))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(not :passed)))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + ;; `and' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(and :passed :failed)))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(and :passed + (not :failed))))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; `or' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(or (and :passed :failed) + :passed)))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(or (and :passed :failed) + nil (not t))))) + (should-not (ert-test-result-expected-p test (ert-run-test test))))) + +;;; Test `ert-select-tests'. +(ert-deftest ert-test-select-regexp () + (should (equal (ert-select-tests "^ert-test-select-regexp$" t) + (list (ert-get-test 'ert-test-select-regexp))))) + +(ert-deftest ert-test-test-boundp () + (should (ert-test-boundp 'ert-test-test-boundp)) + (should-not (ert-test-boundp (make-symbol "ert-not-a-test")))) + +(ert-deftest ert-test-select-member () + (should (equal (ert-select-tests '(member ert-test-select-member) t) + (list (ert-get-test 'ert-test-select-member))))) + +(ert-deftest ert-test-select-test () + (should (equal (ert-select-tests (ert-get-test 'ert-test-select-test) t) + (list (ert-get-test 'ert-test-select-test))))) + +(ert-deftest ert-test-select-symbol () + (should (equal (ert-select-tests 'ert-test-select-symbol t) + (list (ert-get-test 'ert-test-select-symbol))))) + +(ert-deftest ert-test-select-and () + (let ((test (make-ert-test + :name nil + :body nil + :most-recent-result (make-ert-test-failed + :condition nil + :backtrace nil + :infos nil)))) + (should (equal (ert-select-tests `(and (member ,test) :failed) t) + (list test))))) + +(ert-deftest ert-test-select-tag () + (let ((test (make-ert-test + :name nil + :body nil + :tags '(a b)))) + (should (equal (ert-select-tests `(tag a) (list test)) (list test))) + (should (equal (ert-select-tests `(tag b) (list test)) (list test))) + (should (equal (ert-select-tests `(tag c) (list test)) '())))) + + +;;; Tests for utility functions. +(ert-deftest ert-test-proper-list-p () + (should (ert--proper-list-p '())) + (should (ert--proper-list-p '(1))) + (should (ert--proper-list-p '(1 2))) + (should (ert--proper-list-p '(1 2 3))) + (should (ert--proper-list-p '(1 2 3 4))) + (should (not (ert--proper-list-p 'a))) + (should (not (ert--proper-list-p '(1 . a)))) + (should (not (ert--proper-list-p '(1 2 . a)))) + (should (not (ert--proper-list-p '(1 2 3 . a)))) + (should (not (ert--proper-list-p '(1 2 3 4 . a)))) + (let ((a (list 1))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) (cddr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cddr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cl-cdddr a)) + (should (not (ert--proper-list-p a))))) + +(ert-deftest ert-test-parse-keys-and-body () + (should (equal (ert--parse-keys-and-body '(foo)) '(nil (foo)))) + (should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil))) + (should (equal (ert--parse-keys-and-body '(:bar foo a (b))) + '((:bar foo) (a (b))))) + (should (equal (ert--parse-keys-and-body '(:bar foo :a (b))) + '((:bar foo :a (b)) nil))) + (should (equal (ert--parse-keys-and-body '(bar foo :a (b))) + '(nil (bar foo :a (b))))) + (should-error (ert--parse-keys-and-body '(:bar foo :a)))) + + +(ert-deftest ert-test-run-tests-interactively () + :tags '(:causes-redisplay) + (let ((passing-test (make-ert-test :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test :name 'failing-test + :body (lambda () (ert-fail + "failure message")))) + (skipped-test (make-ert-test :name 'skipped-test + :body (lambda () (ert-skip + "skip message"))))) + (let ((ert-debug-on-error nil)) + (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")) + (messages nil) + (mock-message-fn + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil)) + (ert-run-tests-interactively + `(member ,passing-test ,failing-test, skipped-test) buffer-name + mock-message-fn) + (should (equal messages `(,(concat + "Ran 3 tests, 1 results were " + "as expected, 1 unexpected, " + "1 skipped")))) + (with-current-buffer buffer-name + (goto-char (point-min)) + (should (equal + (buffer-substring (point-min) + (save-excursion + (forward-line 5) + (point))) + (concat + "Selector: (member " + ")\n" + "Passed: 1\n" + "Failed: 1 (1 unexpected)\n" + "Skipped: 1\n" + "Total: 3/3\n"))))) + (when (get-buffer buffer-name) + (kill-buffer buffer-name)))))))) + +(ert-deftest ert-test-special-operator-p () + (should (ert--special-operator-p 'if)) + (should-not (ert--special-operator-p 'car)) + (should-not (ert--special-operator-p 'ert--special-operator-p)) + (let ((b (cl-gensym))) + (should-not (ert--special-operator-p b)) + (fset b 'if) + (should (ert--special-operator-p b)))) + +(ert-deftest ert-test-list-of-should-forms () + (let ((test (make-ert-test :body (lambda () + (should t) + (should (null '())) + (should nil) + (should t))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (equal (ert-test-result-should-forms result) + '(((should t) :form t :value t) + ((should (null '())) :form (null nil) :value t) + ((should nil) :form nil :value nil))))))) + +(ert-deftest ert-test-list-of-should-forms-observers-should-not-stack () + (let ((test (make-ert-test + :body (lambda () + (let ((test2 (make-ert-test + :body (lambda () + (should t))))) + (let ((result (ert-run-test test2))) + (should (ert-test-passed-p result)))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-passed-p result)) + (should (eql (length (ert-test-result-should-forms result)) + 1))))) + +(ert-deftest ert-test-list-of-should-forms-no-deep-copy () + (let ((test (make-ert-test :body (lambda () + (let ((obj (list 'a))) + (should (equal obj '(a))) + (setf (car obj) 'b) + (should (equal obj '(b)))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-passed-p result)) + (should (equal (ert-test-result-should-forms result) + '(((should (equal obj '(a))) :form (equal (b) (a)) :value t + :explanation nil) + ((should (equal obj '(b))) :form (equal (b) (b)) :value t + :explanation nil) + )))))) + +(ert-deftest ert-test-string-first-line () + (should (equal (ert--string-first-line "") "")) + (should (equal (ert--string-first-line "abc") "abc")) + (should (equal (ert--string-first-line "abc\n") "abc")) + (should (equal (ert--string-first-line "foo\nbar") "foo")) + (should (equal (ert--string-first-line " foo\nbar\nbaz\n") " foo"))) + +(ert-deftest ert-test-explain-equal () + (should (equal (ert--explain-equal nil 'foo) + '(different-atoms nil foo))) + (should (equal (ert--explain-equal '(a a) '(a b)) + '(list-elt 1 (different-atoms a b)))) + (should (equal (ert--explain-equal '(1 48) '(1 49)) + '(list-elt 1 (different-atoms (48 "#x30" "?0") + (49 "#x31" "?1"))))) + (should (equal (ert--explain-equal 'nil '(a)) + '(different-types nil (a)))) + (should (equal (ert--explain-equal '(a b c) '(a b c d)) + '(proper-lists-of-different-length 3 4 (a b c) (a b c d) + first-mismatch-at 3))) + (let ((sym (make-symbol "a"))) + (should (equal (ert--explain-equal 'a sym) + `(different-symbols-with-the-same-name a ,sym))))) + +(ert-deftest ert-test-explain-equal-improper-list () + (should (equal (ert--explain-equal '(a . b) '(a . c)) + '(cdr (different-atoms b c))))) + +(ert-deftest ert-test-explain-equal-keymaps () + ;; This used to be very slow. + (should (equal (make-keymap) (make-keymap))) + (should (equal (make-sparse-keymap) (make-sparse-keymap)))) + +(ert-deftest ert-test-significant-plist-keys () + (should (equal (ert--significant-plist-keys '()) '())) + (should (equal (ert--significant-plist-keys '(a b c d e f c g p q r nil s t)) + '(a c e p s)))) + +(ert-deftest ert-test-plist-difference-explanation () + (should (equal (ert--plist-difference-explanation + '(a b c nil) '(a b)) + nil)) + (should (equal (ert--plist-difference-explanation + '(a b c t) '(a b)) + '(different-properties-for-key c (different-atoms t nil)))) + (should (equal (ert--plist-difference-explanation + '(a b c t) '(c nil a b)) + '(different-properties-for-key c (different-atoms t nil)))) + (should (equal (ert--plist-difference-explanation + '(a b c (foo . bar)) '(c (foo . baz) a b)) + '(different-properties-for-key c + (cdr + (different-atoms bar baz)))))) + +(ert-deftest ert-test-abbreviate-string () + (should (equal (ert--abbreviate-string "foo" 4 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 3 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 3 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 2 nil) "fo")) + (should (equal (ert--abbreviate-string "foo" 1 nil) "f")) + (should (equal (ert--abbreviate-string "foo" 0 nil) "")) + (should (equal (ert--abbreviate-string "bar" 4 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 3 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 3 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 2 t) "ar")) + (should (equal (ert--abbreviate-string "bar" 1 t) "r")) + (should (equal (ert--abbreviate-string "bar" 0 t) ""))) + +(ert-deftest ert-test-explain-equal-string-properties () + (should + (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b)) + "foo") + '(char 0 "f" + (different-properties-for-key a (different-atoms b nil)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties + #("foo" 1 3 (a b)) + #("goo" 0 1 (c d))) + '(array-elt 0 (different-atoms (?f "#x66" "?f") + (?g "#x67" "?g"))))) + (should + (equal (ert--explain-equal-including-properties + #("foo" 0 1 (a b c d) 1 3 (a b)) + #("foo" 0 1 (c d a b) 1 2 (a foo))) + '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) + context-before "f" context-after "o")))) + +(ert-deftest ert-test-equal-including-properties () + (should (equal-including-properties "foo" "foo")) + (should (ert-equal-including-properties "foo" "foo")) + + (should (equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should (ert-equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + + (should (equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should (ert-equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + + (should-not (equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd))) + (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd))) + + ;; This is bug 6581. + (should-not (equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + (should (ert-equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t))))) + +(ert-deftest ert-test-stats-set-test-and-result () + (let* ((test-1 (make-ert-test :name 'test-1 + :body (lambda () nil))) + (test-2 (make-ert-test :name 'test-2 + :body (lambda () nil))) + (test-3 (make-ert-test :name 'test-2 + :body (lambda () nil))) + (stats (ert--make-stats (list test-1 test-2) 't)) + (failed (make-ert-test-failed :condition nil + :backtrace nil + :infos nil)) + (skipped (make-ert-test-skipped :condition nil + :backtrace nil + :infos nil))) + (should (eql 2 (ert-stats-total stats))) + (should (eql 0 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 failed) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 nil) + (should (eql 2 (ert-stats-total stats))) + (should (eql 0 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-3 failed) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 1 test-2 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 2 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 skipped) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 1 (ert-stats-skipped stats))))) + + +(provide 'ert-tests) + +;;; ert-tests.el ends here + +;; Local Variables: +;; no-byte-compile: t +;; End: diff --cc test/lisp/emacs-lisp/ert-x-tests.el index 660a1cb218e,00000000000..ef8642aebfb mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@@ -1,280 -1,0 +1,280 @@@ +;;; ert-x-tests.el --- Tests for ert-x.el + - ;; Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. + +;; Author: Phil Hagelberg +;; Christian Ohler + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; This file is part of ERT, the Emacs Lisp Regression Testing tool. +;; See ert.el or the texinfo manual for more details. + +;;; Code: + +(eval-when-compile + (require 'cl-lib)) +(require 'ert) +(require 'ert-x) + +;;; Utilities + +(ert-deftest ert-test-buffer-string-reindented () + (ert-with-test-buffer (:name "well-indented") + (insert (concat "(hello (world\n" + " 'elisp)\n")) + (emacs-lisp-mode) + (should (equal (ert-buffer-string-reindented) (buffer-string)))) + (ert-with-test-buffer (:name "badly-indented") + (insert (concat "(hello\n" + " world)")) + (emacs-lisp-mode) + (should-not (equal (ert-buffer-string-reindented) (buffer-string))))) + +(defun ert--hash-table-to-alist (table) + (let ((accu nil)) + (maphash (lambda (key value) + (push (cons key value) accu)) + table) + (nreverse accu))) + +(ert-deftest ert-test-test-buffers () + (let (buffer-1 + buffer-2) + (let ((test-1 + (make-ert-test + :name 'test-1 + :body (lambda () + (ert-with-test-buffer (:name "foo") + (should (string-match + "[*]Test buffer (ert-test-test-buffers): foo[*]" + (buffer-name))) + (setq buffer-1 (current-buffer)))))) + (test-2 + (make-ert-test + :name 'test-2 + :body (lambda () + (ert-with-test-buffer (:name "bar") + (should (string-match + "[*]Test buffer (ert-test-test-buffers): bar[*]" + (buffer-name))) + (setq buffer-2 (current-buffer)) + (ert-fail "fail for test")))))) + (let ((ert--test-buffers (make-hash-table :weakness t))) + (ert-run-tests `(member ,test-1 ,test-2) #'ignore) + (should (equal (ert--hash-table-to-alist ert--test-buffers) + `((,buffer-2 . t)))) + (should-not (buffer-live-p buffer-1)) + (should (buffer-live-p buffer-2)))))) + + +(ert-deftest ert-filter-string () + (should (equal (ert-filter-string "foo bar baz" "quux") + "foo bar baz")) + (should (equal (ert-filter-string "foo bar baz" "bar") + "foo baz"))) + +(ert-deftest ert-propertized-string () + (should (ert-equal-including-properties + (ert-propertized-string "a" '(a b) "b" '(c t) "cd") + #("abcd" 1 2 (a b) 2 4 (c t)))) + (should (ert-equal-including-properties + (ert-propertized-string "foo " '(face italic) "bar" " baz" nil + " quux") + #("foo bar baz quux" 4 11 (face italic))))) + + +;;; Tests for ERT itself that require test features from ert-x.el. + +(ert-deftest ert-test-run-tests-interactively-2 () + :tags '(:causes-redisplay) + (let* ((passing-test (make-ert-test :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test :name 'failing-test + :body (lambda () + (ert-info ((propertize "foo\nbar" + 'a 'b)) + (ert-fail + "failure message"))))) + (skipped-test (make-ert-test :name 'skipped-test + :body (lambda () (ert-skip + "skip message")))) + (ert-debug-on-error nil) + (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) + (messages nil) + (mock-message-fn + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (cl-flet ((expected-string (with-font-lock-p) + (ert-propertized-string + "Selector: (member " + ")\n" + "Passed: 1\n" + "Failed: 1 (1 unexpected)\n" + "Skipped: 1\n" + "Total: 3/3\n\n" + "Started at:\n" + "Finished.\n" + "Finished at:\n\n" + `(category ,(button-category-symbol + 'ert--results-progress-bar-button) + button (t) + face ,(if with-font-lock-p + 'ert-test-result-unexpected + 'button)) + ".Fs" nil "\n\n" + `(category ,(button-category-symbol + 'ert--results-expand-collapse-button) + button (t) + face ,(if with-font-lock-p + 'ert-test-result-unexpected + 'button)) + "F" nil " " + `(category ,(button-category-symbol + 'ert--test-name-button) + button (t) + ert-test-name failing-test) + "failing-test" + nil "\n Info: " '(a b) "foo\n" + nil " " '(a b) "bar" + nil "\n (ert-test-failed \"failure message\")\n\n\n" + ))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil)) + (ert-run-tests-interactively + `(member ,passing-test ,failing-test ,skipped-test) buffer-name + mock-message-fn) + (should (equal messages `(,(concat + "Ran 3 tests, 1 results were " + "as expected, 1 unexpected, " + "1 skipped")))) + (with-current-buffer buffer-name + (font-lock-mode 0) + (should (ert-equal-including-properties + (ert-filter-string (buffer-string) + '("Started at:\\(.*\\)$" 1) + '("Finished at:\\(.*\\)$" 1)) + (expected-string nil))) + ;; `font-lock-mode' only works if interactive, so + ;; pretend we are. + (let ((noninteractive nil)) + (font-lock-mode 1)) + (should (ert-equal-including-properties + (ert-filter-string (buffer-string) + '("Started at:\\(.*\\)$" 1) + '("Finished at:\\(.*\\)$" 1)) + (expected-string t))))) + (when (get-buffer buffer-name) + (kill-buffer buffer-name))))))) + +(ert-deftest ert-test-describe-test () + "Tests `ert-describe-test'." + (save-window-excursion + (ert-with-buffer-renamed ("*Help*") + (if (< emacs-major-version 24) + (should (equal (should-error (ert-describe-test 'ert-describe-test)) + '(error "Requires Emacs 24"))) + (ert-describe-test 'ert-test-describe-test) + (with-current-buffer "*Help*" + (let ((case-fold-search nil)) + (should (string-match (concat + "\\`ert-test-describe-test is a test" + " defined in" + " ['`‘]ert-x-tests.elc?['’]\\.\n\n" + "Tests ['`‘]ert-describe-test['’]\\.\n\\'") + (buffer-string))))))))) + +(ert-deftest ert-test-message-log-truncation () + :tags '(:causes-redisplay) + (let ((test (make-ert-test + :body (lambda () + ;; Emacs would combine messages if we + ;; generate the same message multiple + ;; times. + (message "a") + (message "b") + (message "c") + (message "d"))))) + (let (result) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max 2)) + (setq result (ert-run-test test))) + (should (equal (with-current-buffer "*Messages*" + (buffer-string)) + "c\nd\n"))) + (should (equal (ert-test-result-messages result) "a\nb\nc\nd\n"))))) + +(ert-deftest ert-test-builtin-message-log-flushing () + "This test attempts to demonstrate that there is no way to +force immediate truncation of the *Messages* buffer from Lisp +\(and hence justifies the existence of +`ert--force-message-log-buffer-truncation'): The only way that +came to my mind was \(message \"\"), which doesn't have the +desired effect." + :tags '(:causes-redisplay) + (ert-with-buffer-renamed ("*Messages*") + (with-current-buffer "*Messages*" + (should (equal (buffer-string) "")) + ;; We used to get sporadic failures in this test that involved + ;; a spurious newline at the beginning of the buffer, before + ;; the first message. Below, we print a message and erase the + ;; buffer since this seems to eliminate the sporadic failures. + (message "foo") + (erase-buffer) + (should (equal (buffer-string) "")) + (let ((message-log-max 2)) + (let ((message-log-max t)) + (cl-loop for i below 4 do + (message "%s" i)) + (should (equal (buffer-string) "0\n1\n2\n3\n"))) + (should (equal (buffer-string) "0\n1\n2\n3\n")) + (message "") + (should (equal (buffer-string) "0\n1\n2\n3\n")) + (message "Test message") + (should (equal (buffer-string) "3\nTest message\n")))))) + +(ert-deftest ert-test-force-message-log-buffer-truncation () + :tags '(:causes-redisplay) + (cl-labels ((body () + (cl-loop for i below 3 do + (message "%s" i))) + ;; Uses the implicit messages buffer truncation implemented + ;; in Emacs' C core. + (c (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max x)) + (body)) + (with-current-buffer "*Messages*" + (buffer-string)))) + ;; Uses our lisp reimplementation. + (lisp (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max t)) + (body)) + (let ((message-log-max x)) + (ert--force-message-log-buffer-truncation)) + (with-current-buffer "*Messages*" + (buffer-string))))) + (cl-loop for x in '(0 1 2 3 4 t) do + (should (equal (c x) (lisp x)))))) + + +(provide 'ert-x-tests) + +;;; ert-x-tests.el ends here diff --cc test/lisp/emacs-lisp/generator-tests.el index 96a68d1b9c1,00000000000..8ed0f2a240d mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@@ -1,284 -1,0 +1,284 @@@ +;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Daniel Colascione +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +(require 'generator) +(require 'ert) +(require 'cl-lib) + +(defun generator-list-subrs () + (cl-loop for x being the symbols + when (and (fboundp x) + (cps--special-form-p (symbol-function x))) + collect x)) + +(defmacro cps-testcase (name &rest body) + "Perform a simple test of the continuation-transforming code. + +`cps-testcase' defines an ERT testcase called NAME that evaluates +BODY twice: once using ordinary `eval' and once using +lambda-generators. The test ensures that the two forms produce +identical output. +" + `(progn + (ert-deftest ,name () + (should + (equal + (funcall (lambda () ,@body)) + (iter-next + (funcall + (iter-lambda () (iter-yield (progn ,@body)))))))) + (ert-deftest ,(intern (format "%s-noopt" name)) () + (should + (equal + (funcall (lambda () ,@body)) + (iter-next + (funcall + (let ((cps-inhibit-atomic-optimization t)) + (iter-lambda () (iter-yield (progn ,@body))))))))))) + +(put 'cps-testcase 'lisp-indent-function 1) + +(defvar *cps-test-i* nil) +(defun cps-get-test-i () + *cps-test-i*) + +(cps-testcase cps-simple-1 (progn 1 2 3)) +(cps-testcase cps-empty-progn (progn)) +(cps-testcase cps-inline-not-progn (inline 1 2 3)) +(cps-testcase cps-prog1-a (prog1 1 2 3)) +(cps-testcase cps-prog1-b (prog1 1)) +(cps-testcase cps-prog1-c (prog2 1 2 3)) +(cps-testcase cps-quote (progn 'hello)) +(cps-testcase cps-function (progn #'hello)) + +(cps-testcase cps-and-fail (and 1 nil 2)) +(cps-testcase cps-and-succeed (and 1 2 3)) +(cps-testcase cps-and-empty (and)) + +(cps-testcase cps-or-fallthrough (or nil 1 2)) +(cps-testcase cps-or-alltrue (or 1 2 3)) +(cps-testcase cps-or-empty (or)) + +(cps-testcase cps-let* (let* ((i 10)) i)) +(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i))) +(cps-testcase cps-let (let ((i 10)) i)) +(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i))) +(cps-testcase cps-let-novars (let nil 42)) +(cps-testcase cps-let*-novars (let* nil 42)) + +(cps-testcase cps-let-parallel + (let ((a 5) (b 6)) (let ((a b) (b a)) (list a b)))) + +(cps-testcase cps-let*-parallel + (let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b)))) + +(cps-testcase cps-while-dynamic + (setq *cps-test-i* 0) + (while (< *cps-test-i* 10) + (setf *cps-test-i* (+ *cps-test-i* 1))) + *cps-test-i*) + +(cps-testcase cps-while-lexical + (let* ((i 0) (j 10)) + (while (< i 10) + (setf i (+ i 1)) + (setf j (+ j (* i 10)))) + j)) + +(cps-testcase cps-while-incf + (let* ((i 0) (j 10)) + (while (< i 10) + (cl-incf i) + (setf j (+ j (* i 10)))) + j)) + +(cps-testcase cps-dynbind + (setf *cps-test-i* 0) + (let* ((*cps-test-i* 5)) + (cps-get-test-i))) + +(cps-testcase cps-nested-application + (+ (+ 3 5) 1)) + +(cps-testcase cps-unwind-protect + (setf *cps-test-i* 0) + (unwind-protect + (setf *cps-test-i* 1) + (setf *cps-test-i* 2)) + *cps-test-i*) + +(cps-testcase cps-catch-unused + (catch 'mytag 42)) + +(cps-testcase cps-catch-thrown + (1+ (catch 'mytag + (throw 'mytag (+ 2 2))))) + +(cps-testcase cps-loop + (cl-loop for x from 1 to 10 collect x)) + +(cps-testcase cps-loop-backquote + `(a b ,(cl-loop for x from 1 to 10 collect x) -1)) + +(cps-testcase cps-if-branch-a + (if t 'abc)) + +(cps-testcase cps-if-branch-b + (if t 'abc 'def)) + +(cps-testcase cps-if-condition-fail + (if nil 'abc 'def)) + +(cps-testcase cps-cond-empty + (cond)) + +(cps-testcase cps-cond-atomi + (cond (42))) + +(cps-testcase cps-cond-complex + (cond (nil 22) ((1+ 1) 42) (t 'bad))) + +(put 'cps-test-error 'error-conditions '(cps-test-condition)) + +(cps-testcase cps-condition-case + (condition-case + condvar + (signal 'cps-test-error 'test-data) + (cps-test-condition condvar))) + +(cps-testcase cps-condition-case-no-error + (condition-case + condvar + 42 + (cps-test-condition condvar))) + +(ert-deftest cps-generator-basic () + (let* ((gen (iter-lambda () + (iter-yield 1) + (iter-yield 2) + (iter-yield 3) + 4)) + (gen-inst (funcall gen))) + (should (eql (iter-next gen-inst) 1)) + (should (eql (iter-next gen-inst) 2)) + (should (eql (iter-next gen-inst) 3)) + + ;; should-error doesn't catch the generator-end condition (which + ;; isn't an error), so we write our own. + (let (errored) + (condition-case x + (iter-next gen-inst) + (iter-end-of-sequence + (setf errored (cdr x)))) + (should (eql errored 4))))) + +(iter-defun mygenerator (i) + (iter-yield 1) + (iter-yield i) + (iter-yield 2)) + +(ert-deftest cps-test-iter-do () + (let (mylist) + (iter-do (x (mygenerator 4)) + (push x mylist)) + (should (equal mylist '(2 4 1))))) + +(iter-defun gen-using-yield-value () + (let (f) + (setf f (iter-yield 42)) + (iter-yield f) + -8)) + +(ert-deftest cps-yield-value () + (let ((it (gen-using-yield-value))) + (should (eql (iter-next it -1) 42)) + (should (eql (iter-next it -1) -1)))) + +(ert-deftest cps-loop () + (should + (equal (cl-loop for x iter-by (mygenerator 42) + collect x) + '(1 42 2)))) + +(iter-defun gen-using-yield-from () + (let ((sub-iter (gen-using-yield-value))) + (iter-yield (1+ (iter-yield-from sub-iter))))) + +(ert-deftest cps-test-yield-from-works () + (let ((it (gen-using-yield-from))) + (should (eql (iter-next it -1) 42)) + (should (eql (iter-next it -1) -1)) + (should (eql (iter-next it -1) -7)))) + +(defvar cps-test-closed-flag nil) + +(ert-deftest cps-test-iter-close () + (garbage-collect) + (let ((cps-test-closed-flag nil)) + (let ((iter (funcall + (iter-lambda () + (unwind-protect (iter-yield 1) + (setf cps-test-closed-flag t)))))) + (should (equal (iter-next iter) 1)) + (should (not cps-test-closed-flag)) + (iter-close iter) + (should cps-test-closed-flag)))) + +(ert-deftest cps-test-iter-close-idempotent () + (garbage-collect) + (let ((cps-test-closed-flag nil)) + (let ((iter (funcall + (iter-lambda () + (unwind-protect (iter-yield 1) + (setf cps-test-closed-flag t)))))) + (should (equal (iter-next iter) 1)) + (should (not cps-test-closed-flag)) + (iter-close iter) + (should cps-test-closed-flag) + (setf cps-test-closed-flag nil) + (iter-close iter) + (should (not cps-test-closed-flag))))) + +(ert-deftest cps-test-iter-cleanup-once-only () + (let* ((nr-unwound 0) + (iter + (funcall (iter-lambda () + (unwind-protect + (progn + (iter-yield 1) + (error "test") + (iter-yield 2)) + (cl-incf nr-unwound)))))) + (should (equal (iter-next iter) 1)) + (should-error (iter-next iter)) + (should (equal nr-unwound 1)))) + +(iter-defun generator-with-docstring () + "Documentation!" + (declare (indent 5)) + nil) + +(ert-deftest cps-test-declarations-preserved () + (should (equal (documentation 'generator-with-docstring) "Documentation!")) + (should (equal (get 'generator-with-docstring 'lisp-indent-function) 5))) diff --cc test/lisp/emacs-lisp/let-alist-tests.el index 65727dc3af5,00000000000..80d418cabbe mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/let-alist-tests.el +++ b/test/lisp/emacs-lisp/let-alist-tests.el @@@ -1,91 -1,0 +1,91 @@@ +;;; let-alist.el --- tests for file handling. -*- lexical-binding: t; -*- + - ;; Copyright (C) 2012-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'let-alist) + +(ert-deftest let-alist-surface-test () + "Tests basic macro expansion for `let-alist'." + (should + (equal '(let ((symbol data)) + (let ((.test-one (cdr (assq 'test-one symbol))) + (.test-two (cdr (assq 'test-two symbol)))) + (list .test-one .test-two + .test-two .test-two))) + (cl-letf (((symbol-function #'make-symbol) (lambda (x) 'symbol))) + (macroexpand + '(let-alist data (list .test-one .test-two + .test-two .test-two)))))) + (should + (equal + (let ((.external "ext") + (.external.too "et")) + (let-alist '((test-two . 0) + (test-three . 1) + (sublist . ((foo . 2) + (bar . 3)))) + (list .test-one .test-two .test-three + .sublist.foo .sublist.bar + ..external ..external.too))) + (list nil 0 1 2 3 "ext" "et")))) + +(ert-deftest let-alist-cons () + (should + (equal + (let ((.external "ext") + (.external.too "et")) + (let-alist '((test-two . 0) + (test-three . 1) + (sublist . ((foo . 2) + (bar . 3)))) + (list `(, .test-one . , .test-two) + .sublist.bar ..external))) + (list '(nil . 0) 3 "ext")))) + +(defvar let-alist--test-counter 0 + "Used to count number of times a function is called.") + +(ert-deftest let-alist-evaluate-once () + "Check that the alist argument is only evaluated once." + (let ((let-alist--test-counter 0)) + (should + (equal + (let-alist (list + (cons 'test-two (cl-incf let-alist--test-counter)) + (cons 'test-three (cl-incf let-alist--test-counter))) + (list .test-one .test-two .test-two .test-three .cl-incf)) + '(nil 1 1 2 nil))))) + +(ert-deftest let-alist-remove-dot () + "Remove first dot from symbol." + (should (equal (let-alist--remove-dot 'hi) 'hi)) + (should (equal (let-alist--remove-dot '.hi) 'hi)) + (should (equal (let-alist--remove-dot '..hi) '.hi))) + +(ert-deftest let-alist-list-to-sexp () + "Check that multiple dots are handled correctly." + (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1))))))))) + (should (equal (let-alist--access-sexp '.foo.bar.baz 'var) + '(cdr (assq 'baz (cdr (assq 'bar (cdr (assq 'foo var)))))))) + (should (equal (let-alist--access-sexp '..foo.bar.baz 'var) '.foo.bar.baz))) + +;;; let-alist.el ends here diff --cc test/lisp/emacs-lisp/map-tests.el index 2a7fcc39d41,00000000000..d145c197a4e mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@@ -1,331 -1,0 +1,331 @@@ +;;; map-tests.el --- Tests for map.el -*- lexical-binding:t -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Nicolas Petton +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Tests for map.el + +;;; Code: + +(require 'ert) +(require 'map) + +(defmacro with-maps-do (var &rest body) + "Successively bind VAR to an alist, vector and hash-table. +Each map is built from the following alist data: +'((0 . 3) (1 . 4) (2 . 5)). +Evaluate BODY for each created map. + +\(fn (var map) body)" + (declare (indent 1) (debug t)) + (let ((alist (make-symbol "alist")) + (vec (make-symbol "vec")) + (ht (make-symbol "ht"))) + `(let ((,alist (list (cons 0 3) + (cons 1 4) + (cons 2 5))) + (,vec (vector 3 4 5)) + (,ht (make-hash-table))) + (puthash 0 3 ,ht) + (puthash 1 4 ,ht) + (puthash 2 5 ,ht) + (dolist (,var (list ,alist ,vec ,ht)) + ,@body)))) + +(ert-deftest test-map-elt () + (with-maps-do map + (should (= 3 (map-elt map 0))) + (should (= 4 (map-elt map 1))) + (should (= 5 (map-elt map 2))) + (should (null (map-elt map -1))) + (should (null (map-elt map 4))))) + +(ert-deftest test-map-elt-default () + (with-maps-do map + (should (= 5 (map-elt map 7 5))))) + +(ert-deftest test-map-elt-with-nil-value () + (should (null (map-elt '((a . 1) + (b)) + 'b + '2)))) + +(ert-deftest test-map-put () + (with-maps-do map + (setf (map-elt map 2) 'hello) + (should (eq (map-elt map 2) 'hello))) + (with-maps-do map + (map-put map 2 'hello) + (should (eq (map-elt map 2) 'hello))) + (let ((ht (make-hash-table))) + (setf (map-elt ht 2) 'a) + (should (eq (map-elt ht 2) + 'a))) + (let ((alist '((0 . a) (1 . b) (2 . c)))) + (setf (map-elt alist 2) 'a) + (should (eq (map-elt alist 2) + 'a))) + (let ((vec [3 4 5])) + (should-error (setf (map-elt vec 3) 6)))) + +(ert-deftest test-map-put-return-value () + (let ((ht (make-hash-table))) + (should (eq (map-put ht 'a 'hello) ht)))) + +(ert-deftest test-map-delete () + (with-maps-do map + (map-delete map 1) + (should (null (map-elt map 1)))) + (with-maps-do map + (map-delete map -2) + (should (null (map-elt map -2))))) + +(ert-deftest test-map-delete-return-value () + (let ((ht (make-hash-table))) + (should (eq (map-delete ht 'a) ht)))) + +(ert-deftest test-map-nested-elt () + (let ((vec [a b [c d [e f]]])) + (should (eq (map-nested-elt vec '(2 2 0)) 'e))) + (let ((alist '((a . 1) + (b . ((c . 2) + (d . 3) + (e . ((f . 4) + (g . 5)))))))) + (should (eq (map-nested-elt alist '(b e f)) + 4))) + (let ((ht (make-hash-table))) + (setf (map-elt ht 'a) 1) + (setf (map-elt ht 'b) (make-hash-table)) + (setf (map-elt (map-elt ht 'b) 'c) 2) + (should (eq (map-nested-elt ht '(b c)) + 2)))) + +(ert-deftest test-map-nested-elt-default () + (let ((vec [a b [c d]])) + (should (null (map-nested-elt vec '(2 3)))) + (should (null (map-nested-elt vec '(2 1 1)))) + (should (= 4 (map-nested-elt vec '(2 1 1) 4))))) + +(ert-deftest test-mapp () + (should (mapp nil)) + (should (mapp '((a . b) (c . d)))) + (should (mapp '(a b c d))) + (should (mapp [])) + (should (mapp [1 2 3])) + (should (mapp (make-hash-table))) + (should (mapp "hello")) + (should (not (mapp 1))) + (should (not (mapp 'hello)))) + +(ert-deftest test-map-keys () + (with-maps-do map + (should (equal (map-keys map) '(0 1 2)))) + (should (null (map-keys nil))) + (should (null (map-keys [])))) + +(ert-deftest test-map-values () + (with-maps-do map + (should (equal (map-values map) '(3 4 5))))) + +(ert-deftest test-map-pairs () + (with-maps-do map + (should (equal (map-pairs map) '((0 . 3) + (1 . 4) + (2 . 5)))))) + +(ert-deftest test-map-length () + (let ((ht (make-hash-table))) + (puthash 'a 1 ht) + (puthash 'b 2 ht) + (puthash 'c 3 ht) + (puthash 'd 4 ht) + (should (= 0 (map-length nil))) + (should (= 0 (map-length []))) + (should (= 0 (map-length (make-hash-table)))) + (should (= 5 (map-length [0 1 2 3 4]))) + (should (= 2 (map-length '((a . 1) (b . 2))))) + (should (= 4 (map-length ht))))) + +(ert-deftest test-map-copy () + (with-maps-do map + (let ((copy (map-copy map))) + (should (equal (map-keys map) (map-keys copy))) + (should (equal (map-values map) (map-values copy))) + (should (not (eq map copy)))))) + +(ert-deftest test-map-apply () + (with-maps-do map + (should (equal (map-apply (lambda (k v) (cons (int-to-string k) v)) + map) + '(("0" . 3) ("1" . 4) ("2" . 5))))) + (let ((vec [a b c])) + (should (equal (map-apply (lambda (k v) (cons (1+ k) v)) + vec) + '((1 . a) + (2 . b) + (3 . c)))))) + +(ert-deftest test-map-keys-apply () + (with-maps-do map + (should (equal (map-keys-apply (lambda (k) (int-to-string k)) + map) + '("0" "1" "2")))) + (let ((vec [a b c])) + (should (equal (map-keys-apply (lambda (k) (1+ k)) + vec) + '(1 2 3))))) + +(ert-deftest test-map-values-apply () + (with-maps-do map + (should (equal (map-values-apply (lambda (v) (1+ v)) + map) + '(4 5 6)))) + (let ((vec [a b c])) + (should (equal (map-values-apply (lambda (v) (symbol-name v)) + vec) + '("a" "b" "c"))))) + +(ert-deftest test-map-filter () + (with-maps-do map + (should (equal (map-keys (map-filter (lambda (_k v) + (<= 4 v)) + map)) + '(1 2))) + (should (null (map-filter (lambda (k _v) + (eq 'd k)) + map)))) + (should (null (map-filter (lambda (_k v) + (eq 3 v)) + [1 2 4 5]))) + (should (equal (map-filter (lambda (k _v) + (eq 3 k)) + [1 2 4 5]) + '((3 . 5))))) + +(ert-deftest test-map-remove () + (with-maps-do map + (should (equal (map-keys (map-remove (lambda (_k v) + (>= v 4)) + map)) + '(0))) + (should (equal (map-keys (map-remove (lambda (k _v) + (eq 'd k)) + map)) + (map-keys map)))) + (should (equal (map-remove (lambda (_k v) + (eq 3 v)) + [1 2 4 5]) + '((0 . 1) + (1 . 2) + (2 . 4) + (3 . 5)))) + (should (null (map-remove (lambda (k _v) + (>= k 0)) + [1 2 4 5])))) + +(ert-deftest test-map-empty-p () + (should (map-empty-p nil)) + (should (not (map-empty-p '((a . b) (c . d))))) + (should (map-empty-p [])) + (should (not (map-empty-p [1 2 3]))) + (should (map-empty-p (make-hash-table))) + (should (not (map-empty-p "hello"))) + (should (map-empty-p ""))) + +(ert-deftest test-map-contains-key () + (should (map-contains-key '((a . 1) (b . 2)) 'a)) + (should (not (map-contains-key '((a . 1) (b . 2)) 'c))) + (should (map-contains-key '(("a" . 1)) "a")) + (should (not (map-contains-key '(("a" . 1)) "a" #'eq))) + (should (map-contains-key [a b c] 2)) + (should (not (map-contains-key [a b c] 3)))) + +(ert-deftest test-map-some () + (with-maps-do map + (should (map-some (lambda (k _v) + (eq 1 k)) + map)) + (should-not (map-some (lambda (k _v) + (eq 'd k)) + map))) + (let ((vec [a b c])) + (should (map-some (lambda (k _v) + (> k 1)) + vec)) + (should-not (map-some (lambda (k _v) + (> k 3)) + vec)))) + +(ert-deftest test-map-every-p () + (with-maps-do map + (should (map-every-p (lambda (k _v) + k) + map)) + (should (not (map-every-p (lambda (_k _v) + nil) + map)))) + (let ((vec [a b c])) + (should (map-every-p (lambda (k _v) + (>= k 0)) + vec)) + (should (not (map-every-p (lambda (k _v) + (> k 3)) + vec))))) + +(ert-deftest test-map-into () + (let* ((alist '((a . 1) (b . 2))) + (ht (map-into alist 'hash-table))) + (should (hash-table-p ht)) + (should (equal (map-into (map-into alist 'hash-table) 'list) + alist)) + (should (listp (map-into ht 'list))) + (should (equal (map-keys (map-into (map-into ht 'list) 'hash-table)) + (map-keys ht))) + (should (equal (map-values (map-into (map-into ht 'list) 'hash-table)) + (map-values ht))) + (should (null (map-into nil 'list))) + (should (map-empty-p (map-into nil 'hash-table))) + (should-error (map-into [1 2 3] 'string)))) + +(ert-deftest test-map-let () + (map-let (foo bar baz) '((foo . 1) (bar . 2)) + (should (= foo 1)) + (should (= bar 2)) + (should (null baz))) + (map-let (('foo a) + ('bar b) + ('baz c)) + '((foo . 1) (bar . 2)) + (should (= a 1)) + (should (= b 2)) + (should (null c)))) + +(ert-deftest test-map-merge-with () + (should (equal (map-merge-with 'list #'+ + '((1 . 2)) + '((1 . 3) (2 . 4)) + '((1 . 1) (2 . 5) (3 . 0))) + '((3 . 0) (2 . 9) (1 . 6))))) + +(provide 'map-tests) +;;; map-tests.el ends here diff --cc test/lisp/emacs-lisp/nadvice-tests.el index e1d125de4af,00000000000..cd51599b86a mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@@ -1,211 -1,0 +1,211 @@@ +;;; advice-tests.el --- Test suite for the new advice thingy. + - ;; Copyright (C) 2012-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(ert-deftest advice-tests-nadvice () + "Test nadvice code." + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 2))) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) + (defun sm-test1 (x) (+ x 4)) + (should (equal (sm-test1 6) 20)) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 2))) + (should (equal (sm-test1 6) 10)) + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test1 6) 50)) + (defun sm-test1 (x) (+ x 14)) + (should (equal (sm-test1 6) 100)) + (should (equal (null (get 'sm-test1 'defalias-fset-function)) nil)) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test1 6) 20)) + (should (equal (get 'sm-test1 'defalias-fset-function) nil)) + + (advice-add 'sm-test3 :around + (lambda (f &rest args) `(toto ,(apply f args))) + '((name . wrap-with-toto))) + (defmacro sm-test3 (x) `(call-test3 ,x)) + (should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56))))) + +(ert-deftest advice-tests-macroaliases () + "Test nadvice code on aliases to macros." + (defmacro sm-test1 (a) `(list ',a)) + (defalias 'sm-test1-alias 'sm-test1) + (should (equal (macroexpand '(sm-test1-alias 5)) '(list '5))) + (advice-add 'sm-test1-alias :around + (lambda (f &rest args) `(cons 1 ,(apply f args)))) + (should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list '5)))) + (defmacro sm-test1 (a) `(list 0 ',a)) + (should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list 0 '5))))) + + +(ert-deftest advice-tests-advice () + "Test advice code." + (defun sm-test2 (x) (+ x 4)) + (should (equal (sm-test2 6) 10)) + (defadvice sm-test2 (around sm-test activate) + ad-do-it (setq ad-return-value (* ad-return-value 5))) + (should (equal (sm-test2 6) 50)) + (ad-deactivate 'sm-test2) + (should (equal (sm-test2 6) 10)) + (ad-activate 'sm-test2) + (should (equal (sm-test2 6) 50)) + (defun sm-test2 (x) (+ x 14)) + (should (equal (sm-test2 6) 100)) + (should (equal (null (get 'sm-test2 'defalias-fset-function)) nil)) + (ad-remove-advice 'sm-test2 'around 'sm-test) + (should (equal (sm-test2 6) 100)) + (ad-activate 'sm-test2) + (should (equal (sm-test2 6) 20)) + (should (equal (null (get 'sm-test2 'defalias-fset-function)) t)) + + (defadvice sm-test4 (around wrap-with-toto activate) + ad-do-it (setq ad-return-value `(toto ,ad-return-value))) + (defmacro sm-test4 (x) `(call-test4 ,x)) + (should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56)))) + (defmacro sm-test4 (x) `(call-testq ,x)) + (should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56)))) + + ;; This used to signal an error (bug#12858). + (autoload 'sm-test6 "foo") + (defadvice sm-test6 (around test activate) + ad-do-it)) + +(ert-deftest advice-tests-combination () + "Combining old style and new style advices." + (defun sm-test5 (x) (+ x 4)) + (should (equal (sm-test5 6) 10)) + (advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test5 6) 50)) + (defadvice sm-test5 (around test activate) + ad-do-it (setq ad-return-value (+ ad-return-value 0.1))) + (should (equal (sm-test5 5) 45.1)) + (ad-deactivate 'sm-test5) + (should (equal (sm-test5 6) 50)) + (ad-activate 'sm-test5) + (should (equal (sm-test5 6) 50.1)) + (defun sm-test5 (x) (+ x 14)) + (should (equal (sm-test5 6) 100.1)) + (advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test5 6) 20.1))) + +(ert-deftest advice-test-called-interactively-p () + "Check interaction between advice and called-interactively-p." + (defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4)) + (advice-add 'sm-test7 :around + (lambda (f &rest args) + (list (cons 1 (called-interactively-p)) (apply f args)))) + (should (equal (sm-test7) '((1 . nil) 11))) + (should (equal (call-interactively 'sm-test7) '((1 . t) 11))) + (let ((smi 7)) + (advice-add 'sm-test7 :before + (lambda (&rest args) + (setq smi (called-interactively-p)))) + (should (equal (list (sm-test7) smi) + '(((1 . nil) 11) nil))) + (should (equal (list (call-interactively 'sm-test7) smi) + '(((1 . t) 11) t)))) + (advice-add 'sm-test7 :around + (lambda (f &rest args) + (cons (cons 2 (called-interactively-p)) (apply f args)))) + (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11)))) + +(ert-deftest advice-test-called-interactively-p-around () + "Check interaction between around advice and called-interactively-p. + +This tests the currently broken case of the innermost advice to a +function being an around advice." + :expected-result :failed + (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p))) + (advice-add 'sm-test7.2 :around + (lambda (f &rest args) + (list (cons 1 (called-interactively-p)) (apply f args)))) + (should (equal (sm-test7.2) '((1 . nil) (1 . nil)))) + (should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t))))) + +(ert-deftest advice-test-called-interactively-p-filter-args () + "Check interaction between filter-args advice and called-interactively-p." + :expected-result :failed + (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p))) + (advice-add 'sm-test7.3 :filter-args #'list) + (should (equal (sm-test7.3) '(1 . nil))) + (should (equal (call-interactively 'sm-test7.3) '(1 . t)))) + +(ert-deftest advice-test-call-interactively () + "Check interaction between advice on call-interactively and called-interactively-p." + (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p))) + (let ((old (symbol-function 'call-interactively))) + (unwind-protect + (progn + (advice-add 'call-interactively :before #'ignore) + (should (equal (sm-test7.4) '(1 . nil))) + (should (equal (call-interactively 'sm-test7.4) '(1 . t)))) + (advice-remove 'call-interactively #'ignore) + (should (eq (symbol-function 'call-interactively) old))))) + +(ert-deftest advice-test-interactive () + "Check handling of interactive spec." + (defun sm-test8 (a) (interactive "p") a) + (defadvice sm-test8 (before adv1 activate) nil) + (defadvice sm-test8 (before adv2 activate) (interactive "P") nil) + (should (equal (interactive-form 'sm-test8) '(interactive "P")))) + +(ert-deftest advice-test-preactivate () + (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) + (defun sm-test9 (a) (interactive "p") a) + (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) + (defadvice sm-test9 (before adv1 pre act protect compile) nil) + (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil)) + (defadvice sm-test9 (before adv2 pre act protect compile) + (interactive "P") nil) + (should (equal (interactive-form 'sm-test9) '(interactive "P")))) + +(ert-deftest advice-test-multiples () + (let ((sm-test10 (lambda (a) (+ a 10))) + (sm-advice (lambda (x) (if (consp x) (list (* 5 (car x))) (* 4 x))))) + (should (equal (funcall sm-test10 5) 15)) + (add-function :filter-args (var sm-test10) sm-advice) + (should (advice-function-member-p sm-advice sm-test10)) + (should (equal (funcall sm-test10 5) 35)) + (add-function :filter-return (var sm-test10) sm-advice) + (should (equal (funcall sm-test10 5) 60)) + ;; Make sure we can add multiple times the same function, under the + ;; condition that they have different `name' properties. + (add-function :filter-args (var sm-test10) sm-advice '((name . "args"))) + (should (equal (funcall sm-test10 5) 140)) + (remove-function (var sm-test10) "args") + (should (equal (funcall sm-test10 5) 60)) + (add-function :filter-args (var sm-test10) sm-advice '((name . "args"))) + (add-function :filter-return (var sm-test10) sm-advice '((name . "ret"))) + (should (equal (funcall sm-test10 5) 560)) + ;; Make sure that if we specify to remove a function that was added + ;; multiple times, they are all removed, rather than removing only some + ;; arbitrary subset of them. + (remove-function (var sm-test10) sm-advice) + (should (equal (funcall sm-test10 5) 15)))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; advice-tests.el ends here. diff --cc test/lisp/emacs-lisp/package-tests.el index f8e05721255,00000000000..9afdfe67c26 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@@ -1,626 -1,0 +1,626 @@@ +;;; package-test.el --- Tests for the Emacs package system + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Daniel Hackney +;; Version: 1.0 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; You may want to run this from a separate Emacs instance from your +;; main one, because a bug in the code below could mess with your +;; installed packages. + +;; Run this in a clean Emacs session using: +;; +;; $ emacs -Q --batch -L . -l package-test.el -l ert -f ert-run-tests-batch-and-exit + +;;; Code: + +(require 'package) +(require 'ert) +(require 'cl-lib) + +(setq package-menu-async nil) + +(defvar package-test-user-dir nil + "Directory to use for installing packages during testing.") + +(defvar package-test-file-dir (file-name-directory (or load-file-name + buffer-file-name)) + "Directory of the actual \"package-test.el\" file.") + +(defvar simple-single-desc + (package-desc-create :name 'simple-single + :version '(1 3) + :summary "A single-file package with no dependencies" + :kind 'single + :extras '((:authors ("J. R. Hacker" . "jrh@example.com")) + (:maintainer "J. R. Hacker" . "jrh@example.com") + (:url . "http://doodles.au"))) + "Expected `package-desc' parsed from simple-single-1.3.el.") + +(defvar simple-depend-desc + (package-desc-create :name 'simple-depend + :version '(1 0) + :summary "A single-file package with a dependency." + :kind 'single + :reqs '((simple-single (1 3))) + :extras '((:authors ("J. R. Hacker" . "jrh@example.com")) + (:maintainer "J. R. Hacker" . "jrh@example.com"))) + "Expected `package-desc' parsed from simple-depend-1.0.el.") + +(defvar multi-file-desc + (package-desc-create :name 'multi-file + :version '(0 2 3) + :summary "Example of a multi-file tar package" + :kind 'tar + :extras '((:url . "http://puddles.li"))) + "Expected `package-desc' from \"multi-file-0.2.3.tar\".") + +(defvar new-pkg-desc + (package-desc-create :name 'new-pkg + :version '(1 0) + :kind 'single) + "Expected `package-desc' parsed from new-pkg-1.0.el.") + +(defvar simple-depend-desc-1 + (package-desc-create :name 'simple-depend-1 + :version '(1 0) + :summary "A single-file package with a dependency." + :kind 'single + :reqs '((simple-depend (1 0)) + (multi-file (0 1)))) + "`package-desc' used for testing dependencies.") + +(defvar simple-depend-desc-2 + (package-desc-create :name 'simple-depend-2 + :version '(1 0) + :summary "A single-file package with a dependency." + :kind 'single + :reqs '((simple-depend-1 (1 0)) + (multi-file (0 1)))) + "`package-desc' used for testing dependencies.") + +(defvar package-test-data-dir (expand-file-name "package-resources" package-test-file-dir) + "Base directory of package test files.") + +(defvar package-test-fake-contents-file + (expand-file-name "archive-contents" package-test-data-dir) + "Path to a static copy of \"archive-contents\".") + +(cl-defmacro with-package-test ((&optional &key file + basedir + install + location + update-news + upload-base) + &rest body) + "Set up temporary locations and variables for testing." + (declare (indent 1)) + `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t)) + (process-environment (cons (format "HOME=%s" package-test-user-dir) + process-environment)) + (package-user-dir package-test-user-dir) + (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) + (default-directory package-test-file-dir) + abbreviated-home-dir + package--initialized + package-alist + ,@(if update-news + '(package-update-news-on-upload t) + (list (cl-gensym))) + ,@(if upload-base + '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) + (package-archive-upload-base package-test-archive-upload-base)) + (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (kill-buffer buf))) + (unwind-protect + (progn + ,(if basedir `(cd ,basedir)) + (unless (file-directory-p package-user-dir) + (mkdir package-user-dir)) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest r) t)) + ((symbol-function 'y-or-n-p) (lambda (&rest r) t))) + ,@(when install + `((package-initialize) + (package-refresh-contents) + (mapc 'package-install ,install))) + (with-temp-buffer + ,(if file + `(insert-file-contents ,file)) + ,@body))) + + (when (file-directory-p package-test-user-dir) + (delete-directory package-test-user-dir t)) + + (when (and (boundp 'package-test-archive-upload-base) + (file-directory-p package-test-archive-upload-base)) + (delete-directory package-test-archive-upload-base t))))) + +(defmacro with-fake-help-buffer (&rest body) + "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." + `(with-temp-buffer + (help-mode) + ;; Trick `help-buffer' into using the temp buffer. + (let ((help-xref-following t)) + ,@body))) + +(defun package-test-strip-version (dir) + (replace-regexp-in-string "-pkg\\.el\\'" "" (package--description-file dir))) + +(defun package-test-suffix-matches (base suffix-list) + "Return file names matching BASE concatenated with each item in SUFFIX-LIST" + (cl-mapcan + '(lambda (item) (file-expand-wildcards (concat base item))) + suffix-list)) + +(defvar tar-parse-info) +(declare-function tar-header-name "tar-mode" (cl-x) t) ; defstruct + +(defun package-test-search-tar-file (filename) + "Search the current buffer's `tar-parse-info' variable for FILENAME. + +Must called from within a `tar-mode' buffer." + (cl-dolist (header tar-parse-info) + (let ((tar-name (tar-header-name header))) + (when (string= tar-name filename) + (cl-return t))))) + +(defun package-test-desc-version-string (desc) + "Return the package version as a string." + (package-version-join (package-desc-version desc))) + +(ert-deftest package-test-desc-from-buffer () + "Parse an elisp buffer to get a `package-desc' object." + (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el") + (should (equal (package-buffer-info) simple-single-desc))) + (with-package-test (:basedir "package-resources" :file "simple-depend-1.0.el") + (should (equal (package-buffer-info) simple-depend-desc))) + (with-package-test (:basedir "package-resources" + :file "multi-file-0.2.3.tar") + (tar-mode) + (should (equal (package-tar-file-info) multi-file-desc)))) + +(ert-deftest package-test-install-single () + "Install a single file without using an archive." + (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el") + (should (package-install-from-buffer)) + (package-initialize) + (should (package-installed-p 'simple-single)) + ;; Check if we properly report an "already installed". + (package-install 'simple-single) + (with-current-buffer "*Messages*" + (should (string-match "^[`‘']simple-single[’'] is already installed\n?\\'" + (buffer-string)))) + (should (package-installed-p 'simple-single)) + (let* ((simple-pkg-dir (file-name-as-directory + (expand-file-name + "simple-single-1.3" + package-test-user-dir))) + (autoloads-file (expand-file-name "simple-single-autoloads.el" + simple-pkg-dir))) + (should (file-directory-p simple-pkg-dir)) + (with-temp-buffer + (insert-file-contents (expand-file-name "simple-single-pkg.el" + simple-pkg-dir)) + (should (string= (buffer-string) + (concat ";;; -*- no-byte-compile: t -*-\n" + "(define-package \"simple-single\" \"1.3\" " + "\"A single-file package " + "with no dependencies\" 'nil " + ":authors '((\"J. R. Hacker\" . \"jrh@example.com\")) " + ":maintainer '(\"J. R. Hacker\" . \"jrh@example.com\") " + ":url \"http://doodles.au\"" + ")\n")))) + (should (file-exists-p autoloads-file)) + (should-not (get-file-buffer autoloads-file))))) + +(ert-deftest package-test-install-dependency () + "Install a package which includes a dependency." + (with-package-test () + (package-initialize) + (package-refresh-contents) + (package-install 'simple-depend) + (should (package-installed-p 'simple-single)) + (should (package-installed-p 'simple-depend)))) + +(ert-deftest package-test-macro-compilation () + "Install a package which includes a dependency." + (with-package-test (:basedir "package-resources") + (package-install-file (expand-file-name "macro-problem-package-1.0/")) + (require 'macro-problem) + ;; `macro-problem-func' uses a macro from `macro-aux'. + (should (equal (macro-problem-func) '(progn a b))) + (package-install-file (expand-file-name "macro-problem-package-2.0/")) + ;; After upgrading, `macro-problem-func' depends on a new version + ;; of the macro from `macro-aux'. + (should (equal (macro-problem-func) '(1 b))) + ;; `macro-problem-10-and-90' depends on an entirely new macro from `macro-aux'. + (should (equal (macro-problem-10-and-90) '(10 90))))) + +(ert-deftest package-test-install-two-dependencies () + "Install a package which includes a dependency." + (with-package-test () + (package-initialize) + (package-refresh-contents) + (package-install 'simple-two-depend) + (should (package-installed-p 'simple-single)) + (should (package-installed-p 'simple-depend)) + (should (package-installed-p 'simple-two-depend)))) + +(ert-deftest package-test-refresh-contents () + "Parse an \"archive-contents\" file." + (with-package-test () + (package-initialize) + (package-refresh-contents) + (should (eq 4 (length package-archive-contents))))) + +(ert-deftest package-test-install-single-from-archive () + "Install a single package from a package archive." + (with-package-test () + (package-initialize) + (package-refresh-contents) + (package-install 'simple-single))) + +(ert-deftest package-test-install-prioritized () + "Install a lower version from a higher-prioritized archive." + (with-package-test () + (let* ((newer-version (expand-file-name "package-resources/newer-versions" + package-test-file-dir)) + (package-archives `(("older" . ,package-test-data-dir) + ("newer" . ,newer-version))) + (package-archive-priorities '(("older" . 100)))) + + (package-initialize) + (package-refresh-contents) + (package-install 'simple-single) + + (let ((installed (cadr (assq 'simple-single package-alist)))) + (should (version-list-= '(1 3) + (package-desc-version installed))))))) + +(ert-deftest package-test-install-multifile () + "Check properties of the installed multi-file package." + (with-package-test (:basedir "package-resources" :install '(multi-file)) + (let ((autoload-file + (expand-file-name "multi-file-autoloads.el" + (expand-file-name + "multi-file-0.2.3" + package-test-user-dir))) + (installed-files '("dir" "multi-file.info" "multi-file-sub.elc" + "multi-file-autoloads.el" "multi-file.elc")) + (autoload-forms '("^(defvar multi-file-custom-var" + "^(custom-autoload 'multi-file-custom-var" + "^(autoload 'multi-file-mode")) + (pkg-dir (file-name-as-directory + (expand-file-name + "multi-file-0.2.3" + package-test-user-dir)))) + (package-refresh-contents) + (should (package-installed-p 'multi-file)) + (with-temp-buffer + (insert-file-contents-literally autoload-file) + (dolist (fn installed-files) + (should (file-exists-p (expand-file-name fn pkg-dir)))) + (dolist (re autoload-forms) + (goto-char (point-min)) + (should (re-search-forward re nil t))))))) + +(ert-deftest package-test-update-listing () + "Ensure installed package status is updated." + (with-package-test () + (let ((buf (package-list-packages))) + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-execute) + (run-hooks 'post-command-hook) + (should (package-installed-p 'simple-single)) + (switch-to-buffer "*Packages*") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) + (goto-char (point-min)) + (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t)) + (kill-buffer buf)))) + +(ert-deftest package-test-update-archives () + "Test updating package archives." + (with-package-test () + (let ((buf (package-list-packages))) + (package-menu-refresh) + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-execute) + (should (package-installed-p 'simple-single)) + (let ((package-test-data-dir + (expand-file-name "package-resources/newer-versions" package-test-file-dir))) + (setq package-archives `(("gnu" . ,package-test-data-dir))) + (package-menu-refresh) + + ;; New version should be available and old version should be installed + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single\\s-+1.4\\s-+available" nil t)) + (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) + + (goto-char (point-min)) + (should (re-search-forward "^\\s-+new-pkg\\s-+1.0\\s-+\\(available\\|new\\)" nil t)) + + (package-menu-mark-upgrades) + (package-menu-execute) + (package-menu-refresh) + (should (package-installed-p 'simple-single '(1 4))))))) + +(ert-deftest package-test-update-archives-async () + "Test updating package archives asynchronously." + (skip-unless (executable-find "python2")) + ;; For some reason this test doesn't work reliably on hydra.nixos.org. + (skip-unless (not (getenv "NIX_STORE"))) + (with-package-test (:basedir + package-test-data-dir + :location "http://0.0.0.0:8000/") + (let* ((package-menu-async t) + (process (start-process + "package-server" "package-server-buffer" + (executable-find "python2") + (expand-file-name "package-test-server.py")))) + (unwind-protect + (progn + (list-packages) + (should package--downloads-in-progress) + (should mode-line-process) + (should-not + (with-timeout (10 'timeout) + (while package--downloads-in-progress + (accept-process-output nil 1)) + nil)) + ;; If the server process died, there's some non-Emacs problem. + ;; Eg maybe the port was already in use. + (skip-unless (process-live-p process)) + (goto-char (point-min)) + (should + (search-forward-regexp "^ +simple-single" nil t))) + (if (process-live-p process) (kill-process process)))))) + +(ert-deftest package-test-describe-package () + "Test displaying help for a package." + + (require 'finder-inf) + ;; Built-in + (with-fake-help-buffer + (describe-package '5x5) + (goto-char (point-min)) + (should (search-forward "5x5 is a built-in package." nil t)) + ;; Don't assume the descriptions are in any particular order. + (save-excursion (should (search-forward "Status: Built-in." nil t))) + (save-excursion (should (search-forward "Summary: simple little puzzle game" nil t))) + (should (search-forward "The aim of 5x5" nil t))) + + ;; Installed + (with-package-test () + (package-initialize) + (package-refresh-contents) + (package-install 'simple-single) + (with-fake-help-buffer + (describe-package 'simple-single) + (goto-char (point-min)) + (should (search-forward "simple-single is an installed package." nil t)) + (save-excursion (should (re-search-forward "Status: Installed in ['`‘]simple-single-1.3/['’] (unsigned)." nil t))) + (save-excursion (should (search-forward "Version: 1.3" nil t))) + (save-excursion (should (search-forward "Summary: A single-file package with no dependencies" nil t))) + (save-excursion (should (search-forward "Homepage: http://doodles.au" nil t))) + (save-excursion (should (re-search-forward "Keywords: \\[?frobnicate\\]?" nil t))) + ;; No description, though. Because at this point we don't know + ;; what archive the package originated from, and we don't have + ;; its readme file saved. + ))) + +(ert-deftest package-test-describe-non-installed-package () + "Test displaying of the readme for non-installed package." + + (with-package-test () + (package-initialize) + (package-refresh-contents) + (with-fake-help-buffer + (describe-package 'simple-single) + (goto-char (point-min)) + (should (search-forward "Homepage: http://doodles.au" nil t)) + (should (search-forward "This package provides a minor mode to frobnicate" + nil t))))) + +(ert-deftest package-test-describe-non-installed-multi-file-package () + "Test displaying of the readme for non-installed multi-file package." + + (with-package-test () + (package-initialize) + (package-refresh-contents) + (with-fake-help-buffer + (describe-package 'multi-file) + (goto-char (point-min)) + (should (search-forward "Homepage: http://puddles.li" nil t)) + (should (search-forward "This is a bare-bones readme file for the multi-file" + nil t))))) + +(ert-deftest package-test-signed () + "Test verifying package signature." + (skip-unless (ignore-errors + (let ((homedir (make-temp-file "package-test" t))) + (unwind-protect + (let ((process-environment + (cons (format "HOME=%s" homedir) + process-environment))) + (epg-check-configuration (epg-configuration)) + t) + (delete-directory homedir t))))) + (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) + (package-test-data-dir + (expand-file-name "package-resources/signed" package-test-file-dir))) + (with-package-test () + (package-initialize) + (package-import-keyring keyring) + (package-refresh-contents) + (should (package-install 'signed-good)) + (should-error (package-install 'signed-bad)) + ;; Check if the installed package status is updated. + (let ((buf (package-list-packages))) + (package-menu-refresh) + (should (re-search-forward + "^\\s-+signed-good\\s-+\\(\\S-+\\)\\s-+\\(\\S-+\\)\\s-" + nil t)) + (should (string-equal (match-string-no-properties 1) "1.0")) + (should (string-equal (match-string-no-properties 2) "installed"))) + ;; Check if the package description is updated. + (with-fake-help-buffer + (describe-package 'signed-good) + (goto-char (point-min)) + (should (re-search-forward "signed-good is an? \\(\\S-+\\) package." nil t)) + (should (string-equal (match-string-no-properties 1) "installed")) + (should (re-search-forward + "Status: Installed in ['`‘]signed-good-1.0/['’]." + nil t)))))) + + + +;;; Tests for package-x features. + +(require 'package-x) + +(defvar package-x-test--single-archive-entry-1-3 + (cons 'simple-single + (package-make-ac-desc '(1 3) nil + "A single-file package with no dependencies" + 'single + '((:authors ("J. R. Hacker" . "jrh@example.com")) + (:maintainer "J. R. Hacker" . "jrh@example.com") + (:url . "http://doodles.au")))) + "Expected contents of the archive entry from the \"simple-single\" package.") + +(defvar package-x-test--single-archive-entry-1-4 + (cons 'simple-single + (package-make-ac-desc '(1 4) nil + "A single-file package with no dependencies" + 'single + '((:authors ("J. R. Hacker" . "jrh@example.com")) + (:maintainer "J. R. Hacker" . "jrh@example.com")))) + "Expected contents of the archive entry from the updated \"simple-single\" package.") + +(ert-deftest package-x-test-upload-buffer () + "Test creating an \"archive-contents\" file" + (with-package-test (:basedir "package-resources" + :file "simple-single-1.3.el" + :upload-base t) + (package-upload-buffer) + (should (file-exists-p (expand-file-name "archive-contents" + package-archive-upload-base))) + (should (file-exists-p (expand-file-name "simple-single-1.3.el" + package-archive-upload-base))) + (should (file-exists-p (expand-file-name "simple-single-readme.txt" + package-archive-upload-base))) + + (let (archive-contents) + (with-temp-buffer + (insert-file-contents + (expand-file-name "archive-contents" + package-archive-upload-base)) + (setq archive-contents + (package-read-from-string + (buffer-substring (point-min) (point-max))))) + (should (equal archive-contents + (list 1 package-x-test--single-archive-entry-1-3)))))) + +(ert-deftest package-x-test-upload-new-version () + "Test uploading a new version of a package" + (with-package-test (:basedir "package-resources" + :file "simple-single-1.3.el" + :upload-base t) + (package-upload-buffer) + (with-temp-buffer + (insert-file-contents "newer-versions/simple-single-1.4.el") + (package-upload-buffer)) + + (let (archive-contents) + (with-temp-buffer + (insert-file-contents + (expand-file-name "archive-contents" + package-archive-upload-base)) + (setq archive-contents + (package-read-from-string + (buffer-substring (point-min) (point-max))))) + (should (equal archive-contents + (list 1 package-x-test--single-archive-entry-1-4)))))) + +(ert-deftest package-test-get-deps () + "Test `package--get-deps' with complex structures." + (let ((package-alist + (mapcar (lambda (p) (list (package-desc-name p) p)) + (list simple-single-desc + simple-depend-desc + multi-file-desc + new-pkg-desc + simple-depend-desc-1 + simple-depend-desc-2)))) + (should + (equal (package--get-deps 'simple-depend) + '(simple-single))) + (should + (equal (package--get-deps 'simple-depend 'indirect) + nil)) + (should + (equal (package--get-deps 'simple-depend 'direct) + '(simple-single))) + (should + (equal (package--get-deps 'simple-depend-2) + '(simple-depend-1 multi-file simple-depend simple-single))) + (should + (equal (package--get-deps 'simple-depend-2 'indirect) + '(simple-depend multi-file simple-single))) + (should + (equal (package--get-deps 'simple-depend-2 'direct) + '(simple-depend-1 multi-file))))) + +(ert-deftest package-test-sort-by-dependence () + "Test `package--sort-by-dependence' with complex structures." + (let ((package-alist + (mapcar (lambda (p) (list (package-desc-name p) p)) + (list simple-single-desc + simple-depend-desc + multi-file-desc + new-pkg-desc + simple-depend-desc-1 + simple-depend-desc-2))) + (delete-list + (list simple-single-desc + simple-depend-desc + multi-file-desc + new-pkg-desc + simple-depend-desc-1 + simple-depend-desc-2))) + (should + (equal (package--sort-by-dependence delete-list) + + (list simple-depend-desc-2 simple-depend-desc-1 new-pkg-desc + multi-file-desc simple-depend-desc simple-single-desc))) + (should + (equal (package--sort-by-dependence (reverse delete-list)) + (list new-pkg-desc simple-depend-desc-2 simple-depend-desc-1 + multi-file-desc simple-depend-desc simple-single-desc))))) + +(provide 'package-test) + +;;; package-test.el ends here diff --cc test/lisp/emacs-lisp/pcase-tests.el index 701bcccc0e6,00000000000..a428e4092f1 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@@ -1,74 -1,0 +1,74 @@@ +;;; pcase-tests.el --- Test suite for pcase macro. + - ;; Copyright (C) 2012-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(ert-deftest pcase-tests-base () + "Test pcase code." + (should (equal (pcase '(1 . 2) ((app car '2) 6) ((app car '1) 5)) 5))) + +(ert-deftest pcase-tests-bugs () + (should (equal (pcase '(2 . 3) ;bug#18554 + (`(,hd . ,(and (pred atom) tl)) (list hd tl)) + ((pred consp) nil)) + '(2 3)))) + +(pcase-defmacro pcase-tests-plus (pat n) + `(app (lambda (v) (- v ,n)) ,pat)) + +(ert-deftest pcase-tests-macro () + (should (equal (pcase 5 ((pcase-tests-plus x 3) x)) 2))) + +(defun pcase-tests-grep (fname exp) + (when (consp exp) + (or (eq fname (car exp)) + (cl-some (lambda (exp) (pcase-tests-grep fname exp)) (cdr exp))))) + +(ert-deftest pcase-tests-tests () + (should (pcase-tests-grep 'memq '(or (+ 2 3) (memq x y)))) + (should-not (pcase-tests-grep 'memq '(or (+ 2 3) (- x y))))) + +(ert-deftest pcase-tests-member () + (should (pcase-tests-grep + 'memq (macroexpand-all '(pcase x ((or 1 2 3) body))))) + (should (pcase-tests-grep + 'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body))))) + (should-not (pcase-tests-grep + 'memq (macroexpand-all '(pcase x ((or "a" 2 3) body))))) + (let ((exp (macroexpand-all + '(pcase x + ("a" body1) + (2 body2) + ((or "a" 2 3) body))))) + (should-not (pcase-tests-grep 'memq exp)) + (should-not (pcase-tests-grep 'member exp)))) + +(ert-deftest pcase-tests-vectors () + (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; pcase-tests.el ends here. diff --cc test/lisp/emacs-lisp/regexp-opt-tests.el index ee177b3e2e9,00000000000..01119a3374f mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/regexp-opt-tests.el +++ b/test/lisp/emacs-lisp/regexp-opt-tests.el @@@ -1,33 -1,0 +1,33 @@@ +;;; regexp-tests.el --- Test suite for regular expression handling. + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'regexp-opt) + +(ert-deftest regexp-test-regexp-opt () + "Test the `compilation-error-regexp-alist' regexps. +The test data is in `compile-tests--test-regexps-data'." + (should (string-match (regexp-opt-charset '(?^)) "a^b"))) + +;;; regexp-tests.el ends here. diff --cc test/lisp/emacs-lisp/seq-tests.el index 5d936828fbb,00000000000..a8ca48b1328 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@@ -1,341 -1,0 +1,341 @@@ +;;; seq-tests.el --- Tests for sequences.el + - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Nicolas Petton +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Tests for sequences.el + +;;; Code: + +(require 'ert) +(require 'seq) + +(defmacro with-test-sequences (spec &rest body) + "Successively bind VAR to a list, vector, and string built from SEQ. +Evaluate BODY for each created sequence. + +\(fn (var seq) body)" + (declare (indent 1) (debug ((symbolp form) body))) + (let ((initial-seq (make-symbol "initial-seq"))) + `(let ((,initial-seq ,(cadr spec))) + ,@(mapcar (lambda (s) + `(let ((,(car spec) (apply (function ,s) ,initial-seq))) + ,@body)) + '(list vector string))))) + +(defun same-contents-p (seq1 seq2) + "Return t if SEQ1 and SEQ2 have the same contents, nil otherwise." + (equal (append seq1 '()) (append seq2 '()))) + +(defun test-sequences-evenp (integer) + "Return t if INTEGER is even." + (eq (logand integer 1) 0)) + +(defun test-sequences-oddp (integer) + "Return t if INTEGER is odd." + (not (test-sequences-evenp integer))) + +(ert-deftest test-setf-seq-elt () + (with-test-sequences (seq '(1 2 3)) + (setf (seq-elt seq 1) 4) + (should (= 4 (seq-elt seq 1))))) + +(ert-deftest test-seq-drop () + (with-test-sequences (seq '(1 2 3 4)) + (should (equal (seq-drop seq 0) seq)) + (should (equal (seq-drop seq 1) (seq-subseq seq 1))) + (should (equal (seq-drop seq 2) (seq-subseq seq 2))) + (should (seq-empty-p (seq-drop seq 4))) + (should (seq-empty-p (seq-drop seq 10)))) + (with-test-sequences (seq '()) + (should (seq-empty-p (seq-drop seq 0))) + (should (seq-empty-p (seq-drop seq 1))))) + +(ert-deftest test-seq-take () + (with-test-sequences (seq '(2 3 4 5)) + (should (seq-empty-p (seq-take seq 0))) + (should (= (seq-length (seq-take seq 1)) 1)) + (should (= (seq-elt (seq-take seq 1) 0) 2)) + (should (same-contents-p (seq-take seq 3) '(2 3 4))) + (should (equal (seq-take seq 10) seq)))) + +(ert-deftest test-seq-drop-while () + (with-test-sequences (seq '(1 3 2 4)) + (should (equal (seq-drop-while #'test-sequences-oddp seq) + (seq-drop seq 2))) + (should (equal (seq-drop-while #'test-sequences-evenp seq) + seq)) + (should (seq-empty-p (seq-drop-while #'numberp seq)))) + (with-test-sequences (seq '()) + (should (seq-empty-p (seq-drop-while #'test-sequences-oddp seq))))) + +(ert-deftest test-seq-take-while () + (with-test-sequences (seq '(1 3 2 4)) + (should (equal (seq-take-while #'test-sequences-oddp seq) + (seq-take seq 2))) + (should (seq-empty-p (seq-take-while #'test-sequences-evenp seq))) + (should (equal (seq-take-while #'numberp seq) seq))) + (with-test-sequences (seq '()) + (should (seq-empty-p (seq-take-while #'test-sequences-oddp seq))))) + +(ert-deftest test-seq-filter () + (with-test-sequences (seq '(6 7 8 9 10)) + (should (equal (seq-filter #'test-sequences-evenp seq) '(6 8 10))) + (should (equal (seq-filter #'test-sequences-oddp seq) '(7 9))) + (should (equal (seq-filter (lambda (elt) nil) seq) '()))) + (with-test-sequences (seq '()) + (should (equal (seq-filter #'test-sequences-evenp seq) '())))) + +(ert-deftest test-seq-remove () + (with-test-sequences (seq '(6 7 8 9 10)) + (should (equal (seq-remove #'test-sequences-evenp seq) '(7 9))) + (should (equal (seq-remove #'test-sequences-oddp seq) '(6 8 10))) + (should (same-contents-p (seq-remove (lambda (elt) nil) seq) seq))) + (with-test-sequences (seq '()) + (should (equal (seq-remove #'test-sequences-evenp seq) '())))) + +(ert-deftest test-seq-count () + (with-test-sequences (seq '(6 7 8 9 10)) + (should (equal (seq-count #'test-sequences-evenp seq) 3)) + (should (equal (seq-count #'test-sequences-oddp seq) 2)) + (should (equal (seq-count (lambda (elt) nil) seq) 0))) + (with-test-sequences (seq '()) + (should (equal (seq-count #'test-sequences-evenp seq) 0)))) + +(ert-deftest test-seq-reduce () + (with-test-sequences (seq '(1 2 3 4)) + (should (= (seq-reduce #'+ seq 0) 10)) + (should (= (seq-reduce #'+ seq 5) 15))) + (with-test-sequences (seq '()) + (should (eq (seq-reduce #'+ seq 0) 0)) + (should (eq (seq-reduce #'+ seq 7) 7)))) + +(ert-deftest test-seq-some () + (with-test-sequences (seq '(4 3 2 1)) + (should (seq-some #'test-sequences-evenp seq)) + (should (seq-some #'test-sequences-oddp seq)) + (should-not (seq-some (lambda (elt) (> elt 10)) seq))) + (with-test-sequences (seq '()) + (should-not (seq-some #'test-sequences-oddp seq))) + (should (seq-some #'null '(1 nil 2)))) + +(ert-deftest test-seq-find () + (with-test-sequences (seq '(4 3 2 1)) + (should (= 4 (seq-find #'test-sequences-evenp seq))) + (should (= 3 (seq-find #'test-sequences-oddp seq))) + (should-not (seq-find (lambda (elt) (> elt 10)) seq))) + (should-not (seq-find #'null '(1 nil 2))) + (should-not (seq-find #'null '(1 nil 2) t)) + (should-not (seq-find #'null '(1 2 3))) + (should (seq-find #'null '(1 2 3) 'sentinel))) + +(ert-deftest test-seq-contains () + (with-test-sequences (seq '(3 4 5 6)) + (should (seq-contains seq 3)) + (should-not (seq-contains seq 7))) + (with-test-sequences (seq '()) + (should-not (seq-contains seq 3)) + (should-not (seq-contains seq nil)))) + +(ert-deftest test-seq-every-p () + (with-test-sequences (seq '(43 54 22 1)) + (should (seq-every-p (lambda (elt) t) seq)) + (should-not (seq-every-p #'test-sequences-oddp seq)) + (should-not (seq-every-p #'test-sequences-evenp seq))) + (with-test-sequences (seq '(42 54 22 2)) + (should (seq-every-p #'test-sequences-evenp seq)) + (should-not (seq-every-p #'test-sequences-oddp seq))) + (with-test-sequences (seq '()) + (should (seq-every-p #'identity seq)) + (should (seq-every-p #'test-sequences-evenp seq)))) + +(ert-deftest test-seq-empty-p () + (with-test-sequences (seq '(0)) + (should-not (seq-empty-p seq))) + (with-test-sequences (seq '(0 1 2)) + (should-not (seq-empty-p seq))) + (with-test-sequences (seq '()) + (should (seq-empty-p seq)))) + +(ert-deftest test-seq-sort () + (should (equal (seq-sort #'< "cbaf") "abcf")) + (should (equal (seq-sort #'< '(2 1 9 4)) '(1 2 4 9))) + (should (equal (seq-sort #'< [2 1 9 4]) [1 2 4 9])) + (should (equal (seq-sort #'< "") ""))) + +(ert-deftest test-seq-uniq () + (with-test-sequences (seq '(2 4 6 8 6 4 3)) + (should (equal (seq-uniq seq) '(2 4 6 8 3)))) + (with-test-sequences (seq '(3 3 3 3 3)) + (should (equal (seq-uniq seq) '(3)))) + (with-test-sequences (seq '()) + (should (equal (seq-uniq seq) '())))) + +(ert-deftest test-seq-subseq () + (with-test-sequences (seq '(2 3 4 5)) + (should (equal (seq-subseq seq 0 4) seq)) + (should (same-contents-p (seq-subseq seq 2 4) '(4 5))) + (should (same-contents-p (seq-subseq seq 1 3) '(3 4))) + (should (same-contents-p (seq-subseq seq 1 -1) '(3 4)))) + (should (vectorp (seq-subseq [2 3 4 5] 2))) + (should (stringp (seq-subseq "foo" 2 3))) + (should (listp (seq-subseq '(2 3 4 4) 2 3))) + (should-error (seq-subseq '(1 2 3) 4)) + (should-not (seq-subseq '(1 2 3) 3)) + (should (seq-subseq '(1 2 3) -3)) + (should-error (seq-subseq '(1 2 3) 1 4)) + (should (seq-subseq '(1 2 3) 1 3)) + (should-error (seq-subseq '() -1)) + (should-error (seq-subseq [] -1)) + (should-error (seq-subseq "" -1)) + (should-not (seq-subseq '() 0)) + (should-error (seq-subseq '() 0 -1))) + +(ert-deftest test-seq-concatenate () + (with-test-sequences (seq '(2 4 6)) + (should (equal (seq-concatenate 'string seq [8]) (string 2 4 6 8))) + (should (equal (seq-concatenate 'list seq '(8 10)) '(2 4 6 8 10))) + (should (equal (seq-concatenate 'vector seq '(8 10)) [2 4 6 8 10])) + (should (equal (seq-concatenate 'vector nil '(8 10)) [8 10])) + (should (equal (seq-concatenate 'vector seq nil) [2 4 6])))) + +(ert-deftest test-seq-mapcat () + (should (equal (seq-mapcat #'seq-reverse '((3 2 1) (6 5 4))) + '(1 2 3 4 5 6))) + (should (equal (seq-mapcat #'seq-reverse '[(3 2 1) (6 5 4)]) + '(1 2 3 4 5 6))) + (should (equal (seq-mapcat #'seq-reverse '((3 2 1) (6 5 4)) 'vector) + '[1 2 3 4 5 6]))) + +(ert-deftest test-seq-partition () + (should (same-contents-p (seq-partition '(0 1 2 3 4 5 6 7) 3) + '((0 1 2) (3 4 5) (6 7)))) + (should (same-contents-p (seq-partition '[0 1 2 3 4 5 6 7] 3) + '([0 1 2] [3 4 5] [6 7]))) + (should (same-contents-p (seq-partition "Hello world" 2) + '("He" "ll" "o " "wo" "rl" "d"))) + (should (equal (seq-partition '() 2) '())) + (should (equal (seq-partition '(1 2 3) -1) '()))) + +(ert-deftest test-seq-group-by () + (with-test-sequences (seq '(1 2 3 4)) + (should (equal (seq-group-by #'test-sequences-oddp seq) + '((t 1 3) (nil 2 4))))) + (should (equal (seq-group-by #'car '((a 1) (b 3) (c 4) (a 2))) + '((b (b 3)) (c (c 4)) (a (a 1) (a 2)))))) + +(ert-deftest test-seq-reverse () + (with-test-sequences (seq '(1 2 3 4)) + (should (same-contents-p (seq-reverse seq) '(4 3 2 1))) + (should (equal (type-of (seq-reverse seq)) + (type-of seq))))) + +(ert-deftest test-seq-into () + (let* ((vector [1 2 3]) + (list (seq-into vector 'list))) + (should (same-contents-p vector list)) + (should (listp list))) + (let* ((list '(hello world)) + (vector (seq-into list 'vector))) + (should (same-contents-p vector list)) + (should (vectorp vector))) + (let* ((string "hello") + (list (seq-into string 'list))) + (should (same-contents-p string list)) + (should (stringp string))) + (let* ((string "hello") + (vector (seq-into string 'vector))) + (should (same-contents-p string vector)) + (should (stringp string))) + (let* ((list nil) + (vector (seq-into list 'vector))) + (should (same-contents-p list vector)) + (should (vectorp vector)))) + +(ert-deftest test-seq-intersection () + (let ((v1 [2 3 4 5]) + (v2 [1 3 5 6 7])) + (should (same-contents-p (seq-intersection v1 v2) + '(3 5)))) + (let ((l1 '(2 3 4 5)) + (l2 '(1 3 5 6 7))) + (should (same-contents-p (seq-intersection l1 l2) + '(3 5)))) + (let ((v1 [2 4 6]) + (v2 [1 3 5])) + (should (seq-empty-p (seq-intersection v1 v2))))) + +(ert-deftest test-seq-difference () + (let ((v1 [2 3 4 5]) + (v2 [1 3 5 6 7])) + (should (same-contents-p (seq-difference v1 v2) + '(2 4)))) + (let ((l1 '(2 3 4 5)) + (l2 '(1 3 5 6 7))) + (should (same-contents-p (seq-difference l1 l2) + '(2 4)))) + (let ((v1 [2 4 6]) + (v2 [2 4 6])) + (should (seq-empty-p (seq-difference v1 v2))))) + +(ert-deftest test-seq-let () + (with-test-sequences (seq '(1 2 3 4)) + (seq-let (a b c d e) seq + (should (= a 1)) + (should (= b 2)) + (should (= c 3)) + (should (= d 4)) + (should (null e))) + (seq-let (a b &rest others) seq + (should (= a 1)) + (should (= b 2)) + (should (same-contents-p others (seq-drop seq 2))))) + (let ((seq '(1 (2 (3 (4)))))) + (seq-let (_ (_ (_ (a)))) seq + (should (= a 4)))) + (let (seq) + (seq-let (a b c) seq + (should (null a)) + (should (null b)) + (should (null c))))) + +(ert-deftest test-seq-min-max () + (with-test-sequences (seq '(4 5 3 2 0 4)) + (should (= (seq-min seq) 0)) + (should (= (seq-max seq) 5)))) + +(ert-deftest test-seq-into-sequence () + (with-test-sequences (seq '(1 2 3)) + (should (eq seq (seq-into-sequence seq))) + (should-error (seq-into-sequence 2)))) + +(ert-deftest test-seq-position () + (with-test-sequences (seq '(2 4 6)) + (should (null (seq-position seq 1))) + (should (= (seq-position seq 4) 1))) + (let ((seq '(a b c))) + (should (null (seq-position seq 'd #'eq))) + (should (= (seq-position seq 'a #'eq) 0)) + (should (null (seq-position seq (make-symbol "a") #'eq))))) + +(provide 'seq-tests) +;;; seq-tests.el ends here diff --cc test/lisp/emacs-lisp/subr-x-tests.el index bdd3dffe02a,00000000000..e30b5d8f549 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@@ -1,526 -1,0 +1,526 @@@ +;;; subr-x-tests.el --- Testing the extended lisp routines + - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Fabián E. Gallina +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'subr-x) + + +;; if-let tests + +(ert-deftest subr-x-test-if-let-single-binding-expansion () + "Test single bindings are expanded properly." + (should (equal + (macroexpand + '(if-let (a 1) + (- a) + "no")) + '(let* ((a (and t 1))) + (if a + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let (a) + (- a) + "no")) + '(let* ((a (and t nil))) + (if a + (- a) + "no"))))) + +(ert-deftest subr-x-test-if-let-single-symbol-expansion () + "Test single symbol bindings are expanded properly." + (should (equal + (macroexpand + '(if-let (a) + (- a) + "no")) + '(let* ((a (and t nil))) + (if a + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let (a b c) + (- a) + "no")) + '(let* ((a (and t nil)) + (b (and a nil)) + (c (and b nil))) + (if c + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let (a (b 2) c) + (- a) + "no")) + '(let* ((a (and t nil)) + (b (and a 2)) + (c (and b nil))) + (if c + (- a) + "no"))))) + +(ert-deftest subr-x-test-if-let-nil-related-expansion () + "Test nil is processed properly." + (should (equal + (macroexpand + '(if-let (nil) + (- a) + "no")) + '(let* ((nil (and t nil))) + (if nil + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let ((nil)) + (- a) + "no")) + '(let* ((nil (and t nil))) + (if nil + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let ((a 1) (nil) (b 2)) + (- a) + "no")) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let ((a 1) nil (b 2)) + (- a) + "no")) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a) + "no"))))) + +(ert-deftest subr-x-test-if-let-malformed-binding () + "Test malformed bindings trigger errors." + (should-error (macroexpand + '(if-let (_ (a 1 1) (b 2) (c 3) d) + (- a) + "no")) + :type 'error) + (should-error (macroexpand + '(if-let (_ (a 1) (b 2 2) (c 3) d) + (- a) + "no")) + :type 'error) + (should-error (macroexpand + '(if-let (_ (a 1) (b 2) (c 3 3) d) + (- a) + "no")) + :type 'error) + (should-error (macroexpand + '(if-let ((a 1 1)) + (- a) + "no")) + :type 'error)) + +(ert-deftest subr-x-test-if-let-true () + "Test `if-let' with truthy bindings." + (should (equal + (if-let (a 1) + a + "no") + 1)) + (should (equal + (if-let ((a 1) (b 2) (c 3)) + (list a b c) + "no") + (list 1 2 3)))) + +(ert-deftest subr-x-test-if-let-false () + "Test `if-let' with falsie bindings." + (should (equal + (if-let (a nil) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a nil) (b 2) (c 3)) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a 1) (b nil) (c 3)) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a 1) (b 2) (c nil)) + (list a b c) + "no") + "no")) + (should (equal + (if-let (z (a 1) (b 2) (c 3)) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a 1) (b 2) (c 3) d) + (list a b c) + "no") + "no"))) + +(ert-deftest subr-x-test-if-let-bound-references () + "Test `if-let' bindings can refer to already bound symbols." + (should (equal + (if-let ((a (1+ 0)) (b (1+ a)) (c (1+ b))) + (list a b c) + "no") + (list 1 2 3)))) + +(ert-deftest subr-x-test-if-let-and-laziness-is-preserved () + "Test `if-let' respects `and' laziness." + (let (a-called b-called c-called) + (should (equal + (if-let ((a nil) + (b (setq b-called t)) + (c (setq c-called t))) + "yes" + (list a-called b-called c-called)) + (list nil nil nil)))) + (let (a-called b-called c-called) + (should (equal + (if-let ((a (setq a-called t)) + (b nil) + (c (setq c-called t))) + "yes" + (list a-called b-called c-called)) + (list t nil nil)))) + (let (a-called b-called c-called) + (should (equal + (if-let ((a (setq a-called t)) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) + "yes" + (list a-called b-called c-called)) + (list t t nil))))) + + +;; when-let tests + +(ert-deftest subr-x-test-when-let-body-expansion () + "Test body allows for multiple sexps wrapping with progn." + (should (equal + (macroexpand + '(when-let (a 1) + (message "opposite") + (- a))) + '(let* ((a (and t 1))) + (if a + (progn + (message "opposite") + (- a))))))) + +(ert-deftest subr-x-test-when-let-single-binding-expansion () + "Test single bindings are expanded properly." + (should (equal + (macroexpand + '(when-let (a 1) + (- a))) + '(let* ((a (and t 1))) + (if a + (- a))))) + (should (equal + (macroexpand + '(when-let (a) + (- a))) + '(let* ((a (and t nil))) + (if a + (- a)))))) + +(ert-deftest subr-x-test-when-let-single-symbol-expansion () + "Test single symbol bindings are expanded properly." + (should (equal + (macroexpand + '(when-let (a) + (- a))) + '(let* ((a (and t nil))) + (if a + (- a))))) + (should (equal + (macroexpand + '(when-let (a b c) + (- a))) + '(let* ((a (and t nil)) + (b (and a nil)) + (c (and b nil))) + (if c + (- a))))) + (should (equal + (macroexpand + '(when-let (a (b 2) c) + (- a))) + '(let* ((a (and t nil)) + (b (and a 2)) + (c (and b nil))) + (if c + (- a)))))) + +(ert-deftest subr-x-test-when-let-nil-related-expansion () + "Test nil is processed properly." + (should (equal + (macroexpand + '(when-let (nil) + (- a))) + '(let* ((nil (and t nil))) + (if nil + (- a))))) + (should (equal + (macroexpand + '(when-let ((nil)) + (- a))) + '(let* ((nil (and t nil))) + (if nil + (- a))))) + (should (equal + (macroexpand + '(when-let ((a 1) (nil) (b 2)) + (- a))) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a))))) + (should (equal + (macroexpand + '(when-let ((a 1) nil (b 2)) + (- a))) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a)))))) + +(ert-deftest subr-x-test-when-let-malformed-binding () + "Test malformed bindings trigger errors." + (should-error (macroexpand + '(when-let (_ (a 1 1) (b 2) (c 3) d) + (- a))) + :type 'error) + (should-error (macroexpand + '(when-let (_ (a 1) (b 2 2) (c 3) d) + (- a))) + :type 'error) + (should-error (macroexpand + '(when-let (_ (a 1) (b 2) (c 3 3) d) + (- a))) + :type 'error) + (should-error (macroexpand + '(when-let ((a 1 1)) + (- a))) + :type 'error)) + +(ert-deftest subr-x-test-when-let-true () + "Test `when-let' with truthy bindings." + (should (equal + (when-let (a 1) + a) + 1)) + (should (equal + (when-let ((a 1) (b 2) (c 3)) + (list a b c)) + (list 1 2 3)))) + +(ert-deftest subr-x-test-when-let-false () + "Test `when-let' with falsie bindings." + (should (equal + (when-let (a nil) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a nil) (b 2) (c 3)) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a 1) (b nil) (c 3)) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a 1) (b 2) (c nil)) + (list a b c) + "no") + nil)) + (should (equal + (when-let (z (a 1) (b 2) (c 3)) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a 1) (b 2) (c 3) d) + (list a b c) + "no") + nil))) + +(ert-deftest subr-x-test-when-let-bound-references () + "Test `when-let' bindings can refer to already bound symbols." + (should (equal + (when-let ((a (1+ 0)) (b (1+ a)) (c (1+ b))) + (list a b c)) + (list 1 2 3)))) + +(ert-deftest subr-x-test-when-let-and-laziness-is-preserved () + "Test `when-let' respects `and' laziness." + (let (a-called b-called c-called) + (should (equal + (progn + (when-let ((a nil) + (b (setq b-called t)) + (c (setq c-called t))) + "yes") + (list a-called b-called c-called)) + (list nil nil nil)))) + (let (a-called b-called c-called) + (should (equal + (progn + (when-let ((a (setq a-called t)) + (b nil) + (c (setq c-called t))) + "yes") + (list a-called b-called c-called)) + (list t nil nil)))) + (let (a-called b-called c-called) + (should (equal + (progn + (when-let ((a (setq a-called t)) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) + "yes") + (list a-called b-called c-called)) + (list t t nil))))) + + +;; Thread first tests + +(ert-deftest subr-x-test-thread-first-no-forms () + "Test `thread-first' with no forms expands to the first form." + (should (equal (macroexpand '(thread-first 5)) 5)) + (should (equal (macroexpand '(thread-first (+ 1 2))) '(+ 1 2)))) + +(ert-deftest subr-x-test-thread-first-function-names-are-threaded () + "Test `thread-first' wraps single function names." + (should (equal (macroexpand + '(thread-first 5 + -)) + '(- 5))) + (should (equal (macroexpand + '(thread-first (+ 1 2) + -)) + '(- (+ 1 2))))) + +(ert-deftest subr-x-test-thread-first-expansion () + "Test `thread-first' expands correctly." + (should (equal + (macroexpand '(thread-first + 5 + (+ 20) + (/ 25) + - + (+ 40))) + '(+ (- (/ (+ 5 20) 25)) 40)))) + +(ert-deftest subr-x-test-thread-first-examples () + "Test several `thread-first' examples." + (should (equal (thread-first (+ 40 2)) 42)) + (should (equal (thread-first + 5 + (+ 20) + (/ 25) + - + (+ 40)) 39)) + (should (equal (thread-first + "this-is-a-string" + (split-string "-") + (nbutlast 2) + (append (list "good"))) + (list "this" "is" "good")))) + +;; Thread last tests + +(ert-deftest subr-x-test-thread-last-no-forms () + "Test `thread-last' with no forms expands to the first form." + (should (equal (macroexpand '(thread-last 5)) 5)) + (should (equal (macroexpand '(thread-last (+ 1 2))) '(+ 1 2)))) + +(ert-deftest subr-x-test-thread-last-function-names-are-threaded () + "Test `thread-last' wraps single function names." + (should (equal (macroexpand + '(thread-last 5 + -)) + '(- 5))) + (should (equal (macroexpand + '(thread-last (+ 1 2) + -)) + '(- (+ 1 2))))) + +(ert-deftest subr-x-test-thread-last-expansion () + "Test `thread-last' expands correctly." + (should (equal + (macroexpand '(thread-last + 5 + (+ 20) + (/ 25) + - + (+ 40))) + '(+ 40 (- (/ 25 (+ 20 5))))))) + +(ert-deftest subr-x-test-thread-last-examples () + "Test several `thread-last' examples." + (should (equal (thread-last (+ 40 2)) 42)) + (should (equal (thread-last + 5 + (+ 20) + (/ 25) + - + (+ 40)) 39)) + (should (equal (thread-last + (list 1 -2 3 -4 5) + (mapcar #'abs) + (cl-reduce #'+) + (format "abs sum is: %s")) + "abs sum is: 15"))) + + +(provide 'subr-x-tests) +;;; subr-x-tests.el ends here diff --cc test/lisp/emacs-lisp/tabulated-list-test.el index 9aa62ee59e5,00000000000..0fb8dee7fd1 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/tabulated-list-test.el +++ b/test/lisp/emacs-lisp/tabulated-list-test.el @@@ -1,118 -1,0 +1,118 @@@ +;;; tabulated-list-test.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Artur Malabarba + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'tabulated-list) +(require 'ert) + +(defconst tabulated-list--test-entries + '(("zzzz-game" ["zzzz-game" "zzzz-game" "2113" "installed" " play zzzz in Emacs"]) + ("4clojure" ["4clojure" "4clojure" "1507" "obsolete" " Open and evaluate 4clojure.com questions"]) + ("abc-mode" ["abc-mode" "abc-mode" "944" "available" " Major mode for editing abc music files"]) + ("mode" ["mode" "mode" "1128" "installed" " A simple mode for editing Actionscript 3 files"]))) + +(defun tabulated-list--test-sort-car (a b) + (string< (car a) (car b))) + +(defconst tabulated-list--test-format + [("name" 10 tabulated-list--test-sort-car) + ("name-2" 10 t) + ("Version" 9 nil) + ("Status" 10 ) + ("Description" 0 nil)]) + +(defmacro tabulated-list--test-with-buffer (&rest body) + `(with-temp-buffer + (tabulated-list-mode) + (setq tabulated-list-entries (copy-alist tabulated-list--test-entries)) + (setq tabulated-list-format tabulated-list--test-format) + (setq tabulated-list-padding 7) + (tabulated-list-init-header) + (tabulated-list-print) + ,@body)) + + +;;; Tests +(ert-deftest tabulated-list-print () + (tabulated-list--test-with-buffer + ;; Basic printing. + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + ;; Preserve position. + (forward-line 3) + (let ((pos (thing-at-point 'line))) + (pop tabulated-list-entries) + (tabulated-list-print t) + (should (equal (thing-at-point 'line) pos)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + ;; Check the UPDATE argument + (pop tabulated-list-entries) + (setf (cdr (car tabulated-list-entries)) (list ["x" "x" "944" "available" " XX"])) + (tabulated-list-print t t) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " x x 944 available XX + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + (should (equal (thing-at-point 'line) pos))))) + +(ert-deftest tabulated-list-sort () + (tabulated-list--test-with-buffer + ;; Basic sorting + (goto-char (point-min)) + (skip-chars-forward "[:blank:]") + (tabulated-list-sort) + (let ((text (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= text " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files + zzzz-game zzzz-game 2113 installed play zzzz in Emacs\n")) + + (skip-chars-forward "^[:blank:]") + (skip-chars-forward "[:blank:]") + (should (equal (get-text-property (point) 'tabulated-list-column-name) + "name-2")) + (tabulated-list-sort) + ;; Check a `t' as the sorting predicate. + (should (string= text (buffer-substring-no-properties (point-min) (point-max)))) + ;; Invert. + (tabulated-list-sort 1) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + mode mode 1128 installed A simple mode for editing Actionscript 3 files + abc-mode abc-mode 944 available Major mode for editing abc music files + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions\n")) + ;; Again + (tabulated-list-sort 1) + (should (string= text (buffer-substring-no-properties (point-min) (point-max))))) + ;; Check that you can't sort some cols. + (skip-chars-forward "^[:blank:]") + (skip-chars-forward "[:blank:]") + (should-error (tabulated-list-sort) :type 'user-error) + (should-error (tabulated-list-sort 4) :type 'user-error))) + +(provide 'tabulated-list-test) +;;; tabulated-list-test.el ends here diff --cc test/lisp/emacs-lisp/thunk-tests.el index 7abbd299ead,00000000000..f995d362c7d mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/thunk-tests.el +++ b/test/lisp/emacs-lisp/thunk-tests.el @@@ -1,55 -1,0 +1,55 @@@ +;;; thunk-tests.el --- Tests for thunk.el -*- lexical-binding: t -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Nicolas Petton +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Tests for thunk.el + +;;; Code: + +(require 'ert) +(require 'thunk) + +(ert-deftest thunk-should-be-lazy () + (let (x) + (thunk-delay (setq x t)) + (should (null x)))) + +(ert-deftest thunk-can-be-evaluated () + (let* (x + (thunk (thunk-delay (setq x t)))) + (should-not (thunk-evaluated-p thunk)) + (should (null x)) + (thunk-force thunk) + (should (thunk-evaluated-p thunk)) + (should x))) + +(ert-deftest thunk-evaluation-is-cached () + (let* ((x 0) + (thunk (thunk-delay (setq x (1+ x))))) + (thunk-force thunk) + (should (= x 1)) + (thunk-force thunk) + (should (= x 1)))) + +(provide 'thunk-tests) +;;; thunk-tests.el ends here diff --cc test/lisp/emacs-lisp/timer-tests.el index b006b398a81,00000000000..e3cdec73232 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@@ -1,42 -1,0 +1,42 @@@ +;;; timer-tests.el --- tests for timers -*- lexical-binding:t -*- + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(ert-deftest timer-tests-sit-for () + (let ((timer-ran nil) + ;; Want sit-for behavior when interactive + (noninteractive nil)) + (run-at-time '(0 0 0 0) + nil + (lambda () (setq timer-ran t))) + ;; The test assumes run-at-time didn't take the liberty of firing + ;; the timer, so assert the test's assumption + (should (not timer-ran)) + (sit-for 0 t) + (should timer-ran))) + +(ert-deftest timer-tests-debug-timer-check () + ;; This function exists only if --enable-checking. + (if (fboundp 'debug-timer-check) + (should (debug-timer-check)) t)) + +;;; timer-tests.el ends here diff --cc test/lisp/epg-tests.el index a958d82bd03,00000000000..4a317974ef5 mode 100644,000000..100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@@ -1,172 -1,0 +1,172 @@@ +;;; epg-tests.el --- Test suite for epg.el -*- lexical-binding: t -*- + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'epg) + +(defvar epg-tests-context nil) + +(defvar epg-tests-data-directory + (expand-file-name "data/epg" (getenv "EMACS_TEST_DIRECTORY")) + "Directory containing epg test data.") + +(defun epg-tests-gpg-usable (&optional require-passphrase) + (and (executable-find epg-gpg-program) + (condition-case nil + (progn + (epg-check-configuration (epg-configuration)) + (if require-passphrase + (string-match "\\`1\\." + (cdr (assq 'version (epg-configuration)))) + t)) + (error nil)))) + +(defun epg-tests-passphrase-callback (_c _k _d) + ;; Need to create a copy here, since the string will be wiped out + ;; after the use. + (copy-sequence "test0123456789")) + +(cl-defmacro with-epg-tests ((&optional &key require-passphrase + require-public-key + require-secret-key) + &rest body) + "Set up temporary locations and variables for testing." + (declare (indent 1)) + `(let* ((epg-tests-home-directory (make-temp-file "epg-tests-homedir" t))) + (unwind-protect + (let ((context (epg-make-context 'OpenPGP))) + (setf (epg-context-home-directory context) + epg-tests-home-directory) + (setenv "GPG_AGENT_INFO") + ,(if require-passphrase + `(epg-context-set-passphrase-callback + context + #'epg-tests-passphrase-callback)) + ,(if require-public-key + `(epg-import-keys-from-file + context + (expand-file-name "pubkey.asc" epg-tests-data-directory))) + ,(if require-secret-key + `(epg-import-keys-from-file + context + (expand-file-name "seckey.asc" epg-tests-data-directory))) + (with-temp-buffer + (make-local-variable 'epg-tests-context) + (setq epg-tests-context context) + ,@body)) + (when (file-directory-p epg-tests-home-directory) + (delete-directory epg-tests-home-directory t))))) + +(ert-deftest epg-decrypt-1 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t) + (should (equal "test" + (epg-decrypt-string epg-tests-context "\ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== +=U8z7 +-----END PGP MESSAGE-----"))))) + +(ert-deftest epg-roundtrip-1 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t) + (let ((cipher (epg-encrypt-string epg-tests-context "symmetric" nil))) + (should (equal "symmetric" + (epg-decrypt-string epg-tests-context cipher)))))) + +(ert-deftest epg-roundtrip-2 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let* ((recipients (epg-list-keys epg-tests-context "joe@example.com")) + (cipher (epg-encrypt-string epg-tests-context "public key" + recipients nil t))) + (should (equal "public key" + (epg-decrypt-string epg-tests-context cipher)))))) + +(ert-deftest epg-sign-verify-1 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let (signature verify-result) + (setf (epg-context-signers epg-tests-context) + (epg-list-keys epg-tests-context "joe@example.com")) + (setq signature (epg-sign-string epg-tests-context "signed" t)) + (epg-verify-string epg-tests-context signature "signed") + (setq verify-result (epg-context-result-for context 'verify)) + (should (= 1 (length verify-result))) + (should (eq 'good (epg-signature-status (car verify-result))))))) + +(ert-deftest epg-sign-verify-2 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let (signature verify-result) + (setf (epg-context-signers epg-tests-context) + (epg-list-keys epg-tests-context "joe@example.com")) + (setq signature (epg-sign-string epg-tests-context "clearsigned" 'clear)) + ;; Clearsign signature always ends with a new line. + (should (equal "clearsigned\n" + (epg-verify-string epg-tests-context signature))) + (setq verify-result (epg-context-result-for context 'verify)) + (should (= 1 (length verify-result))) + (should (eq 'good (epg-signature-status (car verify-result))))))) + +(ert-deftest epg-sign-verify-3 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let (signature verify-result) + (setf (epg-context-signers epg-tests-context) + (epg-list-keys epg-tests-context "joe@example.com")) + (setq signature (epg-sign-string epg-tests-context "normal signed")) + (should (equal "normal signed" + (epg-verify-string epg-tests-context signature))) + (setq verify-result (epg-context-result-for context 'verify)) + (should (= 1 (length verify-result))) + (should (eq 'good (epg-signature-status (car verify-result))))))) + +(ert-deftest epg-import-1 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase nil) + (should (= 0 (length (epg-list-keys epg-tests-context)))) + (should (= 0 (length (epg-list-keys epg-tests-context nil t))))) + (with-epg-tests (:require-passphrase nil + :require-public-key t) + (should (= 1 (length (epg-list-keys epg-tests-context)))) + (should (= 0 (length (epg-list-keys epg-tests-context nil t))))) + (with-epg-tests (:require-public-key nil + :require-public-key t + :require-secret-key t) + (should (= 1 (length (epg-list-keys epg-tests-context)))) + (should (= 1 (length (epg-list-keys epg-tests-context nil t)))))) + +(provide 'epg-tests) + +;;; epg-tests.el ends here diff --cc test/lisp/eshell/eshell.el index 81898db79a7,00000000000..d5676dd1daf mode 100644,000000..100644 --- a/test/lisp/eshell/eshell.el +++ b/test/lisp/eshell/eshell.el @@@ -1,252 -1,0 +1,252 @@@ +;;; tests/eshell.el --- Eshell test suite + - ;; Copyright (C) 1999-2015 Free Software Foundation, Inc. ++;; Copyright (C) 1999-2016 Free Software Foundation, Inc. + +;; Author: John Wiegley + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Eshell test suite. + +;;; Code: + +(require 'ert) +(require 'eshell) + +(defmacro with-temp-eshell (&rest body) + "Evaluate BODY in a temporary Eshell buffer." + `(let* ((eshell-directory-name (make-temp-file "eshell" t)) + (eshell-history-file-name nil) + (eshell-buffer (eshell t))) + (unwind-protect + (with-current-buffer eshell-buffer + ,@body) + (let (kill-buffer-query-functions) + (kill-buffer eshell-buffer) + (delete-directory eshell-directory-name t))))) + +(defun eshell-insert-command (text &optional func) + "Insert a command at the end of the buffer." + (goto-char eshell-last-output-end) + (insert-and-inherit text) + (funcall (or func 'eshell-send-input))) + +(defun eshell-match-result (regexp) + "Check that text after `eshell-last-input-end' matches REGEXP." + (goto-char eshell-last-input-end) + (should (string-match-p regexp (buffer-substring-no-properties + (point) (point-max))))) + +(defun eshell-command-result-p (text regexp &optional func) + "Insert a command at the end of the buffer." + (eshell-insert-command text func) + (eshell-match-result regexp)) + +(defun eshell-test-command-result (command) + "Like `eshell-command-result', but not using HOME." + (let ((eshell-directory-name (make-temp-file "eshell" t)) + (eshell-history-file-name nil)) + (unwind-protect + (eshell-command-result command) + (delete-directory eshell-directory-name t)))) + +;;; Tests: + +(ert-deftest eshell-test/simple-command-result () + "Test `eshell-command-result' with a simple command." + (should (equal (eshell-test-command-result "+ 1 2") 3))) + +(ert-deftest eshell-test/lisp-command () + "Test `eshell-command-result' with an elisp command." + (should (equal (eshell-test-command-result "(+ 1 2)") 3))) + +(ert-deftest eshell-test/for-loop () + "Test `eshell-command-result' with a for loop.." + (let ((process-environment (cons "foo" process-environment))) + (should (equal (eshell-test-command-result + "for foo in 5 { echo $foo }") 5)))) + +(ert-deftest eshell-test/for-name-loop () ;Bug#15231 + "Test `eshell-command-result' with a for loop using `name'." + (let ((process-environment (cons "name" process-environment))) + (should (equal (eshell-test-command-result + "for name in 3 { echo $name }") 3)))) + +(ert-deftest eshell-test/for-name-shadow-loop () ; bug#15372 + "Test `eshell-command-result' with a for loop using an env-var." + (let ((process-environment (cons "name=env-value" process-environment))) + (with-temp-eshell + (eshell-command-result-p "echo $name; for name in 3 { echo $name }; echo $name" + "env-value\n3\nenv-value\n")))) + +(ert-deftest eshell-test/lisp-command-args () + "Test `eshell-command-result' with elisp and trailing args. +Test that trailing arguments outside the S-expression are +ignored. e.g. \"(+ 1 2) 3\" => 3" + (should (equal (eshell-test-command-result "(+ 1 2) 3") 3))) + +(ert-deftest eshell-test/subcommand () + "Test `eshell-command-result' with a simple subcommand." + (should (equal (eshell-test-command-result "{+ 1 2}") 3))) + +(ert-deftest eshell-test/subcommand-args () + "Test `eshell-command-result' with a subcommand and trailing args. +Test that trailing arguments outside the subcommand are ignored. +e.g. \"{+ 1 2} 3\" => 3" + (should (equal (eshell-test-command-result "{+ 1 2} 3") 3))) + +(ert-deftest eshell-test/subcommand-lisp () + "Test `eshell-command-result' with an elisp subcommand and trailing args. +Test that trailing arguments outside the subcommand are ignored. +e.g. \"{(+ 1 2)} 3\" => 3" + (should (equal (eshell-test-command-result "{(+ 1 2)} 3") 3))) + +(ert-deftest eshell-test/interp-cmd () + "Interpolate command result" + (should (equal (eshell-test-command-result "+ ${+ 1 2} 3") 6))) + +(ert-deftest eshell-test/interp-lisp () + "Interpolate Lisp form evaluation" + (should (equal (eshell-test-command-result "+ $(+ 1 2) 3") 6))) + +(ert-deftest eshell-test/interp-concat () + "Interpolate and concat command" + (should (equal (eshell-test-command-result "+ ${+ 1 2}3 3") 36))) + +(ert-deftest eshell-test/interp-concat-lisp () + "Interpolate and concat Lisp form" + (should (equal (eshell-test-command-result "+ $(+ 1 2)3 3") 36))) + +(ert-deftest eshell-test/interp-concat2 () + "Interpolate and concat two commands" + (should (equal (eshell-test-command-result "+ ${+ 1 2}${+ 1 2} 3") 36))) + +(ert-deftest eshell-test/interp-concat-lisp2 () + "Interpolate and concat two Lisp forms" + (should (equal (eshell-test-command-result "+ $(+ 1 2)$(+ 1 2) 3") 36))) + +(ert-deftest eshell-test/window-height () + "$LINES should equal (window-height)" + (should (eshell-test-command-result "= $LINES (window-height)"))) + +(ert-deftest eshell-test/window-width () + "$COLUMNS should equal (window-width)" + (should (eshell-test-command-result "= $COLUMNS (window-width)"))) + +(ert-deftest eshell-test/last-result-var () + "Test using the \"last result\" ($$) variable" + (with-temp-eshell + (eshell-command-result-p "+ 1 2; + $$ 2" + "3\n5\n"))) + +(ert-deftest eshell-test/last-result-var2 () + "Test using the \"last result\" ($$) variable twice" + (with-temp-eshell + (eshell-command-result-p "+ 1 2; + $$ $$" + "3\n6\n"))) + +(ert-deftest eshell-test/last-arg-var () + "Test using the \"last arg\" ($_) variable" + (with-temp-eshell + (eshell-command-result-p "+ 1 2; + $_ 4" + "3\n6\n"))) + +(ert-deftest eshell-test/escape-nonspecial () + "Test that \"\\c\" and \"c\" are equivalent when \"c\" is not a +special character." + (with-temp-eshell + (eshell-command-result-p "echo he\\llo" + "hello\n"))) + +(ert-deftest eshell-test/escape-nonspecial-unicode () + "Test that \"\\c\" and \"c\" are equivalent when \"c\" is a +unicode character (unicode characters are nonspecial by +definition)." + (with-temp-eshell + (eshell-command-result-p "echo Vid\\éos" + "Vidéos\n"))) + +(ert-deftest eshell-test/escape-nonspecial-quoted () + "Test that the backslash is preserved for escaped nonspecial +chars" + (with-temp-eshell + (eshell-command-result-p "echo \"h\\i\"" + ;; Backslashes are doubled for regexp. + "h\\\\i\n"))) + +(ert-deftest eshell-test/escape-special-quoted () + "Test that the backslash is not preserved for escaped special +chars" + (with-temp-eshell + (eshell-command-result-p "echo \"h\\\\i\"" + ;; Backslashes are doubled for regexp. + "h\\\\i\n"))) + +(ert-deftest eshell-test/command-running-p () + "Modeline should show no command running" + (with-temp-eshell + (let ((eshell-status-in-mode-line t)) + (should (memq 'eshell-command-running-string mode-line-format)) + (should (equal eshell-command-running-string "--"))))) + +(ert-deftest eshell-test/forward-arg () + "Test moving across command arguments" + (with-temp-eshell + (eshell-insert-command "echo $(+ 1 (- 4 3)) \"alpha beta\" file" 'ignore) + (let ((here (point)) begin valid) + (eshell-bol) + (setq begin (point)) + (eshell-forward-argument 4) + (setq valid (= here (point))) + (eshell-backward-argument 4) + (prog1 + (and valid (= begin (point))) + (eshell-bol) + (delete-region (point) (point-max)))))) + +(ert-deftest eshell-test/queue-input () + "Test queuing command input" + (with-temp-eshell + (eshell-insert-command "sleep 2") + (eshell-insert-command "echo alpha" 'eshell-queue-input) + (let ((count 10)) + (while (and eshell-current-command + (> count 0)) + (sit-for 1) + (setq count (1- count)))) + (eshell-match-result "alpha\n"))) + +(ert-deftest eshell-test/flush-output () + "Test flushing of previous output" + (with-temp-eshell + (eshell-insert-command "echo alpha") + (eshell-kill-output) + (eshell-match-result (regexp-quote "*** output flushed ***\n")) + (should (forward-line)) + (should (= (point) eshell-last-output-start)))) + +(ert-deftest eshell-test/run-old-command () + "Re-run an old command" + (with-temp-eshell + (eshell-insert-command "echo alpha") + (goto-char eshell-last-input-start) + (string= (eshell-get-old-input) "echo alpha"))) + +(provide 'esh-test) + +;;; tests/eshell.el ends here diff --cc test/lisp/faces-tests.el index ff9dfc53fbe,00000000000..809ba24d210 mode 100644,000000..100644 --- a/test/lisp/faces-tests.el +++ b/test/lisp/faces-tests.el @@@ -1,59 -1,0 +1,59 @@@ +;;; faces-tests.el --- Tests for faces.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Artur Malabarba +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) +(require 'faces) + +(defface faces--test1 + '((t :background "black" :foreground "black")) + "") + +(defface faces--test2 + '((t :box 1)) + "") + +(ert-deftest faces--test-color-at-point () + (with-temp-buffer + (insert (propertize "STRING" 'face '(faces--test2 faces--test1))) + (goto-char (point-min)) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black"))) + (with-temp-buffer + (insert (propertize "STRING" 'face '(:foreground "black" :background "black"))) + (goto-char (point-min)) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black"))) + (with-temp-buffer + (emacs-lisp-mode) + (setq-local font-lock-comment-face 'faces--test1) + (setq-local font-lock-constant-face 'faces--test2) + (insert ";; `symbol'") + (font-lock-fontify-region (point-min) (point-max)) + (goto-char (point-min)) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black")) + (goto-char 6) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black")))) + +(provide 'faces-tests) +;;; faces-tests.el ends here diff --cc test/lisp/filenotify-tests.el index 376904dd65c,00000000000..4cde86c8eee mode 100644,000000..100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@@ -1,852 -1,0 +1,852 @@@ +;;; file-notify-tests.el --- Tests of file notifications -*- lexical-binding: t; -*- + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; Some of the tests require access to a remote host files. Since +;; this could be problematic, a mock-up connection method "mock" is +;; used. Emulating a remote connection, it simply calls "sh -i". +;; Tramp's file name handlers still run, so this test is sufficient +;; except for connection establishing. + +;; If you want to test a real Tramp connection, set +;; $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable value in order to +;; overwrite the default value. If you want to skip tests accessing a +;; remote host, set this environment variable to "/dev/null" or +;; whatever is appropriate on your system. + +;; A whole test run can be performed calling the command `file-notify-test-all'. + +;;; Code: + +(require 'ert) +(require 'filenotify) +(require 'tramp) + +;; There is no default value on w32 systems, which could work out of the box. +(defconst file-notify-test-remote-temporary-file-directory + (cond + ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY")) + ((eq system-type 'windows-nt) null-device) + (t (add-to-list + 'tramp-methods + '("mock" + (tramp-login-program "sh") + (tramp-login-args (("-i"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (format "/mock::%s" temporary-file-directory))) + "Temporary directory for Tramp tests.") + +(defvar file-notify--test-tmpfile nil) +(defvar file-notify--test-tmpfile1 nil) +(defvar file-notify--test-desc nil) +(defvar file-notify--test-results nil) +(defvar file-notify--test-event nil) +(defvar file-notify--test-events nil) + +(defun file-notify--test-timeout () + "Timeout to wait for arriving events, in seconds." + (cond + ((file-remote-p temporary-file-directory) 6) + ((string-equal (file-notify--test-library) "w32notify") 20) + ((eq system-type 'cygwin) 10) + (t 3))) + +(defun file-notify--test-cleanup () + "Cleanup after a test." + (file-notify-rm-watch file-notify--test-desc) + + (when (and file-notify--test-tmpfile + (file-exists-p file-notify--test-tmpfile)) + (if (file-directory-p file-notify--test-tmpfile) + (delete-directory file-notify--test-tmpfile 'recursive) + (delete-file file-notify--test-tmpfile))) + (when (and file-notify--test-tmpfile1 + (file-exists-p file-notify--test-tmpfile1)) + (if (file-directory-p file-notify--test-tmpfile1) + (delete-directory file-notify--test-tmpfile1 'recursive) + (delete-file file-notify--test-tmpfile1))) + (when (file-remote-p temporary-file-directory) + (tramp-cleanup-connection + (tramp-dissect-file-name temporary-file-directory) nil 'keep-password)) + + (setq file-notify--test-tmpfile nil + file-notify--test-tmpfile1 nil + file-notify--test-desc nil + file-notify--test-results nil + file-notify--test-events nil) + (when file-notify--test-event + (error "file-notify--test-event should not be set but bound dynamically"))) + +(setq password-cache-expiry nil + tramp-verbose 0 + tramp-message-show-message nil) + +;; This shall happen on hydra only. +(when (getenv "NIX_STORE") + (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) + +;; We do not want to try and fail `file-notify-add-watch'. +(defun file-notify--test-local-enabled () + "Whether local file notification is enabled. +This is needed for local `temporary-file-directory' only, in the +remote case we return always t." + (or file-notify--library + (file-remote-p temporary-file-directory))) + +(defvar file-notify--test-remote-enabled-checked nil + "Cached result of `file-notify--test-remote-enabled'. +If the function did run, the value is a cons cell, the `cdr' +being the result.") + +(defun file-notify--test-remote-enabled () + "Whether remote file notification is enabled." + (unless (consp file-notify--test-remote-enabled-checked) + (let (desc) + (ignore-errors + (and + (file-remote-p file-notify-test-remote-temporary-file-directory) + (file-directory-p file-notify-test-remote-temporary-file-directory) + (file-writable-p file-notify-test-remote-temporary-file-directory) + (setq desc + (file-notify-add-watch + file-notify-test-remote-temporary-file-directory + '(change) 'ignore)))) + (setq file-notify--test-remote-enabled-checked (cons t desc)) + (when desc (file-notify-rm-watch desc)))) + ;; Return result. + (cdr file-notify--test-remote-enabled-checked)) + +(defun file-notify--test-library () + "The used library for the test, as a string. +In the remote case, it is the process name which runs on the +remote host, or nil." + (if (null (file-remote-p temporary-file-directory)) + (symbol-name file-notify--library) + (and (consp file-notify--test-remote-enabled-checked) + (processp (cdr file-notify--test-remote-enabled-checked)) + (replace-regexp-in-string + "<[[:digit:]]+>\\'" "" + (process-name (cdr file-notify--test-remote-enabled-checked)))))) + +(defmacro file-notify--deftest-remote (test docstring) + "Define ert `TEST-remote' for remote files." + (declare (indent 1)) + `(ert-deftest ,(intern (concat (symbol-name test) "-remote")) () + ,docstring + (let* ((temporary-file-directory + file-notify-test-remote-temporary-file-directory) + (ert-test (ert-get-test ',test))) + (skip-unless (file-notify--test-remote-enabled)) + (tramp-cleanup-connection + (tramp-dissect-file-name temporary-file-directory) nil 'keep-password) + (funcall (ert-test-body ert-test))))) + +(ert-deftest file-notify-test00-availability () + "Test availability of `file-notify'." + (skip-unless (file-notify--test-local-enabled)) + ;; Report the native library which has been used. + (message "Library: `%s'" (file-notify--test-library)) + (should + (setq file-notify--test-desc + (file-notify-add-watch temporary-file-directory '(change) 'ignore))) + + ;; Cleanup. + (file-notify--test-cleanup)) + +(file-notify--deftest-remote file-notify-test00-availability + "Test availability of `file-notify' for remote files.") + +(ert-deftest file-notify-test01-add-watch () + "Check `file-notify-add-watch'." + (skip-unless (file-notify--test-local-enabled)) + + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 + (format "%s/%s" file-notify--test-tmpfile (md5 (current-time-string)))) + + ;; Check, that different valid parameters are accepted. + (should + (setq file-notify--test-desc + (file-notify-add-watch temporary-file-directory '(change) 'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (should + (setq file-notify--test-desc + (file-notify-add-watch + temporary-file-directory '(attribute-change) 'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (should + (setq file-notify--test-desc + (file-notify-add-watch + temporary-file-directory '(change attribute-change) 'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile '(change attribute-change) 'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (delete-file file-notify--test-tmpfile) + + ;; Check error handling. + (should-error (file-notify-add-watch 1 2 3 4) + :type 'wrong-number-of-arguments) + (should + (equal (should-error + (file-notify-add-watch 1 2 3)) + '(wrong-type-argument 1))) + (should + (equal (should-error + (file-notify-add-watch temporary-file-directory 2 3)) + '(wrong-type-argument 2))) + (should + (equal (should-error + (file-notify-add-watch temporary-file-directory '(change) 3)) + '(wrong-type-argument 3))) + ;; The upper directory of a file must exist. + (should + (equal (should-error + (file-notify-add-watch + file-notify--test-tmpfile1 '(change attribute-change) 'ignore)) + `(file-notify-error + "Directory does not exist" ,file-notify--test-tmpfile))) + + ;; Cleanup. + (file-notify--test-cleanup)) + +(file-notify--deftest-remote file-notify-test01-add-watch + "Check `file-notify-add-watch' for remote files.") + +(defun file-notify--test-event-test () + "Ert test function to be called by `file-notify--test-event-handler'. +We cannot pass arguments, so we assume that `file-notify--test-event' +is bound somewhere." + ;; Check the descriptor. + (should (equal (car file-notify--test-event) file-notify--test-desc)) + ;; Check the file name. + (should + (or (string-equal (file-notify--event-file-name file-notify--test-event) + file-notify--test-tmpfile) + (string-equal (file-notify--event-file-name file-notify--test-event) + file-notify--test-tmpfile1) + (string-equal (file-notify--event-file-name file-notify--test-event) + temporary-file-directory))) + ;; Check the second file name if exists. + (when (eq (nth 1 file-notify--test-event) 'renamed) + (should + (or (string-equal (file-notify--event-file1-name file-notify--test-event) + file-notify--test-tmpfile1) + (string-equal (file-notify--event-file1-name file-notify--test-event) + temporary-file-directory))))) + +(defun file-notify--test-event-handler (event) + "Run a test over FILE-NOTIFY--TEST-EVENT. +For later analysis, append the test result to `file-notify--test-results' +and the event to `file-notify--test-events'." + (let* ((file-notify--test-event event) + (result + (ert-run-test (make-ert-test :body 'file-notify--test-event-test)))) + ;; Do not add lock files, this would confuse the checks. + (unless (string-match + (regexp-quote ".#") + (file-notify--event-file-name file-notify--test-event)) + ;;(message "file-notify--test-event-handler %S" file-notify--test-event) + (setq file-notify--test-events + (append file-notify--test-events `(,file-notify--test-event)) + file-notify--test-results + (append file-notify--test-results `(,result)))))) + +(defun file-notify--test-make-temp-name () + "Create a temporary file name for test." + (expand-file-name + (make-temp-name "file-notify-test") temporary-file-directory)) + +(defmacro file-notify--wait-for-events (timeout until) + "Wait for and return file notification events until form UNTIL is true. +TIMEOUT is the maximum time to wait for, in seconds." + `(with-timeout (,timeout (ignore)) + (while (null ,until) + (read-event nil nil 0.1)))) + +(defmacro file-notify--test-with-events (events &rest body) + "Run BODY collecting events and then compare with EVENTS. +EVENTS is either a simple list of events, or a list of lists of +events, which represent different possible results. Don't wait +longer than timeout seconds for the events to be delivered." + (declare (indent 1)) + (let ((outer (make-symbol "outer"))) + `(let* ((,outer file-notify--test-events) + (events (if (consp (car ,events)) ,events (list ,events))) + (max-length (apply 'max (mapcar 'length events))) + create-lockfiles result) + ;; Flush pending events. + (file-notify--wait-for-events + (file-notify--test-timeout) + (input-pending-p)) + (let (file-notify--test-events) + ,@body + (file-notify--wait-for-events + ;; More events need more time. Use some fudge factor. + (* (ceiling max-length 100) (file-notify--test-timeout)) + (= max-length (length file-notify--test-events))) + ;; One of the possible results shall match. + (should + (dolist (elt events result) + (setq result + (or result + (equal elt (mapcar #'cadr file-notify--test-events)))))) + (setq ,outer (append ,outer file-notify--test-events))) + (setq file-notify--test-events ,outer)))) + +(ert-deftest file-notify-test02-events () + "Check file creation/change/removal notifications." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + ;; Check file creation, change and deletion. It doesn't work + ;; for cygwin and kqueue, because we don't use an implicit + ;; directory monitor (kqueue), or the timings are too bad (cygwin). + (unless (or (eq system-type 'cygwin) + (string-equal (file-notify--test-library) "kqueue")) + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + (t '(created changed deleted stopped))) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (delete-file file-notify--test-tmpfile)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc))) + + ;; Check file change and deletion. + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; inotify and kqueue raise just one `changed' event. + ((or (string-equal "inotify" (file-notify--test-library)) + (string-equal "kqueue" (file-notify--test-library))) + '(changed deleted stopped)) + ;; gfilenotify raises one or two `changed' events + ;; randomly, no chance to test. So we accept both cases. + ((string-equal "gfilenotify" (file-notify--test-library)) + '((changed deleted stopped) + (changed changed deleted stopped))) + (t '(changed changed deleted stopped))) + (read-event nil nil 0.1) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (delete-file file-notify--test-tmpfile)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc)) + + ;; Check file creation, change and deletion when watching a + ;; directory. There must be a `stopped' event when deleting + ;; the directory. + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does raise a `stopped' event when a + ;; watched directory is deleted. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed deleted)) + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for kqueue. + ((string-equal (file-notify--test-library) "kqueue") + '(created changed deleted stopped)) + (t '(created changed deleted deleted stopped))) + (read-event nil nil 0.1) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (delete-directory temporary-file-directory 'recursive)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc))) + + ;; Check copy of files inside a directory. + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed created changed changed changed changed + deleted deleted)) + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; There are three `deleted' events, for two files and + ;; for the directory. Except for kqueue. + ((string-equal (file-notify--test-library) "kqueue") + '(created changed created changed deleted stopped)) + (t '(created changed created changed + deleted deleted deleted stopped))) + (read-event nil nil 0.1) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) + ;; The next two events shall not be visible. + (read-event nil nil 0.1) + (set-file-modes file-notify--test-tmpfile 000) + (read-event nil nil 0.1) + (set-file-times file-notify--test-tmpfile '(0 0)) + (read-event nil nil 0.1) + (delete-directory temporary-file-directory 'recursive)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc))) + + ;; Check rename of files inside a directory. + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed renamed deleted)) + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for kqueue. + ((string-equal (file-notify--test-library) "kqueue") + '(created changed renamed deleted stopped)) + (t '(created changed renamed deleted deleted stopped))) + (read-event nil nil 0.1) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1) + ;; After the rename, we won't get events anymore. + (read-event nil nil 0.1) + (delete-directory temporary-file-directory 'recursive)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc))) + + ;; Check attribute change. Does not work for cygwin. + (unless (eq system-type 'cygwin) + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(attribute-change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. + ((string-equal (file-notify--test-library) "w32notify") + '(changed changed changed changed)) + ;; For kqueue and in the remote case, `write-region' + ;; raises also an `attribute-changed' event. + ((or (string-equal (file-notify--test-library) "kqueue") + (file-remote-p temporary-file-directory)) + '(attribute-changed attribute-changed attribute-changed)) + (t '(attribute-changed attribute-changed))) + (read-event nil nil 0.1) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (set-file-modes file-notify--test-tmpfile 000) + (read-event nil nil 0.1) + (set-file-times file-notify--test-tmpfile '(0 0)) + (read-event nil nil 0.1) + (delete-file file-notify--test-tmpfile)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc))) + + ;; Check the global sequence again just to make sure that + ;; `file-notify--test-events' has been set correctly. + (should file-notify--test-results) + (dolist (result file-notify--test-results) + (when (ert-test-failed-p result) + (ert-fail + (cadr (ert-test-result-with-condition-condition result)))))) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test02-events + "Check file creation/change/removal notifications for remote files.") + +(require 'autorevert) +(setq auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded" + auto-revert-remote-files t + auto-revert-stop-on-user-input nil) + +(ert-deftest file-notify-test03-autorevert () + "Check autorevert via file notification." + (skip-unless (file-notify--test-local-enabled)) + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let ((timeout (if (file-remote-p temporary-file-directory) 60 10)) + buf) + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (setq buf (find-file-noselect file-notify--test-tmpfile)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-mode 1) + + ;; `auto-revert-buffers' runs every 5". + (with-timeout (timeout (ignore)) + (while (null auto-revert-notify-watch-descriptor) + (sleep-for 1))) + + ;; Check, that file notification has been used. + (should auto-revert-mode) + (should auto-revert-use-notify) + (should auto-revert-notify-watch-descriptor) + + ;; Modify file. We wait for a second, in order to have + ;; another timestamp. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 1) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (file-notify--wait-for-events + timeout + (string-match + (format-message "Reverting buffer `%s'." (buffer-name buf)) + (buffer-string)))) + (should (string-match "another text" (buffer-string))) + + ;; Stop file notification. Autorevert shall still work via polling. + ;; It doesn't work for `w32notify'. + (unless (string-equal (file-notify--test-library) "w32notify") + (file-notify-rm-watch auto-revert-notify-watch-descriptor) + (file-notify--wait-for-events + timeout (null auto-revert-use-notify)) + (should-not auto-revert-use-notify) + (should-not auto-revert-notify-watch-descriptor) + + ;; Modify file. We wait for two seconds, in order to + ;; have another timestamp. One second seems to be too + ;; short. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 2) + (write-region + "foo bla" nil file-notify--test-tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (file-notify--wait-for-events + timeout + (string-match + (format-message "Reverting buffer `%s'." (buffer-name buf)) + (buffer-string)))) + (should (string-match "foo bla" (buffer-string)))))) + + ;; Cleanup. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors (kill-buffer buf)) + (file-notify--test-cleanup)))) + +(file-notify--deftest-remote file-notify-test03-autorevert + "Check autorevert via file notification for remote files.") + +(ert-deftest file-notify-test04-file-validity () + "Check `file-notify-valid-p' for files." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + ;; After calling `file-notify-rm-watch', the descriptor is not + ;; valid anymore. + (file-notify-rm-watch file-notify--test-desc) + (should-not (file-notify-valid-p file-notify--test-desc)) + (delete-file file-notify--test-tmpfile)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; inotify and kqueue raise just one `changed' event. + ((or (string-equal "inotify" (file-notify--test-library)) + (string-equal "kqueue" (file-notify--test-library))) + '(changed deleted stopped)) + ;; gfilenotify raises one or two `changed' events + ;; randomly, no chance to test. So we accept both cases. + ((string-equal "gfilenotify" (file-notify--test-library)) + '((changed deleted stopped) + (changed changed deleted stopped))) + (t '(changed changed deleted stopped))) + (should (file-notify-valid-p file-notify--test-desc)) + (read-event nil nil 0.1) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (delete-file file-notify--test-tmpfile)) + ;; After deleting the file, the descriptor is not valid anymore. + (should-not (file-notify-valid-p file-notify--test-desc)) + (file-notify-rm-watch file-notify--test-desc)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; w32notify does not send a `stopped' event when deleting a + ;; directory. The test does not work, therefore. + (unless (string-equal (file-notify--test-library) "w32notify") + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for kqueue. + ((string-equal (file-notify--test-library) "kqueue") + '(created changed deleted stopped)) + (t '(created changed deleted deleted stopped))) + (should (file-notify-valid-p file-notify--test-desc)) + (read-event nil nil 0.1) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (delete-directory temporary-file-directory t)) + ;; After deleting the parent directory, the descriptor must + ;; not be valid anymore. + (should-not (file-notify-valid-p file-notify--test-desc)))) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test04-file-validity + "Check `file-notify-valid-p' via file notification for remote files.") + +(ert-deftest file-notify-test05-dir-validity () + "Check `file-notify-valid-p' for directories." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile + (file-name-as-directory (file-notify--test-make-temp-name))) + (make-directory file-notify--test-tmpfile) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + ;; After removing the watch, the descriptor must not be valid + ;; anymore. + (file-notify-rm-watch file-notify--test-desc) + (file-notify--wait-for-events + (file-notify--test-timeout) + (not (file-notify-valid-p file-notify--test-desc))) + (should-not (file-notify-valid-p file-notify--test-desc))) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; The batch-mode operation of w32notify is fragile (there's no + ;; input threads to send the message to). + (unless (and noninteractive + (string-equal (file-notify--test-library) "w32notify")) + (setq file-notify--test-tmpfile + (file-name-as-directory (file-notify--test-make-temp-name))) + (make-directory file-notify--test-tmpfile) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + ;; After deleting the directory, the descriptor must not be + ;; valid anymore. + (delete-directory file-notify--test-tmpfile t) + (file-notify--wait-for-events + (file-notify--test-timeout) + (not (file-notify-valid-p file-notify--test-desc))) + (should-not (file-notify-valid-p file-notify--test-desc))) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test05-dir-validity + "Check `file-notify-valid-p' via file notification for remote directories.") + +(ert-deftest file-notify-test06-many-events () + "Check that events are not dropped." + (skip-unless (file-notify--test-local-enabled)) + ;; Under cygwin events arrive in random order. Impossible to define a test. + (skip-unless (not (eq system-type 'cygwin))) + + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (make-directory file-notify--test-tmpfile) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) 'file-notify--test-event-handler))) + (unwind-protect + (let ((n 1000) + source-file-list target-file-list + (default-directory file-notify--test-tmpfile)) + (dotimes (i n) + ;; It matters which direction we rename, at least for + ;; kqueue. This backend parses directories in alphabetic + ;; order (x%d before y%d). So we rename both directions. + (if (zerop (mod i 2)) + (progn + (push (expand-file-name (format "x%d" i)) source-file-list) + (push (expand-file-name (format "y%d" i)) target-file-list)) + (push (expand-file-name (format "y%d" i)) source-file-list) + (push (expand-file-name (format "x%d" i)) target-file-list))) + (file-notify--test-with-events (make-list (+ n n) 'created) + (let ((source-file-list source-file-list) + (target-file-list target-file-list)) + (while (and source-file-list target-file-list) + (read-event nil nil 0.1) + (write-region "" nil (pop source-file-list) nil 'no-message) + (read-event nil nil 0.1) + (write-region "" nil (pop target-file-list) nil 'no-message)))) + (file-notify--test-with-events + (cond + ;; w32notify fires both `deleted' and `renamed' events. + ((string-equal (file-notify--test-library) "w32notify") + (let (r) + (dotimes (_i n r) + (setq r (append '(deleted renamed) r))))) + (t (make-list n 'renamed))) + (let ((source-file-list source-file-list) + (target-file-list target-file-list)) + (while (and source-file-list target-file-list) + (rename-file (pop source-file-list) (pop target-file-list) t)))) + (file-notify--test-with-events (make-list n 'deleted) + (dolist (file target-file-list) + (delete-file file)))) + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test06-many-events + "Check that events are not dropped for remote directories.") + +(defun file-notify-test-all (&optional interactive) + "Run all tests for \\[file-notify]." + (interactive "p") + (if interactive + (ert-run-tests-interactively "^file-notify-") + (ert-run-tests-batch "^file-notify-"))) + +;; TODO: + +;; * For w32notify, no stopped events arrive when a directory is removed. +;; * Check, why cygwin recognizes only `deleted' and `stopped' events. + +(provide 'file-notify-tests) +;;; file-notify-tests.el ends here diff --cc test/lisp/gnus/auth-source-tests.el index dd70d546d5c,00000000000..5faa1fe20bf mode 100644,000000..100644 --- a/test/lisp/gnus/auth-source-tests.el +++ b/test/lisp/gnus/auth-source-tests.el @@@ -1,223 -1,0 +1,223 @@@ +;;; auth-source-tests.el --- Tests for auth-source.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Damien Cassou , +;; Nicolas Petton + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'auth-source) + +(defvar secrets-enabled t + "Enable the secrets backend to test its features.") + +(defun auth-source-validate-backend (source validation-alist) + (let ((backend (auth-source-backend-parse source))) + (should (auth-source-backend-p backend)) + (dolist (pair validation-alist) + (should (equal (eieio-oref backend (car pair)) (cdr pair)))))) + +(ert-deftest auth-source-backend-parse-macos-keychain () + (auth-source-validate-backend '(:source (:macos-keychain-generic foobar)) + '((:source . "foobar") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-generic-string () + (auth-source-validate-backend "macos-keychain-generic:foobar" + '((:source . "foobar") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-string () + (auth-source-validate-backend "macos-keychain-internet:foobar" + '((:source . "foobar") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-symbol () + (auth-source-validate-backend 'macos-keychain-internet + '((:source . "default") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-generic-symbol () + (auth-source-validate-backend 'macos-keychain-generic + '((:source . "default") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-default-string () + (auth-source-validate-backend 'macos-keychain-internet + '((:source . "default") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-plstore () + (auth-source-validate-backend '(:source "foo.plist") + '((:source . "foo.plist") + (:type . plstore) + (:search-function . auth-source-plstore-search) + (:create-function . auth-source-plstore-create)))) + +(ert-deftest auth-source-backend-parse-netrc () + (auth-source-validate-backend '(:source "foo") + '((:source . "foo") + (:type . netrc) + (:search-function . auth-source-netrc-search) + (:create-function . auth-source-netrc-create)))) + +(ert-deftest auth-source-backend-parse-netrc-string () + (auth-source-validate-backend "foo" + '((:source . "foo") + (:type . netrc) + (:search-function . auth-source-netrc-search) + (:create-function . auth-source-netrc-create)))) + +(ert-deftest auth-source-backend-parse-secrets () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source (:secrets "foo")) + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-strings () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend "secrets:foo" + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-nil-source () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source (:secrets nil)) + '((:source . "session") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-alias () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'foo to "foo" + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) + (auth-source-validate-backend '(:source (:secrets foo)) + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +(ert-deftest auth-source-backend-parse-secrets-symbol () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'default to "foo" + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) + (auth-source-validate-backend 'default + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +(ert-deftest auth-source-backend-parse-secrets-no-alias () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'foo to nil (so that + ;; "Login" is used by default + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) nil))) + (auth-source-validate-backend '(:source (:secrets foo)) + '((:source . "Login") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +;; TODO This test shows suspicious behavior of auth-source: the +;; "secrets" source is used even though nothing in the input indicates +;; that is what we want +(ert-deftest auth-source-backend-parse-secrets-no-source () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source '(foo)) + '((:source . "session") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(defun auth-source--test-netrc-parse-entry (entry host user port) + "Parse a netrc entry from buffer." + (auth-source-forget-all-cached) + (setq port (auth-source-ensure-strings port)) + (with-temp-buffer + (insert entry) + (goto-char (point-min)) + (let* ((check (lambda(alist) + (and alist + (auth-source-search-collection + host + (or + (auth-source--aget alist "machine") + (auth-source--aget alist "host") + t)) + (auth-source-search-collection + user + (or + (auth-source--aget alist "login") + (auth-source--aget alist "account") + (auth-source--aget alist "user") + t)) + (auth-source-search-collection + port + (or + (auth-source--aget alist "port") + (auth-source--aget alist "protocol") + t))))) + (entries (auth-source-netrc-parse-entries check 1))) + entries))) + +(ert-deftest auth-source-test-netrc-parse-entry () + (should (equal (auth-source--test-netrc-parse-entry + "machine mymachine1 login user1 password pass1\n" t t t) + '((("password" . "pass1") + ("login" . "user1") + ("machine" . "mymachine1"))))) + (should (equal (auth-source--test-netrc-parse-entry + "machine mymachine1 login user1 password pass1 port 100\n" + t t t) + '((("port" . "100") + ("password" . "pass1") + ("login" . "user1") + ("machine" . "mymachine1")))))) + +(provide 'auth-source-tests) +;;; auth-source-tests.el ends here diff --cc test/lisp/gnus/gnus-tests.el index ef785ec9a0b,00000000000..6801ce69a3e mode 100644,000000..100644 --- a/test/lisp/gnus/gnus-tests.el +++ b/test/lisp/gnus/gnus-tests.el @@@ -1,35 -1,0 +1,35 @@@ +;;; gnus-tests.el --- Wrapper for the Gnus tests + - ;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Teodor Zlatanov + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file should contain nothing but requires for all the Gnus +;; tests that are not standalone. + +;;; Code: +;; registry.el is required by gnus-registry.el but this way we're explicit. +(eval-when-compile (require 'cl)) + +(require 'registry) +(require 'gnus-registry) + +(provide 'gnus-tests) +;;; gnus-tests.el ends here diff --cc test/lisp/gnus/message-tests.el index 790b5c15125,00000000000..3afa1569f64 mode 100644,000000..100644 --- a/test/lisp/gnus/message-tests.el +++ b/test/lisp/gnus/message-tests.el @@@ -1,60 -1,0 +1,60 @@@ +;;; message-mode-tests.el --- Tests for message-mode -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: João Távora + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file contains tests for message-mode. + +;;; Code: + +(require 'message) +(require 'ert) +(require 'ert-x) + +(ert-deftest message-mode-propertize () + (with-temp-buffer + (unwind-protect + (let (message-auto-save-directory) + (message-mode) + (insert "here's an opener (\n" + "here's a sad face :-(\n" + "> here's citing someone with an opener (\n" + "and here's a closer ") + (let ((last-command-event ?\))) + (ert-simulate-command '(self-insert-command 1))) + ;; Auto syntax propertization doesn't kick in until + ;; parse-sexp-lookup-properties is set. + (setq-local parse-sexp-lookup-properties t) + (backward-sexp) + (should (string= "here's an opener " + (buffer-substring-no-properties + (line-beginning-position) + (point)))) + (forward-sexp) + (should (string= "and here's a closer )" + (buffer-substring-no-properties + (line-beginning-position) + (point))))) + (set-buffer-modified-p nil)))) + +(provide 'message-mode-tests) + +;;; message-mode-tests.el ends here diff --cc test/lisp/help-fns-tests.el index 79e90f7819c,00000000000..babba1a68fc mode 100644,000000..100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@@ -1,70 -1,0 +1,70 @@@ +;;; help-fns.el --- tests for help-fns.el + - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(autoload 'help-fns-test--macro "help-fns" nil nil t) + +(ert-deftest help-fns-test-bug17410 () + "Test for http://debbugs.gnu.org/17410 ." + (describe-function 'help-fns-test--macro) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward "autoloaded Lisp macro" (line-end-position))))) + +(defun abc\\\[universal-argument\]b\`c\'d\\e\"f (x) + "A function with a funny name. + +\(fn XYZZY)" + x) + +(defun defgh\\\[universal-argument\]b\`c\'d\\e\"f (x) + "Another function with a funny name." + x) + +(ert-deftest help-fns-test-funny-names () + "Test for help with functions with funny names." + (describe-function 'abc\\\[universal-argument\]b\`c\'d\\e\"f) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward + "(abc\\\\\\[universal-argument\\]b\\`c\\'d\\\\e\\\"f XYZZY)"))) + (describe-function 'defgh\\\[universal-argument\]b\`c\'d\\e\"f) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward + "(defgh\\\\\\[universal-argument\\]b\\`c\\'d\\\\e\\\"f X)")))) + +(ert-deftest help-fns-test-describe-symbol () + "Test the `describe-symbol' function." + ;; 'describe-symbol' would originally signal an error for + ;; 'font-lock-comment-face'. + (describe-symbol 'font-lock-comment-face) + (with-current-buffer "*Help*" + (should (> (point-max) 1)) + (goto-char (point-min)) + (should (looking-at "^font-lock-comment-face is ")))) + +;;; help-fns.el ends here diff --cc test/lisp/imenu-tests.el index 984e620bb18,00000000000..b6e0f604d0e mode 100644,000000..100644 --- a/test/lisp/imenu-tests.el +++ b/test/lisp/imenu-tests.el @@@ -1,88 -1,0 +1,88 @@@ +;;; imenu-tests.el --- Test suite for imenu. + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Masatake YAMATO +;; Keywords: tools convenience + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'imenu) + +;; (imenu-simple-scan-deftest-gather-strings-from-list +;; '(nil t 'a (0 . "x") ("c" . "d") ("a" 0 "b") )) +;; => ("b" "a" "d" "c" "x") +(defun imenu-simple-scan-deftest-gather-strings-from-list(input) + "Gather strings from INPUT, a list." + (let ((result ())) + (while input + (cond + ((stringp input) + (setq result (cons input result) + input nil)) + ((atom input) + (setq input nil)) + ((listp (car input)) + (setq result (append + (imenu-simple-scan-deftest-gather-strings-from-list (car input)) + result) + input (cdr input))) + ((stringp (car input)) + (setq result (cons (car input) result) + input (cdr input))) + (t + (setq input (cdr input))))) + result)) + +(defmacro imenu-simple-scan-deftest (name doc major-mode content expected-items) + "Generate an ert test for mode-own imenu expression. +Run `imenu-create-index-function' at the buffer which content is +CONTENT with MAJOR-MODE. A generated test runs `imenu-create-index-function' +at the buffer which content is CONTENT with MAJOR-MODE. Then it compares a list +of strings which are picked up from the result with EXPECTED-ITEMS." + (let ((xname (intern (concat "imenu-simple-scan-deftest-" (symbol-name name))))) + `(ert-deftest ,xname () + ,doc + (with-temp-buffer + (insert ,content) + (funcall ',major-mode) + (let ((result-items (sort (imenu-simple-scan-deftest-gather-strings-from-list + (funcall imenu-create-index-function)) + #'string-lessp)) + (expected-items (sort (copy-sequence ,expected-items) #'string-lessp))) + (should (equal result-items expected-items)) + ))))) + +(imenu-simple-scan-deftest sh "Test imenu expression for sh-mode." sh-mode "a() +{ +} +function b +{ +} +function c() +{ +} +function ABC_D() +{ +} +" '("a" "b" "c" "ABC_D")) + +(provide 'imenu-tests) + +;;; imenu-tests.el ends here diff --cc test/lisp/info-xref-tests.el index 67f963beb00,00000000000..bc3115042bc mode 100644,000000..100644 --- a/test/lisp/info-xref-tests.el +++ b/test/lisp/info-xref-tests.el @@@ -1,147 -1,0 +1,147 @@@ +;;; info-xref.el --- tests for info-xref.el + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'info-xref) + +(defun info-xref-test-internal (body result) + "Body of a basic info-xref ert test. +BODY is a string from an info buffer. +RESULT is a list (NBAD NGOOD NUNAVAIL)." + (get-buffer-create info-xref-output-buffer) + (setq info-xref-xfile-alist nil) + (require 'info) + (let ((Info-directory-list '(".")) + Info-additional-directory-list) + (info-xref-with-output + (with-temp-buffer + (insert body) + (info-xref-check-buffer)))) + (should (equal result (list info-xref-bad info-xref-good info-xref-unavail))) + ;; If there was an error, we can leave this around. + (kill-buffer info-xref-output-buffer)) + +(ert-deftest info-xref-test-node-crossref () + "Test parsing of @xref{node,crossref,,manual} with Texinfo 4/5." + (info-xref-test-internal " +*Note crossref: (manual-foo)node. Texinfo 4/5 format with crossref. +" '(0 0 1))) + +(ert-deftest info-xref-test-node-4 () + "Test parsing of @xref{node,,,manual} with Texinfo 4." + (info-xref-test-internal " +*Note node: (manual-foo)node. Texinfo 4 format with no crossref. +" '(0 0 1))) + +(ert-deftest info-xref-test-node-5 () + "Test parsing of @xref{node,,,manual} with Texinfo 5." + (info-xref-test-internal " +*Note (manual-foo)node::. Texinfo 5 format with no crossref. +" '(0 0 1))) + +;; TODO Easier to have static data files in the repo? +(defun info-xref-test-write-file (file body) + "Write BODY to texi FILE." + (with-temp-buffer + (insert "\ +\\input texinfo +@setfilename " + (format "%s.info\n" (file-name-sans-extension file)) + "\ +@settitle test + +@ifnottex +@node Top +@top test +@end ifnottex + +@menu +* Chapter One:: +@end menu + +@node Chapter One +@chapter Chapter One + +text. + +" + body + "\ +@bye +" + ) + (write-region nil nil file nil 'silent)) + (should (equal 0 (call-process "makeinfo" file)))) + +(ert-deftest info-xref-test-makeinfo () + "Test that info-xref can parse basic makeinfo output." + (skip-unless (executable-find "makeinfo")) + (let ((tempfile (make-temp-file "info-xref-test" nil ".texi")) + (tempfile2 (make-temp-file "info-xref-test2" nil ".texi")) + (errflag t)) + (unwind-protect + (progn + ;; tempfile contains xrefs to various things, including tempfile2. + (info-xref-test-write-file + tempfile + (concat "\ +@xref{nodename,,,missing,Missing Manual}. + +@xref{nodename,crossref,title,missing,Missing Manual}. + +@xref{Chapter One}. + +@xref{Chapter One,Something}. + +" + (format "@xref{Chapter One,,,%s,Present Manual}.\n" + (file-name-sans-extension (file-name-nondirectory + tempfile2))))) + ;; Something for tempfile to xref to. + (info-xref-test-write-file tempfile2 "") + (require 'info) + (save-window-excursion + (let ((Info-directory-list + (list + (or (file-name-directory tempfile) "."))) + Info-additional-directory-list) + (info-xref-check (format "%s.info" (file-name-sans-extension + tempfile)))) + (should (equal (list info-xref-bad info-xref-good + info-xref-unavail) + '(0 1 2))) + (setq errflag nil) + ;; If there was an error, we can leave this around. + (kill-buffer info-xref-output-buffer))) + ;; Useful diagnostic in case of problems. + (if errflag + (with-temp-buffer + (call-process "makeinfo" nil t nil "--version") + (message "%s" (buffer-string)))) + (mapc 'delete-file (list tempfile tempfile2 + (format "%s.info" (file-name-sans-extension + tempfile)) + (format "%s.info" (file-name-sans-extension + tempfile2))))))) + +;;; info-xref.el ends here diff --cc test/lisp/international/mule-util-tests.el index 24b56c0969b,00000000000..9846aa13295 mode 100644,000000..100644 --- a/test/lisp/international/mule-util-tests.el +++ b/test/lisp/international/mule-util-tests.el @@@ -1,84 -1,0 +1,84 @@@ +;;; mule-util --- tests for international/mule-util.el + - ;; Copyright (C) 2002-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2002-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'mule-util) + +(defconst mule-util-test-truncate-data + '((("" 0) . "") + (("x" 1) . "x") + (("xy" 1) . "x") + (("xy" 2 1) . "y") + (("xy" 0) . "") + (("xy" 3) . "xy") + (("中" 0) . "") + (("中" 1) . "") + (("中" 2) . "中") + (("中" 1 nil ? ) . " ") + (("中文" 3 1 ? ) . " ") + (("x中x" 2) . "x") + (("x中x" 3) . "x中") + (("x中x" 3) . "x中") + (("x中x" 4 1) . "中x") + (("kor한e글an" 8 1 ? ) . "or한e글") + (("kor한e글an" 7 2 ? ) . "r한e ") + (("" 0 nil nil "...") . "") + (("x" 3 nil nil "...") . "x") + (("中" 3 nil nil "...") . "中") + (("foo" 3 nil nil "...") . "foo") + (("foo" 2 nil nil "...") . "fo") ;; XEmacs failure? + (("foobar" 6 0 nil "...") . "foobar") + (("foobarbaz" 6 nil nil "...") . "foo...") + (("foobarbaz" 7 2 nil "...") . "ob...") + (("foobarbaz" 9 3 nil "...") . "barbaz") + (("こhんeにlちlはo" 15 1 ? t) . " hんeにlちlはo") + (("こhんeにlちlはo" 14 1 ? t) . " hんeにlち...") + (("x" 3 nil nil "粵語") . "x") + (("中" 2 nil nil "粵語") . "中") + (("中" 1 nil ?x "粵語") . "x") ;; XEmacs error + (("中文" 3 nil ? "粵語") . "中 ") ;; XEmacs error + (("foobarbaz" 4 nil nil "粵語") . "粵語") + (("foobarbaz" 5 nil nil "粵語") . "f粵語") + (("foobarbaz" 6 nil nil "粵語") . "fo粵語") + (("foobarbaz" 8 3 nil "粵語") . "b粵語") + (("こhんeにlちlはo" 14 4 ?x "日本語") . "xeに日本語") + (("こhんeにlちlはo" 13 4 ?x "日本語") . "xex日本語") + ) + "Test data for `truncate-string-to-width'.") + +(defun mule-util-test-truncate-create (n) + "Create a test for element N of the `mule-util-test-truncate-data' constant." + (let ((testname (intern (format "mule-util-test-truncate-%.2d" n))) + (testdoc (format "Test element %d of `mule-util-test-truncate-data'." + n)) + (testdata (nth n mule-util-test-truncate-data))) + (eval + `(ert-deftest ,testname () + ,testdoc + (should (equal (apply 'truncate-string-to-width ',(car testdata)) + ,(cdr testdata))))))) + +(dotimes (i (length mule-util-test-truncate-data)) + (mule-util-test-truncate-create i)) + +;;; mule-util.el ends here diff --cc test/lisp/isearch-tests.el index d60c229c8f7,00000000000..48c342403c9 mode 100644,000000..100644 --- a/test/lisp/isearch-tests.el +++ b/test/lisp/isearch-tests.el @@@ -1,32 -1,0 +1,32 @@@ +;;; isearch-tests.el --- Tests for isearch.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) + +(ert-deftest isearch--test-update () + (with-temp-buffer + (setq isearch--current-buffer (current-buffer))) + (with-temp-buffer + (isearch-update) + (should (equal isearch--current-buffer (current-buffer))))) + +(provide 'isearch-tests) +;;; isearch-tests.el ends here diff --cc test/lisp/json-tests.el index bb043dc4e05,00000000000..78cebb45eed mode 100644,000000..100644 --- a/test/lisp/json-tests.el +++ b/test/lisp/json-tests.el @@@ -1,320 -1,0 +1,320 @@@ +;;; json-tests.el --- Test suite for json.el + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Dmitry Gutov + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) +(require 'json) + +(defmacro json-tests--with-temp-buffer (content &rest body) + "Create a temporary buffer with CONTENT and evaluate BODY there. +Point is moved to beginning of the buffer." + (declare (indent 1)) + `(with-temp-buffer + (insert ,content) + (goto-char (point-min)) + ,@body)) + +;;; Utilities + +(ert-deftest test-json-join () + (should (equal (json-join '() ", ") "")) + (should (equal (json-join '("a" "b" "c") ", ") "a, b, c"))) + +(ert-deftest test-json-alist-p () + (should (json-alist-p '())) + (should (json-alist-p '((a 1) (b 2) (c 3)))) + (should (json-alist-p '((:a 1) (:b 2) (:c 3)))) + (should (json-alist-p '(("a" 1) ("b" 2) ("c" 3)))) + (should-not (json-alist-p '(:a :b :c))) + (should-not (json-alist-p '(:a 1 :b 2 :c 3))) + (should-not (json-alist-p '((:a 1) (:b 2) 3)))) + +(ert-deftest test-json-plist-p () + (should (json-plist-p '())) + (should (json-plist-p '(:a 1 :b 2 :c 3))) + (should-not (json-plist-p '(a 1 b 2 c 3))) + (should-not (json-plist-p '("a" 1 "b" 2 "c" 3))) + (should-not (json-plist-p '(:a :b :c))) + (should-not (json-plist-p '((:a 1) (:b 2) (:c 3))))) + +(ert-deftest test-json-plist-reverse () + (should (equal (json--plist-reverse '()) '())) + (should (equal (json--plist-reverse '(:a 1)) '(:a 1))) + (should (equal (json--plist-reverse '(:a 1 :b 2 :c 3)) + '(:c 3 :b 2 :a 1)))) + +(ert-deftest test-json-plist-to-alist () + (should (equal (json--plist-to-alist '()) '())) + (should (equal (json--plist-to-alist '(:a 1)) '((:a . 1)))) + (should (equal (json--plist-to-alist '(:a 1 :b 2 :c 3)) + '((:a . 1) (:b . 2) (:c . 3))))) + +(ert-deftest test-json-advance () + (json-tests--with-temp-buffer "{ \"a\": 1 }" + (json-advance 0) + (should (= (point) (point-min))) + (json-advance 3) + (should (= (point) (+ (point-min) 3))))) + +(ert-deftest test-json-peek () + (json-tests--with-temp-buffer "" + (should (eq (json-peek) :json-eof))) + (json-tests--with-temp-buffer "{ \"a\": 1 }" + (should (equal (json-peek) ?{)))) + +(ert-deftest test-json-pop () + (json-tests--with-temp-buffer "" + (should-error (json-pop) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "{ \"a\": 1 }" + (should (equal (json-pop) ?{)) + (should (= (point) (+ (point-min) 1))))) + +(ert-deftest test-json-skip-whitespace () + (json-tests--with-temp-buffer "\t\r\n\f\b { \"a\": 1 }" + (json-skip-whitespace) + (should (equal (char-after (point)) ?{)))) + +;;; Paths + +(ert-deftest test-json-path-to-position-with-objects () + (let* ((json-string "{\"foo\": {\"bar\": {\"baz\": \"value\"}}}") + (matched-path (json-path-to-position 32 json-string))) + (should (equal (plist-get matched-path :path) '("foo" "bar" "baz"))) + (should (equal (plist-get matched-path :match-start) 25)) + (should (equal (plist-get matched-path :match-end) 32)))) + +(ert-deftest test-json-path-to-position-with-arrays () + (let* ((json-string "{\"foo\": [\"bar\", [\"baz\"]]}") + (matched-path (json-path-to-position 20 json-string))) + (should (equal (plist-get matched-path :path) '("foo" 1 0))) + (should (equal (plist-get matched-path :match-start) 18)) + (should (equal (plist-get matched-path :match-end) 23)))) + +(ert-deftest test-json-path-to-position-no-match () + (let* ((json-string "{\"foo\": {\"bar\": \"baz\"}}") + (matched-path (json-path-to-position 5 json-string))) + (should (null matched-path)))) + +;;; Keywords + +(ert-deftest test-json-read-keyword () + (json-tests--with-temp-buffer "true" + (should (json-read-keyword "true"))) + (json-tests--with-temp-buffer "true" + (should-error + (json-read-keyword "false") :type 'json-unknown-keyword)) + (json-tests--with-temp-buffer "foo" + (should-error + (json-read-keyword "foo") :type 'json-unknown-keyword))) + +(ert-deftest test-json-encode-keyword () + (should (equal (json-encode-keyword t) "true")) + (should (equal (json-encode-keyword json-false) "false")) + (should (equal (json-encode-keyword json-null) "null"))) + +;;; Numbers + +(ert-deftest test-json-read-number () + (json-tests--with-temp-buffer "3" + (should (= (json-read-number) 3))) + (json-tests--with-temp-buffer "-5" + (should (= (json-read-number) -5))) + (json-tests--with-temp-buffer "123.456" + (should (= (json-read-number) 123.456))) + (json-tests--with-temp-buffer "1e3" + (should (= (json-read-number) 1e3))) + (json-tests--with-temp-buffer "2e+3" + (should (= (json-read-number) 2e3))) + (json-tests--with-temp-buffer "3E3" + (should (= (json-read-number) 3e3))) + (json-tests--with-temp-buffer "1e-7" + (should (= (json-read-number) 1e-7))) + (json-tests--with-temp-buffer "abc" + (should-error (json-read-number) :type 'json-number-format))) + +(ert-deftest test-json-encode-number () + (should (equal (json-encode-number 3) "3")) + (should (equal (json-encode-number -5) "-5")) + (should (equal (json-encode-number 123.456) "123.456"))) + +;; Strings + +(ert-deftest test-json-read-escaped-char () + (json-tests--with-temp-buffer "\\\"" + (should (equal (json-read-escaped-char) ?\")))) + +(ert-deftest test-json-read-string () + (json-tests--with-temp-buffer "\"foo \\\"bar\\\"\"" + (should (equal (json-read-string) "foo \"bar\""))) + (json-tests--with-temp-buffer "\"abcαβγ\"" + (should (equal (json-read-string) "abcαβγ"))) + (json-tests--with-temp-buffer "\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"" + (should (equal (json-read-string) "\nasdфывfgh\t"))) + (json-tests--with-temp-buffer "foo" + (should-error (json-read-string) :type 'json-string-format))) + +(ert-deftest test-json-encode-string () + (should (equal (json-encode-string "foo") "\"foo\"")) + (should (equal (json-encode-string "a\n\fb") "\"a\\n\\fb\"")) + (should (equal (json-encode-string "\nasdфыв\u001f\u007ffgh\t") + "\"\\nasdфыв\\u001f\u007ffgh\\t\""))) + +(ert-deftest test-json-encode-key () + (should (equal (json-encode-key "foo") "\"foo\"")) + (should (equal (json-encode-key 'foo) "\"foo\"")) + (should (equal (json-encode-key :foo) "\"foo\"")) + (should-error (json-encode-key 5) :type 'json-key-format) + (should-error (json-encode-key ["foo"]) :type 'json-key-format) + (should-error (json-encode-key '("foo")) :type 'json-key-format)) + +;;; Objects + +(ert-deftest test-json-new-object () + (let ((json-object-type 'alist)) + (should (equal (json-new-object) '()))) + (let ((json-object-type 'plist)) + (should (equal (json-new-object) '()))) + (let* ((json-object-type 'hash-table) + (json-object (json-new-object))) + (should (hash-table-p json-object)) + (should (= (hash-table-count json-object) 0)))) + +(ert-deftest test-json-add-to-object () + (let* ((json-object-type 'alist) + (json-key-type nil) + (obj (json-new-object))) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (equal (assq 'a obj) '(a . 1))) + (should (equal (assq 'b obj) '(b . 2)))) + (let* ((json-object-type 'plist) + (json-key-type nil) + (obj (json-new-object))) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (plist-get obj :a) 1)) + (should (= (plist-get obj :b) 2))) + (let* ((json-object-type 'hash-table) + (json-key-type nil) + (obj (json-new-object))) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (gethash "a" obj) 1)) + (should (= (gethash "b" obj) 2)))) + +(ert-deftest test-json-read-object () + (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" + (let ((json-object-type 'alist)) + (should (equal (json-read-object) '((a . 1) (b . 2)))))) + (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" + (let ((json-object-type 'plist)) + (should (equal (json-read-object) '(:a 1 :b 2))))) + (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" + (let* ((json-object-type 'hash-table) + (hash-table (json-read-object))) + (should (= (gethash "a" hash-table) 1)) + (should (= (gethash "b" hash-table) 2)))) + (json-tests--with-temp-buffer "{ \"a\": 1 \"b\": 2 }" + (should-error (json-read-object) :type 'json-object-format))) + +(ert-deftest test-json-encode-hash-table () + (let ((hash-table (make-hash-table)) + (json-encoding-object-sort-predicate 'string<) + (json-encoding-pretty-print nil)) + (puthash :a 1 hash-table) + (puthash :b 2 hash-table) + (puthash :c 3 hash-table) + (should (equal (json-encode hash-table) + "{\"a\":1,\"b\":2,\"c\":3}")))) + +(ert-deftest json-encode-simple-alist () + (let ((json-encoding-pretty-print nil)) + (should (equal (json-encode '((a . 1) (b . 2))) + "{\"a\":1,\"b\":2}")))) + +(ert-deftest test-json-encode-plist () + (let ((plist '(:a 1 :b 2)) + (json-encoding-pretty-print nil)) + (should (equal (json-encode plist) "{\"a\":1,\"b\":2}")))) + +(ert-deftest test-json-encode-plist-with-sort-predicate () + (let ((plist '(:c 3 :a 1 :b 2)) + (json-encoding-object-sort-predicate 'string<) + (json-encoding-pretty-print nil)) + (should (equal (json-encode plist) "{\"a\":1,\"b\":2,\"c\":3}")))) + +(ert-deftest test-json-encode-alist-with-sort-predicate () + (let ((alist '((:c . 3) (:a . 1) (:b . 2))) + (json-encoding-object-sort-predicate 'string<) + (json-encoding-pretty-print nil)) + (should (equal (json-encode alist) "{\"a\":1,\"b\":2,\"c\":3}")))) + +(ert-deftest test-json-encode-list () + (let ((json-encoding-pretty-print nil)) + (should (equal (json-encode-list '(:a 1 :b 2)) + "{\"a\":1,\"b\":2}")) + (should (equal (json-encode-list '((:a . 1) (:b . 2))) + "{\"a\":1,\"b\":2}")) + (should (equal (json-encode-list '(1 2 3 4)) "[1,2,3,4]")))) + +;;; Arrays + +(ert-deftest test-json-read-array () + (let ((json-array-type 'vector)) + (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" + (should (equal (json-read-array) [1 2 "a" "b"])))) + (let ((json-array-type 'list)) + (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" + (should (equal (json-read-array) '(1 2 "a" "b"))))) + (json-tests--with-temp-buffer "[1 2]" + (should-error (json-read-array) :type 'json-error))) + +(ert-deftest test-json-encode-array () + (let ((json-encoding-pretty-print nil)) + (should (equal (json-encode-array [1 2 "a" "b"]) + "[1,2,\"a\",\"b\"]")))) + +;;; Reader + +(ert-deftest test-json-read () + (json-tests--with-temp-buffer "{ \"a\": 1 }" + ;; We don't care exactly what the return value is (that is tested + ;; in `test-json-read-object'), but it should parse without error. + (should (json-read))) + (json-tests--with-temp-buffer "" + (should-error (json-read) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "xxx" + (should-error (json-read) :type 'json-readtable-error))) + +(ert-deftest test-json-read-from-string () + (let ((json-string "{ \"a\": 1 }")) + (json-tests--with-temp-buffer json-string + (should (equal (json-read-from-string json-string) + (json-read)))))) + +;;; JSON encoder + +(ert-deftest test-json-encode () + (should (equal (json-encode "foo") "\"foo\"")) + (with-temp-buffer + (should-error (json-encode (current-buffer)) :type 'json-error))) + +(provide 'json-tests) +;;; json-tests.el ends here diff --cc test/lisp/legacy/bytecomp-tests.el index c65009cb1b0,00000000000..48211f03ba4 mode 100644,000000..100644 --- a/test/lisp/legacy/bytecomp-tests.el +++ b/test/lisp/legacy/bytecomp-tests.el @@@ -1,429 -1,0 +1,429 @@@ +;;; bytecomp-testsuite.el + - ;; Copyright (C) 2008-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2008-2016 Free Software Foundation, Inc. + +;; Author: Shigeru Fukaya +;; Created: November 2008 +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +(require 'ert) + +;;; Code: +(defconst byte-opt-testsuite-arith-data + '( + ;; some functional tests + (let ((a most-positive-fixnum) (b 1) (c 1.0)) (+ a b c)) + (let ((a most-positive-fixnum) (b -2) (c 1.0)) (- a b c)) + (let ((a most-positive-fixnum) (b 2) (c 1.0)) (* a b c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c)) + (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (+ a -1 b)) + (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (- a 1 (- b))) + ;; This fails. Should it be a bug? + ;; (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) + (let ((a 1.0)) (* a 0)) + (let ((a 1.0)) (* a 2.0 0)) + (let ((a 1.0)) (/ 0 a)) + (let ((a 1.0)) (/ 3 a 2)) + (let ((a most-positive-fixnum) (b 2.0)) (* a 2 b)) + (let ((a 3) (b 2)) (/ a b 1.0)) + (/ 3 -1) + (+ 4 3 2 1) + (+ 4 3 2.0 1) + (- 4 3 2 1) ; not new, for reference + (- 4 3 2.0 1) ; not new, for reference + (* 4 3 2 1) + (* 4 3 2.0 1) + (/ 4 3 2 1) + (/ 4 3 2.0 1) + (let ((a 3) (b 2)) (+ a b 1)) + (let ((a 3) (b 2)) (+ a b -1)) + (let ((a 3) (b 2)) (- a b 1)) + (let ((a 3) (b 2)) (- a b -1)) + (let ((a 3) (b 2)) (+ a b a 1)) + (let ((a 3) (b 2)) (+ a b a -1)) + (let ((a 3) (b 2)) (- a b a 1)) + (let ((a 3) (b 2)) (- a b a -1)) + (let ((a 3) (b 2)) (* a b -1)) + (let ((a 3) (b 2)) (* a -1)) + (let ((a 3) (b 2)) (/ a b 1)) + (let ((a 3) (b 2)) (/ (+ a b) 1)) + + ;; coverage test + (let ((a 3) (b 2) (c 1.0)) (+)) + (let ((a 3) (b 2) (c 1.0)) (+ 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 2 0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (+ a)) + (let ((a 3) (b 2) (c 1.0)) (+ a 0)) + (let ((a 3) (b 2) (c 1.0)) (+ a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (+ c 0)) + (let ((a 3) (b 2) (c 1.0)) (+ c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 c)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (+ 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (+ 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (+ a 1)) + (let ((a 3) (b 2) (c 1.0)) (+ a -1)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 a)) + (let ((a 3) (b 2) (c 1.0)) (+ -1 a)) + (let ((a 3) (b 2) (c 1.0)) (+ c 1)) + (let ((a 3) (b 2) (c 1.0)) (+ c -1)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 c)) + (let ((a 3) (b 2) (c 1.0)) (+ -1 c)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 0)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 1)) + (let ((a 3) (b 2) (c 1.0)) (+ a b -1)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (+ a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (+ a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (+ a b c -1)) + + (let ((a 3) (b 2) (c 1.0)) (-)) + (let ((a 3) (b 2) (c 1.0)) (- 2)) + (let ((a 3) (b 2) (c 1.0)) (- 2 0)) + (let ((a 3) (b 2) (c 1.0)) (- 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 2.0)) + (let ((a 3) (b 2) (c 1.0)) (- 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (- 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 2)) + (let ((a 3) (b 2) (c 1.0)) (- 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (- a)) + (let ((a 3) (b 2) (c 1.0)) (- a 0)) + (let ((a 3) (b 2) (c 1.0)) (- a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (- c 0)) + (let ((a 3) (b 2) (c 1.0)) (- c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 c)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (- a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (- 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (- 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (- 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (- a 1)) + (let ((a 3) (b 2) (c 1.0)) (- a -1)) + (let ((a 3) (b 2) (c 1.0)) (- 1 a)) + (let ((a 3) (b 2) (c 1.0)) (- -1 a)) + (let ((a 3) (b 2) (c 1.0)) (- c 1)) + (let ((a 3) (b 2) (c 1.0)) (- c -1)) + (let ((a 3) (b 2) (c 1.0)) (- 1 c)) + (let ((a 3) (b 2) (c 1.0)) (- -1 c)) + (let ((a 3) (b 2) (c 1.0)) (- a b 0)) + (let ((a 3) (b 2) (c 1.0)) (- a b 1)) + (let ((a 3) (b 2) (c 1.0)) (- a b -1)) + (let ((a 3) (b 2) (c 1.0)) (- a b 2)) + (let ((a 3) (b 2) (c 1.0)) (- 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (- a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (- a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (- a b c -1)) + + (let ((a 3) (b 2) (c 1.0)) (*)) + (let ((a 3) (b 2) (c 1.0)) (* 2)) + (let ((a 3) (b 2) (c 1.0)) (* 2 0)) + (let ((a 3) (b 2) (c 1.0)) (* 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 2.0)) + (let ((a 3) (b 2) (c 1.0)) (* 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (* 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 2)) + (let ((a 3) (b 2) (c 1.0)) (* 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (* a)) + (let ((a 3) (b 2) (c 1.0)) (* a 0)) + (let ((a 3) (b 2) (c 1.0)) (* a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (* c 0)) + (let ((a 3) (b 2) (c 1.0)) (* c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 c)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (* a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (* 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (* 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (* 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (* a 1)) + (let ((a 3) (b 2) (c 1.0)) (* a -1)) + (let ((a 3) (b 2) (c 1.0)) (* 1 a)) + (let ((a 3) (b 2) (c 1.0)) (* -1 a)) + (let ((a 3) (b 2) (c 1.0)) (* c 1)) + (let ((a 3) (b 2) (c 1.0)) (* c -1)) + (let ((a 3) (b 2) (c 1.0)) (* 1 c)) + (let ((a 3) (b 2) (c 1.0)) (* -1 c)) + (let ((a 3) (b 2) (c 1.0)) (* a b 0)) + (let ((a 3) (b 2) (c 1.0)) (* a b 1)) + (let ((a 3) (b 2) (c 1.0)) (* a b -1)) + (let ((a 3) (b 2) (c 1.0)) (* a b 2)) + (let ((a 3) (b 2) (c 1.0)) (* 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (* a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (* a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (* a b c -1)) + + (let ((a 3) (b 2) (c 1.0)) (/)) + (let ((a 3) (b 2) (c 1.0)) (/ 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 2 0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (/ a)) + (let ((a 3) (b 2) (c 1.0)) (/ a 0)) + (let ((a 3) (b 2) (c 1.0)) (/ a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (/ c 0)) + (let ((a 3) (b 2) (c 1.0)) (/ c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 c)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (/ 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (/ 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (/ a 1)) + (let ((a 3) (b 2) (c 1.0)) (/ a -1)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 a)) + (let ((a 3) (b 2) (c 1.0)) (/ -1 a)) + (let ((a 3) (b 2) (c 1.0)) (/ c 1)) + (let ((a 3) (b 2) (c 1.0)) (/ c -1)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 c)) + (let ((a 3) (b 2) (c 1.0)) (/ -1 c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 0)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 1)) + (let ((a 3) (b 2) (c 1.0)) (/ a b -1)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c -1))) + "List of expression for test. +Each element will be executed by interpreter and with +bytecompiled code, and their results compared.") + +(defun bytecomp-check-1 (pat) + "Return non-nil if PAT is the same whether directly evalled or compiled." + (let ((warning-minimum-log-level :emergency) + (byte-compile-warnings nil) + (v0 (condition-case nil + (eval pat) + (error nil))) + (v1 (condition-case nil + (funcall (byte-compile (list 'lambda nil pat))) + (error nil)))) + (equal v0 v1))) + +(put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1) + +(defun bytecomp-explain-1 (pat) + (let ((v0 (condition-case nil + (eval pat) + (error nil))) + (v1 (condition-case nil + (funcall (byte-compile (list 'lambda nil pat))) + (error nil)))) + (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." + pat v0 v1))) + +(ert-deftest bytecomp-tests () + "Test the Emacs byte compiler." + (dolist (pat byte-opt-testsuite-arith-data) + (should (bytecomp-check-1 pat)))) + +(defun test-byte-opt-arithmetic (&optional arg) + "Unit test for byte-opt arithmetic operations. +Subtests signal errors if something goes wrong." + (interactive "P") + (switch-to-buffer (generate-new-buffer "*Font Pase Test*")) + (let ((warning-minimum-log-level :emergency) + (byte-compile-warnings nil) + (pass-face '((t :foreground "green"))) + (fail-face '((t :foreground "red"))) + (print-escape-nonascii t) + (print-escape-newlines t) + (print-quoted t) + v0 v1) + (dolist (pat byte-opt-testsuite-arith-data) + (condition-case nil + (setq v0 (eval pat)) + (error (setq v0 nil))) + (condition-case nil + (setq v1 (funcall (byte-compile (list 'lambda nil pat)))) + (error (setq v1 nil))) + (insert (format "%s" pat)) + (indent-to-column 65) + (if (equal v0 v1) + (insert (propertize "OK" 'face pass-face)) + (insert (propertize "FAIL\n" 'face fail-face)) + (indent-to-column 55) + (insert (propertize (format "[%s] vs [%s]" v0 v1) + 'face fail-face))) + (insert "\n")))) + +(defun test-byte-comp-compile-and-load (compile &rest forms) + (let ((elfile nil) + (elcfile nil)) + (unwind-protect + (progn + (setf elfile (make-temp-file "test-bytecomp" nil ".el")) + (when compile + (setf elcfile (make-temp-file "test-bytecomp" nil ".elc"))) + (with-temp-buffer + (dolist (form forms) + (print form (current-buffer))) + (write-region (point-min) (point-max) elfile nil 'silent)) + (if compile + (let ((byte-compile-dest-file-function + (lambda (e) elcfile))) + (byte-compile-file elfile t)) + (load elfile nil 'nomessage))) + (when elfile (delete-file elfile)) + (when elcfile (delete-file elcfile))))) +(put 'test-byte-comp-compile-and-load 'lisp-indent-function 1) + +(ert-deftest test-byte-comp-macro-expansion () + (test-byte-comp-compile-and-load t + '(progn (defmacro abc (arg) 1) (defun def () (abc 2)))) + (should (equal (funcall 'def) 1))) + +(ert-deftest test-byte-comp-macro-expansion-eval-and-compile () + (test-byte-comp-compile-and-load t + '(eval-and-compile (defmacro abc (arg) -1) (defun def () (abc 2)))) + (should (equal (funcall 'def) -1))) + +(ert-deftest test-byte-comp-macro-expansion-eval-when-compile () + ;; Make sure we interpret eval-when-compile forms properly. CLISP + ;; and SBCL interpreter eval-when-compile (well, the CL equivalent) + ;; in the same way. + (test-byte-comp-compile-and-load t + '(eval-when-compile + (defmacro abc (arg) -10) + (defun abc-1 () (abc 2))) + '(defmacro abc-2 () (abc-1)) + '(defun def () (abc-2))) + (should (equal (funcall 'def) -10))) + +(ert-deftest test-byte-comp-macro-expand-lexical-override () + ;; Intuitively, one might expect the defmacro to override the + ;; macrolet since macrolet's is explicitly called out as being + ;; equivalent to toplevel, but CLISP and SBCL both evaluate the form + ;; this way, so we should too. + (test-byte-comp-compile-and-load t + '(require 'cl-lib) + '(cl-macrolet ((m () 4)) + (defmacro m () 5) + (defun def () (m)))) + (should (equal (funcall 'def) 4))) + +(ert-deftest bytecomp-tests--warnings () + (with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) (erase-buffer))) + (test-byte-comp-compile-and-load t + '(progn + (defun my-test0 () + (my--test11 3) + (my--test12 3) + (my--test2 5)) + (defmacro my--test11 (arg) (+ arg 1)) + (eval-and-compile + (defmacro my--test12 (arg) (+ arg 1)) + (defun my--test2 (arg) (+ arg 1))))) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (goto-char (point-min)) + ;; Should warn that mt--test1[12] are first used as functions. + ;; The second alternative is for when the file name is so long + ;; that pretty-printing starts the message on the next line. + (should (or (re-search-forward "my--test11:\n.*macro" nil t) + (re-search-forward "my--test11:\n.*:\n.*macro" nil t))) + (should (or (re-search-forward "my--test12:\n.*macro" nil t) + (re-search-forward "my--test12:\n.*:\n.*macro" nil t))) + (goto-char (point-min)) + ;; Should not warn that mt--test2 is not known to be defined. + (should-not (re-search-forward "my--test2" nil t)))) + +(ert-deftest test-eager-load-macro-expansion () + (test-byte-comp-compile-and-load nil + '(progn (defmacro abc (arg) 1) (defun def () (abc 2)))) + (should (equal (funcall 'def) 1))) + +(ert-deftest test-eager-load-macro-expansion-eval-and-compile () + (test-byte-comp-compile-and-load nil + '(eval-and-compile (defmacro abc (arg) -1) (defun def () (abc 2)))) + (should (equal (funcall 'def) -1))) + +(ert-deftest test-eager-load-macro-expansion-eval-when-compile () + ;; Make sure we interpret eval-when-compile forms properly. CLISP + ;; and SBCL interpreter eval-when-compile (well, the CL equivalent) + ;; in the same way. + (test-byte-comp-compile-and-load nil + '(eval-when-compile + (defmacro abc (arg) -10) + (defun abc-1 () (abc 2))) + '(defmacro abc-2 () (abc-1)) + '(defun def () (abc-2))) + (should (equal (funcall 'def) -10))) + +(ert-deftest test-eager-load-macro-expand-lexical-override () + ;; Intuitively, one might expect the defmacro to override the + ;; macrolet since macrolet's is explicitly called out as being + ;; equivalent to toplevel, but CLISP and SBCL both evaluate the form + ;; this way, so we should too. + (test-byte-comp-compile-and-load nil + '(require 'cl-lib) + '(cl-macrolet ((m () 4)) + (defmacro m () 5) + (defun def () (m)))) + (should (equal (funcall 'def) 4))) + + +;; Local Variables: +;; no-byte-compile: t +;; End: + +(provide 'byte-opt-testsuite) + diff --cc test/lisp/legacy/coding-tests.el index cda382fff97,00000000000..cba8c7bc25f mode 100644,000000..100644 --- a/test/lisp/legacy/coding-tests.el +++ b/test/lisp/legacy/coding-tests.el @@@ -1,50 -1,0 +1,50 @@@ +;;; coding-tests.el --- tests for text encoding and decoding + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Eli Zaretskii + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +;; Directory to hold test data files. +(defvar coding-tests-workdir + (expand-file-name "coding-tests" temporary-file-directory)) + +;; Remove all generated test files. +(defun coding-tests-remove-files () + (delete-directory coding-tests-workdir t)) + +(ert-deftest ert-test-coding-bogus-coding-systems () + (unwind-protect + (let (test-file) + (or (file-directory-p coding-tests-workdir) + (mkdir coding-tests-workdir t)) + (setq test-file (expand-file-name "nonexistent" coding-tests-workdir)) + (if (file-exists-p test-file) + (delete-file test-file)) + (should-error + (let ((coding-system-for-read 'bogus)) + (insert-file-contents test-file))) + ;; See bug #21602. + (setq test-file (expand-file-name "writing" coding-tests-workdir)) + (should-error + (let ((coding-system-for-write (intern "\"us-ascii\""))) + (write-region "some text" nil test-file)))) + (coding-tests-remove-files))) diff --cc test/lisp/legacy/core-elisp-tests.el index c31ecef4a32,00000000000..76985331566 mode 100644,000000..100644 --- a/test/lisp/legacy/core-elisp-tests.el +++ b/test/lisp/legacy/core-elisp-tests.el @@@ -1,52 -1,0 +1,52 @@@ +;;; core-elisp-tests.el --- Testing some core Elisp rules + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(ert-deftest core-elisp-tests-1-defvar-in-let () + "Test some core Elisp rules." + (with-temp-buffer + ;; Check that when defvar is run within a let-binding, the toplevel default + ;; is properly initialized. + (should (equal (list (let ((c-e-x 1)) (defvar c-e-x 2) c-e-x) c-e-x) + '(1 2))) + (should (equal (list (let ((c-e-x 1)) + (defcustom c-e-x 2 "doc" :group 'blah) c-e-x) + c-e-x) + '(1 2))))) + +(ert-deftest core-elisp-tests-2-window-configurations () + "Test properties of window-configurations." + (let ((wc (current-window-configuration))) + (with-current-buffer (window-buffer (frame-selected-window)) + (push-mark) + (activate-mark)) + (set-window-configuration wc) + (should (or (not mark-active) (mark))))) + +(ert-deftest core-elisp-tests-3-backquote () + (should (eq 3 (eval ``,,'(+ 1 2))))) + +(provide 'core-elisp-tests) +;;; core-elisp-tests.el ends here diff --cc test/lisp/legacy/decoder-tests.el index 80ff5205ac5,00000000000..5699fec7d17 mode 100644,000000..100644 --- a/test/lisp/legacy/decoder-tests.el +++ b/test/lisp/legacy/decoder-tests.el @@@ -1,349 -1,0 +1,349 @@@ +;;; decoder-tests.el --- test for text decoder + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Kenichi Handa + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +;; Directory to hold test data files. +(defvar decoder-tests-workdir + (expand-file-name "decoder-tests" temporary-file-directory)) + +;; Remove all generated test files. +(defun decoder-tests-remove-files () + (delete-directory decoder-tests-workdir t)) + +;; Return the contents (specified by CONTENT-TYPE; ascii, latin, or +;; binary) of a test file. +(defun decoder-tests-file-contents (content-type) + (let* ((ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZ\n") + (latin (concat ascii "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏ\n")) + (binary (string-to-multibyte + (concat (string-as-unibyte latin) + (unibyte-string #xC0 #xC1 ?\n))))) + (cond ((eq content-type 'ascii) ascii) + ((eq content-type 'latin) latin) + ((eq content-type 'binary) binary) + (t + (error "Invalid file content type: %s" content-type))))) + +;; Generate FILE with CONTENTS encoded by CODING-SYSTEM. +;; whose encoding specified by CODING-SYSTEM. +(defun decoder-tests-gen-file (file contents coding-system) + (or (file-directory-p decoder-tests-workdir) + (mkdir decoder-tests-workdir t)) + (setq file (expand-file-name file decoder-tests-workdir)) + (with-temp-file file + (set-buffer-file-coding-system coding-system) + (insert contents)) + file) + +;;; The following three functions are filters for contents of a test +;;; file. + +;; Convert all LFs to CR LF sequences in the string STR. +(defun decoder-tests-lf-to-crlf (str) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (delete-char -1) + (insert "\r\n")) + (buffer-string))) + +;; Convert all LFs to CRs in the string STR. +(defun decoder-tests-lf-to-cr (str) + (with-temp-buffer + (insert str) + (subst-char-in-region (point-min) (point-max) ?\n ?\r) + (buffer-string))) + +;; Convert all LFs to LF LF sequences in the string STR. +(defun decoder-tests-lf-to-lflf (str) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (insert "\n")) + (buffer-string))) + +;; Prepend the UTF-8 BOM to STR. +(defun decoder-tests-add-bom (str) + (concat "\xfeff" str)) + +;; Return the name of test file whose contents specified by +;; CONTENT-TYPE and whose encoding specified by CODING-SYSTEM. +(defun decoder-tests-filename (content-type coding-system &optional ext) + (if ext + (expand-file-name (format "%s-%s.%s" content-type coding-system ext) + decoder-tests-workdir) + (expand-file-name (format "%s-%s" content-type coding-system) + decoder-tests-workdir))) + + +;;; Check ASCII optimizing decoder + +;; Generate a test file whose contents specified by CONTENT-TYPE and +;; whose encoding specified by CODING-SYSTEM. +(defun decoder-tests-ao-gen-file (content-type coding-system) + (let ((file (decoder-tests-filename content-type coding-system))) + (decoder-tests-gen-file file + (decoder-tests-file-contents content-type) + coding-system))) + +;; Test the decoding of a file whose contents and encoding are +;; specified by CONTENT-TYPE and WRITE-CODING. The test passes if the +;; file is read by READ-CODING and detected as DETECTED-CODING and the +;; contents is correctly decoded. +;; Optional 5th arg TRANSLATOR is a function to translate the original +;; file contents to match with the expected result of decoding. For +;; instance, when a file of dos eol-type is read by unix eol-type, +;; `decode-test-lf-to-crlf' must be specified. + +(defun decoder-tests (content-type write-coding read-coding detected-coding + &optional translator) + (prefer-coding-system 'utf-8-auto) + (let ((filename (decoder-tests-filename content-type write-coding))) + (with-temp-buffer + (let ((coding-system-for-read read-coding) + (contents (decoder-tests-file-contents content-type)) + (disable-ascii-optimization nil)) + (if translator + (setq contents (funcall translator contents))) + (insert-file-contents filename) + (if (and (coding-system-equal buffer-file-coding-system detected-coding) + (string= (buffer-string) contents)) + nil + (list buffer-file-coding-system + (string-to-list (buffer-string)) + (string-to-list contents))))))) + +(ert-deftest ert-test-decoder-ascii () + (unwind-protect + (progn + (dolist (eol-type '(unix dos mac)) + (decoder-tests-ao-gen-file 'ascii eol-type)) + (should-not (decoder-tests 'ascii 'unix 'undecided 'unix)) + (should-not (decoder-tests 'ascii 'dos 'undecided 'dos)) + (should-not (decoder-tests 'ascii 'dos 'dos 'dos)) + (should-not (decoder-tests 'ascii 'mac 'undecided 'mac)) + (should-not (decoder-tests 'ascii 'mac 'mac 'mac)) + (should-not (decoder-tests 'ascii 'dos 'utf-8 'utf-8-dos)) + (should-not (decoder-tests 'ascii 'dos 'unix 'unix + 'decoder-tests-lf-to-crlf)) + (should-not (decoder-tests 'ascii 'mac 'dos 'dos + 'decoder-tests-lf-to-cr)) + (should-not (decoder-tests 'ascii 'dos 'mac 'mac + 'decoder-tests-lf-to-lflf))) + (decoder-tests-remove-files))) + +(ert-deftest ert-test-decoder-latin () + (unwind-protect + (progn + (dolist (coding '("utf-8" "utf-8-with-signature")) + (dolist (eol-type '("unix" "dos" "mac")) + (decoder-tests-ao-gen-file 'latin + (intern (concat coding "-" eol-type))))) + (should-not (decoder-tests 'latin 'utf-8-unix 'undecided 'utf-8-unix)) + (should-not (decoder-tests 'latin 'utf-8-unix 'utf-8-unix 'utf-8-unix)) + (should-not (decoder-tests 'latin 'utf-8-dos 'undecided 'utf-8-dos)) + (should-not (decoder-tests 'latin 'utf-8-dos 'utf-8-dos 'utf-8-dos)) + (should-not (decoder-tests 'latin 'utf-8-mac 'undecided 'utf-8-mac)) + (should-not (decoder-tests 'latin 'utf-8-mac 'utf-8-mac 'utf-8-mac)) + (should-not (decoder-tests 'latin 'utf-8-dos 'unix 'utf-8-unix + 'decoder-tests-lf-to-crlf)) + (should-not (decoder-tests 'latin 'utf-8-mac 'dos 'utf-8-dos + 'decoder-tests-lf-to-cr)) + (should-not (decoder-tests 'latin 'utf-8-dos 'mac 'utf-8-mac + 'decoder-tests-lf-to-lflf)) + (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'undecided + 'utf-8-with-signature-unix)) + (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'utf-8-auto + 'utf-8-with-signature-unix)) + (should-not (decoder-tests 'latin 'utf-8-with-signature-dos 'undecided + 'utf-8-with-signature-dos)) + (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'utf-8 + 'utf-8-unix 'decoder-tests-add-bom)) + (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'utf-8 + 'utf-8-unix 'decoder-tests-add-bom))) + (decoder-tests-remove-files))) + +(ert-deftest ert-test-decoder-binary () + (unwind-protect + (progn + (dolist (eol-type '("unix" "dos" "mac")) + (decoder-tests-ao-gen-file 'binary + (intern (concat "raw-text" "-" eol-type)))) + (should-not (decoder-tests 'binary 'raw-text-unix 'undecided + 'raw-text-unix)) + (should-not (decoder-tests 'binary 'raw-text-dos 'undecided + 'raw-text-dos)) + (should-not (decoder-tests 'binary 'raw-text-mac 'undecided + 'raw-text-mac)) + (should-not (decoder-tests 'binary 'raw-text-dos 'unix + 'raw-text-unix 'decoder-tests-lf-to-crlf)) + (should-not (decoder-tests 'binary 'raw-text-mac 'dos + 'raw-text-dos 'decoder-tests-lf-to-cr)) + (should-not (decoder-tests 'binary 'raw-text-dos 'mac + 'raw-text-mac 'decoder-tests-lf-to-lflf))) + (decoder-tests-remove-files))) + + +;;; Check the coding system `prefer-utf-8'. + +;; Read FILE. Check if the encoding was detected as DETECT. If +;; PREFER is non-nil, prefer that coding system before reading. + +(defun decoder-tests-prefer-utf-8-read (file detect prefer) + (with-temp-buffer + (with-coding-priority (if prefer (list prefer)) + (insert-file-contents file)) + (if (eq buffer-file-coding-system detect) + nil + (format "Invalid detection: %s" buffer-file-coding-system)))) + +;; Read FILE, modify it, and write it. Check if the coding system +;; used for writing was CODING. If CODING-TAG is non-nil, insert +;; coding tag with it before writing. If STR is non-nil, insert it +;; before writing. + +(defun decoder-tests-prefer-utf-8-write (file coding-tag coding + &optional str) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (if coding-tag + (insert (format ";; -*- coding: %s; -*-\n" coding-tag)) + (insert ";;\n")) + (if str + (insert str)) + (write-file (decoder-tests-filename 'test 'test "el")) + (if (coding-system-equal buffer-file-coding-system coding) + nil + (format "Incorrect encoding: %s" last-coding-system-used)))) + +(ert-deftest ert-test-decoder-prefer-utf-8 () + (unwind-protect + (let ((ascii (decoder-tests-gen-file "ascii.el" + (decoder-tests-file-contents 'ascii) + 'unix)) + (latin (decoder-tests-gen-file "utf-8.el" + (decoder-tests-file-contents 'latin) + 'utf-8-unix))) + (should-not (decoder-tests-prefer-utf-8-read + ascii 'prefer-utf-8-unix nil)) + (should-not (decoder-tests-prefer-utf-8-read + latin 'utf-8-unix nil)) + (should-not (decoder-tests-prefer-utf-8-read + latin 'utf-8-unix 'iso-8859-1)) + (should-not (decoder-tests-prefer-utf-8-read + latin 'utf-8-unix 'sjis)) + (should-not (decoder-tests-prefer-utf-8-write + ascii nil 'prefer-utf-8-unix)) + (should-not (decoder-tests-prefer-utf-8-write + ascii 'iso-8859-1 'iso-8859-1-unix)) + (should-not (decoder-tests-prefer-utf-8-write + ascii nil 'utf-8-unix "À"))) + (decoder-tests-remove-files))) + + +;;; The following is for benchmark testing of the new optimized +;;; decoder, not for regression testing. + +(defun generate-ascii-file () + (dotimes (i 100000) + (insert-char ?a 80) + (insert "\n"))) + +(defun generate-rarely-nonascii-file () + (dotimes (i 100000) + (if (/= i 50000) + (insert-char ?a 80) + (insert ?À) + (insert-char ?a 79)) + (insert "\n"))) + +(defun generate-mostly-nonascii-file () + (dotimes (i 30000) + (insert-char ?a 80) + (insert "\n")) + (dotimes (i 20000) + (insert-char ?À 80) + (insert "\n")) + (dotimes (i 10000) + (insert-char ?あ 80) + (insert "\n"))) + + +(defvar test-file-list + '((generate-ascii-file + ("~/ascii-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" unix) + ("~/ascii-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" unix) + ("~/ascii-tag-none.unix" "" unix) + ("~/ascii-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" dos) + ("~/ascii-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" dos) + ("~/ascii-tag-none.dos" "" dos)) + (generate-rarely-nonascii-file + ("~/utf-8-r-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" utf-8-unix) + ("~/utf-8-r-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" utf-8-unix) + ("~/utf-8-r-tag-none.unix" "" utf-8-unix) + ("~/utf-8-r-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" utf-8-dos) + ("~/utf-8-r-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" utf-8-dos) + ("~/utf-8-r-tag-none.dos" "" utf-8-dos)) + (generate-mostly-nonascii-file + ("~/utf-8-m-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" utf-8-unix) + ("~/utf-8-m-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" utf-8-unix) + ("~/utf-8-m-tag-none.unix" "" utf-8-unix) + ("~/utf-8-m-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" utf-8-dos) + ("~/utf-8-m-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" utf-8-dos) + ("~/utf-8-m-tag-none.dos" "" utf-8-dos)))) + +(defun generate-benchmark-test-file () + (interactive) + (with-temp-buffer + (message "Generating data...") + (dolist (files test-file-list) + (delete-region (point-min) (point-max)) + (funcall (car files)) + (dolist (file (cdr files)) + (message "Writing %s..." (car file)) + (goto-char (point-min)) + (insert (nth 1 file) "\n") + (let ((coding-system-for-write (nth 2 file))) + (write-region (point-min) (point-max) (car file))) + (delete-region (point-min) (point)))))) + +(defun benchmark-decoder () + (let ((gc-cons-threshold 4000000)) + (insert "Without optimization:\n") + (dolist (files test-file-list) + (dolist (file (cdr files)) + (let* ((disable-ascii-optimization t) + (result (benchmark-run 10 + (with-temp-buffer (insert-file-contents (car file)))))) + (insert (format "%s: %s\n" (car file) result))))) + (insert "With optimization:\n") + (dolist (files test-file-list) + (dolist (file (cdr files)) + (let* ((disable-ascii-optimization nil) + (result (benchmark-run 10 + (with-temp-buffer (insert-file-contents (car file)))))) + (insert (format "%s: %s\n" (car file) result))))))) diff --cc test/lisp/legacy/files-tests.el index 0522e0c5c79,00000000000..3c6f61b792c mode 100644,000000..100644 --- a/test/lisp/legacy/files-tests.el +++ b/test/lisp/legacy/files-tests.el @@@ -1,172 -1,0 +1,172 @@@ +;;; files.el --- tests for file handling. + - ;; Copyright (C) 2012-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +;; Set to t if the local variable was set, `query' if the query was +;; triggered. +(defvar files-test-result nil) + +(defvar files-test-safe-result nil) +(put 'files-test-safe-result 'safe-local-variable 'booleanp) + +(defun files-test-fun1 () + (setq files-test-result t)) + +;; Test combinations: +;; `enable-local-variables' t, nil, :safe, :all, or something else. +;; `enable-local-eval' t, nil, or something else. + +(defvar files-test-local-variable-data + ;; Unsafe eval form + '((("eval: (files-test-fun1)") + (t t (eq files-test-result t)) + (t nil (eq files-test-result nil)) + (t maybe (eq files-test-result 'query)) + (nil t (eq files-test-result nil)) + (nil nil (eq files-test-result nil)) + (nil maybe (eq files-test-result nil)) + (:safe t (eq files-test-result nil)) + (:safe nil (eq files-test-result nil)) + (:safe maybe (eq files-test-result nil)) + (:all t (eq files-test-result t)) + (:all nil (eq files-test-result nil)) + (:all maybe (eq files-test-result t)) ; This combination is ambiguous. + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result nil)) + (maybe maybe (eq files-test-result 'query))) + ;; Unsafe local variable value + (("files-test-result: t") + (t t (eq files-test-result 'query)) + (t nil (eq files-test-result 'query)) + (t maybe (eq files-test-result 'query)) + (nil t (eq files-test-result nil)) + (nil nil (eq files-test-result nil)) + (nil maybe (eq files-test-result nil)) + (:safe t (eq files-test-result nil)) + (:safe nil (eq files-test-result nil)) + (:safe maybe (eq files-test-result nil)) + (:all t (eq files-test-result t)) + (:all nil (eq files-test-result t)) + (:all maybe (eq files-test-result t)) + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result 'query)) + (maybe maybe (eq files-test-result 'query))) + ;; Safe local variable + (("files-test-safe-result: t") + (t t (eq files-test-safe-result t)) + (t nil (eq files-test-safe-result t)) + (t maybe (eq files-test-safe-result t)) + (nil t (eq files-test-safe-result nil)) + (nil nil (eq files-test-safe-result nil)) + (nil maybe (eq files-test-safe-result nil)) + (:safe t (eq files-test-safe-result t)) + (:safe nil (eq files-test-safe-result t)) + (:safe maybe (eq files-test-safe-result t)) + (:all t (eq files-test-safe-result t)) + (:all nil (eq files-test-safe-result t)) + (:all maybe (eq files-test-safe-result t)) + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result 'query)) + (maybe maybe (eq files-test-result 'query))) + ;; Safe local variable with unsafe value + (("files-test-safe-result: 1") + (t t (eq files-test-result 'query)) + (t nil (eq files-test-result 'query)) + (t maybe (eq files-test-result 'query)) + (nil t (eq files-test-safe-result nil)) + (nil nil (eq files-test-safe-result nil)) + (nil maybe (eq files-test-safe-result nil)) + (:safe t (eq files-test-safe-result nil)) + (:safe nil (eq files-test-safe-result nil)) + (:safe maybe (eq files-test-safe-result nil)) + (:all t (eq files-test-safe-result 1)) + (:all nil (eq files-test-safe-result 1)) + (:all maybe (eq files-test-safe-result 1)) + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result 'query)) + (maybe maybe (eq files-test-result 'query)))) + "List of file-local variable tests. +Each list element should have the form + + (LOCAL-VARS-LIST . TEST-LIST) + +where LOCAL-VARS-LISTS should be a list of local variable +definitions (strings) and TEST-LIST is a list of tests to +perform. Each entry of TEST-LIST should have the form + + (ENABLE-LOCAL-VARIABLES ENABLE-LOCAL-EVAL FORM) + +where ENABLE-LOCAL-VARIABLES is the value to assign to +`enable-local-variables', ENABLE-LOCAL-EVAL is the value to +assign to `enable-local-eval', and FORM is a desired `should' +form.") + +(defun file-test--do-local-variables-test (str test-settings) + (with-temp-buffer + (insert str) + (setq files-test-result nil + files-test-safe-result nil) + (let ((enable-local-variables (nth 0 test-settings)) + (enable-local-eval (nth 1 test-settings)) + ;; Prevent any dir-locals file interfering with the tests. + (enable-dir-local-variables nil) + (files-test-queried nil)) + (hack-local-variables) + (eval (nth 2 test-settings))))) + +(ert-deftest files-test-local-variables () + "Test the file-local variables implementation." + (unwind-protect + (progn + (defadvice hack-local-variables-confirm (around files-test activate) + (setq files-test-result 'query) + nil) + (dolist (test files-test-local-variable-data) + (let ((str (concat "text\n\n;; Local Variables:\n;; " + (mapconcat 'identity (car test) "\n;; ") + "\n;; End:\n"))) + (dolist (subtest (cdr test)) + (should (file-test--do-local-variables-test str subtest)))))) + (ad-disable-advice 'hack-local-variables-confirm 'around 'files-test))) + +(defvar files-test-bug-18141-file + (expand-file-name "data/files-bug18141.el.gz" (getenv "EMACS_TEST_DIRECTORY")) + "Test file for bug#18141.") + +(ert-deftest files-test-bug-18141 () + "Test for http://debbugs.gnu.org/18141 ." + (skip-unless (executable-find "gzip")) + (let ((tempfile (make-temp-file "files-test-bug-18141" nil ".gz"))) + (unwind-protect + (progn + (copy-file files-test-bug-18141-file tempfile t) + (with-current-buffer (find-file-noselect tempfile) + (set-buffer-modified-p t) + (save-buffer) + (should (eq buffer-file-coding-system 'iso-2022-7bit-unix)))) + (delete-file tempfile)))) + + +;; Stop the above "Local Var..." confusing Emacs. + + +;;; files.el ends here diff --cc test/lisp/legacy/font-parse-tests.el index e2c51e6bfde,00000000000..6274253360f mode 100644,000000..100644 --- a/test/lisp/legacy/font-parse-tests.el +++ b/test/lisp/legacy/font-parse-tests.el @@@ -1,165 -1,0 +1,165 @@@ +;;; font-parse-tests.el --- Test suite for font parsing. + - ;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Chong Yidong +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Type M-x test-font-parse RET to generate the test buffer. + +;;; Code: + +(require 'ert) + +(defvar font-parse-tests--data + `((" " ,(intern " ") nil nil nil nil) + ("Monospace" Monospace nil nil nil nil) + ("Foo1" Foo1 nil nil nil nil) + ("12" nil 12.0 nil nil nil) + ("12 " ,(intern "12 ") nil nil nil nil) + ;; Fontconfig format + ("Foo:" Foo nil nil nil nil) + ("Foo-8" Foo 8.0 nil nil nil) + ("Foo-18:" Foo 18.0 nil nil nil) + ("Foo-18:light" Foo 18.0 light nil nil) + ("Foo 10:weight=bold" ,(intern "Foo 10") nil bold nil nil) + ("Foo-12:weight=bold" Foo 12.0 bold nil nil) + ("Foo 8-20:slant=oblique" ,(intern "Foo 8") 20.0 nil oblique nil) + ("Foo:light:roman" Foo nil light roman nil) + ("Foo:italic:roman" Foo nil nil roman nil) + ("Foo 12:light:oblique" ,(intern "Foo 12") nil light oblique nil) + ("Foo-12:demibold:oblique" Foo 12.0 demibold oblique nil) + ("Foo:black:proportional" Foo nil black nil 0) + ("Foo-10:black:proportional" Foo 10.0 black nil 0) + ("Foo:weight=normal" Foo nil normal nil nil) + ("Foo:weight=bold" Foo nil bold nil nil) + ("Foo:weight=bold:slant=italic" Foo nil bold italic) + ("Foo:weight=bold:slant=italic:mono" Foo nil bold italic 100) + ("Foo-10:demibold:slant=normal" Foo 10.0 demibold normal nil) + ("Foo 11-16:oblique:weight=bold" ,(intern "Foo 11") 16.0 bold oblique nil) + ("Foo:oblique:randomprop=randomtag:weight=bold" Foo nil bold oblique nil) + ("Foo:randomprop=randomtag:bar=baz" Foo nil nil nil nil) + ("Foo Book Light:bar=baz" ,(intern "Foo Book Light") nil nil nil nil) + ("Foo Book Light 10:bar=baz" ,(intern "Foo Book Light 10") nil nil nil nil) + ("Foo Book Light-10:bar=baz" ,(intern "Foo Book Light") 10.0 nil nil nil) + ;; GTK format + ("Oblique" nil nil nil oblique nil) + ("Bold 17" nil 17.0 bold nil nil) + ("17 Bold" ,(intern "17") nil bold nil nil) + ("Book Oblique 2" nil 2.0 book oblique nil) + ("Bar 7" Bar 7.0 nil nil nil) + ("Bar Ultra-Light" Bar nil ultra-light nil nil) + ("Bar Light 8" Bar 8.0 light nil nil) + ("Bar Book Medium 9" Bar 9.0 medium nil nil) + ("Bar Semi-Bold Italic 10" Bar 10.0 semi-bold italic nil) + ("Bar Semi-Condensed Bold Italic 11" Bar 11.0 bold italic nil) + ("Foo 10 11" ,(intern "Foo 10") 11.0 nil nil nil) + ("Foo 1985 Book" ,(intern "Foo 1985") nil book nil nil) + ("Foo 1985 A Book" ,(intern "Foo 1985 A") nil book nil nil) + ("Foo 1 Book 12" ,(intern "Foo 1") 12.0 book nil nil) + ("Foo A Book 12 A" ,(intern "Foo A Book 12 A") nil nil nil nil) + ("Foo 1985 Book 12 Oblique" ,(intern "Foo 1985 Book 12") nil nil oblique nil) + ("Foo 1985 Book 12 Italic 10" ,(intern "Foo 1985 Book 12") 10.0 nil italic nil) + ("Foo Book Bar 6 Italic" ,(intern "Foo Book Bar 6") nil nil italic nil) + ("Foo Book Bar Bold" ,(intern "Foo Book Bar") nil bold nil nil)) + "List of font names parse data. +Each element should have the form + (NAME FAMILY SIZE WEIGHT SLANT SPACING) +where NAME is the name to parse, and the remainder are the +expected font properties from parsing NAME.") + +(defun font-parse-check (name prop expected) + (let ((result (font-get (font-spec :name name) prop))) + (if (and (symbolp result) (symbolp expected)) + (eq result expected) + (equal result expected)))) + +(put 'font-parse-check 'ert-explainer 'font-parse-explain) + +(defun font-parse-explain (name prop expected) + (let ((result (font-get (font-spec :name name) prop)) + (propname (symbol-name prop))) + (format "Parsing `%s': expected %s `%s', got `%s'." + name (substring propname 1) expected + (font-get (font-spec :name name) prop)))) + +(ert-deftest font-parse-tests () + "Test parsing of Fontconfig-style and GTK-style font names." + (dolist (test font-parse-tests--data) + (let* ((name (nth 0 test))) + (should (font-parse-check name :family (nth 1 test))) + (should (font-parse-check name :size (nth 2 test))) + (should (font-parse-check name :weight (nth 3 test))) + (should (font-parse-check name :slant (nth 4 test))) + (should (font-parse-check name :spacing (nth 5 test)))))) + + +(defun test-font-parse () + "Test font name parsing." + (interactive) + (switch-to-buffer (generate-new-buffer "*Font Pase Test*")) + (setq show-trailing-whitespace nil) + (let ((pass-face '((t :foreground "green"))) + (fail-face '((t :foreground "red")))) + (dolist (test font-parse-tests--data) + (let* ((name (nth 0 test)) + (fs (font-spec :name name)) + (family (font-get fs :family)) + (size (font-get fs :size)) + (weight (font-get fs :weight)) + (slant (font-get fs :slant)) + (spacing (font-get fs :spacing))) + (insert name) + (if (> (current-column) 20) + (insert "\n")) + (indent-to-column 21) + (insert (propertize (symbol-name family) + 'face (if (eq family (nth 1 test)) + pass-face + fail-face))) + (indent-to-column 40) + (insert (propertize (format "%s" size) + 'face (if (equal size (nth 2 test)) + pass-face + fail-face))) + (indent-to-column 48) + (insert (propertize (format "%s" weight) + 'face (if (eq weight (nth 3 test)) + pass-face + fail-face))) + (indent-to-column 60) + (insert (propertize (format "%s" slant) + 'face (if (eq slant (nth 4 test)) + pass-face + fail-face))) + (indent-to-column 69) + (insert (propertize (format "%s" spacing) + 'face (if (eq spacing (nth 5 test)) + pass-face + fail-face))) + (insert "\n")))) + (goto-char (point-min))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; font-parse-tests.el ends here. diff --cc test/lisp/legacy/lexbind-tests.el index dd60cd6db41,00000000000..3bf8c1361ad mode 100644,000000..100644 --- a/test/lisp/legacy/lexbind-tests.el +++ b/test/lisp/legacy/lexbind-tests.el @@@ -1,75 -1,0 +1,75 @@@ +;;; lexbind-tests.el --- Testing the lexbind byte-compiler + - ;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) + +(defconst lexbind-tests + `( + (let ((f #'car)) + (let ((f (lambda (x) (cons (funcall f x) (cdr x))))) + (funcall f '(1 . 2)))) + ) + "List of expression for test. +Each element will be executed by interpreter and with +bytecompiled code, and their results compared.") + + + +(defun lexbind-check-1 (pat) + "Return non-nil if PAT is the same whether directly evalled or compiled." + (let ((warning-minimum-log-level :emergency) + (byte-compile-warnings nil) + (v0 (condition-case nil + (eval pat t) + (error nil))) + (v1 (condition-case nil + (funcall (let ((lexical-binding t)) + (byte-compile `(lambda nil ,pat)))) + (error nil)))) + (equal v0 v1))) + +(put 'lexbind-check-1 'ert-explainer 'lexbind-explain-1) + +(defun lexbind-explain-1 (pat) + (let ((v0 (condition-case nil + (eval pat t) + (error nil))) + (v1 (condition-case nil + (funcall (let ((lexical-binding t)) + (byte-compile (list 'lambda nil pat)))) + (error nil)))) + (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." + pat v0 v1))) + +(ert-deftest lexbind-tests () + "Test the Emacs byte compiler lexbind handling." + (dolist (pat lexbind-tests) + (should (lexbind-check-1 pat)))) + + + +(provide 'lexbind-tests) +;;; lexbind-tests.el ends here diff --cc test/lisp/legacy/occur-tests.el index 1699cd007e5,00000000000..da45d5f6502 mode 100644,000000..100644 --- a/test/lisp/legacy/occur-tests.el +++ b/test/lisp/legacy/occur-tests.el @@@ -1,352 -1,0 +1,352 @@@ +;;; occur-tests.el --- Test suite for occur. + - ;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2010-2016 Free Software Foundation, Inc. + +;; Author: Juri Linkov +;; Keywords: matching, internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +(defconst occur-tests + '( + ;; * Test one-line matches (at bob, eob, bol, eol). + ("x" 0 "\ +xa +b +cx +xd +xex +fx +" "\ +6 matches in 5 lines for \"x\" in buffer: *test-occur* + 1:xa + 3:cx + 4:xd + 5:xex + 6:fx +") + ;; * Test multi-line matches, this is the first test from + ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html + ;; where numbers are replaced with letters. + ("a\na" 0 "\ +a +a +a +a +a +" "\ +2 matches for \"a\na\" in buffer: *test-occur* + 1:a + :a + 3:a + :a +") + ;; * Test multi-line matches, this is the second test from + ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html + ;; where numbers are replaced with letters. + ("a\nb" 0 "\ +a +b +c +a +b +" "\ +2 matches for \"a\nb\" in buffer: *test-occur* + 1:a + :b + 4:a + :b +") + ;; * Test line numbers for multi-line matches with empty last match line. + ("a\n" 0 "\ +a + +c +a + +" "\ +2 matches for \"a\n\" in buffer: *test-occur* + 1:a + : + 4:a + : +") + ;; * Test multi-line matches with 3 match lines. + ("x\n.x\n" 0 "\ +ax +bx +c +d +ex +fx +" "\ +2 matches for \"x\n.x\n\" in buffer: *test-occur* + 1:ax + :bx + :c + 5:ex + :fx + : +") + ;; * Test non-overlapping context lines with matches at bob/eob. + ("x" 1 "\ +ax +b +c +d +ex +f +g +hx +" "\ +3 matches for \"x\" in buffer: *test-occur* + 1:ax + :b +------- + :d + 5:ex + :f +------- + :g + 8:hx +") + ;; * Test non-overlapping context lines with matches not at bob/eob. + ("x" 1 "\ +a +bx +c +d +ex +f +" "\ +2 matches for \"x\" in buffer: *test-occur* + :a + 2:bx + :c +------- + :d + 5:ex + :f +") + ;; * Test overlapping context lines with matches at bob/eob. + ("x" 2 "\ +ax +bx +c +dx +e +f +gx +h +i +j +kx +" "\ +5 matches for \"x\" in buffer: *test-occur* + 1:ax + 2:bx + :c + 4:dx + :e + :f + 7:gx + :h + :i + :j + 11:kx +") + ;; * Test overlapping context lines with matches not at bob/eob. + ("x" 2 "\ +a +b +cx +d +e +f +gx +h +i +" "\ +2 matches for \"x\" in buffer: *test-occur* + :a + :b + 3:cx + :d + :e + :f + 7:gx + :h + :i +") + ;; * Test overlapping context lines with empty first and last line.. + ("x" 2 "\ + +b +cx +d +e +f +gx +h + +" "\ +2 matches for \"x\" in buffer: *test-occur* + : + :b + 3:cx + :d + :e + :f + 7:gx + :h + : +") + ;; * Test multi-line overlapping context lines. + ("x\n.x" 2 "\ +ax +bx +c +d +ex +fx +g +h +i +jx +kx +" "\ +3 matches for \"x\n.x\" in buffer: *test-occur* + 1:ax + :bx + :c + :d + 5:ex + :fx + :g + :h + :i + 10:jx + :kx +") + ;; * Test multi-line non-overlapping context lines. + ("x\n.x" 2 "\ +ax +bx +c +d +e +f +gx +hx +" "\ +2 matches for \"x\n.x\" in buffer: *test-occur* + 1:ax + :bx + :c + :d +------- + :e + :f + 7:gx + :hx +") + ;; * Test non-overlapping negative (before-context) lines. + ("x" -2 "\ +a +bx +c +d +e +fx +g +h +ix +" "\ +3 matches for \"x\" in buffer: *test-occur* + :a + 2:bx +------- + :d + :e + 6:fx +------- + :g + :h + 9:ix +") + ;; * Test overlapping negative (before-context) lines. + ("x" -3 "\ +a +bx +c +dx +e +f +gx +h +" "\ +3 matches for \"x\" in buffer: *test-occur* + :a + 2:bx + :c + 4:dx + :e + :f + 7:gx +") + +) + "List of tests for `occur'. +Each element has the format: +\(REGEXP NLINES INPUT-BUFFER-STRING OUTPUT-BUFFER-STRING).") + +(defun occur-test-case (test) + (let ((regexp (nth 0 test)) + (nlines (nth 1 test)) + (input-buffer-string (nth 2 test)) + (temp-buffer (get-buffer-create " *test-occur*"))) + (unwind-protect + (save-window-excursion + (with-current-buffer temp-buffer + (erase-buffer) + (insert input-buffer-string) + (occur regexp nlines) + (with-current-buffer "*Occur*" + (buffer-substring-no-properties (point-min) (point-max))))) + (and (buffer-name temp-buffer) + (kill-buffer temp-buffer))))) + +(defun occur-test-create (n) + "Create a test for element N of the `occur-tests' constant." + (let ((testname (intern (format "occur-test-%.2d" n))) + (testdoc (format "Test element %d of `occur-tests'." n))) + (eval + `(ert-deftest ,testname () + ,testdoc + (let (occur-hook) + (should (equal (occur-test-case (nth ,n occur-tests)) + (nth 3 (nth ,n occur-tests))))))))) + +(dotimes (i (length occur-tests)) + (occur-test-create i)) + +(provide 'occur-tests) + +;;; occur-tests.el ends here diff --cc test/lisp/legacy/process-tests.el index ee9e4f35891,00000000000..8554a287ccd mode 100644,000000..100644 --- a/test/lisp/legacy/process-tests.el +++ b/test/lisp/legacy/process-tests.el @@@ -1,165 -1,0 +1,165 @@@ +;;; process-tests.el --- Testing the process facilities + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) + +;; Timeout in seconds; the test fails if the timeout is reached. +(defvar process-test-sentinel-wait-timeout 2.0) + +;; Start a process that exits immediately. Call WAIT-FUNCTION, +;; possibly multiple times, to wait for the process to complete. +(defun process-test-sentinel-wait-function-working-p (wait-function) + (let ((proc (start-process "test" nil "bash" "-c" "exit 20")) + (sentinel-called nil) + (start-time (float-time))) + (set-process-sentinel proc (lambda (proc msg) + (setq sentinel-called t))) + (while (not (or sentinel-called + (> (- (float-time) start-time) + process-test-sentinel-wait-timeout))) + (funcall wait-function)) + (cl-assert (eq (process-status proc) 'exit)) + (cl-assert (= (process-exit-status proc) 20)) + sentinel-called)) + +(ert-deftest process-test-sentinel-accept-process-output () + (skip-unless (executable-find "bash")) + (should (process-test-sentinel-wait-function-working-p + #'accept-process-output))) + +(ert-deftest process-test-sentinel-sit-for () + (skip-unless (executable-find "bash")) + (should + (process-test-sentinel-wait-function-working-p (lambda () (sit-for 0.01 t))))) + +(when (eq system-type 'windows-nt) + (ert-deftest process-test-quoted-batfile () + "Check that Emacs hides CreateProcess deficiency (bug#18745)." + (let (batfile) + (unwind-protect + (progn + ;; CreateProcess will fail when both the bat file and 1st + ;; argument are quoted, so include spaces in both of those + ;; to force quoting. + (setq batfile (make-temp-file "echo args" nil ".bat")) + (with-temp-file batfile + (insert "@echo arg1=%1, arg2=%2\n")) + (with-temp-buffer + (call-process batfile nil '(t t) t "x &y") + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) + (with-temp-buffer + (call-process-shell-command + (mapconcat #'shell-quote-argument (list batfile "x &y") " ") + nil '(t t) t) + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))) + (when batfile (delete-file batfile)))))) + +(ert-deftest process-test-stderr-buffer () + (skip-unless (executable-find "bash")) + (let* ((stdout-buffer (generate-new-buffer "*stdout*")) + (stderr-buffer (generate-new-buffer "*stderr*")) + (proc (make-process :name "test" + :command (list "bash" "-c" + (concat "echo hello stdout!; " + "echo hello stderr! >&2; " + "exit 20")) + :buffer stdout-buffer + :stderr stderr-buffer)) + (sentinel-called nil) + (start-time (float-time))) + (set-process-sentinel proc (lambda (proc msg) + (setq sentinel-called t))) + (while (not (or sentinel-called + (> (- (float-time) start-time) + process-test-sentinel-wait-timeout))) + (accept-process-output)) + (cl-assert (eq (process-status proc) 'exit)) + (cl-assert (= (process-exit-status proc) 20)) + (should (with-current-buffer stdout-buffer + (goto-char (point-min)) + (looking-at "hello stdout!"))) + (should (with-current-buffer stderr-buffer + (goto-char (point-min)) + (looking-at "hello stderr!"))))) + +(ert-deftest process-test-stderr-filter () + (skip-unless (executable-find "bash")) + (let* ((sentinel-called nil) + (stderr-sentinel-called nil) + (stdout-output nil) + (stderr-output nil) + (stdout-buffer (generate-new-buffer "*stdout*")) + (stderr-buffer (generate-new-buffer "*stderr*")) + (stderr-proc (make-pipe-process :name "stderr" + :buffer stderr-buffer)) + (proc (make-process :name "test" :buffer stdout-buffer + :command (list "bash" "-c" + (concat "echo hello stdout!; " + "echo hello stderr! >&2; " + "exit 20")) + :stderr stderr-proc)) + (start-time (float-time))) + (set-process-filter proc (lambda (proc input) + (push input stdout-output))) + (set-process-sentinel proc (lambda (proc msg) + (setq sentinel-called t))) + (set-process-filter stderr-proc (lambda (proc input) + (push input stderr-output))) + (set-process-sentinel stderr-proc (lambda (proc input) + (setq stderr-sentinel-called t))) + (while (not (or sentinel-called + (> (- (float-time) start-time) + process-test-sentinel-wait-timeout))) + (accept-process-output)) + (cl-assert (eq (process-status proc) 'exit)) + (cl-assert (= (process-exit-status proc) 20)) + (should sentinel-called) + (should (equal 1 (with-current-buffer stdout-buffer + (point-max)))) + (should (equal "hello stdout!\n" + (mapconcat #'identity (nreverse stdout-output) ""))) + (should stderr-sentinel-called) + (should (equal 1 (with-current-buffer stderr-buffer + (point-max)))) + (should (equal "hello stderr!\n" + (mapconcat #'identity (nreverse stderr-output) ""))))) + +(ert-deftest start-process-should-not-modify-arguments () + "`start-process' must not modify its arguments in-place." + ;; See bug#21831. + (let* ((path (pcase system-type + ((or 'windows-nt 'ms-dos) + ;; Make sure the file name uses forward slashes. + ;; The original bug was that 'start-process' would + ;; convert forward slashes to backslashes. + (expand-file-name (executable-find "attrib.exe"))) + (_ "/bin//sh"))) + (samepath (copy-sequence path))) + ;; Make sure 'start-process' actually goes all the way and invokes + ;; the program. + (should (process-live-p (condition-case nil + (start-process "" nil path) + (error nil)))) + (should (equal path samepath)))) + +(provide 'process-tests) diff --cc test/lisp/legacy/syntax-tests.el index b884c3ef5b8,00000000000..d4af80e8ebe mode 100644,000000..100644 --- a/test/lisp/legacy/syntax-tests.el +++ b/test/lisp/legacy/syntax-tests.el @@@ -1,97 -1,0 +1,97 @@@ +;;; syntax-tests.el --- Testing syntax rules and basic movement -*- lexical-binding: t -*- + - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Daniel Colascione +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: +(require 'ert) +(require 'cl-lib) + +(defun run-up-list-test (fn data start instructions) + (cl-labels ((posof (thing) + (and (symbolp thing) + (= (length (symbol-name thing)) 1) + (- (aref (symbol-name thing) 0) ?a -1)))) + (with-temp-buffer + (set-syntax-table (make-syntax-table)) + ;; Use a syntax table in which single quote is a string + ;; character so that we can embed the test data in a lisp string + ;; literal. + (modify-syntax-entry ?\' "\"") + (insert data) + (goto-char (posof start)) + (dolist (instruction instructions) + (cond ((posof instruction) + (funcall fn) + (should (eql (point) (posof instruction)))) + ((symbolp instruction) + (should-error (funcall fn) + :type instruction)) + (t (cl-assert nil nil "unknown ins"))))))) + +(defmacro define-up-list-test (name fn data start &rest expected) + `(ert-deftest ,name () + (run-up-list-test ,fn ,data ',start ',expected))) + +(define-up-list-test up-list-basic + (lambda () (up-list)) + (or "(1 1 (1 1) 1 (1 1) 1)") + ;; abcdefghijklmnopqrstuv + i k v scan-error) + +(define-up-list-test up-list-with-forward-sexp-function + (lambda () + (let ((forward-sexp-function + (lambda (&optional arg) + (let ((forward-sexp-function nil)) + (forward-sexp arg))))) + (up-list))) + (or "(1 1 (1 1) 1 (1 1) 1)") + ;; abcdefghijklmnopqrstuv + i k v scan-error) + +(define-up-list-test up-list-out-of-string + (lambda () (up-list 1 t)) + (or "1 (1 '2 2 (2 2 2' 1) 1") + ;; abcdefghijklmnopqrstuvwxy + o r u scan-error) + +(define-up-list-test up-list-cross-string + (lambda () (up-list 1 t)) + (or "(1 '2 ( 2' 1 '2 ) 2' 1)") + ;; abcdefghijklmnopqrstuvwxy + i r u x scan-error) + +(define-up-list-test up-list-no-cross-string + (lambda () (up-list 1 t t)) + (or "(1 '2 ( 2' 1 '2 ) 2' 1)") + ;; abcdefghijklmnopqrstuvwxy + i k x scan-error) + +(define-up-list-test backward-up-list-basic + (lambda () (backward-up-list)) + (or "(1 1 (1 1) 1 (1 1) 1)") + ;; abcdefghijklmnopqrstuv + i f a scan-error) + +(provide 'syntax-tests) +;;; syntax-tests.el ends here diff --cc test/lisp/legacy/textprop-tests.el index 0baa911421b,00000000000..397ef28c035 mode 100644,000000..100644 --- a/test/lisp/legacy/textprop-tests.el +++ b/test/lisp/legacy/textprop-tests.el @@@ -1,69 -1,0 +1,69 @@@ +;;; textprop-tests.el --- Test suite for text properties. + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Wolfgang Jenkner +;; Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +(ert-deftest textprop-tests-format () + "Test `format' with text properties." + ;; See Bug#21351. + (should (equal-including-properties + (format #("mouse-1, RET: %s -- w: copy %s" + 12 20 (face minibuffer-prompt) + 21 30 (face minibuffer-prompt)) + "visit" "link") + #("mouse-1, RET: visit -- w: copy link" + 12 23 (face minibuffer-prompt) + 24 35 (face minibuffer-prompt))))) + +(ert-deftest textprop-tests-font-lock--remove-face-from-text-property () + "Test `font-lock--remove-face-from-text-property'." + (let* ((string "foobar") + (stack (list string)) + (faces '(bold (:foreground "red") underline))) + ;; Build each string in `stack' by adding a face to the previous + ;; string. + (let ((faces (reverse faces))) + (push (copy-sequence (car stack)) stack) + (put-text-property 0 3 'font-lock-face (pop faces) (car stack)) + (push (copy-sequence (car stack)) stack) + (put-text-property 3 6 'font-lock-face (pop faces) (car stack)) + (push (copy-sequence (car stack)) stack) + (font-lock-prepend-text-property 2 5 + 'font-lock-face (pop faces) (car stack))) + ;; Check that removing the corresponding face from each string + ;; yields the previous string in `stack'. + (while faces + ;; (message "%S" (car stack)) + (should (equal-including-properties + (progn + (font-lock--remove-face-from-text-property 0 6 + 'font-lock-face + (pop faces) + (car stack)) + (pop stack)) + (car stack)))) + ;; Sanity check. + ;; (message "%S" (car stack)) + (should (and (equal-including-properties (pop stack) string) + (null stack))))) diff --cc test/lisp/legacy/undo-tests.el index f462b269337,00000000000..b1c786993e8 mode 100644,000000..100644 --- a/test/lisp/legacy/undo-tests.el +++ b/test/lisp/legacy/undo-tests.el @@@ -1,448 -1,0 +1,448 @@@ +;;; undo-tests.el --- Tests of primitive-undo + - ;; Copyright (C) 2012-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; Author: Aaron S. Hawley + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; Profiling when the code was translate from C to Lisp on 2012-12-24. + +;;; C + +;; (elp-instrument-function 'primitive-undo) +;; (load-file "undo-test.elc") +;; (benchmark 100 '(let ((undo-test5-error nil)) (undo-test-all))) +;; Elapsed time: 305.218000s (104.841000s in 14804 GCs) +;; M-x elp-results +;; Function Name Call Count Elapsed Time Average Time +;; primitive-undo 2600 3.4889999999 0.0013419230 + +;;; Lisp + +;; (load-file "primundo.elc") +;; (elp-instrument-function 'primitive-undo) +;; (benchmark 100 '(undo-test-all)) +;; Elapsed time: 295.974000s (104.582000s in 14704 GCs) +;; M-x elp-results +;; Function Name Call Count Elapsed Time Average Time +;; primitive-undo 2700 3.6869999999 0.0013655555 + +;;; Code: + +(require 'ert) + +(ert-deftest undo-test0 () + "Test basics of \\[undo]." + (with-temp-buffer + (buffer-enable-undo) + (condition-case err + (undo) + (error + (unless (string= "No further undo information" + (cadr err)) + (error err)))) + (undo-boundary) + (insert "This") + (undo-boundary) + (erase-buffer) + (undo-boundary) + (insert "That") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (insert "With ") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (kill-word 1) + (undo-boundary) + (put-text-property (point-min) (point-max) 'face 'bold) + (undo-boundary) + (remove-text-properties (point-min) (point-max) '(face default)) + (undo-boundary) + (set-buffer-multibyte (not enable-multibyte-characters)) + (undo-boundary) + (undo) + (should + (equal (should-error (undo-more nil)) + '(wrong-type-argument number-or-marker-p nil))) + (undo-more 7) + (should (string-equal "" (buffer-string))))) + +(ert-deftest undo-test1 () + "Test undo of \\[undo] command (redo)." + (with-temp-buffer + (buffer-enable-undo) + (undo-boundary) + (insert "This") + (undo-boundary) + (erase-buffer) + (undo-boundary) + (insert "That") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (insert "With ") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (kill-word 1) + (undo-boundary) + (facemenu-add-face 'bold (point-min) (point-max)) + (undo-boundary) + (set-buffer-multibyte (not enable-multibyte-characters)) + (undo-boundary) + (should + (string-equal (buffer-string) + (progn + (undo) + (undo-more 4) + (undo) + ;(undo-more -4) + (buffer-string)))))) + +(ert-deftest undo-test2 () + "Test basic redoing with \\[undo] command." + (with-temp-buffer + (buffer-enable-undo) + (undo-boundary) + (insert "One") + (undo-boundary) + (insert " Zero") + (undo-boundary) + (push-mark nil t) + (delete-region (save-excursion + (forward-word -1) + (point)) (point)) + (undo-boundary) + (beginning-of-line) + (insert "Zero") + (undo-boundary) + (undo) + (should + (string-equal (buffer-string) + (progn + (undo-more 2) + (undo) + (buffer-string)))))) + +(ert-deftest undo-test4 () + "Test \\[undo] of \\[flush-lines]." + (with-temp-buffer + (buffer-enable-undo) + (dotimes (i 1048576) + (if (zerop (% i 2)) + (insert "Evenses") + (insert "Oddses"))) + (undo-boundary) + (should + ;; Avoid string-equal because ERT will save the `buffer-string' + ;; to the explanation. Using `not' will record nil or non-nil. + (not + (null + (string-equal (buffer-string) + (progn + (flush-lines "oddses" (point-min) (point-max)) + (undo-boundary) + (undo) + (undo) + (buffer-string)))))))) + +(ert-deftest undo-test5 () + "Test basic redoing with \\[undo] command." + (with-temp-buffer + (buffer-enable-undo) + (undo-boundary) + (insert "AYE") + (undo-boundary) + (insert " BEE") + (undo-boundary) + (setq buffer-undo-list (cons '(0.0 bogus) buffer-undo-list)) + (push-mark nil t) + (delete-region (save-excursion + (forward-word -1) + (point)) (point)) + (undo-boundary) + (beginning-of-line) + (insert "CEE") + (undo-boundary) + (undo) + (setq buffer-undo-list (cons "bogus" buffer-undo-list)) + (should + (string-equal + (buffer-string) + (progn + (if (and (boundp 'undo-test5-error) (not undo-test5-error)) + (progn + (should (null (undo-more 2))) + (should (undo))) + ;; Errors are generated by new Lisp version of + ;; `primitive-undo' not by built-in C version. + (should + (equal (should-error (undo-more 2)) + '(error "Unrecognized entry in undo list (0.0 bogus)"))) + (should + (equal (should-error (undo)) + '(error "Unrecognized entry in undo list \"bogus\"")))) + (buffer-string)))))) + +;; http://debbugs.gnu.org/14824 +(ert-deftest undo-test-buffer-modified () + "Test undoing marks buffer unmodified." + (with-temp-buffer + (buffer-enable-undo) + (insert "1") + (undo-boundary) + (set-buffer-modified-p nil) + (insert "2") + (undo) + (should-not (buffer-modified-p)))) + +(ert-deftest undo-test-file-modified () + "Test undoing marks buffer visiting file unmodified." + (let ((tempfile (make-temp-file "undo-test"))) + (unwind-protect + (progn + (with-current-buffer (find-file-noselect tempfile) + (insert "1") + (undo-boundary) + (set-buffer-modified-p nil) + (insert "2") + (undo) + (should-not (buffer-modified-p)))) + (delete-file tempfile)))) + +(ert-deftest undo-test-region-not-most-recent () + "Test undo in region of an edit not the most recent." + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "1111") + (undo-boundary) + (goto-char 2) + (insert "2") + (forward-char 2) + (undo-boundary) + (insert "3") + (undo-boundary) + ;; Highlight around "2", not "3" + (push-mark (+ 3 (point-min)) t t) + (setq mark-active t) + (goto-char (point-min)) + (undo) + (should (string= (buffer-string) + "11131")))) + +(ert-deftest undo-test-region-deletion () + "Test undoing a deletion to demonstrate bug 17235." + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "12345") + (search-backward "4") + (undo-boundary) + (delete-forward-char 1) + (search-backward "1") + (undo-boundary) + (insert "xxxx") + (undo-boundary) + (insert "yy") + (search-forward "35") + (undo-boundary) + ;; Select "35" + (push-mark (point) t t) + (setq mark-active t) + (forward-char -2) + (undo) ; Expect "4" to come back + (should (string= (buffer-string) + "xxxxyy12345")))) + +(ert-deftest undo-test-region-example () + "The same example test case described in comments for +undo-make-selective-list." + ;; buf pos: + ;; 123456789 buffer-undo-list undo-deltas + ;; --------- ---------------- ----------- + ;; aaa (1 . 4) (1 . -3) + ;; aaba (3 . 4) N/A (in region) + ;; ccaaba (1 . 3) (1 . -2) + ;; ccaabaddd (7 . 10) (7 . -3) + ;; ccaabdd ("ad" . 6) (6 . 2) + ;; ccaabaddd (6 . 8) (6 . -2) + ;; | |<-- region: "caab", from 2 to 6 + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "aaa") + (goto-char 3) + (undo-boundary) + (insert "b") + (goto-char 1) + (undo-boundary) + (insert "cc") + (goto-char 7) + (undo-boundary) + (insert "ddd") + (search-backward "ad") + (undo-boundary) + (delete-forward-char 2) + (undo-boundary) + ;; Select "dd" + (push-mark (point) t t) + (setq mark-active t) + (goto-char (point-max)) + (undo) + (undo-boundary) + (should (string= (buffer-string) + "ccaabaddd")) + ;; Select "caab" + (push-mark 2 t t) + (setq mark-active t) + (goto-char 6) + (undo) + (undo-boundary) + (should (string= (buffer-string) + "ccaaaddd")))) + +(ert-deftest undo-test-region-eob () + "Test undo in region of a deletion at EOB, demonstrating bug 16411." + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "This sentence corrupted?") + (undo-boundary) + ;; Same as recipe at + ;; http://debbugs.gnu.org/cgi/bugreport.cgi?bug=16411 + (insert "aaa") + (undo-boundary) + (undo) + ;; Select entire buffer + (push-mark (point) t t) + (setq mark-active t) + (goto-char (point-min)) + ;; Should undo the undo of "aaa", ie restore it. + (undo) + (should (string= (buffer-string) + "This sentence corrupted?aaa")))) + +(ert-deftest undo-test-marker-adjustment-nominal () + "Test nominal behavior of marker adjustments." + (with-temp-buffer + (buffer-enable-undo) + (insert "abcdefg") + (undo-boundary) + (let ((m (make-marker))) + (set-marker m 2 (current-buffer)) + (goto-char (point-min)) + (delete-forward-char 3) + (undo-boundary) + (should (= (point-min) (marker-position m))) + (undo) + (undo-boundary) + (should (= 2 (marker-position m)))))) + +(ert-deftest undo-test-region-t-marker () + "Test undo in region containing marker with t insertion-type." + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "abcdefg") + (undo-boundary) + (let ((m (make-marker))) + (set-marker-insertion-type m t) + (set-marker m (point-min) (current-buffer)) ; m at a + (goto-char (+ 2 (point-min))) + (push-mark (point) t t) + (setq mark-active t) + (goto-char (point-min)) + (delete-forward-char 1) ;; delete region covering "ab" + (undo-boundary) + (should (= (point-min) (marker-position m))) + ;; Resurrect "ab". m's insertion type means the reinsertion + ;; moves it forward 2, and then the marker adjustment returns it + ;; to its rightful place. + (undo) + (undo-boundary) + (should (= (point-min) (marker-position m)))))) + +(ert-deftest undo-test-marker-adjustment-moved () + "Test marker adjustment behavior when the marker moves. +Demonstrates bug 16818." + (with-temp-buffer + (buffer-enable-undo) + (insert "abcdefghijk") + (undo-boundary) + (let ((m (make-marker))) + (set-marker m 2 (current-buffer)) ; m at b + (goto-char (point-min)) + (delete-forward-char 3) ; m at d + (undo-boundary) + (set-marker m 4) ; m at g + (undo) + (undo-boundary) + ;; m still at g, but shifted 3 because deletion undone + (should (= 7 (marker-position m)))))) + +(ert-deftest undo-test-region-mark-adjustment () + "Test that the mark's marker adjustment in undo history doesn't +obstruct undo in region from finding the correct change group. +Demonstrates bug 16818." + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "First line\n") + (insert "Second line\n") + (undo-boundary) + + (goto-char (point-min)) + (insert "aaa") + (undo-boundary) + + (undo) + (undo-boundary) + + (goto-char (point-max)) + (insert "bbb") + (undo-boundary) + + (push-mark (point) t t) + (setq mark-active t) + (goto-char (- (point) 3)) + (delete-forward-char 1) + (undo-boundary) + + (insert "bbb") + (undo-boundary) + + (goto-char (point-min)) + (push-mark (point) t t) + (setq mark-active t) + (goto-char (+ (point) 3)) + (undo) + (undo-boundary) + + (should (string= (buffer-string) "aaaFirst line\nSecond line\nbbb")))) + +(defun undo-test-all (&optional interactive) + "Run all tests for \\[undo]." + (interactive "p") + (if interactive + (ert-run-tests-interactively "^undo-") + (ert-run-tests-batch "^undo-"))) + +(provide 'undo-tests) +;;; undo-tests.el ends here diff --cc test/lisp/man-tests.el index adfeff8e7e3,00000000000..b1cc4437256 mode 100644,000000..100644 --- a/test/lisp/man-tests.el +++ b/test/lisp/man-tests.el @@@ -1,118 -1,0 +1,118 @@@ +;;; man-tests.el --- Test suite for man. + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Wolfgang Jenkner +;; Keywords: help, internal, unix + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'man) + +(defconst man-tests-parse-man-k-tests + '(;; GNU/Linux: man-db-2.6.1 + ("\ +sin (3) - sine function +sinf (3) - sine function +sinl (3) - sine function" + . (#("sin(3)" 0 6 (help-echo "sine function")) #("sinf(3)" 0 7 (help-echo "sine function")) #("sinl(3)" 0 7 (help-echo "sine function")))) + ;; GNU/Linux: man-1.6g + ("\ +sin (3) - sine function +sinf [sin] (3) - sine function +sinl [sin] (3) - sine function" + . (#("sin(3)" 0 6 (help-echo "sine function")) #("sinf(3)" 0 7 (help-echo "sine function")) #("sinl(3)" 0 7 (help-echo "sine function")))) + ;; FreeBSD 9 + ("\ +sin(3), sinf(3), sinl(3) - sine functions" + . (#("sin(3)" 0 6 (help-echo "sine functions")) #("sinf(3)" 0 7 (help-echo "sine functions")) #("sinl(3)" 0 7 (help-echo "sine functions")))) + ;; SunOS, Solaris + ;; http://docs.oracle.com/cd/E19455-01/805-6331/usradm-7/index.html + ;; SunOS 4 + ("\ +tset, reset (1) - establish or restore terminal characteristics" + . (#("tset(1)" 0 7 (help-echo "establish or restore terminal characteristics")) #("reset(1)" 0 8 (help-echo "establish or restore terminal characteristics")))) + ;; SunOS 5.7, Solaris + ("\ +reset tset (1b) - establish or restore terminal characteristics +tset tset (1b) - establish or restore terminal characteristics" + . (#("reset(1b)" 0 8 (help-echo "establish or restore terminal characteristics")) #("tset(1b)" 0 7 (help-echo "establish or restore terminal characteristics")))) + ;; Minix 3 + ;; http://www.minix3.org/manpages/html5/whatis.html + ("\ +cawf, nroff (1) - C version of the nroff-like, Amazingly Workable (text) Formatter +whatis (5) - database of online manual pages" + . (#("cawf(1)" 0 7 (help-echo "C version of the nroff-like, Amazingly Workable (text) Formatter")) #("nroff(1)" 0 8 (help-echo "C version of the nroff-like, Amazingly Workable (text) Formatter")) #("whatis(5)" 0 9 (help-echo "database of online manual pages")))) + ;; HP-UX + ;; http://docstore.mik.ua/manuals/hp-ux/en/B2355-60130/man.1.html + ;; Assuming that the line break in the zgrep description was + ;; introduced by the man page formatting. + ("\ +grep, egrep, fgrep (1) - search a file for a pattern +zgrep(1) - search possibly compressed files for a regular expression" + . (#("grep(1)" 0 7 (help-echo "search a file for a pattern")) #("egrep(1)" 0 8 (help-echo "search a file for a pattern")) #("fgrep(1)" 0 8 (help-echo "search a file for a pattern")) #("zgrep(1)" 0 8 (help-echo "search possibly compressed files for a regular expression")))) + ;; AIX + ;; http://pic.dhe.ibm.com/infocenter/aix/v7r1/topic/com.ibm.aix.cmds/doc/aixcmds6/whatis.htm + ("\ +ls(1) -Displays the contents of a directory." + . (#("ls(1)" 0 5 (help-echo "Displays the contents of a directory.")))) + ;; https://www.ibm.com/developerworks/mydeveloperworks/blogs/cgaix/entry/catman_0703_102_usr_lbin_mkwhatis_the_error_number_is_1?lang=en + ("\ +loopmount(1) - Associate an image file to a loopback device." + . (#("loopmount(1)" 0 12 (help-echo "Associate an image file to a loopback device.")))) + ) + "List of tests for `Man-parse-man-k'. +Each element is a cons cell whose car is a string containing +man -k output. That should result in the table which is stored +in the cdr of the element.") + +(defun man-tests-name-equal-p (name description string) + (and (equal name string) + (not (next-single-property-change 0 'help-echo string)) + (equal (get-text-property 0 'help-echo string) description))) + +(defun man-tests-parse-man-k-test-case (test) + (let ((temp-buffer (get-buffer-create " *test-man*")) + (man-k-output (car test))) + (unwind-protect + (save-window-excursion + (with-current-buffer temp-buffer + (erase-buffer) + (insert man-k-output) + (let ((result (Man-parse-man-k)) + (checklist (cdr test))) + (while (and checklist result + (man-tests-name-equal-p + (car checklist) + (get-text-property 0 'help-echo + (car checklist)) + (pop result))) + (pop checklist)) + (and (null checklist) (null result))))) + (and (buffer-name temp-buffer) + (kill-buffer temp-buffer))))) + +(ert-deftest man-tests () + "Test man." + (dolist (test man-tests-parse-man-k-tests) + (should (man-tests-parse-man-k-test-case test)))) + +(provide 'man-tests) + +;;; man-tests.el ends here diff --cc test/lisp/minibuffer-tests.el index 69e7b76fa30,00000000000..0f2abf45673 mode 100644,000000..100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@@ -1,46 -1,0 +1,46 @@@ +;;; completion-tests.el --- Tests for completion functions -*- lexical-binding: t; -*- + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +(ert-deftest completion-test1 () + (with-temp-buffer + (cl-flet* ((test/completion-table (string pred action) + (if (eq action 'lambda) + nil + "test: ")) + (test/completion-at-point () + (list (copy-marker (point-min)) + (copy-marker (point)) + #'test/completion-table))) + (let ((completion-at-point-functions (list #'test/completion-at-point))) + (insert "TEST") + (completion-at-point) + (should (equal (buffer-string) + "test: ")))))) + +(provide 'completion-tests) +;;; completion-tests.el ends here diff --cc test/lisp/net/dbus-tests.el index 9465c859505,00000000000..12be1637109 mode 100644,000000..100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@@ -1,182 -1,0 +1,182 @@@ +;;; dbus-tests.el --- Tests of D-Bus integration into Emacs + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Code: + +(require 'ert) +(require 'dbus) + +(setq dbus-debug nil) + +(defvar dbus--test-enabled-session-bus + (and (featurep 'dbusbind) + (dbus-ignore-errors (dbus-get-unique-name :session))) + "Check, whether we are registered at the session bus.") + +(defvar dbus--test-enabled-system-bus + (and (featurep 'dbusbind) + (dbus-ignore-errors (dbus-get-unique-name :system))) + "Check, whether we are registered at the system bus.") + +(defun dbus--test-availability (bus) + "Test availability of D-Bus BUS." + (should (dbus-list-names bus)) + (should (dbus-list-activatable-names bus)) + (should (dbus-list-known-names bus)) + (should (dbus-get-unique-name bus))) + +(ert-deftest dbus-test00-availability-session () + "Test availability of D-Bus `:session'." + :expected-result (if dbus--test-enabled-session-bus :passed :failed) + (dbus--test-availability :session)) + +(ert-deftest dbus-test00-availability-system () + "Test availability of D-Bus `:system'." + :expected-result (if dbus--test-enabled-system-bus :passed :failed) + (dbus--test-availability :system)) + +(ert-deftest dbus-test01-type-conversion () + "Check type conversion functions." + (let ((ustr "0123abc_xyz\x01\xff") + (mstr "Grüß Göttin")) + (should + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array "")) "")) + (should + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array ustr)) ustr)) + (should + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array mstr) 'multibyte) + mstr)) + ;; Should not work for multibyte strings. + (should-not + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array mstr)) mstr)) + + (should + (string-equal + (dbus-unescape-from-identifier (dbus-escape-as-identifier "")) "")) + (should + (string-equal + (dbus-unescape-from-identifier (dbus-escape-as-identifier ustr)) ustr)) + ;; Should not work for multibyte strings. + (should-not + (string-equal + (dbus-unescape-from-identifier (dbus-escape-as-identifier mstr)) mstr)))) + +(defun dbus--test-register-service (bus) + "Check service registration at BUS." + ;; Cleanup. + (dbus-ignore-errors (dbus-unregister-service bus dbus-service-emacs)) + + ;; Register an own service. + (should (eq (dbus-register-service bus dbus-service-emacs) :primary-owner)) + (should (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-register-service bus dbus-service-emacs) :already-owner)) + (should (member dbus-service-emacs (dbus-list-known-names bus))) + + ;; Unregister the service. + (should (eq (dbus-unregister-service bus dbus-service-emacs) :released)) + (should-not (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-unregister-service bus dbus-service-emacs) :non-existent)) + (should-not (member dbus-service-emacs (dbus-list-known-names bus))) + + ;; `dbus-service-dbus' is reserved for the BUS itself. + (should-error (dbus-register-service bus dbus-service-dbus)) + (should-error (dbus-unregister-service bus dbus-service-dbus))) + +(ert-deftest dbus-test02-register-service-session () + "Check service registration at `:session' bus." + (skip-unless (and dbus--test-enabled-session-bus + (dbus-register-service :session dbus-service-emacs))) + (dbus--test-register-service :session) + + (let ((service "org.freedesktop.Notifications")) + (when (member service (dbus-list-known-names :session)) + ;; Cleanup. + (dbus-ignore-errors (dbus-unregister-service :session service)) + + (should (eq (dbus-register-service :session service) :in-queue)) + (should (eq (dbus-unregister-service :session service) :released)) + + (should + (eq (dbus-register-service :session service :do-not-queue) :exists)) + (should (eq (dbus-unregister-service :session service) :not-owner))))) + +(ert-deftest dbus-test02-register-service-system () + "Check service registration at `:system' bus." + (skip-unless (and dbus--test-enabled-system-bus + (dbus-register-service :system dbus-service-emacs))) + (dbus--test-register-service :system)) + +(ert-deftest dbus-test02-register-service-own-bus () + "Check service registration with an own bus. +This includes initialization and closing the bus." + ;; Start bus. + (let ((output + (ignore-errors + (shell-command-to-string "dbus-launch --sh-syntax"))) + bus pid) + (skip-unless (stringp output)) + (when (string-match "DBUS_SESSION_BUS_ADDRESS='\\(.+\\)';" output) + (setq bus (match-string 1 output))) + (when (string-match "DBUS_SESSION_BUS_PID=\\([[:digit:]]+\\);" output) + (setq pid (match-string 1 output))) + (unwind-protect + (progn + (skip-unless + (dbus-ignore-errors + (and bus pid + (featurep 'dbusbind) + (dbus-init-bus bus) + (dbus-get-unique-name bus) + (dbus-register-service bus dbus-service-emacs)))) + ;; Run the test. + (dbus--test-register-service bus)) + + ;; Save exit. + (when pid (call-process "kill" nil nil nil pid))))) + +(ert-deftest dbus-test03-peer-interface () + "Check `dbus-interface-peer' methods." + (skip-unless + (and dbus--test-enabled-session-bus + (dbus-register-service :session dbus-service-emacs) + ;; "GetMachineId" is not implemented (yet). When it returns a + ;; value, another D-Bus client like dbus-monitor is reacting + ;; on `dbus-interface-peer'. We cannot test then. + (not + (dbus-ignore-errors + (dbus-call-method + :session dbus-service-emacs dbus-path-dbus + dbus-interface-peer "GetMachineId" :timeout 100))))) + + (should (dbus-ping :session dbus-service-emacs 100)) + (dbus-unregister-service :session dbus-service-emacs) + (should-not (dbus-ping :session dbus-service-emacs 100))) + +(defun dbus-test-all (&optional interactive) + "Run all tests for \\[dbus]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^dbus")) + +(provide 'dbus-tests) +;;; dbus-tests.el ends here diff --cc test/lisp/net/newsticker-tests.el index 1e51b9eb693,00000000000..d8531083e60 mode 100644,000000..100644 --- a/test/lisp/net/newsticker-tests.el +++ b/test/lisp/net/newsticker-tests.el @@@ -1,168 -1,0 +1,168 @@@ +;;; newsticker-testsuite.el --- Test suite for newsticker. + - ;; Copyright (C) 2003-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2003-2016 Free Software Foundation, Inc. + +;; Author: Ulf Jasper +;; Keywords: News, RSS, Atom + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'newsticker) + +;; ====================================================================== +;; Tests for newsticker-backend +;; ====================================================================== +(ert-deftest newsticker--guid () + "Test for `newsticker--guid-*'. +Signals an error if something goes wrong." + (should (string= "blah" (newsticker--guid-to-string "blah"))) + (should (string= "myguid" (newsticker--guid '("title1" "description1" "link1" + nil 'new 42 nil nil + ((guid () "myguid"))))))) + +(ert-deftest newsticker--cache-contains () + "Test for `newsticker--cache-contains'." + (let ((newsticker--cache '((feed1 + ("title1" "description1" "link1" nil 'new 42 + nil nil ((guid () "myguid"))))))) + (newsticker--guid-to-string + (assoc 'guid (newsticker--extra '("title1" "description1" + "link1" nil 'new 42 nil nil + ((guid "myguid")))))) + (should (newsticker--cache-contains newsticker--cache 'feed1 "WRONGTITLE" + "description1" "link1" 'new "myguid")) + (should (not (newsticker--cache-contains newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "WRONG GUID"))) + (should (newsticker--cache-contains newsticker--cache 'feed1 "title1" + "description1" "link1" 'new "myguid"))) + (let ((newsticker--cache '((feed1 + ("title1" "description1" "link1" nil 'new 42 + nil nil ((guid () "myguid1"))) + ("title1" "description1" "link1" nil 'new 42 + nil nil ((guid () "myguid2"))))))) + (should (not (newsticker--cache-contains newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "myguid"))) + (should (string= "myguid1" + (newsticker--guid (newsticker--cache-contains + newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "myguid1")))) + (should (string= "myguid2" + (newsticker--guid (newsticker--cache-contains + newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "myguid2")))))) + +(defun newsticker-tests--decode-iso8601-date (input expected) + "Actually test `newsticker--decode-iso8601-date'. +Apply to INPUT and compare with EXPECTED." + (let ((result (format-time-string "%Y-%m-%dT%H:%M:%S" + (newsticker--decode-iso8601-date input) + t))) + (should (string= result expected)))) + +(ert-deftest newsticker--decode-iso8601-date () + "Test `newsticker--decode-iso8601-date'." + (newsticker-tests--decode-iso8601-date "2004" + "2004-01-01T00:00:00") + (newsticker-tests--decode-iso8601-date "2004-09" + "2004-09-01T00:00:00") + (newsticker-tests--decode-iso8601-date "2004-09-17" + "2004-09-17T00:00:00") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09" + "2004-09-17T05:09:00") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09:49" + "2004-09-17T05:09:49") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09:49.123" + "2004-09-17T05:09:49") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09+01:00" + "2004-09-17T04:09:00") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09-02:00" + "2004-09-17T07:09:00")) + +(defun newsticker--do-test--decode-rfc822-date (input expected) + "Actually test `newsticker--decode-rfc822-date'. +Apply to INPUT and compare with EXPECTED." + (let ((result (format-time-string "%Y-%m-%dT%H:%M:%S" + (newsticker--decode-rfc822-date input) + t))) + (should (string= result expected)))) + +(ert-deftest newsticker--decode-rfc822-date () + "Test `newsticker--decode-rfc822-date'." + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008 19:27:52 +0100" + "2008-03-10T18:27:52") + ;;(format-time-string "%d.%m.%y, %H:%M %T%z" + ;;(newsticker--decode-rfc822-date "Mon, 10 Mar 2008 19:27:52 +0200")) + + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008 19:27:52" + "2008-03-10T19:27:52") + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008 19:27" + "2008-03-10T19:27:00") + (newsticker--do-test--decode-rfc822-date "10 Mar 2008 19:27" + "2008-03-10T19:27:00") + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008" + "2008-03-10T00:00:00") + (newsticker--do-test--decode-rfc822-date "10 Mar 2008" + "2008-03-10T00:00:00") + (newsticker--do-test--decode-rfc822-date "Sat, 01 Dec 2007 00:05:00 +0100" + "2007-11-30T23:05:00") + (newsticker--do-test--decode-rfc822-date "Sun, 30 Dec 2007 18:58:13 +0100" + "2007-12-30T17:58:13")) + +;; ====================================================================== +;; Tests for newsticker-treeview +;; ====================================================================== +(ert-deftest newsticker--group-manage-orphan-feeds () + "Test `newsticker--group-manage-orphan-feeds'. +Signals an error if something goes wrong." + (let ((newsticker-groups '("Feeds")) + (newsticker-url-list-defaults nil) + (newsticker-url-list '(("feed1") ("feed2") ("feed3")))) + (newsticker--group-manage-orphan-feeds) + (should (equal '("Feeds" "feed3" "feed2" "feed1") + newsticker-groups)))) + +(ert-deftest newsticker--group-find-parent-group () + "Test `newsticker--group-find-parent-group'." + (let ((newsticker-groups '("g1" "f1a" ("g2" "f2" ("g3" "f3a" "f3b")) "f1b"))) + ;; feeds + (should (equal "g1" (car (newsticker--group-find-parent-group "f1a")))) + (should (equal "g1" (car (newsticker--group-find-parent-group "f1b")))) + (should (equal "g2" (car (newsticker--group-find-parent-group "f2")))) + (should (equal "g3" (car (newsticker--group-find-parent-group "f3b")))) + ;; groups + (should (equal "g1" (car (newsticker--group-find-parent-group "g2")))) + (should (equal "g2" (car (newsticker--group-find-parent-group "g3")))))) + +(ert-deftest newsticker--group-do-rename-group () + "Test `newsticker--group-do-rename-group'." + (let ((newsticker-groups '("g1" "f1a" ("g2" "f2" ("g3" "f3a" "f3b")) "f1b"))) + (should (equal '("g1" "f1a" ("h2" "f2" ("g3" "f3a" "f3b")) "f1b") + (newsticker--group-do-rename-group "g2" "h2"))) + )) + + +(provide 'newsticker-tests) + +;;; newsticker-tests.el ends here diff --cc test/lisp/net/sasl-scram-rfc-tests.el index 46b139b21a7,00000000000..130de240481 mode 100644,000000..100644 --- a/test/lisp/net/sasl-scram-rfc-tests.el +++ b/test/lisp/net/sasl-scram-rfc-tests.el @@@ -1,50 -1,0 +1,50 @@@ +;;; sasl-scram-rfc-tests.el --- tests for SCRAM-SHA-1 -*- lexical-binding: t; -*- + - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Magnus Henoch + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Test cases from RFC 5802. + +;;; Code: + +(require 'sasl) +(require 'sasl-scram-rfc) + +(ert-deftest sasl-scram-sha-1-test () + ;; The following strings are taken from section 5 of RFC 5802. + (let ((client + (sasl-make-client (sasl-find-mechanism '("SCRAM-SHA-1")) + "user" + "imap" + "localhost")) + (data "r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,s=QSXCR+Q6sek8bf92,i=4096") + (c-nonce "fyko+d2lbbFgONRv9qkxdawL") + (sasl-read-passphrase + (lambda (_prompt) (copy-sequence "pencil")))) + (sasl-client-set-property client 'c-nonce c-nonce) + (should + (equal + (sasl-scram-sha-1-client-final-message client (vector nil data)) + "c=biws,r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,p=v0X8v3Bz2T0CJGbJQyF0X+HI4Ts=")) + + ;; This should not throw an error: + (sasl-scram-sha-1-authenticate-server client (vector nil "v=rmF9pqV8S7suAoZWja4dJRkFsKQ= +")))) + +;;; sasl-scram-rfc-tests.el ends here diff --cc test/lisp/net/tramp-tests.el index 23171d6e983,00000000000..5938ada8486 mode 100644,000000..100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@@ -1,2280 -1,0 +1,2280 @@@ +;;; tramp-tests.el --- Tests of remote file access + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; The tests require a recent ert.el from Emacs 24.4. + +;; Some of the tests require access to a remote host files. Since +;; this could be problematic, a mock-up connection method "mock" is +;; used. Emulating a remote connection, it simply calls "sh -i". +;; Tramp's file name handlers still run, so this test is sufficient +;; except for connection establishing. + +;; If you want to test a real Tramp connection, set +;; $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable value in order to +;; overwrite the default value. If you want to skip tests accessing a +;; remote host, set this environment variable to "/dev/null" or +;; whatever is appropriate on your system. + +;; A whole test run can be performed calling the command `tramp-test-all'. + +;;; Code: + +(require 'ert) +(require 'tramp) +(require 'vc) +(require 'vc-bzr) +(require 'vc-git) +(require 'vc-hg) + +(declare-function tramp-find-executable "tramp-sh") +(declare-function tramp-get-remote-path "tramp-sh") +(declare-function tramp-get-remote-stat "tramp-sh") +(declare-function tramp-get-remote-perl "tramp-sh") +(defvar tramp-copy-size-limit) +(defvar tramp-persistency-file-name) +(defvar tramp-remote-process-environment) + +;; There is no default value on w32 systems, which could work out of the box. +(defconst tramp-test-temporary-file-directory + (cond + ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY")) + ((eq system-type 'windows-nt) null-device) + (t (add-to-list + 'tramp-methods + '("mock" + (tramp-login-program "sh") + (tramp-login-args (("-i"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (format "/mock::%s" temporary-file-directory))) + "Temporary directory for Tramp tests.") + +(setq password-cache-expiry nil + tramp-verbose 0 + tramp-copy-size-limit nil + tramp-message-show-message nil + tramp-persistency-file-name nil) + +;; This shall happen on hydra only. +(when (getenv "NIX_STORE") + (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) + +(defvar tramp--test-enabled-checked nil + "Cached result of `tramp--test-enabled'. +If the function did run, the value is a cons cell, the `cdr' +being the result.") + +(defun tramp--test-enabled () + "Whether remote file access is enabled." + (unless (consp tramp--test-enabled-checked) + (setq + tramp--test-enabled-checked + (cons + t (ignore-errors + (and + (file-remote-p tramp-test-temporary-file-directory) + (file-directory-p tramp-test-temporary-file-directory) + (file-writable-p tramp-test-temporary-file-directory)))))) + + (when (cdr tramp--test-enabled-checked) + ;; Cleanup connection. + (ignore-errors + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + nil 'keep-password))) + + ;; Return result. + (cdr tramp--test-enabled-checked)) + +(defun tramp--test-make-temp-name (&optional local) + "Create a temporary file name for test." + (expand-file-name + (make-temp-name "tramp-test") + (if local temporary-file-directory tramp-test-temporary-file-directory))) + +(defmacro tramp--instrument-test-case (verbose &rest body) + "Run BODY with `tramp-verbose' equal VERBOSE. +Print the the content of the Tramp debug buffer, if BODY does not +eval properly in `should', `should-not' or `should-error'. BODY +shall not contain a timeout." + (declare (indent 1) (debug (natnump body))) + `(let ((tramp-verbose ,verbose) + (tramp-message-show-message t) + (tramp-debug-on-error t) + (debug-ignored-errors + (cons "^make-symbolic-link not supported$" debug-ignored-errors))) + (unwind-protect + (progn ,@body) + (when (> tramp-verbose 3) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (with-current-buffer (tramp-get-connection-buffer v) + (message "%s" (buffer-string))) + (with-current-buffer (tramp-get-debug-buffer v) + (message "%s" (buffer-string)))))))) + +(ert-deftest tramp-test00-availability () + "Test availability of Tramp functions." + :expected-result (if (tramp--test-enabled) :passed :failed) + (message "Remote directory: `%s'" tramp-test-temporary-file-directory) + (should (ignore-errors + (and + (file-remote-p tramp-test-temporary-file-directory) + (file-directory-p tramp-test-temporary-file-directory) + (file-writable-p tramp-test-temporary-file-directory))))) + +(ert-deftest tramp-test01-file-name-syntax () + "Check remote file name syntax." + ;; Simple cases. + (should (tramp-tramp-file-p "/method::")) + (should (tramp-tramp-file-p "/host:")) + (should (tramp-tramp-file-p "/user@:")) + (should (tramp-tramp-file-p "/user@host:")) + (should (tramp-tramp-file-p "/method:host:")) + (should (tramp-tramp-file-p "/method:user@:")) + (should (tramp-tramp-file-p "/method:user@host:")) + (should (tramp-tramp-file-p "/method:user@email@host:")) + + ;; Using a port. + (should (tramp-tramp-file-p "/host#1234:")) + (should (tramp-tramp-file-p "/user@host#1234:")) + (should (tramp-tramp-file-p "/method:host#1234:")) + (should (tramp-tramp-file-p "/method:user@host#1234:")) + + ;; Using an IPv4 address. + (should (tramp-tramp-file-p "/1.2.3.4:")) + (should (tramp-tramp-file-p "/user@1.2.3.4:")) + (should (tramp-tramp-file-p "/method:1.2.3.4:")) + (should (tramp-tramp-file-p "/method:user@1.2.3.4:")) + + ;; Using an IPv6 address. + (should (tramp-tramp-file-p "/[]:")) + (should (tramp-tramp-file-p "/[::1]:")) + (should (tramp-tramp-file-p "/user@[::1]:")) + (should (tramp-tramp-file-p "/method:[::1]:")) + (should (tramp-tramp-file-p "/method:user@[::1]:")) + + ;; Local file name part. + (should (tramp-tramp-file-p "/host:/:")) + (should (tramp-tramp-file-p "/method:::")) + (should (tramp-tramp-file-p "/method::/path/to/file")) + (should (tramp-tramp-file-p "/method::file")) + + ;; Multihop. + (should (tramp-tramp-file-p "/method1:|method2::")) + (should (tramp-tramp-file-p "/method1:host1|host2:")) + (should (tramp-tramp-file-p "/method1:host1|method2:host2:")) + (should (tramp-tramp-file-p "/method1:user1@host1|method2:user2@host2:")) + (should (tramp-tramp-file-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:")) + + ;; No strings. + (should-not (tramp-tramp-file-p nil)) + (should-not (tramp-tramp-file-p 'symbol)) + ;; "/:" suppresses file name handlers. + (should-not (tramp-tramp-file-p "/::")) + (should-not (tramp-tramp-file-p "/:@:")) + (should-not (tramp-tramp-file-p "/:[]:")) + ;; Multihops require a method. + (should-not (tramp-tramp-file-p "/host1|host2:")) + ;; Methods or hostnames shall be at least two characters on MS Windows. + (when (memq system-type '(cygwin windows-nt)) + (should-not (tramp-tramp-file-p "/c:/path/to/file")) + (should-not (tramp-tramp-file-p "/c::/path/to/file")))) + +(ert-deftest tramp-test02-file-name-dissect () + "Check remote file name components." + (let ((tramp-default-method "default-method") + (tramp-default-user "default-user") + (tramp-default-host "default-host")) + ;; Expand `tramp-default-user' and `tramp-default-host'. + (should (string-equal + (file-remote-p "/method::") + (format "/%s:%s@%s:" "method" "default-user" "default-host"))) + (should (string-equal (file-remote-p "/method::" 'method) "method")) + (should (string-equal (file-remote-p "/method::" 'user) "default-user")) + (should (string-equal (file-remote-p "/method::" 'host) "default-host")) + (should (string-equal (file-remote-p "/method::" 'localname) "")) + (should (string-equal (file-remote-p "/method::" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/host:") + (format "/%s:%s@%s:" "default-method" "default-user" "host"))) + (should (string-equal (file-remote-p "/host:" 'method) "default-method")) + (should (string-equal (file-remote-p "/host:" 'user) "default-user")) + (should (string-equal (file-remote-p "/host:" 'host) "host")) + (should (string-equal (file-remote-p "/host:" 'localname) "")) + (should (string-equal (file-remote-p "/host:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-host'. + (should (string-equal + (file-remote-p "/user@:") + (format "/%s:%s@%s:" "default-method""user" "default-host"))) + (should (string-equal (file-remote-p "/user@:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@:" 'user) "user")) + (should (string-equal (file-remote-p "/user@:" 'host) "default-host")) + (should (string-equal (file-remote-p "/user@:" 'localname) "")) + (should (string-equal (file-remote-p "/user@:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@host:") + (format "/%s:%s@%s:" "default-method" "user" "host"))) + (should (string-equal + (file-remote-p "/user@host:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@host:" 'user) "user")) + (should (string-equal (file-remote-p "/user@host:" 'host) "host")) + (should (string-equal (file-remote-p "/user@host:" 'localname) "")) + (should (string-equal (file-remote-p "/user@host:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:host:") + (format "/%s:%s@%s:" "method" "default-user" "host"))) + (should (string-equal (file-remote-p "/method:host:" 'method) "method")) + (should (string-equal (file-remote-p "/method:host:" 'user) "default-user")) + (should (string-equal (file-remote-p "/method:host:" 'host) "host")) + (should (string-equal (file-remote-p "/method:host:" 'localname) "")) + (should (string-equal (file-remote-p "/method:host:" 'hop) nil)) + + ;; Expand `tramp-default-host'. + (should (string-equal + (file-remote-p "/method:user@:") + (format "/%s:%s@%s:" "method" "user" "default-host"))) + (should (string-equal (file-remote-p "/method:user@:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@:" 'user) "user")) + (should (string-equal (file-remote-p "/method:user@:" 'host) + "default-host")) + (should (string-equal (file-remote-p "/method:user@:" 'localname) "")) + (should (string-equal (file-remote-p "/method:user@:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@host:") + (format "/%s:%s@%s:" "method" "user" "host"))) + (should (string-equal + (file-remote-p "/method:user@host:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@host:" 'user) "user")) + (should (string-equal (file-remote-p "/method:user@host:" 'host) "host")) + (should (string-equal (file-remote-p "/method:user@host:" 'localname) "")) + (should (string-equal (file-remote-p "/method:user@host:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@email@host:") + (format "/%s:%s@%s:" "method" "user@email" "host"))) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'user) "user@email")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'host) "host")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'localname) "")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/host#1234:") + (format "/%s:%s@%s:" "default-method" "default-user" "host#1234"))) + (should (string-equal + (file-remote-p "/host#1234:" 'method) "default-method")) + (should (string-equal (file-remote-p "/host#1234:" 'user) "default-user")) + (should (string-equal (file-remote-p "/host#1234:" 'host) "host#1234")) + (should (string-equal (file-remote-p "/host#1234:" 'localname) "")) + (should (string-equal (file-remote-p "/host#1234:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@host#1234:") + (format "/%s:%s@%s:" "default-method" "user" "host#1234"))) + (should (string-equal + (file-remote-p "/user@host#1234:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@host#1234:" 'user) "user")) + (should (string-equal (file-remote-p "/user@host#1234:" 'host) "host#1234")) + (should (string-equal (file-remote-p "/user@host#1234:" 'localname) "")) + (should (string-equal (file-remote-p "/user@host#1234:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:host#1234:") + (format "/%s:%s@%s:" "method" "default-user" "host#1234"))) + (should (string-equal + (file-remote-p "/method:host#1234:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:host#1234:" 'user) "default-user")) + (should (string-equal + (file-remote-p "/method:host#1234:" 'host) "host#1234")) + (should (string-equal (file-remote-p "/method:host#1234:" 'localname) "")) + (should (string-equal (file-remote-p "/method:host#1234:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@host#1234:") + (format "/%s:%s@%s:" "method" "user" "host#1234"))) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'user) "user")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'host) "host#1234")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'localname) "")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/1.2.3.4:") + (format "/%s:%s@%s:" "default-method" "default-user" "1.2.3.4"))) + (should (string-equal (file-remote-p "/1.2.3.4:" 'method) "default-method")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'user) "default-user")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'localname) "")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@1.2.3.4:") + (format "/%s:%s@%s:" "default-method" "user" "1.2.3.4"))) + (should (string-equal + (file-remote-p "/user@1.2.3.4:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'user) "user")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'localname) "")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:1.2.3.4:") + (format "/%s:%s@%s:" "method" "default-user" "1.2.3.4"))) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:1.2.3.4:" 'user) "default-user")) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'localname) "")) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:") + (format "/%s:%s@%s:" "method" "user" "1.2.3.4"))) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@1.2.3.4:" 'user) "user")) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'localname) "")) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'hop) nil)) + + ;; Expand `tramp-default-method', `tramp-default-user' and + ;; `tramp-default-host'. + (should (string-equal + (file-remote-p "/[]:") + (format + "/%s:%s@%s:" "default-method" "default-user" "default-host"))) + (should (string-equal (file-remote-p "/[]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/[]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/[]:" 'host) "default-host")) + (should (string-equal (file-remote-p "/[]:" 'localname) "")) + (should (string-equal (file-remote-p "/[]:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (let ((tramp-default-host "::1")) + (should (string-equal + (file-remote-p "/[]:") + (format "/%s:%s@%s:" "default-method" "default-user" "[::1]"))) + (should (string-equal (file-remote-p "/[]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/[]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/[]:" 'host) "::1")) + (should (string-equal (file-remote-p "/[]:" 'localname) "")) + (should (string-equal (file-remote-p "/[]:" 'hop) nil))) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/[::1]:") + (format "/%s:%s@%s:" "default-method" "default-user" "[::1]"))) + (should (string-equal (file-remote-p "/[::1]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/[::1]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/[::1]:" 'host) "::1")) + (should (string-equal (file-remote-p "/[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/[::1]:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@[::1]:") + (format "/%s:%s@%s:" "default-method" "user" "[::1]"))) + (should (string-equal + (file-remote-p "/user@[::1]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@[::1]:" 'user) "user")) + (should (string-equal (file-remote-p "/user@[::1]:" 'host) "::1")) + (should (string-equal (file-remote-p "/user@[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/user@[::1]:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:[::1]:") + (format "/%s:%s@%s:" "method" "default-user" "[::1]"))) + (should (string-equal (file-remote-p "/method:[::1]:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:[::1]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/method:[::1]:" 'host) "::1")) + (should (string-equal (file-remote-p "/method:[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/method:[::1]:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@[::1]:") + (format "/%s:%s@%s:" "method" "user" "[::1]"))) + (should (string-equal + (file-remote-p "/method:user@[::1]:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@[::1]:" 'user) "user")) + (should (string-equal (file-remote-p "/method:user@[::1]:" 'host) "::1")) + (should (string-equal + (file-remote-p "/method:user@[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/method:user@[::1]:" 'hop) nil)) + + ;; Local file name part. + (should (string-equal (file-remote-p "/host:/:" 'localname) "/:")) + (should (string-equal (file-remote-p "/method:::" 'localname) ":")) + (should (string-equal (file-remote-p "/method:: " 'localname) " ")) + (should (string-equal (file-remote-p "/method::file" 'localname) "file")) + (should (string-equal + (file-remote-p "/method::/path/to/file" 'localname) + "/path/to/file")) + + ;; Multihop. + (should + (string-equal + (file-remote-p "/method1:user1@host1|method2:user2@host2:/path/to/file") + (format "/%s:%s@%s|%s:%s@%s:" + "method1" "user1" "host1" "method2" "user2" "host2"))) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'method) + "method2")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'user) + "user2")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'host) + "host2")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'localname) + "/path/to/file")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'hop) + (format "%s:%s@%s|" + "method1" "user1" "host1"))) + + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file") + (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:" + "method1" "user1" "host1" + "method2" "user2" "host2" + "method3" "user3" "host3"))) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'method) + "method3")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'user) + "user3")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'host) + "host3")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'localname) + "/path/to/file")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'hop) + (format "%s:%s@%s|%s:%s@%s|" + "method1" "user1" "host1" "method2" "user2" "host2"))))) + +(ert-deftest tramp-test03-file-name-defaults () + "Check default values for some methods." + ;; Default values in tramp-adb.el. + (should (string-equal (file-remote-p "/adb::" 'host) "")) + ;; Default values in tramp-ftp.el. + (should (string-equal (file-remote-p "/ftp.host:" 'method) "ftp")) + (dolist (u '("ftp" "anonymous")) + (should (string-equal (file-remote-p (format "/%s@:" u) 'method) "ftp"))) + ;; Default values in tramp-gvfs.el. + (when (and (load "tramp-gvfs" 'noerror 'nomessage) + (symbol-value 'tramp-gvfs-enabled)) + (should (string-equal (file-remote-p "/synce::" 'user) nil))) + ;; Default values in tramp-gw.el. + (dolist (m '("tunnel" "socks")) + (should + (string-equal (file-remote-p (format "/%s::" m) 'user) (user-login-name)))) + ;; Default values in tramp-sh.el. + (dolist (h `("127.0.0.1" "[::1]" "localhost" "localhost6" ,(system-name))) + (should (string-equal (file-remote-p (format "/root@%s:" h) 'method) "su"))) + (dolist (m '("su" "sudo" "ksu")) + (should (string-equal (file-remote-p (format "/%s::" m) 'user) "root"))) + (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp")) + (should + (string-equal (file-remote-p (format "/%s::" m) 'user) (user-login-name)))) + ;; Default values in tramp-smb.el. + (should (string-equal (file-remote-p "/user%domain@host:" 'method) "smb")) + (should (string-equal (file-remote-p "/smb::" 'user) nil))) + +(ert-deftest tramp-test04-substitute-in-file-name () + "Check `substitute-in-file-name'." + (should (string-equal (substitute-in-file-name "/method:host://foo") "/foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo")) + (should + (string-equal (substitute-in-file-name "/method:host:/path///foo") "/foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/~/foo") "/method:host:~/foo")) + (should + (string-equal (substitute-in-file-name "/method:host:/path//~/foo") "~/foo")) + (let (process-environment) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$FOO") + "/method:host:/path/$FOO")) + (setenv "FOO" "bla") + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$FOO") + "/method:host:/path/bla")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$$FOO") + "/method:host:/path/$FOO")))) + +(ert-deftest tramp-test05-expand-file-name () + "Check `expand-file-name'." + (should + (string-equal + (expand-file-name "/method:host:/path/./file") "/method:host:/path/file")) + (should + (string-equal + (expand-file-name "/method:host:/path/../file") "/method:host:/file"))) + +(ert-deftest tramp-test06-directory-file-name () + "Check `directory-file-name'. +This checks also `file-name-as-directory', `file-name-directory', +`file-name-nondirectory' and `unhandled-file-name-directory'." + (should + (string-equal + (directory-file-name "/method:host:/path/to/file") + "/method:host:/path/to/file")) + (should + (string-equal + (directory-file-name "/method:host:/path/to/file/") + "/method:host:/path/to/file")) + (should + (string-equal + (file-name-as-directory "/method:host:/path/to/file") + "/method:host:/path/to/file/")) + (should + (string-equal + (file-name-as-directory "/method:host:/path/to/file/") + "/method:host:/path/to/file/")) + (should + (string-equal + (file-name-directory "/method:host:/path/to/file") + "/method:host:/path/to/")) + (should + (string-equal + (file-name-directory "/method:host:/path/to/file/") + "/method:host:/path/to/file/")) + (should + (string-equal (file-name-nondirectory "/method:host:/path/to/file") "file")) + (should + (string-equal (file-name-nondirectory "/method:host:/path/to/file/") "")) + (should-not + (unhandled-file-name-directory "/method:host:/path/to/file"))) + +(ert-deftest tramp-test07-file-exists-p () + "Check `file-exist-p', `write-region' and `delete-file'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (should-not (file-exists-p tmp-name)) + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (delete-file tmp-name) + (should-not (file-exists-p tmp-name)))) + +(ert-deftest tramp-test08-file-local-copy () + "Check `file-local-copy'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + tmp-name2) + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (setq tmp-name2 (file-local-copy tmp-name1))) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "foo"))) + ;; Check also that a file transfer with compression works. + (let ((default-directory tramp-test-temporary-file-directory) + (tramp-copy-size-limit 4) + (tramp-inline-compress-start-size 2)) + (delete-file tmp-name2) + (should (setq tmp-name2 (file-local-copy tmp-name1))))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))))) + +(ert-deftest tramp-test09-insert-file-contents () + "Check `insert-file-contents'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo")) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foofoo")) + ;; Insert partly. + (insert-file-contents tmp-name nil 1 3) + (should (string-equal (buffer-string) "oofoofoo")) + ;; Replace. + (insert-file-contents tmp-name nil nil nil 'replace) + (should (string-equal (buffer-string) "foo")))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test10-write-region () + "Check `write-region'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (with-temp-buffer + (insert "foo") + (write-region nil nil tmp-name)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo"))) + ;; Append. + (with-temp-buffer + (insert "bla") + (write-region nil nil tmp-name 'append)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foobla"))) + ;; Write string. + (write-region "foo" nil tmp-name) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo"))) + ;; Write partly. + (with-temp-buffer + (insert "123456789") + (write-region 3 5 tmp-name)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "34")))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test11-copy-file () + "Check `copy-file'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name)) + (tmp-name4 (tramp--test-make-temp-name 'local)) + (tmp-name5 (tramp--test-make-temp-name 'local))) + + ;; Copy on remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (copy-file tmp-name1 tmp-name2) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "foo"))) + (should-error (copy-file tmp-name1 tmp-name2)) + (copy-file tmp-name1 tmp-name2 'ok) + (make-directory tmp-name3) + (copy-file tmp-name1 tmp-name3) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2)) + (ignore-errors (delete-directory tmp-name3 'recursive))) + + ;; Copy from remote side to local side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (copy-file tmp-name1 tmp-name4) + (should (file-exists-p tmp-name4)) + (with-temp-buffer + (insert-file-contents tmp-name4) + (should (string-equal (buffer-string) "foo"))) + (should-error (copy-file tmp-name1 tmp-name4)) + (copy-file tmp-name1 tmp-name4 'ok) + (make-directory tmp-name5) + (copy-file tmp-name1 tmp-name5) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name5)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name5 'recursive))) + + ;; Copy from local side to remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name4 nil 'nomessage) + (copy-file tmp-name4 tmp-name1) + (should (file-exists-p tmp-name1)) + (with-temp-buffer + (insert-file-contents tmp-name1) + (should (string-equal (buffer-string) "foo"))) + (should-error (copy-file tmp-name4 tmp-name1)) + (copy-file tmp-name4 tmp-name1 'ok) + (make-directory tmp-name3) + (copy-file tmp-name4 tmp-name3) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name4) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name3 'recursive))))) + +(ert-deftest tramp-test12-rename-file () + "Check `rename-file'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name)) + (tmp-name4 (tramp--test-make-temp-name 'local)) + (tmp-name5 (tramp--test-make-temp-name 'local))) + + ;; Rename on remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (rename-file tmp-name1 tmp-name2) + (should-not (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "foo"))) + (write-region "foo" nil tmp-name1) + (should-error (rename-file tmp-name1 tmp-name2)) + (rename-file tmp-name1 tmp-name2 'ok) + (should-not (file-exists-p tmp-name1)) + (write-region "foo" nil tmp-name1) + (make-directory tmp-name3) + (rename-file tmp-name1 tmp-name3) + (should-not (file-exists-p tmp-name1)) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2)) + (ignore-errors (delete-directory tmp-name3 'recursive))) + + ;; Rename from remote side to local side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (rename-file tmp-name1 tmp-name4) + (should-not (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name4)) + (with-temp-buffer + (insert-file-contents tmp-name4) + (should (string-equal (buffer-string) "foo"))) + (write-region "foo" nil tmp-name1) + (should-error (rename-file tmp-name1 tmp-name4)) + (rename-file tmp-name1 tmp-name4 'ok) + (should-not (file-exists-p tmp-name1)) + (write-region "foo" nil tmp-name1) + (make-directory tmp-name5) + (rename-file tmp-name1 tmp-name5) + (should-not (file-exists-p tmp-name1)) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name5)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name5 'recursive))) + + ;; Rename from local side to remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name4 nil 'nomessage) + (rename-file tmp-name4 tmp-name1) + (should-not (file-exists-p tmp-name4)) + (should (file-exists-p tmp-name1)) + (with-temp-buffer + (insert-file-contents tmp-name1) + (should (string-equal (buffer-string) "foo"))) + (write-region "foo" nil tmp-name4 nil 'nomessage) + (should-error (rename-file tmp-name4 tmp-name1)) + (rename-file tmp-name4 tmp-name1 'ok) + (should-not (file-exists-p tmp-name4)) + (write-region "foo" nil tmp-name4 nil 'nomessage) + (make-directory tmp-name3) + (rename-file tmp-name4 tmp-name3) + (should-not (file-exists-p tmp-name4)) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name4) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name3 'recursive))))) + +(ert-deftest tramp-test13-make-directory () + "Check `make-directory'. +This tests also `file-directory-p' and `file-accessible-directory-p'." + (skip-unless (tramp--test-enabled)) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "foo/bar" tmp-name1))) + (unwind-protect + (progn + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (should (file-accessible-directory-p tmp-name1)) + (should-error (make-directory tmp-name2) :type 'file-error) + (make-directory tmp-name2 'parents) + (should (file-directory-p tmp-name2)) + (should (file-accessible-directory-p tmp-name2))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + +(ert-deftest tramp-test14-delete-directory () + "Check `delete-directory'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + ;; Delete empty directory. + (make-directory tmp-name) + (should (file-directory-p tmp-name)) + (delete-directory tmp-name) + (should-not (file-directory-p tmp-name)) + ;; Delete non-empty directory. + (make-directory tmp-name) + (write-region "foo" nil (expand-file-name "bla" tmp-name)) + (should-error (delete-directory tmp-name) :type 'file-error) + (delete-directory tmp-name 'recursive) + (should-not (file-directory-p tmp-name)))) + +(ert-deftest tramp-test15-copy-directory () + "Check `copy-directory'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-smb-file-name-handler))) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (expand-file-name + (file-name-nondirectory tmp-name1) tmp-name2)) + (tmp-name4 (expand-file-name "foo" tmp-name1)) + (tmp-name5 (expand-file-name "foo" tmp-name2)) + (tmp-name6 (expand-file-name "foo" tmp-name3))) + (unwind-protect + (progn + ;; Copy empty directory. + (make-directory tmp-name1) + (write-region "foo" nil tmp-name4) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name4)) + (copy-directory tmp-name1 tmp-name2) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name5)) + ;; Target directory does exist already. + (copy-directory tmp-name1 tmp-name2) + (should (file-directory-p tmp-name3)) + (should (file-exists-p tmp-name6))) + + ;; Cleanup. + (ignore-errors + (delete-directory tmp-name1 'recursive) + (delete-directory tmp-name2 'recursive))))) + +(ert-deftest tramp-test16-directory-files () + "Check `directory-files'." + (skip-unless (tramp--test-enabled)) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "bla" tmp-name1)) + (tmp-name3 (expand-file-name "foo" tmp-name1))) + (unwind-protect + (progn + (make-directory tmp-name1) + (write-region "foo" nil tmp-name2) + (write-region "bla" nil tmp-name3) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (should (file-exists-p tmp-name3)) + (should (equal (directory-files tmp-name1) '("." ".." "bla" "foo"))) + (should (equal (directory-files tmp-name1 'full) + `(,(concat tmp-name1 "/.") + ,(concat tmp-name1 "/..") + ,tmp-name2 ,tmp-name3))) + (should (equal (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp) + '("bla" "foo"))) + (should (equal (directory-files + tmp-name1 'full directory-files-no-dot-files-regexp) + `(,tmp-name2 ,tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + +(ert-deftest tramp-test17-insert-directory () + "Check `insert-directory'." + (skip-unless (tramp--test-enabled)) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "foo" tmp-name1)) + ;; We test for the summary line. Keyword "total" could be localized. + (process-environment + (append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment))) + (unwind-protect + (progn + (make-directory tmp-name1) + (write-region "foo" nil tmp-name2) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-directory tmp-name1 nil) + (goto-char (point-min)) + (should (looking-at-p (regexp-quote tmp-name1)))) + (with-temp-buffer + (insert-directory tmp-name1 "-al") + (goto-char (point-min)) + (should (looking-at-p (format "^.+ %s$" (regexp-quote tmp-name1))))) + (with-temp-buffer + (insert-directory (file-name-as-directory tmp-name1) "-al") + (goto-char (point-min)) + (should + (looking-at-p (format "^.+ %s/$" (regexp-quote tmp-name1))))) + (with-temp-buffer + (insert-directory + (file-name-as-directory tmp-name1) "-al" nil 'full-directory-p) + (goto-char (point-min)) + (should + (looking-at-p + (concat + ;; There might be a summary line. + "\\(total.+[[:digit:]]+\n\\)?" + ;; We don't know in which order ".", ".." and "foo" appear. + "\\(.+ \\(\\.?\\.\\|foo\\)\n\\)\\{3\\}"))))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + +(ert-deftest tramp-test18-file-attributes () + "Check `file-attributes'. +This tests also `file-readable-p' and `file-regular-p'." + (skip-unless (tramp--test-enabled)) + + ;; We must use `file-truename' for the temporary directory, because + ;; it could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-test-temporary-file-directory + (file-truename tramp-test-temporary-file-directory)) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + ;; File name with "//". + (tmp-name3 + (format + "%s%s" + (file-remote-p tmp-name1) + (replace-regexp-in-string + "/" "//" (file-remote-p tmp-name1 'localname)))) + attr) + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (setq attr (file-attributes tmp-name1)) + (should (consp attr)) + (should (file-exists-p tmp-name1)) + (should (file-readable-p tmp-name1)) + (should (file-regular-p tmp-name1)) + ;; We do not test inodes and device numbers. + (should (null (car attr))) + (should (numberp (nth 1 attr))) ;; Link. + (should (numberp (nth 2 attr))) ;; Uid. + (should (numberp (nth 3 attr))) ;; Gid. + ;; Last access time. + (should (stringp (current-time-string (nth 4 attr)))) + ;; Last modification time. + (should (stringp (current-time-string (nth 5 attr)))) + ;; Last status change time. + (should (stringp (current-time-string (nth 6 attr)))) + (should (numberp (nth 7 attr))) ;; Size. + (should (stringp (nth 8 attr))) ;; Modes. + + (setq attr (file-attributes tmp-name1 'string)) + (should (stringp (nth 2 attr))) ;; Uid. + (should (stringp (nth 3 attr))) ;; Gid. + + (condition-case err + (progn + (make-symbolic-link tmp-name1 tmp-name2) + (should (file-exists-p tmp-name2)) + (should (file-symlink-p tmp-name2)) + (setq attr (file-attributes tmp-name2)) + (should (string-equal + (car attr) + (file-remote-p (file-truename tmp-name1) 'localname))) + (delete-file tmp-name2)) + (file-error + (should (string-equal (error-message-string err) + "make-symbolic-link not supported")))) + + ;; Check, that "//" in symlinks are handled properly. + (with-temp-buffer + (let ((default-directory tramp-test-temporary-file-directory)) + (shell-command + (format + "ln -s %s %s" + (tramp-file-name-localname (tramp-dissect-file-name tmp-name3)) + (tramp-file-name-localname (tramp-dissect-file-name tmp-name2))) + t))) + (when (file-symlink-p tmp-name2) + (setq attr (file-attributes tmp-name2)) + (should + (string-equal + (car attr) + (tramp-file-name-localname (tramp-dissect-file-name tmp-name3)))) + (delete-file tmp-name2)) + + (delete-file tmp-name1) + (make-directory tmp-name1) + (should (file-exists-p tmp-name1)) + (should (file-readable-p tmp-name1)) + (should-not (file-regular-p tmp-name1)) + (setq attr (file-attributes tmp-name1)) + (should (eq (car attr) t))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1)) + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2))))) + +(ert-deftest tramp-test19-directory-files-and-attributes () + "Check `directory-files-and-attributes'." + (skip-unless (tramp--test-enabled)) + + ;; `directory-files-and-attributes' contains also values for "../". + ;; Ensure that this doesn't change during tests, for + ;; example due to handling temporary files. + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "bla" tmp-name1)) + attr) + (unwind-protect + (progn + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (write-region "foo" nil (expand-file-name "foo" tmp-name2)) + (write-region "bar" nil (expand-file-name "bar" tmp-name2)) + (write-region "boz" nil (expand-file-name "boz" tmp-name2)) + (setq attr (directory-files-and-attributes tmp-name2)) + (should (consp attr)) + ;; Dumb remote shells without perl(1) or stat(1) are not + ;; able to return the date correctly. They say "don't know". + (dolist (elt attr) + (unless + (equal + (nth 5 + (file-attributes (expand-file-name (car elt) tmp-name2))) + '(0 0)) + (should + (equal (file-attributes (expand-file-name (car elt) tmp-name2)) + (cdr elt))))) + (setq attr (directory-files-and-attributes tmp-name2 'full)) + (dolist (elt attr) + (unless (equal (nth 5 (file-attributes (car elt))) '(0 0)) + (should + (equal (file-attributes (car elt)) (cdr elt))))) + (setq attr (directory-files-and-attributes tmp-name2 nil "^b")) + (should (equal (mapcar 'car attr) '("bar" "boz")))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + +(ert-deftest tramp-test20-file-modes () + "Check `file-modes'. +This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-adb-file-name-handler + tramp-gvfs-file-name-handler + tramp-smb-file-name-handler)))) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (set-file-modes tmp-name #o777) + (should (= (file-modes tmp-name) #o777)) + (should (file-executable-p tmp-name)) + (should (file-writable-p tmp-name)) + (set-file-modes tmp-name #o444) + (should (= (file-modes tmp-name) #o444)) + (should-not (file-executable-p tmp-name)) + ;; A file is always writable for user "root". + (unless (zerop (nth 2 (file-attributes tmp-name))) + (should-not (file-writable-p tmp-name)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test21-file-links () + "Check `file-symlink-p'. +This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." + (skip-unless (tramp--test-enabled)) + + ;; We must use `file-truename' for the temporary directory, because + ;; it could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-test-temporary-file-directory + (file-truename tramp-test-temporary-file-directory)) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name 'local))) + + ;; Check `make-symbolic-link'. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + ;; Method "smb" supports `make-symbolic-link' only if the + ;; remote host has CIFS capabilities. tramp-adb.el and + ;; tramp-gvfs.el do not support symbolic links at all. + (condition-case err + (make-symbolic-link tmp-name1 tmp-name2) + (file-error + (skip-unless + (not (string-equal (error-message-string err) + "make-symbolic-link not supported"))))) + (should (file-symlink-p tmp-name2)) + (should-error (make-symbolic-link tmp-name1 tmp-name2)) + (make-symbolic-link tmp-name1 tmp-name2 'ok-if-already-exists) + (should (file-symlink-p tmp-name2)) + ;; `tmp-name3' is a local file name. + (should-error (make-symbolic-link tmp-name1 tmp-name3))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))) + + ;; Check `add-name-to-file'. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (add-name-to-file tmp-name1 tmp-name2) + (should-not (file-symlink-p tmp-name2)) + (should-error (add-name-to-file tmp-name1 tmp-name2)) + (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) + (should-not (file-symlink-p tmp-name2)) + ;; `tmp-name3' is a local file name. + (should-error (add-name-to-file tmp-name1 tmp-name3))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))) + + ;; Check `file-truename'. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (make-symbolic-link tmp-name1 tmp-name2) + (should (file-symlink-p tmp-name2)) + (should-not (string-equal tmp-name2 (file-truename tmp-name2))) + (should + (string-equal (file-truename tmp-name1) (file-truename tmp-name2))) + (should (file-equal-p tmp-name1 tmp-name2))) + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))) + + ;; `file-truename' shall preserve trailing link of directories. + (unless (file-symlink-p tramp-test-temporary-file-directory) + (let* ((dir1 (directory-file-name tramp-test-temporary-file-directory)) + (dir2 (file-name-as-directory dir1))) + (should (string-equal (file-truename dir1) (expand-file-name dir1))) + (should (string-equal (file-truename dir2) (expand-file-name dir2))))))) + +(ert-deftest tramp-test22-file-times () + "Check `set-file-times' and `file-newer-than-file-p'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-gvfs-file-name-handler tramp-smb-file-name-handler)))) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (should (consp (nth 5 (file-attributes tmp-name1)))) + ;; '(0 0) means don't know, and will be replaced by + ;; `current-time'. Therefore, we use '(0 1). + ;; We skip the test, if the remote handler is not able to + ;; set the correct time. + (skip-unless (set-file-times tmp-name1 '(0 1))) + ;; Dumb remote shells without perl(1) or stat(1) are not + ;; able to return the date correctly. They say "don't know". + (unless (equal (nth 5 (file-attributes tmp-name1)) '(0 0)) + (should (equal (nth 5 (file-attributes tmp-name1)) '(0 1))) + (write-region "bla" nil tmp-name2) + (should (file-exists-p tmp-name2)) + (should (file-newer-than-file-p tmp-name2 tmp-name1)) + ;; `tmp-name3' does not exist. + (should (file-newer-than-file-p tmp-name2 tmp-name3)) + (should-not (file-newer-than-file-p tmp-name3 tmp-name1)))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))))) + +(ert-deftest tramp-test23-visited-file-modtime () + "Check `set-visited-file-modtime' and `verify-visited-file-modtime'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (verify-visited-file-modtime)) + (set-visited-file-modtime '(0 1)) + (should (verify-visited-file-modtime)) + (should (equal (visited-file-modtime) '(0 1 0 0))))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test24-file-name-completion () + "Check `file-name-completion' and `file-name-all-completions'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name) + (should (file-directory-p tmp-name)) + (write-region "foo" nil (expand-file-name "foo" tmp-name)) + (write-region "bar" nil (expand-file-name "bold" tmp-name)) + (make-directory (expand-file-name "boz" tmp-name)) + (should (equal (file-name-completion "fo" tmp-name) "foo")) + (should (equal (file-name-completion "b" tmp-name) "bo")) + (should + (equal (file-name-completion "b" tmp-name 'file-directory-p) "boz/")) + (should (equal (file-name-all-completions "fo" tmp-name) '("foo"))) + (should + (equal (sort (file-name-all-completions "b" tmp-name) 'string-lessp) + '("bold" "boz/")))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name 'recursive))))) + +(ert-deftest tramp-test25-load () + "Check `load'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (load tmp-name 'noerror 'nomessage) + (should-not (featurep 'tramp-test-load)) + (write-region "(provide 'tramp-test-load)" nil tmp-name) + ;; `load' in lread.c does not pass `must-suffix'. Why? + ;(should-error (load tmp-name nil 'nomessage 'nosuffix 'must-suffix)) + (load tmp-name nil 'nomessage 'nosuffix) + (should (featurep 'tramp-test-load))) + + ;; Cleanup. + (ignore-errors + (and (featurep 'tramp-test-load) (unload-feature 'tramp-test-load)) + (delete-file tmp-name))))) + +(ert-deftest tramp-test26-process-file () + "Check `process-file'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-gvfs-file-name-handler tramp-smb-file-name-handler)))) + + (let* ((tmp-name (tramp--test-make-temp-name)) + (fnnd (file-name-nondirectory tmp-name)) + (default-directory tramp-test-temporary-file-directory) + kill-buffer-query-functions) + (unwind-protect + (progn + ;; We cannot use "/bin/true" and "/bin/false"; those paths + ;; do not exist on hydra. + (should (zerop (process-file "true"))) + (should-not (zerop (process-file "false"))) + (should-not (zerop (process-file "binary-does-not-exist"))) + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (should (zerop (process-file "ls" nil t nil fnnd))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + (should (string-equal (format "%s\n" fnnd) (buffer-string))) + (should-not (get-buffer-window (current-buffer) t)) + + ;; Second run. The output must be appended. + (should (zerop (process-file "ls" nil t t fnnd))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + (should + (string-equal (format "%s\n%s\n" fnnd fnnd) (buffer-string))) + ;; A non-nil DISPLAY must not raise the buffer. + (should-not (get-buffer-window (current-buffer) t)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test27-start-file-process () + "Check `start-file-process'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-adb-file-name-handler + tramp-gvfs-file-name-handler + tramp-smb-file-name-handler)))) + + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name)) + kill-buffer-query-functions proc) + (unwind-protect + (with-temp-buffer + (setq proc (start-file-process "test1" (current-buffer) "cat")) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors (delete-process proc))) + + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (setq proc + (start-file-process + "test2" (current-buffer) + "cat" (file-name-nondirectory tmp-name))) + (should (processp proc)) + ;; Read output. + (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors + (delete-process proc) + (delete-file tmp-name))) + + (unwind-protect + (with-temp-buffer + (setq proc (start-file-process "test3" (current-buffer) "cat")) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (set-process-filter + proc + (lambda (p s) (with-current-buffer (process-buffer p) (insert s)))) + (process-send-string proc "foo") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors (delete-process proc))))) + +(ert-deftest tramp-test28-shell-command () + "Check `shell-command'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-adb-file-name-handler + tramp-gvfs-file-name-handler + tramp-smb-file-name-handler)))) + + (let ((tmp-name (tramp--test-make-temp-name)) + (default-directory tramp-test-temporary-file-directory) + kill-buffer-query-functions) + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (shell-command + (format "ls %s" (file-name-nondirectory tmp-name)) (current-buffer)) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + (should + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))) + + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (async-shell-command + (format "ls %s" (file-name-nondirectory tmp-name)) (current-buffer)) + (set-process-sentinel (get-buffer-process (current-buffer)) nil) + ;; Read output. + (with-timeout (10 (ert-fail "`async-shell-command' timed out")) + (while (< (- (point-max) (point-min)) + (1+ (length (file-name-nondirectory tmp-name)))) + (accept-process-output (get-buffer-process (current-buffer)) 1))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + ;; There might be a nasty "Process *Async Shell* finished" message. + (goto-char (point-min)) + (forward-line) + (narrow-to-region (point-min) (point)) + (should + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))) + + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (async-shell-command "read line; ls $line" (current-buffer)) + (set-process-sentinel (get-buffer-process (current-buffer)) nil) + (process-send-string + (get-buffer-process (current-buffer)) + (format "%s\n" (file-name-nondirectory tmp-name))) + ;; Read output. + (with-timeout (10 (ert-fail "`async-shell-command' timed out")) + (while (< (- (point-max) (point-min)) + (1+ (length (file-name-nondirectory tmp-name)))) + (accept-process-output (get-buffer-process (current-buffer)) 1))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + ;; There might be a nasty "Process *Async Shell* finished" message. + (goto-char (point-min)) + (forward-line) + (narrow-to-region (point-min) (point)) + (should + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test29-vc-registered () + "Check `vc-registered'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + (let* ((default-directory tramp-test-temporary-file-directory) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "foo" tmp-name1)) + (tramp-remote-process-environment tramp-remote-process-environment) + (vc-handled-backends + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (cond + ((tramp-find-executable v vc-git-program (tramp-get-remote-path v)) + '(Git)) + ((tramp-find-executable v vc-hg-program (tramp-get-remote-path v)) + '(Hg)) + ((tramp-find-executable v vc-bzr-program (tramp-get-remote-path v)) + (setq tramp-remote-process-environment + (cons (format "BZR_HOME=%s" + (file-remote-p tmp-name1 'localname)) + tramp-remote-process-environment)) + ;; We must force a reconnect, in order to activate $BZR_HOME. + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + nil 'keep-password) + '(Bzr)) + (t nil))))) + (skip-unless vc-handled-backends) + (message "%s" vc-handled-backends) + + (unwind-protect + (progn + (make-directory tmp-name1) + (write-region "foo" nil tmp-name2) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (should-not (vc-registered tmp-name1)) + (should-not (vc-registered tmp-name2)) + + (let ((default-directory tmp-name1)) + ;; Create empty repository, and register the file. + ;; Sometimes, creation of repository fails (bzr!); we skip + ;; the test then. + (condition-case nil + (vc-create-repo (car vc-handled-backends)) + (error (skip-unless nil))) + ;; The structure of VC-FILESET is not documented. Let's + ;; hope it won't change. + (condition-case nil + (vc-register + (list (car vc-handled-backends) + (list (file-name-nondirectory tmp-name2)))) + ;; `vc-register' has changed its arguments in Emacs 25.1. + (error + (vc-register + nil (list (car vc-handled-backends) + (list (file-name-nondirectory tmp-name2))))))) + (should (vc-registered tmp-name2))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + +(ert-deftest tramp-test30-make-auto-save-file-name () + "Check `make-auto-save-file-name'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name))) + + (unwind-protect + (progn + ;; Use default `auto-save-file-name-transforms' mechanism. + (let (tramp-auto-save-directory) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (should + (string-equal + (make-auto-save-file-name) + ;; This is taken from original `make-auto-save-file-name'. + (expand-file-name + (format + "#%s#" + (subst-char-in-string + ?/ ?! (replace-regexp-in-string "!" "!!" tmp-name1))) + temporary-file-directory))))) + + ;; No mapping. + (let (tramp-auto-save-directory auto-save-file-name-transforms) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (should + (string-equal + (make-auto-save-file-name) + (expand-file-name + (format "#%s#" (file-name-nondirectory tmp-name1)) + tramp-test-temporary-file-directory))))) + + ;; Use default `tramp-auto-save-directory' mechanism. + (let ((tramp-auto-save-directory tmp-name2)) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (should + (string-equal + (make-auto-save-file-name) + ;; This is taken from Tramp. + (expand-file-name + (format + "#%s#" + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + tmp-name1)) + tmp-name2))) + (should (file-directory-p tmp-name2)))) + + ;; Relative file names shall work, too. + (let ((tramp-auto-save-directory ".")) + (with-temp-buffer + (setq buffer-file-name tmp-name1 + default-directory tmp-name2) + (should + (string-equal + (make-auto-save-file-name) + ;; This is taken from Tramp. + (expand-file-name + (format + "#%s#" + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + tmp-name1)) + tmp-name2))) + (should (file-directory-p tmp-name2))))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-directory tmp-name2 'recursive))))) + +(defun tramp--test-adb-p () + "Check, whether the remote host runs Android. +This requires restrictions of file name syntax." + (tramp-adb-file-name-p tramp-test-temporary-file-directory)) + +(defun tramp--test-ftp-p () + "Check, whether an FTP-like method is used. +This does not support globbing characters in file names (yet)." + ;; Globbing characters are ??, ?* and ?\[. + (and (eq (tramp-find-foreign-file-name-handler + tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler) + (string-match + "ftp$" (file-remote-p tramp-test-temporary-file-directory 'method)))) + +(defun tramp--test-gvfs-p () + "Check, whether the remote host runs a GVFS based method. +This requires restrictions of file name syntax." + (tramp-gvfs-file-name-p tramp-test-temporary-file-directory)) + +(defun tramp--test-smb-or-windows-nt-p () + "Check, whether the locale or remote host runs MS Windows. +This requires restrictions of file name syntax." + (or (eq system-type 'windows-nt) + (tramp-smb-file-name-p tramp-test-temporary-file-directory))) + +(defun tramp--test-hpux-p () + "Check, whether the remote host runs HP-UX. +Several special characters do not work properly there." + ;; We must refill the cache. `file-truename' does it. + (with-parsed-tramp-file-name + (file-truename tramp-test-temporary-file-directory) nil + (string-match "^HP-UX" (tramp-get-connection-property v "uname" "")))) + +(defun tramp--test-darwin-p () + "Check, whether the remote host runs Mac OS X. +Several special characters do not work properly there." + ;; We must refill the cache. `file-truename' does it. + (with-parsed-tramp-file-name + (file-truename tramp-test-temporary-file-directory) nil + (string-match "^Darwin" (tramp-get-connection-property v "uname" "")))) + +(defun tramp--test-check-files (&rest files) + "Run a simple but comprehensive test over every file in FILES." + ;; We must use `file-truename' for the temporary directory, because + ;; it could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-test-temporary-file-directory + (file-truename tramp-test-temporary-file-directory)) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name 'local)) + (files (delq nil files))) + (unwind-protect + (progn + (make-directory tmp-name1) + (make-directory tmp-name2) + (dolist (elt files) + (let* ((file1 (expand-file-name elt tmp-name1)) + (file2 (expand-file-name elt tmp-name2)) + (file3 (expand-file-name (concat elt "foo") tmp-name1))) + (write-region elt nil file1) + (should (file-exists-p file1)) + + ;; Check file contents. + (with-temp-buffer + (insert-file-contents file1) + (should (string-equal (buffer-string) elt))) + + ;; Copy file both directions. + (copy-file file1 tmp-name2) + (should (file-exists-p file2)) + (delete-file file1) + (should-not (file-exists-p file1)) + (copy-file file2 tmp-name1) + (should (file-exists-p file1)) + + ;; Method "smb" supports `make-symbolic-link' only if the + ;; remote host has CIFS capabilities. tramp-adb.el and + ;; tramp-gvfs.el do not support symbolic links at all. + (condition-case err + (progn + (make-symbolic-link file1 file3) + (should (file-symlink-p file3)) + (should + (string-equal + (expand-file-name file1) (file-truename file3))) + (should + (string-equal + (car (file-attributes file3)) + (file-remote-p (file-truename file1) 'localname))) + ;; Check file contents. + (with-temp-buffer + (insert-file-contents file3) + (should (string-equal (buffer-string) elt))) + (delete-file file3)) + (file-error + (should (string-equal (error-message-string err) + "make-symbolic-link not supported")))))) + + ;; Check file names. + (should (equal (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp) + (sort (copy-sequence files) 'string-lessp))) + (should (equal (directory-files + tmp-name2 nil directory-files-no-dot-files-regexp) + (sort (copy-sequence files) 'string-lessp))) + + ;; `substitute-in-file-name' could return different values. + ;; For `adb', there could be strange file permissions + ;; preventing overwriting a file. We don't care in this + ;; testcase. + (dolist (elt files) + (let ((file1 + (substitute-in-file-name (expand-file-name elt tmp-name1))) + (file2 + (substitute-in-file-name (expand-file-name elt tmp-name2)))) + (ignore-errors (write-region elt nil file1)) + (should (file-exists-p file1)) + (ignore-errors (write-region elt nil file2 nil 'nomessage)) + (should (file-exists-p file2)))) + + (should (equal (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp) + (directory-files + tmp-name2 nil directory-files-no-dot-files-regexp))) + + ;; Check directory creation. We use a subdirectory "foo" + ;; in order to avoid conflicts with previous file name tests. + (dolist (elt files) + (let* ((elt1 (concat elt "foo")) + (file1 (expand-file-name (concat "foo/" elt) tmp-name1)) + (file2 (expand-file-name elt file1)) + (file3 (expand-file-name elt1 file1))) + (make-directory file1 'parents) + (should (file-directory-p file1)) + (write-region elt nil file2) + (should (file-exists-p file2)) + (should + (equal + (directory-files file1 nil directory-files-no-dot-files-regexp) + `(,elt))) + (should + (equal + (caar (directory-files-and-attributes + file1 nil directory-files-no-dot-files-regexp)) + elt)) + + ;; Check symlink in `directory-files-and-attributes'. + (condition-case err + (progn + (make-symbolic-link file2 file3) + (should (file-symlink-p file3)) + (should + (string-equal + (caar (directory-files-and-attributes + file1 nil (regexp-quote elt1))) + elt1)) + (should + (string-equal + (cadr (car (directory-files-and-attributes + file1 nil (regexp-quote elt1)))) + (file-remote-p (file-truename file2) 'localname))) + (delete-file file3) + (should-not (file-exists-p file3))) + (file-error + (should (string-equal (error-message-string err) + "make-symbolic-link not supported")))) + + (delete-file file2) + (should-not (file-exists-p file2)) + (delete-directory file1) + (should-not (file-exists-p file1))))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive)) + (ignore-errors (delete-directory tmp-name2 'recursive))))) + +(defun tramp--test-special-characters () + "Perform the test in `tramp-test31-special-characters*'." + ;; Newlines, slashes and backslashes in file names are not + ;; supported. So we don't test. And we don't test the tab + ;; character on Windows or Cygwin, because the backslash is + ;; interpreted as a path separator, preventing "\t" from being + ;; expanded to . + (tramp--test-check-files + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "foo bar baz" + (if (or (tramp--test-adb-p) (eq system-type 'cygwin)) + " foo bar baz " + " foo\tbar baz\t")) + "$foo$bar$$baz$" + "-foo-bar-baz-" + "%foo%bar%baz%" + "&foo&bar&baz&" + (unless (or (tramp--test-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-smb-or-windows-nt-p)) + "?foo?bar?baz?") + (unless (or (tramp--test-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-smb-or-windows-nt-p)) + "*foo*bar*baz*") + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "'foo'bar'baz'" + "'foo\"bar'baz\"") + "#foo~bar#baz~" + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "!foo!bar!baz!" + "!foo|bar!baz|") + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + ";foo;bar;baz;" + ":foo;bar:baz;") + (unless (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "bar") + "(foo)bar(baz)" + (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]") + "{foo}bar{baz}")) + +;; These tests are inspired by Bug#17238. +(ert-deftest tramp-test31-special-characters () + "Check special characters in file names." + (skip-unless (tramp--test-enabled)) + + (tramp--test-special-characters)) + +(ert-deftest tramp-test31-special-characters-with-stat () + "Check special characters in file names. +Use the `stat' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-stat v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil)) + tramp-connection-properties))) + (tramp--test-special-characters))) + +(ert-deftest tramp-test31-special-characters-with-perl () + "Check special characters in file names. +Use the `perl' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-perl v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-special-characters))) + +(ert-deftest tramp-test31-special-characters-with-ls () + "Check special characters in file names. +Use the `ls' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil) + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-special-characters))) + +(defun tramp--test-utf8 () + "Perform the test in `tramp-test32-utf8*'." + (tramp--instrument-test-case 10 + (let ((coding-system-for-read 'utf-8) + (coding-system-for-write 'utf-8) + (file-name-coding-system 'utf-8)) + (tramp--test-check-files + (unless (tramp--test-hpux-p) "Γυρίστε το Γαλαξία με Ώτο Στοπ") + (unless (or (tramp--test-hpux-p) (tramp--test-darwin-p)) + "أصبح بوسعك الآن تنزيل نسخة كاملة من موسوعة ويكيبيديا العربية لتصفحها بلا اتصال بالإنترنت") + "银河系漫游指南系列" + "Автостопом по гала́ктике")))) + +(ert-deftest tramp-test32-utf8 () + "Check UTF8 encoding in file names and file contents." + (skip-unless (tramp--test-enabled)) + + (tramp--test-utf8)) + +(ert-deftest tramp-test32-utf8-with-stat () + "Check UTF8 encoding in file names and file contents. +Use the `stat' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-stat v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil)) + tramp-connection-properties))) + (tramp--test-utf8))) + +(ert-deftest tramp-test32-utf8-with-perl () + "Check UTF8 encoding in file names and file contents. +Use the `perl' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-perl v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-utf8))) + +(ert-deftest tramp-test32-utf8-with-ls () + "Check UTF8 encoding in file names and file contents. +Use the `ls' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil) + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-utf8))) + +;; This test is inspired by Bug#16928. +(ert-deftest tramp-test33-asynchronous-requests () + "Check parallel asynchronous requests. +Such requests could arrive from timers, process filters and +process sentinels. They shall not disturb each other." + ;; Mark as failed until bug has been fixed. + :expected-result :failed + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + ;; Keep instrumentation verbosity 0 until Tramp bug is fixed. This + ;; has the side effect, that this test fails instead to abort. Good + ;; for hydra. + (tramp--instrument-test-case 0 + (let* ((tmp-name (tramp--test-make-temp-name)) + (default-directory tmp-name) + (remote-file-name-inhibit-cache t) + timer buffers kill-buffer-query-functions) + + (unwind-protect + (progn + (make-directory tmp-name) + + ;; Setup a timer in order to raise an ordinary command again + ;; and again. `vc-registered' is well suited, because there + ;; are many checks. + (setq + timer + (run-at-time + 0 1 + (lambda () + (when buffers + (vc-registered + (buffer-name (nth (random (length buffers)) buffers))))))) + + ;; Create temporary buffers. The number of buffers + ;; corresponds to the number of processes; it could be + ;; increased in order to make pressure on Tramp. + (dotimes (i 5) + (add-to-list 'buffers (generate-new-buffer "*temp*"))) + + ;; Open asynchronous processes. Set process sentinel. + (dolist (buf buffers) + (async-shell-command "read line; touch $line; echo $line" buf) + (set-process-sentinel + (get-buffer-process buf) + (lambda (proc _state) + (delete-file (buffer-name (process-buffer proc)))))) + + ;; Send a string. Use a random order of the buffers. Mix + ;; with regular operation. + (let ((buffers (copy-sequence buffers)) + buf) + (while buffers + (setq buf (nth (random (length buffers)) buffers)) + (process-send-string + (get-buffer-process buf) (format "'%s'\n" buf)) + (file-attributes (buffer-name buf)) + (setq buffers (delq buf buffers)))) + + ;; Wait until the whole output has been read. + (with-timeout ((* 10 (length buffers)) + (ert-fail "`async-shell-command' timed out")) + (let ((buffers (copy-sequence buffers)) + buf) + (while buffers + (setq buf (nth (random (length buffers)) buffers)) + (if (ignore-errors + (memq (process-status (get-buffer-process buf)) + '(run open))) + (accept-process-output (get-buffer-process buf) 0.1) + (setq buffers (delq buf buffers)))))) + + ;; Check. + (dolist (buf buffers) + (with-current-buffer buf + (should + (string-equal (format "'%s'\n" buf) (buffer-string))))) + (should-not + (directory-files tmp-name nil directory-files-no-dot-files-regexp))) + + ;; Cleanup. + (ignore-errors (cancel-timer timer)) + (ignore-errors (delete-directory tmp-name 'recursive)) + (dolist (buf buffers) + (ignore-errors (kill-buffer buf))))))) + +(ert-deftest tramp-test34-recursive-load () + "Check that Tramp does not fail due to recursive load." + (skip-unless (tramp--test-enabled)) + + (dolist (code + (list + (format + "(expand-file-name %S)" + tramp-test-temporary-file-directory) + (format + "(let ((default-directory %S)) (expand-file-name %S))" + tramp-test-temporary-file-directory + temporary-file-directory))) + (should-not + (string-match + "Recursive load" + (shell-command-to-string + (format + "%s -batch -Q -L %s --eval %s" + (expand-file-name invocation-name invocation-directory) + (mapconcat 'shell-quote-argument load-path " -L ") + (shell-quote-argument code))))))) + +(ert-deftest tramp-test35-unload () + "Check that Tramp and its subpackages unload completely. +Since it unloads Tramp, it shall be the last test to run." + ;; Mark as failed until all symbols are unbound. + :expected-result (if (featurep 'tramp) :failed :passed) + (when (featurep 'tramp) + (unload-feature 'tramp 'force) + ;; No Tramp feature must be left. + (should-not (featurep 'tramp)) + (should-not (all-completions "tramp" (delq 'tramp-tests features))) + ;; `file-name-handler-alist' must be clean. + (should-not (all-completions "tramp" (mapcar 'cdr file-name-handler-alist))) + ;; There shouldn't be left a bound symbol. We do not regard our + ;; test symbols, and the Tramp unload hooks. + (mapatoms + (lambda (x) + (and (or (boundp x) (functionp x)) + (string-match "^tramp" (symbol-name x)) + (not (string-match "^tramp--?test" (symbol-name x))) + (not (string-match "unload-hook$" (symbol-name x))) + (ert-fail (format "`%s' still bound" x))))) + ;; There shouldn't be left a hook function containing a Tramp + ;; function. We do not regard the Tramp unload hooks. + (mapatoms + (lambda (x) + (and (boundp x) + (string-match "-hooks?$" (symbol-name x)) + (not (string-match "unload-hook$" (symbol-name x))) + (consp (symbol-value x)) + (ignore-errors (all-completions "tramp" (symbol-value x))) + (ert-fail (format "Hook `%s' still contains Tramp function" x))))))) + +;; TODO: + +;; * dired-compress-file +;; * dired-uncache +;; * file-acl +;; * file-ownership-preserved-p +;; * file-selinux-context +;; * find-backup-file-name +;; * set-file-acl +;; * set-file-selinux-context + +;; * Work on skipped tests. Make a comment, when it is impossible. +;; * Fix `tramp-test15-copy-directory' for `smb'. Using tar in a pipe +;; doesn't work well when an interactive password must be provided. +;; * Fix `tramp-test27-start-file-process' on MS Windows (`process-send-eof'?). +;; * Fix Bug#16928. Set expected error of `tramp-test33-asynchronous-requests'. +;; * Fix `tramp-test35-unload' (Not all symbols are unbound). Set +;; expected error. + +(defun tramp-test-all (&optional interactive) + "Run all tests for \\[tramp]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^tramp")) + +(provide 'tramp-tests) +;;; tramp-tests.el ends here diff --cc test/lisp/obarray-tests.el index 4cc61b6903f,00000000000..92345b7198e mode 100644,000000..100644 --- a/test/lisp/obarray-tests.el +++ b/test/lisp/obarray-tests.el @@@ -1,90 -1,0 +1,90 @@@ +;;; obarray-tests.el --- Tests for obarray -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Przemysław Wojnowski + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'obarray) +(require 'ert) + +(ert-deftest obarrayp-test () + "Should assert that given object is an obarray." + (should-not (obarrayp 42)) + (should-not (obarrayp "aoeu")) + (should-not (obarrayp '())) + (should-not (obarrayp [])) + (should (obarrayp (make-vector 7 0)))) + +(ert-deftest obarrayp-unchecked-content-test () + "Should fail to check content of passed obarray." + :expected-result :failed + (should-not (obarrayp ["a" "b" "c"])) + (should-not (obarrayp [1 2 3]))) + +(ert-deftest obarray-make-default-test () + (let ((table (obarray-make))) + (should (obarrayp table)) + (should (equal (make-vector 59 0) table)))) + +(ert-deftest obarray-make-with-size-test () + (should-error (obarray-make -1) :type 'wrong-type-argument) + (should-error (obarray-make 0) :type 'wrong-type-argument) + (let ((table (obarray-make 1))) + (should (obarrayp table)) + (should (equal (make-vector 1 0) table)))) + +(ert-deftest obarray-get-test () + (let ((table (obarray-make 3))) + (should-not (obarray-get table "aoeu")) + (intern "aoeu" table) + (should (string= "aoeu" (obarray-get table "aoeu"))))) + +(ert-deftest obarray-put-test () + (let ((table (obarray-make 3))) + (should-not (obarray-get table "aoeu")) + (should (string= "aoeu" (obarray-put table "aoeu"))) + (should (string= "aoeu" (obarray-get table "aoeu"))))) + +(ert-deftest obarray-remove-test () + (let ((table (obarray-make 3))) + (should-not (obarray-get table "aoeu")) + (should-not (obarray-remove table "aoeu")) + (should (string= "aoeu" (obarray-put table "aoeu"))) + (should (string= "aoeu" (obarray-get table "aoeu"))) + (should (obarray-remove table "aoeu")) + (should-not (obarray-get table "aoeu")))) + +(ert-deftest obarray-map-test () + "Should execute function on all elements of obarray." + (let* ((table (obarray-make 3)) + (syms '()) + (collect-names (lambda (sym) (push (symbol-name sym) syms)))) + (obarray-map collect-names table) + (should (null syms)) + (obarray-put table "a") + (obarray-put table "b") + (obarray-put table "c") + (obarray-map collect-names table) + (should (equal (sort syms #'string<) '("a" "b" "c"))))) + +(provide 'obarray-tests) +;;; obarray-tests.el ends here diff --cc test/lisp/progmodes/compile-tests.el index 0974a78e073,00000000000..6821a6bfae5 mode 100644,000000..100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@@ -1,366 -1,0 +1,366 @@@ +;;; compile-tests.el --- Test suite for font parsing. + - ;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Chong Yidong +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'compile) + +(defvar compile-tests--test-regexps-data + ;; The computed column numbers are zero-indexed, so subtract 1 from + ;; what's reported in the string. The end column numbers are for + ;; the character after, so it matches what's reported in the string. + '(;; absoft + ("Error on line 3 of t.f: Execution error unclassifiable statement" + 1 nil 3 "t.f") + ("Line 45 of \"foo.c\": bloofle undefined" + 1 nil 45 "foo.c") + ("error on line 19 of fplot.f: spelling error?" + 1 nil 19 "fplot.f") + ("warning on line 17 of fplot.f: data type is undefined for variable d" + 1 nil 17 "fplot.f") + ;; Ada & Mpatrol + ("foo.adb:61:11: [...] in call to size declared at foo.ads:11" + 1 11 61 "foo.adb") + ("foo.adb:61:11: [...] in call to size declared at foo.ads:11" + 52 nil 11 "foo.ads") + (" 0x8008621 main+16 at error.c:17" + 23 nil 17 "error.c") + ;; aix + ("****** Error number 140 in line 8 of file errors.c ******" + 25 nil 8 "errors.c") + ;; ant + ("[javac] /src/DataBaseTestCase.java:27: unreported exception ..." + 13 nil 27 "/src/DataBaseTestCase.java") + ("[javac] /src/DataBaseTestCase.java:49: warning: finally clause cannot complete normally" + 13 nil 49 "/src/DataBaseTestCase.java") + ("[jikes] foo.java:3:5:7:9: blah blah" + 14 (5 . 10) (3 . 7) "foo.java") + ;; bash + ("a.sh: line 1: ls-l: command not found" + 1 nil 1 "a.sh") + ;; borland + ("Error ping.c 15: Unable to open include file 'sys/types.h'" + 1 nil 15 "ping.c") + ("Warning pong.c 68: Call to function 'func' with no prototype" + 1 nil 68 "pong.c") + ("Error E2010 ping.c 15: Unable to open include file 'sys/types.h'" + 1 nil 15 "ping.c") + ("Warning W1022 pong.c 68: Call to function 'func' with no prototype" + 1 nil 68 "pong.c") + ;; caml + ("File \"foobar.ml\", lines 5-8, characters 20-155: blah blah" + 1 (20 . 156) (5 . 8) "foobar.ml") + ("File \"F:\\ocaml\\sorting.ml\", line 65, characters 2-145:\nWarning 26: unused variable equ." + 1 (2 . 146) 65 "F:\\ocaml\\sorting.ml") + ("File \"/usr/share/gdesklets/display/TargetGauge.py\", line 41, in add_children" + 1 nil 41 "/usr/share/gdesklets/display/TargetGauge.py") + ("File \\lib\\python\\Products\\PythonScripts\\PythonScript.py, line 302, in _exec" + 1 nil 302 "\\lib\\python\\Products\\PythonScripts\\PythonScript.py") + ("File \"/tmp/foo.py\", line 10" + 1 nil 10 "/tmp/foo.py") + ;; comma + ("\"foo.f\", line 3: Error: syntax error near end of statement" + 1 nil 3 "foo.f") + ("\"vvouch.c\", line 19.5: 1506-046 (S) Syntax error." + 1 5 19 "vvouch.c") + ("\"foo.c\", line 32 pos 1; (E) syntax error; unexpected symbol: \"lossage\"" + 1 1 32 "foo.c") + ("\"foo.adb\", line 2(11): warning: file name does not match ..." + 1 11 2 "foo.adb") + ("\"src/swapping.c\", line 30.34: 1506-342 (W) \"/*\" detected in comment." + 1 34 30 "src/swapping.c") + ;; cucumber + ("Scenario: undefined step # features/cucumber.feature:3" + 29 nil 3 "features/cucumber.feature") + (" /home/gusev/.rvm/foo/bar.rb:500:in `_wrap_assertion'" + 1 nil 500 "/home/gusev/.rvm/foo/bar.rb") + ;; edg-1 edg-2 + ("build/intel/debug/../../../struct.cpp(42): error: identifier \"foo\" is undefined" + 1 nil 42 "build/intel/debug/../../../struct.cpp") + ("build/intel/debug/struct.cpp(44): warning #1011: missing return statement at end of" + 1 nil 44 "build/intel/debug/struct.cpp") + ("build/intel/debug/iptr.h(302): remark #981: operands are evaluated in unspecified order" + 1 nil 302 "build/intel/debug/iptr.h") + (" detected during ... at line 62 of \"build/intel/debug/../../../trace.h\"" + 31 nil 62 "build/intel/debug/../../../trace.h") + ;; epc + ("Error 24 at (2:progran.f90) : syntax error" + 1 nil 2 "progran.f90") + ;; ftnchek + (" Dummy arg W in module SUBA line 8 file arrayclash.f is array" + 32 nil 8 "arrayclash.f") + (" L4 used at line 55 file test/assign.f; never set" + 16 nil 55 "test/assign.f") + ("Warning near line 10 file arrayclash.f: Module contains no executable" + 1 nil 10 "arrayclash.f") + ("Nonportable usage near line 31 col 9 file assign.f: mixed default and explicit" + 24 9 31 "assign.f") + ;; iar + ("\"foo.c\",3 Error[32]: Error message" + 1 nil 3 "foo.c") + ("\"foo.c\",3 Warning[32]: Error message" + 1 nil 3 "foo.c") + ;; ibm + ("foo.c(2:0) : informational EDC0804: Function foo is not referenced." + 1 0 2 "foo.c") + ("foo.c(3:8) : warning EDC0833: Implicit return statement encountered." + 1 8 3 "foo.c") + ("foo.c(5:5) : error EDC0350: Syntax error." + 1 5 5 "foo.c") + ;; irix + ("ccom: Error: foo.c, line 2: syntax error" + 1 nil 2 "foo.c") + ("cc: Severe: /src/Python-2.3.3/Modules/_curses_panel.c, line 17: Cannot find file ..." + 1 nil 17 "/src/Python-2.3.3/Modules/_curses_panel.c") + ("cc: Info: foo.c, line 27: ..." + 1 nil 27 "foo.c") + ("cfe: Warning 712: foo.c, line 2: illegal combination of pointer and ..." + 1 nil 2 "foo.c") + ("cfe: Warning 600: xfe.c: 170: Not in a conditional directive while ..." + 1 nil 170 "xfe.c") + ("/usr/lib/cmplrs/cc/cfe: Error: foo.c: 1: blah blah" + 1 nil 1 "foo.c") + ("/usr/lib/cmplrs/cc/cfe: warning: foo.c: 1: blah blah" + 1 nil 1 "foo.c") + ("foo bar: baz.f, line 27: ..." + 1 nil 27 "baz.f") + ;; java + ("\tat org.foo.ComponentGateway.doGet(ComponentGateway.java:172)" + 5 nil 172 "ComponentGateway.java") + ("\tat javax.servlet.http.HttpServlet.service(HttpServlet.java:740)" + 5 nil 740 "HttpServlet.java") + ("==1332== at 0x4040743C: System::getErrorString() (../src/Lib/System.cpp:217)" + 13 nil 217 "../src/Lib/System.cpp") + ("==1332== by 0x8008621: main (vtest.c:180)" + 13 nil 180 "vtest.c") + ;; jikes-file jikes-line + ("Found 2 semantic errors compiling \"../javax/swing/BorderFactory.java\":" + 1 nil nil "../javax/swing/BorderFactory.java") + ("Issued 1 semantic warning compiling \"java/awt/Toolkit.java\":" + 1 nil nil "java/awt/Toolkit.java") + ;; gcc-include + ("In file included from /usr/include/c++/3.3/backward/warn.h:4," + 1 nil 4 "/usr/include/c++/3.3/backward/warn.h") + (" from /usr/include/c++/3.3/backward/iostream.h:31:0," + 1 0 31 "/usr/include/c++/3.3/backward/iostream.h") + (" from test_clt.cc:1:" + 1 nil 1 "test_clt.cc") + ;; gnu + ("foo.c:8: message" 1 nil 8 "foo.c") + ("../foo.c:8: W: message" 1 nil 8 "../foo.c") + ("/tmp/foo.c:8:warning message" 1 nil 8 "/tmp/foo.c") + ("foo/bar.py:8: FutureWarning message" 1 nil 8 "foo/bar.py") + ("foo.py:8: RuntimeWarning message" 1 nil 8 "foo.py") + ("foo.c:8:I: message" 1 nil 8 "foo.c") + ("foo.c:8.23: note: message" 1 23 8 "foo.c") + ("foo.c:8.23: info: message" 1 23 8 "foo.c") + ("foo.c:8:23:information: message" 1 23 8 "foo.c") + ("foo.c:8.23-45: Informational: message" 1 (23 . 46) (8 . nil) "foo.c") + ("foo.c:8-23: message" 1 nil (8 . 23) "foo.c") + ;; The next one is not in the GNU standards AFAICS. + ;; Here we seem to interpret it as LINE1-LINE2.COL2. + ("foo.c:8-45.3: message" 1 (nil . 4) (8 . 45) "foo.c") + ("foo.c:8.23-9.1: message" 1 (23 . 2) (8 . 9) "foo.c") + ("jade:dbcommon.dsl:133:17:E: missing argument for function call" + 1 17 133 "dbcommon.dsl") + ("G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found." + 1 nil 54 "G:/cygwin/dev/build-myproj.xml") + ("file:G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found." + 1 nil 54 "G:/cygwin/dev/build-myproj.xml") + ("{standard input}:27041: Warning: end of file not at end of a line; newline inserted" + 1 nil 27041 "{standard input}") + ;; Guile + ("In foo.scm:\n" 1 nil nil "foo.scm") + (" 63:4 [call-with-prompt prompt0 ...]" 1 4 63 nil) + ("1038: 1 [main (\"gud-break.scm\")]" 1 1 1038 nil) + ;; lcc + ("E, file.cc(35,52) Illegal operation on pointers" 1 52 35 "file.cc") + ("W, file.cc(36,52) blah blah" 1 52 36 "file.cc") + ;; makepp + ("makepp: Scanning `/foo/bar.c'" 19 nil nil "/foo/bar.c") + ("makepp: warning: bla bla `/foo/bar.c' and `/foo/bar.h'" 27 nil nil "/foo/bar.c") + ("makepp: bla bla `/foo/Makeppfile:12' bla" 18 nil 12 "/foo/Makeppfile") + ("makepp: bla bla `/foo/bar.c' and `/foo/bar.h'" 35 nil nil "/foo/bar.h") + ;; maven + ("FooBar.java:[111,53] no interface expected here" + 1 53 111 "FooBar.java" 2) + (" [ERROR] /Users/cinsk/hello.java:[651,96] ';' expected" + 15 96 651 "/Users/cinsk/hello.java" 2) ;Bug#11517. + ("[WARNING] /foo/bar/Test.java:[27,43] unchecked conversion" + 11 43 27 "/foo/bar/Test.java" 1) ;Bug#20556 + ;; mips-1 mips-2 + ("TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomo.c due to truncation" + 11 nil 255 "solomon.c") + ("TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomo.c due to truncation" + 70 nil 93 "solomo.c") + ("name defined but never used: LinInt in cmap_calc.c(199)" + 40 nil 199 "cmap_calc.c") + ;; msft + ("keyboard handler.c(537) : warning C4005: 'min' : macro redefinition" + 1 nil 537 "keyboard handler.c") + ("d:\\tmp\\test.c(23) : error C2143: syntax error : missing ';' before 'if'" + 1 nil 23 "d:\\tmp\\test.c") + ("d:\\tmp\\test.c(1145) : see declaration of 'nsRefPtr'" + 1 nil 1145 "d:\\tmp\\test.c") + ("1>test_main.cpp(29): error C2144: syntax error : 'int' should be preceded by ';'" + 3 nil 29 "test_main.cpp") + ("1>test_main.cpp(29): error C4430: missing type specifier - int assumed. Note: C++ does not support default-int" + 3 nil 29 "test_main.cpp") + ;; watcom + ("..\\src\\ctrl\\lister.c(109): Error! E1009: Expecting ';' but found '{'" + 1 nil 109 "..\\src\\ctrl\\lister.c") + ("..\\src\\ctrl\\lister.c(120): Warning! W201: Unreachable code" + 1 nil 120 "..\\src\\ctrl\\lister.c") + ;; oracle + ("Semantic error at line 528, column 5, file erosacqdb.pc:" + 1 5 528 "erosacqdb.pc") + ("Error at line 41, column 10 in file /usr/src/sb/ODBI_BHP.hpp" + 1 10 41 "/usr/src/sb/ODBI_BHP.hpp") + ("PCC-02150: error at line 49, column 27 in file /usr/src/sb/ODBI_dxfgh.pc" + 1 27 49 "/usr/src/sb/ODBI_dxfgh.pc") + ("PCC-00003: invalid SQL Identifier at column name in line 12 of file /usr/src/sb/ODBI_BHP.hpp" + 1 nil 12 "/usr/src/sb/ODBI_BHP.hpp") + ("PCC-00004: mismatched IF/ELSE/ENDIF block at line 27 in file /usr/src/sb/ODBI_BHP.hpp" + 1 nil 27 "/usr/src/sb/ODBI_BHP.hpp") + ("PCC-02151: line 21 column 40 file /usr/src/sb/ODBI_BHP.hpp:" + 1 40 21 "/usr/src/sb/ODBI_BHP.hpp") + ;; perl + ("syntax error at automake line 922, near \"':'\"" + 14 nil 922 "automake") + ("Died at test.pl line 27." + 6 nil 27 "test.pl") + ("store::odrecall('File_A', 'x2') called at store.pm line 90" + 40 nil 90 "store.pm") + ("\t(in cleanup) something bad at foo.pl line 3 during global destruction." + 29 nil 3 "foo.pl") + ("GLib-GObject-WARNING **: /build/buildd/glib2.0-2.14.5/gobject/gsignal.c:1741: instance `0x8206790' has no handler with id `1234' at t-compilation-perl-gtk.pl line 3." + 130 nil 3 "t-compilation-perl-gtk.pl") + ;; php + ("Parse error: parse error, unexpected $ in main.php on line 59" + 1 nil 59 "main.php") + ("Fatal error: Call to undefined function: mysql_pconnect() in db.inc on line 66" + 1 nil 66 "db.inc") + ;; ruby + ("plain-exception.rb:7:in `fun': unhandled exception" + 1 nil 7 "plain-exception.rb") + ("\tfrom plain-exception.rb:3:in `proxy'" 2 nil 3 "plain-exception.rb") + ("\tfrom plain-exception.rb:12" 2 nil 12 "plain-exception.rb") + ;; ruby-Test::Unit + ;; FIXME + (" [examples/test-unit.rb:28:in `here_is_a_deep_assert'" + 5 nil 28 "examples/test-unit.rb") + (" examples/test-unit.rb:19:in `test_a_deep_assert']:" + 6 nil 19 "examples/test-unit.rb") + ("examples/test-unit.rb:10:in `test_assert_raise'" + 1 nil 10 "examples/test-unit.rb") + ;; rxp + ("Error: Mismatched end tag: expected , got \nin unnamed entity at line 71 char 8 of file:///home/reto/test/group.xml" + 1 8 71 "/home/reto/test/group.xml") + ("Warning: Start tag for undeclared element geroup\nin unnamed entity at line 4 char 8 of file:///home/reto/test/group.xml" + 1 8 4 "/home/reto/test/group.xml") + ;; sparc-pascal-file sparc-pascal-line sparc-pascal-example + ("Thu May 14 10:46:12 1992 mom3.p:" + 1 nil nil "mom3.p") + ;; sun + ("cc-1020 CC: REMARK File = CUI_App.h, Line = 735" + 13 nil 735 "CUI_App.h") + ("cc-1070 cc: WARNING File = linkl.c, Line = 38" + 13 nil 38 "linkl.c") + ("cf90-113 f90comp: ERROR NSE, File = Hoved.f90, Line = 16, Column = 3" + 18 3 16 "Hoved.f90") + ;; sun-ada + ("/home3/xdhar/rcds_rc/main.a, line 361, char 6:syntax error: \",\" inserted" + 1 6 361 "/home3/xdhar/rcds_rc/main.a") + ;; 4bsd + ("/usr/src/foo/foo.c(8): warning: w may be used before set" + 1 nil 8 "/usr/src/foo/foo.c") + ("/usr/src/foo/foo.c(9): error: w is used before set" + 1 nil 9 "/usr/src/foo/foo.c") + ("strcmp: variable # of args. llib-lc(359) :: /usr/src/foo/foo.c(8)" + 44 nil 8 "/usr/src/foo/foo.c") + ("bloofle defined( /users/wolfgang/foo.c(4) ), but never used" + 18 nil 4 "/users/wolfgang/foo.c") + ;; perl--Pod::Checker + ;; FIXME + ;; *** ERROR: Spurious text after =cut at line 193 in file foo.pm + ;; *** ERROR: =over on line 37 without closing =back at line EOF in file bar.pm + ;; *** ERROR: =over on line 1 without closing =back (at head1) at line 3 in file x.pod + ;; perl--Test + ("# Failed test 1 in foo.t at line 6" + 1 nil 6 "foo.t") + ;; perl--Test::Harness + ("NOK 1# Test 1 got: \"1234\" (t/foo.t at line 46)" + 1 nil 46 "t/foo.t") + ;; weblint + ("index.html (13:1) Unknown element " + 1 1 13 "index.html")) + "List of tests for `compilation-error-regexp-alist'. +Each element has the form (STR POS COLUMN LINE FILENAME), where +STR is an error string, POS is the position of the error in STR, +COLUMN and LINE are the reported column and line numbers (or nil) +for that error, and FILENAME is the reported filename. + +LINE can also be of the form (LINE . END-LINE) meaning a range of +lines. COLUMN can also be of the form (COLUMN . END-COLUMN) +meaning a range of columns starting on LINE and ending on +END-LINE, if that matched.") + +(defun compile--test-error-line (test) + (erase-buffer) + (setq compilation-locs (make-hash-table)) + (insert (car test)) + (compilation-parse-errors (point-min) (point-max)) + (let ((msg (get-text-property (nth 1 test) 'compilation-message))) + (when msg + (let ((loc (compilation--message->loc msg)) + (col (nth 2 test)) + (line (nth 3 test)) + (file (nth 4 test)) + (type (nth 5 test)) + end-col end-line) + (if (consp col) + (setq end-col (cdr col) col (car col))) + (if (consp line) + (setq end-line (cdr line) line (car line))) + (and (equal (compilation--loc->col loc) col) + (equal (compilation--loc->line loc) line) + (or (not file) + (equal (caar (compilation--loc->file-struct loc)) file)) + (or (null end-col) + (equal (car (cadr (nth 2 (compilation--loc->file-struct loc)))) + end-col)) + (equal (car (nth 2 (compilation--loc->file-struct loc))) + (or end-line line)) + (or (null type) + (equal type (compilation--message->type msg)))))))) + +(ert-deftest compile-test-error-regexps () + "Test the `compilation-error-regexp-alist' regexps. +The test data is in `compile-tests--test-regexps-data'." + (with-temp-buffer + (font-lock-mode -1) + (dolist (test compile-tests--test-regexps-data) + (should (compile--test-error-line test))))) + +;;; compile-tests.el ends here. diff --cc test/lisp/progmodes/elisp-mode-tests.el index 2d0452f69d7,00000000000..1679af30821 mode 100644,000000..100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@@ -1,645 -1,0 +1,645 @@@ +;;; elisp-mode-tests.el --- Tests for emacs-lisp-mode -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Dmitry Gutov +;; Author: Stephen Leake + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'xref) + +;;; Completion + +(defun elisp--test-completions () + (let ((data (elisp-completion-at-point))) + (all-completions (buffer-substring (nth 0 data) (nth 1 data)) + (nth 2 data) + (plist-get (nthcdr 3 data) :predicate)))) + +(ert-deftest elisp-completes-functions () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps))))) + +(ert-deftest elisp-completes-variables () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(foo ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should-not (member "backup-buffer" comps))))) + +(ert-deftest elisp-completes-anything-quoted () + (dolist (text '("`(foo ba" "(foo 'ba" + "`(,foo ba" "`,(foo `ba" + "'(foo (ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should (member "backup-buffer" comps)) + (should (member "backup" comps)))))) + +(ert-deftest elisp-completes-variables-unquoted () + (dolist (text '("`(foo ,ba" "`(,(foo ba" "`(,ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should-not (member "backup-buffer" comps)))))) + +(ert-deftest elisp-completes-functions-in-special-macros () + (dolist (text '("(declare-function ba" "(cl-callf2 ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps)))))) + +(ert-deftest elisp-completes-functions-after-hash-quote () + (ert-deftest elisp-completes-functions-after-let-bindings () + (with-temp-buffer + (emacs-lisp-mode) + (insert "#'ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps)))))) + +(ert-deftest elisp-completes-local-variables () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(let ((bar 1) baz) (foo ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should (member "bar" comps)) + (should (member "baz" comps))))) + +(ert-deftest elisp-completest-variables-in-let-bindings () + (dolist (text '("(let (ba" "(let* ((ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should-not (member "backup-buffer" comps)))))) + +(ert-deftest elisp-completes-functions-after-let-bindings () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(let ((bar 1) (baz 2)) (ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps))))) + +;;; xref + +(defun xref-elisp-test-descr-to-target (xref) + "Return an appropriate `looking-at' match string for XREF." + (let* ((loc (xref-item-location xref)) + (type (or (xref-elisp-location-type loc) + 'defun))) + + (cl-case type + (defalias + ;; summary: "(defalias xref)" + ;; target : "(defalias 'xref" + (concat "(defalias '" (substring (xref-item-summary xref) 10 -1))) + + (defun + (let ((summary (xref-item-summary xref)) + (file (xref-elisp-location-file loc))) + (cond + ((string= "c" (file-name-extension file)) + ;; summary: "(defun buffer-live-p)" + ;; target : "DEFUN (buffer-live-p" + (concat + (upcase (substring summary 1 6)) + " (\"" + (substring summary 7 -1) + "\"")) + + (t + (substring summary 0 -1)) + ))) + + (defvar + (let ((summary (xref-item-summary xref)) + (file (xref-elisp-location-file loc))) + (cond + ((string= "c" (file-name-extension file)) + ;; summary: "(defvar system-name)" + ;; target : "DEFVAR_LISP ("system-name", " + ;; summary: "(defvar abbrev-mode)" + ;; target : DEFVAR_PER_BUFFER ("abbrev-mode" + (concat + (upcase (substring summary 1 7)) + (if (bufferp (variable-binding-locus (xref-elisp-location-symbol loc))) + "_PER_BUFFER (\"" + "_LISP (\"") + (substring summary 8 -1) + "\"")) + + (t + (substring summary 0 -1)) + ))) + + (feature + ;; summary: "(feature xref)" + ;; target : "(provide 'xref)" + (concat "(provide '" (substring (xref-item-summary xref) 9 -1))) + + (otherwise + (substring (xref-item-summary xref) 0 -1)) + ))) + + +(defun xref-elisp-test-run (xrefs expected-xrefs) + (should (= (length xrefs) (length expected-xrefs))) + (while xrefs + (let* ((xref (pop xrefs)) + (expected (pop expected-xrefs)) + (expected-xref (or (when (consp expected) (car expected)) expected)) + (expected-source (when (consp expected) (cdr expected)))) + + ;; Downcase the filenames for case-insensitive file systems. + (setf (xref-elisp-location-file (oref xref location)) + (downcase (xref-elisp-location-file (oref xref location)))) + + (setf (xref-elisp-location-file (oref expected-xref location)) + (downcase (xref-elisp-location-file (oref expected-xref location)))) + + (should (equal xref expected-xref)) + + (xref--goto-location (xref-item-location xref)) + (back-to-indentation) + (should (looking-at (or expected-source + (xref-elisp-test-descr-to-target expected))))) + )) + +(defmacro xref-elisp-deftest (name computed-xrefs expected-xrefs) + "Define an ert test for an xref-elisp feature. +COMPUTED-XREFS and EXPECTED-XREFS are lists of xrefs, except if +an element of EXPECTED-XREFS is a cons (XREF . TARGET), TARGET is +matched to the found location; otherwise, match +to (xref-elisp-test-descr-to-target xref)." + (declare (indent defun) + (debug (symbolp "name"))) + `(ert-deftest ,(intern (concat "xref-elisp-test-" (symbol-name name))) () + (let ((find-file-suppress-same-file-warnings t)) + (xref-elisp-test-run ,computed-xrefs ,expected-xrefs) + ))) + +;; When tests are run from the Makefile, 'default-directory' is $HOME, +;; so we must provide this dir to expand-file-name in the expected +;; results. This also allows running these tests from other +;; directories. +;; +;; We add 'downcase' here to deliberately cause a potential problem on +;; case-insensitive file systems. On such systems, `load-file-name' +;; may not have the same case as the real file system, since the user +;; can set `load-path' to have the wrong case (on my Windows system, +;; `load-path' has the correct case, so this causes the expected test +;; values to have the wrong case). This is handled in +;; `xref-elisp-test-run'. +(defconst emacs-test-dir (downcase (file-name-directory (or load-file-name (buffer-file-name))))) + + +;; alphabetical by test name + +;; Autoloads require no special support; they are handled as functions. + +;; FIXME: defalias-defun-c cmpl-prefix-entry-head +;; FIXME: defalias-defvar-el allout-mode-map + +(xref-elisp-deftest find-defs-constructor + (elisp--xref-find-definitions 'xref-make-elisp-location) + ;; 'xref-make-elisp-location' is just a name for the default + ;; constructor created by the cl-defstruct, so the location is the + ;; cl-defstruct location. + (list + (cons + (xref-make "(cl-defstruct (xref-elisp-location (:constructor xref-make-elisp-location)))" + (xref-make-elisp-location + 'xref-elisp-location 'define-type + (expand-file-name "../../../lisp/progmodes/elisp-mode.el" emacs-test-dir))) + ;; It's not worth adding another special case to `xref-elisp-test-descr-to-target' for this + "(cl-defstruct (xref-elisp-location") + )) + +(xref-elisp-deftest find-defs-defalias-defun-el + (elisp--xref-find-definitions 'Buffer-menu-sort) + (list + (xref-make "(defalias Buffer-menu-sort)" + (xref-make-elisp-location + 'Buffer-menu-sort 'defalias + (expand-file-name "../../../lisp/buff-menu.elc" emacs-test-dir))) + (xref-make "(defun tabulated-list-sort)" + (xref-make-elisp-location + 'tabulated-list-sort nil + (expand-file-name "../../../lisp/emacs-lisp/tabulated-list.el" emacs-test-dir))) + )) + +;; FIXME: defconst + +;; FIXME: eieio defclass + +;; Possible ways of defining the default method implementation for a +;; generic function. We declare these here, so we know we cover all +;; cases, and we don't rely on other code not changing. +;; +;; When the generic and default method are declared in the same place, +;; elisp--xref-find-definitions only returns one. + +(cl-defstruct (xref-elisp-root-type) + slot-1) + +(cl-defgeneric xref-elisp-generic-no-methods (arg1 arg2) + "doc string generic no-methods" + ;; No default implementation, no methods, but fboundp is true for + ;; this symbol; it calls cl-no-applicable-method + ) + +;; WORKAROUND: ‘this’ is unused, and the byte compiler complains, so +;; it should be spelled ‘_this’. But for some unknown reason, that +;; causes the batch mode test to fail; the symbol shows up as +;; ‘this’. It passes in interactive tests, so I haven't been able to +;; track down the problem. +(cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2) + "doc string generic no-default xref-elisp-root-type" + "non-default for no-default") + +;; defgeneric after defmethod in file to ensure the fallback search +;; method of just looking for the function name will fail. +(cl-defgeneric xref-elisp-generic-no-default (arg1 arg2) + "doc string generic no-default generic" + ;; No default implementation; this function calls the cl-generic + ;; dispatching code. + ) + +(cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2) + "doc string generic co-located-default" + "co-located default") + +(cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2) + "doc string generic co-located-default xref-elisp-root-type" + "non-default for co-located-default") + +(cl-defgeneric xref-elisp-generic-separate-default (arg1 arg2) + "doc string generic separate-default" + ;; default implementation provided separately + ) + +(cl-defmethod xref-elisp-generic-separate-default (arg1 arg2) + "doc string generic separate-default default" + "separate default") + +(cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2) + "doc string generic separate-default xref-elisp-root-type" + "non-default for separate-default") + +(cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2) + "doc string generic implicit-generic default" + "default for implicit generic") + +(cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2) + "doc string generic implicit-generic xref-elisp-root-type" + "non-default for implicit generic") + + +(xref-elisp-deftest find-defs-defgeneric-no-methods + (elisp--xref-find-definitions 'xref-elisp-generic-no-methods) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-no-methods)" + (xref-make-elisp-location + 'xref-elisp-generic-no-methods 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-no-default + (elisp--xref-find-definitions 'xref-elisp-generic-no-default) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-no-default)" + (xref-make-elisp-location + 'xref-elisp-generic-no-default 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-no-default xref-elisp-root-type t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-co-located-default + (elisp--xref-find-definitions 'xref-elisp-generic-co-located-default) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-co-located-default)" + (xref-make-elisp-location + 'xref-elisp-generic-co-located-default 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-co-located-default xref-elisp-root-type t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-separate-default + (elisp--xref-find-definitions 'xref-elisp-generic-separate-default) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-separate-default)" + (xref-make-elisp-location + 'xref-elisp-generic-separate-default 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-separate-default (arg1 arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-separate-default t t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-separate-default xref-elisp-root-type t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-implicit-generic + (elisp--xref-find-definitions 'xref-elisp-generic-implicit-generic) + (list + (xref-make "(cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-implicit-generic t t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-implicit-generic xref-elisp-root-type t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +;; Test that we handle more than one method + +;; When run from the Makefile, etags is not loaded at compile time, +;; but it is by the time this test is run. interactively; don't fail +;; for that. +(require 'etags) +(xref-elisp-deftest find-defs-defgeneric-el + (elisp--xref-find-definitions 'xref-location-marker) + (list + (xref-make "(cl-defgeneric xref-location-marker)" + (xref-make-elisp-location + 'xref-location-marker 'cl-defgeneric + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-elisp-location)))" + (xref-make-elisp-location + '(xref-location-marker xref-elisp-location) 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/elisp-mode.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-file-location)))" + (xref-make-elisp-location + '(xref-location-marker xref-file-location) 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-buffer-location)))" + (xref-make-elisp-location + '(xref-location-marker xref-buffer-location) 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-bogus-location)))" + (xref-make-elisp-location + '(xref-location-marker xref-bogus-location) 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-etags-location)))" + (xref-make-elisp-location + '(xref-location-marker xref-etags-location) 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/etags.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-eval + (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ()))) + nil) + +;; Define some mode-local overloadable/overridden functions for xref to find +(require 'mode-local) + +(define-overloadable-function xref-elisp-overloadable-no-methods () + "doc string overloadable no-methods") + +(define-overloadable-function xref-elisp-overloadable-no-default () + "doc string overloadable no-default") + +;; FIXME: byte compiler complains about unused lexical arguments +;; generated by this macro. +(define-mode-local-override xref-elisp-overloadable-no-default c-mode + (start end &optional nonterminal depth returnonerror) + "doc string overloadable no-default c-mode." + "result overloadable no-default c-mode.") + +(define-overloadable-function xref-elisp-overloadable-co-located-default () + "doc string overloadable co-located-default" + "result overloadable co-located-default.") + +(define-mode-local-override xref-elisp-overloadable-co-located-default c-mode + (start end &optional nonterminal depth returnonerror) + "doc string overloadable co-located-default c-mode." + "result overloadable co-located-default c-mode.") + +(define-overloadable-function xref-elisp-overloadable-separate-default () + "doc string overloadable separate-default.") + +(defun xref-elisp-overloadable-separate-default-default () + "doc string overloadable separate-default default" + "result overloadable separate-default.") + +(define-mode-local-override xref-elisp-overloadable-separate-default c-mode + (start end &optional nonterminal depth returnonerror) + "doc string overloadable separate-default c-mode." + "result overloadable separate-default c-mode.") + +(xref-elisp-deftest find-defs-define-overload-no-methods + (elisp--xref-find-definitions 'xref-elisp-overloadable-no-methods) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-no-methods)" + (xref-make-elisp-location + 'xref-elisp-overloadable-no-methods 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-define-overload-no-default + (elisp--xref-find-definitions 'xref-elisp-overloadable-no-default) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-no-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-no-default 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(define-mode-local-override xref-elisp-overloadable-no-default c-mode)" + (xref-make-elisp-location + '(xref-elisp-overloadable-no-default-c-mode . c-mode) 'define-mode-local-override + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-define-overload-co-located-default + (elisp--xref-find-definitions 'xref-elisp-overloadable-co-located-default) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-co-located-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-co-located-default 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(define-mode-local-override xref-elisp-overloadable-co-located-default c-mode)" + (xref-make-elisp-location + '(xref-elisp-overloadable-co-located-default-c-mode . c-mode) 'define-mode-local-override + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-define-overload-separate-default + (elisp--xref-find-definitions 'xref-elisp-overloadable-separate-default) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-separate-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-separate-default 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(defun xref-elisp-overloadable-separate-default-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-separate-default-default nil + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(define-mode-local-override xref-elisp-overloadable-separate-default c-mode)" + (xref-make-elisp-location + '(xref-elisp-overloadable-separate-default-c-mode . c-mode) 'define-mode-local-override + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defun-el + (elisp--xref-find-definitions 'xref-find-definitions) + (list + (xref-make "(defun xref-find-definitions)" + (xref-make-elisp-location + 'xref-find-definitions nil + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))))) + +(xref-elisp-deftest find-defs-defun-eval + (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ()))) + nil) + +(xref-elisp-deftest find-defs-defun-c + (elisp--xref-find-definitions 'buffer-live-p) + (list + (xref-make "(defun buffer-live-p)" + (xref-make-elisp-location 'buffer-live-p nil "src/buffer.c")))) + +;; FIXME: deftype + +(xref-elisp-deftest find-defs-defun-c-defvar-c + (xref-backend-definitions 'elisp "system-name") + (list + (xref-make "(defvar system-name)" + (xref-make-elisp-location 'system-name 'defvar "src/editfns.c")) + (xref-make "(defun system-name)" + (xref-make-elisp-location 'system-name nil "src/editfns.c"))) + ) + +(xref-elisp-deftest find-defs-defun-el-defvar-c + (xref-backend-definitions 'elisp "abbrev-mode") + ;; It's a minor mode, but the variable is defined in buffer.c + (list + (xref-make "(defvar abbrev-mode)" + (xref-make-elisp-location 'abbrev-mode 'defvar "src/buffer.c")) + (cons + (xref-make "(defun abbrev-mode)" + (xref-make-elisp-location + 'abbrev-mode nil + (expand-file-name "../../../lisp/abbrev.el" emacs-test-dir))) + "(define-minor-mode abbrev-mode")) + ) + +;; Source for both variable and defun is "(define-minor-mode +;; compilation-minor-mode". There is no way to tell that directly from +;; the symbol, but we can use (memq sym minor-mode-list) to detect +;; that the symbol is a minor mode. See `elisp--xref-find-definitions' +;; for more comments. +;; +;; IMPROVEME: return defvar instead of defun if source near starting +;; point indicates the user is searching for a variable, not a +;; function. +(require 'compile) ;; not loaded by default at test time +(xref-elisp-deftest find-defs-defun-defvar-el + (elisp--xref-find-definitions 'compilation-minor-mode) + (list + (cons + (xref-make "(defun compilation-minor-mode)" + (xref-make-elisp-location + 'compilation-minor-mode nil + (expand-file-name "../../../lisp/progmodes/compile.el" emacs-test-dir))) + "(define-minor-mode compilation-minor-mode") + )) + +(xref-elisp-deftest find-defs-defvar-el + (elisp--xref-find-definitions 'xref--marker-ring) + (list + (xref-make "(defvar xref--marker-ring)" + (xref-make-elisp-location + 'xref--marker-ring 'defvar + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defvar-c + (elisp--xref-find-definitions 'default-directory) + (list + (cons + (xref-make "(defvar default-directory)" + (xref-make-elisp-location 'default-directory 'defvar "src/buffer.c")) + ;; IMPROVEME: we might be able to compute this target + "DEFVAR_PER_BUFFER (\"default-directory\""))) + +(xref-elisp-deftest find-defs-defvar-eval + (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil))) + nil) + +(xref-elisp-deftest find-defs-face-el + (elisp--xref-find-definitions 'font-lock-keyword-face) + ;; 'font-lock-keyword-face is both a face and a var + (list + (xref-make "(defvar font-lock-keyword-face)" + (xref-make-elisp-location + 'font-lock-keyword-face 'defvar + (expand-file-name "../../../lisp/font-lock.el" emacs-test-dir))) + (xref-make "(defface font-lock-keyword-face)" + (xref-make-elisp-location + 'font-lock-keyword-face 'defface + (expand-file-name "../../../lisp/font-lock.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-face-eval + (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil ""))) + nil) + +(xref-elisp-deftest find-defs-feature-el + (elisp--xref-find-definitions 'xref) + (list + (cons + (xref-make "(feature xref)" + (xref-make-elisp-location + 'xref 'feature + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + ";;; Code:") + )) + +(xref-elisp-deftest find-defs-feature-eval + (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature))) + nil) + +(provide 'elisp-mode-tests) +;;; elisp-mode-tests.el ends here diff --cc test/lisp/progmodes/f90.el index e429b21c092,00000000000..fece86ca1d8 mode 100644,000000..100644 --- a/test/lisp/progmodes/f90.el +++ b/test/lisp/progmodes/f90.el @@@ -1,258 -1,0 +1,258 @@@ +;;; f90.el --- tests for progmodes/f90.el + - ;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Glenn Morris + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file does not have "test" in the name, because it lives under +;; a test/ directory, so that would be superfluous. + +;;; Code: + +(require 'ert) +(require 'f90) + +(defconst f90-test-indent "\ +!! Comment before code. +!!! Comments before code. +#preprocessor before code + +program progname + + implicit none + + integer :: i + + !! Comment. + + do i = 1, 10 + +#preprocessor + + !! Comment. + if ( i % 2 == 0 ) then + !! Comment. + cycle + else + write(*,*) i + end if + end do + +!!! Comment. + +end program progname +" + "Test string for F90 indentation.") + +(ert-deftest f90-test-indent () + "Test F90 indentation." + (with-temp-buffer + (f90-mode) + (insert f90-test-indent) + (indent-rigidly (point-min) (point-max) -999) + (f90-indent-region (point-min) (point-max)) + (should (string-equal (buffer-string) f90-test-indent)))) + +(ert-deftest f90-test-bug3729 () + "Test for http://debbugs.gnu.org/3729 ." + :expected-result :failed + (with-temp-buffer + (f90-mode) + (insert "!! Comment + +include \"file.f90\" + +subroutine test (x) + real x + x = x+1. + return +end subroutine test") + (goto-char (point-min)) + (forward-line 2) + (f90-indent-subprogram) + (should (= 0 (current-indentation))))) + +(ert-deftest f90-test-bug3730 () + "Test for http://debbugs.gnu.org/3730 ." + (with-temp-buffer + (f90-mode) + (insert "a" ) + (move-to-column 68 t) + (insert "(/ x /)") + (f90-do-auto-fill) + (beginning-of-line) + (skip-chars-forward "[ \t]") + (should (equal "&(/" (buffer-substring (point) (+ 3 (point))))))) + +;; TODO bug#5593 + +(ert-deftest f90-test-bug8691 () + "Test for http://debbugs.gnu.org/8691 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, bind(c) :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +;; TODO bug#8812 + +(ert-deftest f90-test-bug8820 () + "Test for http://debbugs.gnu.org/8820 ." + (with-temp-buffer + (f90-mode) + (should (eq (char-syntax ?%) (string-to-char "."))))) + +(ert-deftest f90-test-bug9553a () + "Test for http://debbugs.gnu.org/9553 ." + (with-temp-buffer + (f90-mode) + (insert "!!!") + (dotimes (_i 20) (insert " aaaa")) + (f90-do-auto-fill) + (beginning-of-line) + ;; This gives a more informative failure than looking-at. + (should (equal "!!! a" (buffer-substring (point) (+ 5 (point))))))) + +(ert-deftest f90-test-bug9553b () + "Test for http://debbugs.gnu.org/9553 ." + (with-temp-buffer + (f90-mode) + (insert "!!!") + (dotimes (_i 13) (insert " aaaa")) + (insert "a, aaaa") + (f90-do-auto-fill) + (beginning-of-line) + (should (equal "!!! a" (buffer-substring (point) (+ 5 (point))))))) + +(ert-deftest f90-test-bug9690 () + "Test for http://debbugs.gnu.org/9690 ." + (with-temp-buffer + (f90-mode) + (insert "#include \"foo.h\"") + (f90-indent-line) + (should (= 0 (current-indentation))))) + +(ert-deftest f90-test-bug13138 () + "Test for http://debbugs.gnu.org/13138 ." + (with-temp-buffer + (f90-mode) + (insert "program prog + integer :: i = & +#ifdef foo + & 1 +#else + & 2 +#endif + + write(*,*) i +end program prog") + (goto-char (point-min)) + (forward-line 2) + (f90-indent-subprogram) + (should (= 0 (current-indentation))))) + +(ert-deftest f90-test-bug-19809 () + "Test for http://debbugs.gnu.org/19809 ." + (with-temp-buffer + (f90-mode) + ;; The Fortran standard says that continued strings should have + ;; '&' at the start of continuation lines, but it seems gfortran + ;; allows them to be absent (albeit with a warning). + (insert "program prog + write (*,*), '& +end program prog' +end program prog") + (goto-char (point-min)) + (f90-end-of-subprogram) + (should (= (point) (point-max))))) + +(ert-deftest f90-test-bug20680 () + "Test for http://debbugs.gnu.org/20680 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, extends ( sometype ) :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug20680b () + "Test for http://debbugs.gnu.org/20680 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +enum, bind(c) +enumerator :: e1 = 0 +end enum +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug20969 () + "Test for http://debbugs.gnu.org/20969 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, extends ( sometype ), private :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug20969b () + "Test for http://debbugs.gnu.org/20969 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, private, extends ( sometype ) :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug21794 () + "Test for http://debbugs.gnu.org/21794 ." + (with-temp-buffer + (f90-mode) + (insert "program prog +do i=1,10 +associate (x => xa(i), y => ya(i)) +a(x,y,i) = fun(x,y,i) +end associate +end do +end program prog") + (f90-indent-subprogram) + (forward-line -2) + (should (= 5 (current-indentation))))) + +;;; f90.el ends here diff --cc test/lisp/progmodes/flymake-tests.el index 1d8c12c0655,00000000000..386516190bb mode 100644,000000..100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@@ -1,80 -1,0 +1,80 @@@ +;;; flymake-tests.el --- Test suite for flymake + - ;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Eduard Wiebe + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: +(require 'ert) +(require 'flymake) + +(defvar flymake-tests-data-directory + (expand-file-name "lisp/progmodes/flymake-resources" (getenv "EMACS_TEST_DIRECTORY")) + "Directory containing flymake test data.") + + +;; Warning predicate +(defun flymake-tests--current-face (file predicate) + (let ((buffer (find-file-noselect + (expand-file-name file flymake-tests-data-directory))) + (process-environment (cons "LC_ALL=C" process-environment)) + (i 0)) + (unwind-protect + (with-current-buffer buffer + (setq-local flymake-warning-predicate predicate) + (goto-char (point-min)) + (flymake-mode 1) + ;; Weirdness here... http://debbugs.gnu.org/17647#25 + (while (and flymake-is-running (< (setq i (1+ i)) 10)) + (sleep-for (+ 0.5 flymake-no-changes-timeout))) + (flymake-goto-next-error) + (face-at-point)) + (and buffer (let (kill-buffer-query-functions) (kill-buffer buffer)))))) + +(ert-deftest warning-predicate-rx-gcc () + "Test GCC warning via regexp predicate." + (skip-unless (and (executable-find "gcc") (executable-find "make"))) + (should (eq 'flymake-warnline + (flymake-tests--current-face "test.c" "^[Ww]arning")))) + +(ert-deftest warning-predicate-function-gcc () + "Test GCC warning via function predicate." + (skip-unless (and (executable-find "gcc") (executable-find "make"))) + (should (eq 'flymake-warnline + (flymake-tests--current-face "test.c" + (lambda (msg) (string-match "^[Ww]arning" msg)))))) + +(ert-deftest warning-predicate-rx-perl () + "Test perl warning via regular expression predicate." + (skip-unless (executable-find "perl")) + (should (eq 'flymake-warnline + (flymake-tests--current-face "test.pl" "^Scalar value")))) + +(ert-deftest warning-predicate-function-perl () + "Test perl warning via function predicate." + (skip-unless (executable-find "perl")) + (should (eq 'flymake-warnline + (flymake-tests--current-face + "test.pl" + (lambda (msg) (string-match "^Scalar value" msg)))))) + +(provide 'flymake-tests) + +;;; flymake.el ends here diff --cc test/lisp/progmodes/python-tests.el index 9da6807c144,00000000000..ec93c01059c mode 100644,000000..100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@@ -1,5232 -1,0 +1,5232 @@@ +;;; python-tests.el --- Test suite for python.el + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'python) + +;; Dependencies for testing: +(require 'electric) +(require 'hideshow) +(require 'tramp-sh) + + +(defmacro python-tests-with-temp-buffer (contents &rest body) + "Create a `python-mode' enabled temp buffer with CONTENTS. +BODY is code to be executed within the temp buffer. Point is +always located at the beginning of buffer." + (declare (indent 1) (debug t)) + `(with-temp-buffer + (let ((python-indent-guess-indent-offset nil)) + (python-mode) + (insert ,contents) + (goto-char (point-min)) + ,@body))) + +(defmacro python-tests-with-temp-file (contents &rest body) + "Create a `python-mode' enabled file with CONTENTS. +BODY is code to be executed within the temp buffer. Point is +always located at the beginning of buffer." + (declare (indent 1) (debug t)) + ;; temp-file never actually used for anything? + `(let* ((temp-file (make-temp-file "python-tests" nil ".py")) + (buffer (find-file-noselect temp-file)) + (python-indent-guess-indent-offset nil)) + (unwind-protect + (with-current-buffer buffer + (python-mode) + (insert ,contents) + (goto-char (point-min)) + ,@body) + (and buffer (kill-buffer buffer)) + (delete-file temp-file)))) + +(defun python-tests-look-at (string &optional num restore-point) + "Move point at beginning of STRING in the current buffer. +Optional argument NUM defaults to 1 and is an integer indicating +how many occurrences must be found, when positive the search is +done forwards, otherwise backwards. When RESTORE-POINT is +non-nil the point is not moved but the position found is still +returned. When searching forward and point is already looking at +STRING, it is skipped so the next STRING occurrence is selected." + (let* ((num (or num 1)) + (starting-point (point)) + (string (regexp-quote string)) + (search-fn (if (> num 0) #'re-search-forward #'re-search-backward)) + (deinc-fn (if (> num 0) #'1- #'1+)) + (found-point)) + (prog2 + (catch 'exit + (while (not (= num 0)) + (when (and (> num 0) + (looking-at string)) + ;; Moving forward and already looking at STRING, skip it. + (forward-char (length (match-string-no-properties 0)))) + (and (not (funcall search-fn string nil t)) + (throw 'exit t)) + (when (> num 0) + ;; `re-search-forward' leaves point at the end of the + ;; occurrence, move back so point is at the beginning + ;; instead. + (forward-char (- (length (match-string-no-properties 0))))) + (setq + num (funcall deinc-fn num) + found-point (point)))) + found-point + (and restore-point (goto-char starting-point))))) + +(defun python-tests-self-insert (char-or-str) + "Call `self-insert-command' for chars in CHAR-OR-STR." + (let ((chars + (cond + ((characterp char-or-str) + (list char-or-str)) + ((stringp char-or-str) + (string-to-list char-or-str)) + ((not + (cl-remove-if #'characterp char-or-str)) + char-or-str) + (t (error "CHAR-OR-STR must be a char, string, or list of char"))))) + (mapc + (lambda (char) + (let ((last-command-event char)) + (call-interactively 'self-insert-command))) + chars))) + +(defun python-tests-visible-string (&optional min max) + "Return the buffer string excluding invisible overlays. +Argument MIN and MAX delimit the region to be returned and +default to `point-min' and `point-max' respectively." + (let* ((min (or min (point-min))) + (max (or max (point-max))) + (buffer (current-buffer)) + (buffer-contents (buffer-substring-no-properties min max)) + (overlays + (sort (overlays-in min max) + (lambda (a b) + (let ((overlay-end-a (overlay-end a)) + (overlay-end-b (overlay-end b))) + (> overlay-end-a overlay-end-b)))))) + (with-temp-buffer + (insert buffer-contents) + (dolist (overlay overlays) + (if (overlay-get overlay 'invisible) + (delete-region (overlay-start overlay) + (overlay-end overlay)))) + (buffer-substring-no-properties (point-min) (point-max))))) + + +;;; Tests for your tests, so you can test while you test. + +(ert-deftest python-tests-look-at-1 () + "Test forward movement." + (python-tests-with-temp-buffer + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, +sed do eiusmod tempor incididunt ut labore et dolore magna +aliqua." + (let ((expected (save-excursion + (dotimes (i 3) + (re-search-forward "et" nil t)) + (forward-char -2) + (point)))) + (should (= (python-tests-look-at "et" 3 t) expected)) + ;; Even if NUM is bigger than found occurrences the point of last + ;; one should be returned. + (should (= (python-tests-look-at "et" 6 t) expected)) + ;; If already looking at STRING, it should skip it. + (dotimes (i 2) (re-search-forward "et")) + (forward-char -2) + (should (= (python-tests-look-at "et") expected))))) + +(ert-deftest python-tests-look-at-2 () + "Test backward movement." + (python-tests-with-temp-buffer + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, +sed do eiusmod tempor incididunt ut labore et dolore magna +aliqua." + (let ((expected + (save-excursion + (re-search-forward "et" nil t) + (forward-char -2) + (point)))) + (dotimes (i 3) + (re-search-forward "et" nil t)) + (should (= (python-tests-look-at "et" -3 t) expected)) + (should (= (python-tests-look-at "et" -6 t) expected))))) + + +;;; Bindings + + +;;; Python specialized rx + + +;;; Font-lock and syntax + +(ert-deftest python-syntax-after-python-backspace () + ;; `python-indent-dedent-line-backspace' garbles syntax + :expected-result :failed + (python-tests-with-temp-buffer + "\"\"\"" + (goto-char (point-max)) + (python-indent-dedent-line-backspace 1) + (should (string= (buffer-string) "\"\"")) + (should (null (nth 3 (syntax-ppss)))))) + + +;;; Indentation + +;; See: http://www.python.org/dev/peps/pep-0008/#indentation + +(ert-deftest python-indent-pep8-1 () + "First pep8 case." + (python-tests-with-temp-buffer + "# Aligned with opening delimiter +foo = long_function_name(var_one, var_two, + var_three, var_four) +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "foo = long_function_name(var_one, var_two,") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "var_three, var_four)") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 25)))) + +(ert-deftest python-indent-pep8-2 () + "Second pep8 case." + (python-tests-with-temp-buffer + "# More indentation included to distinguish this from the rest. +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "def long_function_name(") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "var_one, var_two, var_three,") + (should (eq (car (python-indent-context)) + :inside-paren-newline-start-from-block)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "var_four):") + (should (eq (car (python-indent-context)) + :inside-paren-newline-start-from-block)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "print (var_one)") + (should (eq (car (python-indent-context)) + :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-pep8-3 () + "Third pep8 case." + (python-tests-with-temp-buffer + "# Extra indentation is not necessary. +foo = long_function_name( + var_one, var_two, + var_three, var_four) +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "foo = long_function_name(") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "var_one, var_two,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "var_three, var_four)") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-base-case () + "Check base case does not trigger errors." + (python-tests-with-temp-buffer + " + +" + (goto-char (point-min)) + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-comment-1 () + "The most simple after-comment case that shouldn't fail." + (python-tests-with-temp-buffer + "# Contents will be modified to correct indentation +class Blag(object): + def _on_child_complete(self, child_future): + if self.in_terminal_state(): + pass + # We only complete when all our async children have entered a + # terminal state. At that point, if any child failed, we fail +# with the exception with which the first child failed. +" + (python-tests-look-at "# We only complete") + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "# terminal state") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "# with the exception") + (should (eq (car (python-indent-context)) :after-comment)) + ;; This one indents relative to previous block, even given the fact + ;; that it was under-indented. + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "# terminal state" -1) + ;; It doesn't hurt to check again. + (should (eq (car (python-indent-context)) :after-comment)) + (python-indent-line) + (should (= (current-indentation) 8)) + (python-tests-look-at "# with the exception") + (should (eq (car (python-indent-context)) :after-comment)) + ;; Now everything should be lined up. + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-after-comment-2 () + "Test after-comment in weird cases." + (python-tests-with-temp-buffer + "# Contents will be modified to correct indentation +def func(arg): + # I don't do much + return arg + # This comment is badly indented because the user forced so. + # At this line python.el wont dedent, user is always right. + +comment_wins_over_ender = True + +# yeah, that. +" + (python-tests-look-at "# I don't do much") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "return arg") + ;; Comment here just gets ignored, this line is not a comment so + ;; the rules won't apply here. + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "# This comment is badly indented") + (should (eq (car (python-indent-context)) :after-block-end)) + ;; The return keyword do make indentation lose a level... + (should (= (python-indent-calculate-indentation) 0)) + ;; ...but the current indentation was forced by the user. + (python-tests-look-at "# At this line python.el wont dedent") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)) + ;; Should behave the same for blank lines: potentially a comment. + (forward-line 1) + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "comment_wins_over_ender") + ;; The comment won over the ender because the user said so. + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)) + ;; The indentation calculated fine for the assignment, but the user + ;; choose to force it back to the first column. Next line should + ;; be aware of that. + (python-tests-look-at "# yeah, that.") + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-comment-3 () + "Test after-comment in buggy case." + (python-tests-with-temp-buffer + " +class A(object): + + def something(self, arg): + if True: + return arg + + # A comment + + @adecorator + def method(self, a, b): + pass +" + (python-tests-look-at "@adecorator") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-inside-paren-1 () + "The most simple inside-paren case that shouldn't fail." + (python-tests-with-temp-buffer + " +data = { + 'key': + { + 'objlist': [ + { + 'pk': 1, + 'name': 'first', + }, + { + 'pk': 2, + 'name': 'second', + } + ] + } +} +" + (python-tests-look-at "data = {") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "'key':") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "{") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "'objlist': [") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "{") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "'pk': 1,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "'name': 'first',") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "},") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "{") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "'pk': 2,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "'name': 'second',") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "]") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-inside-paren-2 () + "Another more compact paren group style." + (python-tests-with-temp-buffer + " +data = {'key': { + 'objlist': [ + {'pk': 1, + 'name': 'first'}, + {'pk': 2, + 'name': 'second'} + ] +}} +" + (python-tests-look-at "data = {") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "'objlist': [") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "{'pk': 1,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "'name': 'first'},") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 9)) + (python-tests-look-at "{'pk': 2,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "'name': 'second'}") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 9)) + (python-tests-look-at "]") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "}}") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-inside-paren-3 () + "The simplest case possible." + (python-tests-with-temp-buffer + " +data = ('these', + 'are', + 'the', + 'tokens') +" + (python-tests-look-at "data = ('these',") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-inside-paren-4 () + "Respect indentation of first column." + (python-tests-with-temp-buffer + " +data = [ [ 'these', 'are'], + ['the', 'tokens' ] ] +" + (python-tests-look-at "data = [ [ 'these', 'are'],") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 9)))) + +(ert-deftest python-indent-inside-paren-5 () + "Test when :inside-paren initial parens are skipped in context start." + (python-tests-with-temp-buffer + " +while ((not some_condition) and + another_condition): + do_something_interesting( + with_some_arg) +" + (python-tests-look-at "while ((not some_condition) and") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 7)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-inside-paren-6 () + "This should be aligned.." + (python-tests-with-temp-buffer + " +CHOICES = (('some', 'choice'), + ('another', 'choice'), + ('more', 'choices')) +" + (python-tests-look-at "CHOICES = (('some', 'choice'),") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 11)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 11)))) + +(ert-deftest python-indent-inside-paren-7 () + "Test for Bug#21762." + (python-tests-with-temp-buffer + "import re as myre\nvar = [\n" + (goto-char (point-max)) + ;; This signals an error if the test fails + (should (eq (car (python-indent-context)) :inside-paren-newline-start)))) + +(ert-deftest python-indent-after-block-1 () + "The most simple after-block case that shouldn't fail." + (python-tests-with-temp-buffer + " +def foo(a, b, c=True): +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-block-2 () + "A weird (malformed) multiline block statement." + (python-tests-with-temp-buffer + " +def foo(a, b, c={ + 'a': +}): +" + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-block-3 () + "A weird (malformed) sample, usually found in python shells." + (python-tests-with-temp-buffer + " +In [1]: +def func(): +pass + +In [2]: +something +" + (python-tests-look-at "pass") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "something") + (end-of-line) + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-backslash-1 () + "The most common case." + (python-tests-with-temp-buffer + " +from foo.bar.baz import something, something_1 \\\\ + something_2 something_3, \\\\ + something_4, something_5 +" + (python-tests-look-at "from foo.bar.baz import something, something_1") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "something_2 something_3,") + (should (eq (car (python-indent-context)) :after-backslash-first-line)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "something_4, something_5") + (should (eq (car (python-indent-context)) :after-backslash)) + (should (= (python-indent-calculate-indentation) 4)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-backslash-2 () + "A pretty extreme complicated case." + (python-tests-with-temp-buffer + " +objects = Thing.objects.all() \\\\ + .filter( + type='toy', + status='bought' + ) \\\\ + .aggregate( + Sum('amount') + ) \\\\ + .values_list() +" + (python-tests-look-at "objects = Thing.objects.all()") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at ".filter(") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at "type='toy',") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 27)) + (python-tests-look-at "status='bought'") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 27)) + (python-tests-look-at ") \\\\") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at ".aggregate(") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at "Sum('amount')") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 27)) + (python-tests-look-at ") \\\\") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at ".values_list()") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 23)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-backslash-3 () + "Backslash continuation from block start." + (python-tests-with-temp-buffer + " +with open('/path/to/some/file/you/want/to/read') as file_1, \\\\ + open('/path/to/some/file/being/written', 'w') as file_2: + file_2.write(file_1.read()) +" + (python-tests-look-at + "with open('/path/to/some/file/you/want/to/read') as file_1, \\\\") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at + "open('/path/to/some/file/being/written', 'w') as file_2") + (should (eq (car (python-indent-context)) + :after-backslash-block-continuation)) + (should (= (python-indent-calculate-indentation) 5)) + (python-tests-look-at "file_2.write(file_1.read())") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-backslash-4 () + "Backslash continuation from assignment." + (python-tests-with-temp-buffer + " +super_awful_assignment = some_calculation() and \\\\ + another_calculation() and \\\\ + some_final_calculation() +" + (python-tests-look-at + "super_awful_assignment = some_calculation() and \\\\") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "another_calculation() and \\\\") + (should (eq (car (python-indent-context)) + :after-backslash-assignment-continuation)) + (should (= (python-indent-calculate-indentation) 25)) + (python-tests-look-at "some_final_calculation()") + (should (eq (car (python-indent-context)) :after-backslash)) + (should (= (python-indent-calculate-indentation) 25)))) + +(ert-deftest python-indent-after-backslash-5 () + "Dotted continuation bizarre example." + (python-tests-with-temp-buffer + " +def delete_all_things(): + Thing \\\\ + .objects.all() \\\\ + .delete() +" + (python-tests-look-at "Thing \\\\") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at ".objects.all() \\\\") + (should (eq (car (python-indent-context)) :after-backslash-first-line)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at ".delete()") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 16)))) + +(ert-deftest python-indent-block-enders-1 () + "Test de-indentation for pass keyword." + (python-tests-with-temp-buffer + " +Class foo(object): + + def bar(self): + if self.baz: + return (1, + 2, + 3) + + else: + pass +" + (python-tests-look-at "3)") + (forward-line 1) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "pass") + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-block-enders-2 () + "Test de-indentation for return keyword." + (python-tests-with-temp-buffer + " +Class foo(object): + '''raise lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do + + eiusmod tempor incididunt ut labore et dolore magna aliqua. + ''' + def bar(self): + \"return (1, 2, 3).\" + if self.baz: + return (1, + 2, + 3) +" + (python-tests-look-at "def") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "return") + (should (= (python-indent-calculate-indentation) 12)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-block-enders-3 () + "Test de-indentation for continue keyword." + (python-tests-with-temp-buffer + " +for element in lst: + if element is None: + continue +" + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "continue") + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-block-enders-4 () + "Test de-indentation for break keyword." + (python-tests-with-temp-buffer + " +for element in lst: + if element is None: + break +" + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "break") + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-block-enders-5 () + "Test de-indentation for raise keyword." + (python-tests-with-temp-buffer + " +for element in lst: + if element is None: + raise ValueError('Element cannot be None') +" + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "raise") + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-dedenters-1 () + "Test de-indentation for the elif keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + finally: + cleanup() + elif +" + (python-tests-look-at "elif\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)))) + +(ert-deftest python-indent-dedenters-2 () + "Test de-indentation for the else keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + except Exception: + if hide_details: + logger.exception('Unhandled exception') + else + finally: + data.free() +" + (python-tests-look-at "else\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 0)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 8)))) + +(ert-deftest python-indent-dedenters-3 () + "Test de-indentation for the except keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except +" + (python-tests-look-at "except\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 4)))) + +(ert-deftest python-indent-dedenters-4 () + "Test de-indentation for the finally keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + finally +" + (python-tests-look-at "finally\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-dedenters-5 () + "Test invalid levels are skipped in a complex example." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + finally: + if cleanup: + do_cleanup() + else +" + (python-tests-look-at "else\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 8)) + (should (= (python-indent-calculate-indentation t) 0)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 8)))) + +(ert-deftest python-indent-dedenters-6 () + "Test indentation is zero when no opening block for dedenter." + (python-tests-with-temp-buffer + " +try: + # if save: + write_to_disk(data) + else +" + (python-tests-look-at "else\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)))) + +(ert-deftest python-indent-dedenters-7 () + "Test indentation case from Bug#15163." + (python-tests-with-temp-buffer + " +if a: + if b: + pass + else: + pass + else: +" + (python-tests-look-at "else:" 2) + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)))) + +(ert-deftest python-indent-dedenters-8 () + "Test indentation for Bug#18432." + (python-tests-with-temp-buffer + " +if (a == 1 or + a == 2): + pass +elif (a == 3 or +a == 4): +" + (python-tests-look-at "elif (a == 3 or") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)) + (python-tests-look-at "a == 4):\n") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 6)) + (python-indent-line) + (should (= (python-indent-calculate-indentation t) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 0)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 6)))) + +(ert-deftest python-indent-inside-string-1 () + "Test indentation for strings." + (python-tests-with-temp-buffer + " +multiline = ''' +bunch +of +lines +''' +" + (python-tests-look-at "multiline = '''") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "bunch") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "of") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "lines") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "'''") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-inside-string-2 () + "Test indentation for docstrings." + (python-tests-with-temp-buffer + " +def fn(a, b, c=True): + '''docstring + bunch + of + lines + ''' +" + (python-tests-look-at "'''docstring") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "bunch") + (should (eq (car (python-indent-context)) :inside-docstring)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "of") + (should (eq (car (python-indent-context)) :inside-docstring)) + ;; Any indentation deeper than the base-indent must remain unmodified. + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "lines") + (should (eq (car (python-indent-context)) :inside-docstring)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "'''") + (should (eq (car (python-indent-context)) :inside-docstring)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-inside-string-3 () + "Test indentation for nested strings." + (python-tests-with-temp-buffer + " +def fn(a, b, c=True): + some_var = ''' + bunch + of + lines + ''' +" + (python-tests-look-at "some_var = '''") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "bunch") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "of") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "lines") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "'''") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-electric-colon-1 () + "Test indentation case from Bug#18228." + (python-tests-with-temp-buffer + " +def a(): + pass + +def b() +" + (python-tests-look-at "def b()") + (goto-char (line-end-position)) + (python-tests-self-insert ":") + (should (= (current-indentation) 0)))) + +(ert-deftest python-indent-electric-colon-2 () + "Test indentation case for dedenter." + (python-tests-with-temp-buffer + " +if do: + something() + else +" + (python-tests-look-at "else") + (goto-char (line-end-position)) + (python-tests-self-insert ":") + (should (= (current-indentation) 0)))) + +(ert-deftest python-indent-electric-colon-3 () + "Test indentation case for multi-line dedenter." + (python-tests-with-temp-buffer + " +if do: + something() + elif (this + and + that) +" + (python-tests-look-at "that)") + (goto-char (line-end-position)) + (python-tests-self-insert ":") + (python-tests-look-at "elif" -1) + (should (= (current-indentation) 0)) + (python-tests-look-at "and") + (should (= (current-indentation) 6)) + (python-tests-look-at "that)") + (should (= (current-indentation) 6)))) + +(ert-deftest python-indent-region-1 () + "Test indentation case from Bug#18843." + (let ((contents " +def foo (): + try: + pass + except: + pass +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + contents))))) + +(ert-deftest python-indent-region-2 () + "Test region indentation on comments." + (let ((contents " +def f(): + if True: + pass + +# This is +# some multiline +# comment +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + contents))))) + +(ert-deftest python-indent-region-3 () + "Test region indentation on comments." + (let ((contents " +def f(): + if True: + pass +# This is +# some multiline +# comment +") + (expected " +def f(): + if True: + pass + # This is + # some multiline + # comment +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + expected))))) + +(ert-deftest python-indent-region-4 () + "Test region indentation block starts, dedenters and enders." + (let ((contents " +def f(): + if True: +a = 5 + else: + a = 10 + return a +") + (expected " +def f(): + if True: + a = 5 + else: + a = 10 + return a +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + expected))))) + +(ert-deftest python-indent-region-5 () + "Test region indentation for docstrings." + (let ((contents " +def f(): +''' +this is + a multiline +string +''' + x = \\ + ''' +this is an arbitrarily + indented multiline + string +''' +") + (expected " +def f(): + ''' + this is + a multiline + string + ''' + x = \\ + ''' +this is an arbitrarily + indented multiline + string +''' +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + expected))))) + + +;;; Mark + +(ert-deftest python-mark-defun-1 () + """Test `python-mark-defun' with point at defun symbol start.""" + (python-tests-with-temp-buffer + " +def foo(x): + return x + +class A: + pass + +class B: + + def __init__(self): + self.b = 'b' + + def fun(self): + return self.b + +class C: + '''docstring''' +" + (let ((expected-mark-beginning-position + (progn + (python-tests-look-at "class A:") + (1- (point)))) + (expected-mark-end-position-1 + (save-excursion + (python-tests-look-at "pass") + (forward-line) + (point))) + (expected-mark-end-position-2 + (save-excursion + (python-tests-look-at "return self.b") + (forward-line) + (point))) + (expected-mark-end-position-3 + (save-excursion + (python-tests-look-at "'''docstring'''") + (forward-line) + (point)))) + ;; Select class A only, with point at bol. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-1)) + ;; expand to class B, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-2)) + ;; expand to class C, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-3))))) + +(ert-deftest python-mark-defun-2 () + """Test `python-mark-defun' with point at nested defun symbol start.""" + (python-tests-with-temp-buffer + " +def foo(x): + return x + +class A: + pass + +class B: + + def __init__(self): + self.b = 'b' + + def fun(self): + return self.b + +class C: + '''docstring''' +" + (let ((expected-mark-beginning-position + (progn + (python-tests-look-at "def __init__(self):") + (1- (line-beginning-position)))) + (expected-mark-end-position-1 + (save-excursion + (python-tests-look-at "self.b = 'b'") + (forward-line) + (point))) + (expected-mark-end-position-2 + (save-excursion + (python-tests-look-at "return self.b") + (forward-line) + (point))) + (expected-mark-end-position-3 + (save-excursion + (python-tests-look-at "'''docstring'''") + (forward-line) + (point)))) + ;; Select B.__init only, with point at its start. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-1)) + ;; expand to B.fun, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-2)) + ;; expand to class C, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-3))))) + +(ert-deftest python-mark-defun-3 () + """Test `python-mark-defun' with point inside defun symbol.""" + (python-tests-with-temp-buffer + " +def foo(x): + return x + +class A: + pass + +class B: + + def __init__(self): + self.b = 'b' + + def fun(self): + return self.b + +class C: + '''docstring''' +" + (let ((expected-mark-beginning-position + (progn + (python-tests-look-at "def fun(self):") + (python-tests-look-at "(self):") + (1- (line-beginning-position)))) + (expected-mark-end-position + (save-excursion + (python-tests-look-at "return self.b") + (forward-line) + (point)))) + ;; Should select B.fun, despite point is inside the defun symbol. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position))))) + + +;;; Navigation + +(ert-deftest python-nav-beginning-of-defun-1 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "return wrap") + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def wrapped_f(*args):" -1) + (beginning-of-line) + (point)))) + (python-tests-look-at "def wrapped_f(*args):" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def wwrap(f):" -1) + (beginning-of-line) + (point)))) + (python-tests-look-at "def wwrap(f):" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def decoratorFunctionWithArguments" -1) + (beginning-of-line) + (point)))))) + +(ert-deftest python-nav-beginning-of-defun-2 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + self.c() + + def b(): + pass + + def a(): + pass + + def c(self): + pass +" + ;; Nested defuns, are handled with care. + (python-tests-look-at "def c(self):") + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def m(self):" -1) + (beginning-of-line) + (point)))) + ;; Defuns on same levels should be respected. + (python-tests-look-at "def a():" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def b():" -1) + (beginning-of-line) + (point)))) + ;; Jump to a top level defun. + (python-tests-look-at "def b():" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def m(self):" -1) + (beginning-of-line) + (point)))) + ;; Jump to a top level defun again. + (python-tests-look-at "def m(self):" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "class C(object):" -1) + (beginning-of-line) + (point)))))) + +(ert-deftest python-nav-end-of-defun-1 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + self.c() + + def b(): + pass + + def a(): + pass + + def c(self): + pass +" + (should (= (save-excursion + (python-tests-look-at "class C(object):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))) + (should (= (save-excursion + (python-tests-look-at "def m(self):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def c(self):") + (forward-line -1) + (point)))) + (should (= (save-excursion + (python-tests-look-at "def b():") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def b():") + (forward-line 2) + (point)))) + (should (= (save-excursion + (python-tests-look-at "def c(self):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))))) + +(ert-deftest python-nav-end-of-defun-2 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (should (= (save-excursion + (python-tests-look-at "def decoratorFunctionWithArguments") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))) + (should (= (save-excursion + (python-tests-look-at "@decoratorFunctionWithArguments") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))) + (should (= (save-excursion + (python-tests-look-at "def wwrap(f):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "return wwrap") + (line-beginning-position)))) + (should (= (save-excursion + (python-tests-look-at "def wrapped_f(*args):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-beginning-position)))) + (should (= (save-excursion + (python-tests-look-at "f(*args)") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-beginning-position)))))) + +(ert-deftest python-nav-backward-defun-1 () + (python-tests-with-temp-buffer + " +class A(object): # A + + def a(self): # a + pass + + def b(self): # b + pass + + class B(object): # B + + class C(object): # C + + def d(self): # d + pass + + # def e(self): # e + # pass + + def c(self): # c + pass + + # def d(self): # d + # pass +" + (goto-char (point-max)) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def c(self): # c" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def d(self): # d" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " class C(object): # C" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " class B(object): # B" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def b(self): # b" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def a(self): # a" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at "class A(object): # A" -1))) + (should (not (python-nav-backward-defun))))) + +(ert-deftest python-nav-backward-defun-2 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (goto-char (point-max)) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def wrapped_f(*args):" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def wwrap(f):" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at "def decoratorFunctionWithArguments(arg1, arg2, arg3):" -1))) + (should (not (python-nav-backward-defun))))) + +(ert-deftest python-nav-backward-defun-3 () + (python-tests-with-temp-buffer + " +''' + def u(self): + pass + + def v(self): + pass + + def w(self): + pass +''' + +class A(object): + pass +" + (goto-char (point-min)) + (let ((point (python-tests-look-at "class A(object):"))) + (should (not (python-nav-backward-defun))) + (should (= point (point)))))) + +(ert-deftest python-nav-forward-defun-1 () + (python-tests-with-temp-buffer + " +class A(object): # A + + def a(self): # a + pass + + def b(self): # b + pass + + class B(object): # B + + class C(object): # C + + def d(self): # d + pass + + # def e(self): # e + # pass + + def c(self): # c + pass + + # def d(self): # d + # pass +" + (goto-char (point-min)) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(object): # A"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # a"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # b"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(object): # B"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(object): # C"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # d"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # c"))) + (should (not (python-nav-forward-defun))))) + +(ert-deftest python-nav-forward-defun-2 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (goto-char (point-min)) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(arg1, arg2, arg3):"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(f):"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(*args):"))) + (should (not (python-nav-forward-defun))))) + +(ert-deftest python-nav-forward-defun-3 () + (python-tests-with-temp-buffer + " +class A(object): + pass + +''' + def u(self): + pass + + def v(self): + pass + + def w(self): + pass +''' +" + (goto-char (point-min)) + (let ((point (python-tests-look-at "(object):"))) + (should (not (python-nav-forward-defun))) + (should (= point (point)))))) + +(ert-deftest python-nav-beginning-of-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (python-tests-look-at "v2 =") + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v1 =" -1 t))) + (python-tests-look-at "v3 =") + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v2 =" -1 t))) + (python-tests-look-at "v4 =") + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v3 =" -1 t))) + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v4 =" -1 t))))) + +(ert-deftest python-nav-end-of-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (python-tests-look-at "v1 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (python-tests-look-at "789") + (line-end-position)))) + (python-tests-look-at "v2 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (python-tests-look-at "value4)") + (line-end-position)))) + (python-tests-look-at "v3 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (python-tests-look-at + "'continue previous line')") + (line-end-position)))) + (python-tests-look-at "v4 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (goto-char (point-max)) + (python-util-forward-comment -1) + (point)))))) + +(ert-deftest python-nav-forward-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (python-tests-look-at "v1 =") + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (python-tests-look-at "v2 ="))) + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (python-tests-look-at "v3 ="))) + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (python-tests-look-at "v4 ="))) + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (point-max))))) + +(ert-deftest python-nav-backward-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (goto-char (point-max)) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v4 =" -1))) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v3 =" -1))) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v2 =" -1))) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v1 =" -1))))) + +(ert-deftest python-nav-backward-statement-2 () + :expected-result :failed + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +" + ;; FIXME: For some reason `python-nav-backward-statement' is moving + ;; back two sentences when starting from 'value4)'. + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v2 =" -1 t))))) + +(ert-deftest python-nav-beginning-of-block-1 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "return wwrap") + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def decoratorFunctionWithArguments" -1))) + (python-tests-look-at "print 'Inside wwrap()'") + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def wwrap(f):" -1))) + (python-tests-look-at "print 'After f(*args)'") + (end-of-line) + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def wrapped_f(*args):" -1))) + (python-tests-look-at "return wrapped_f") + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def wwrap(f):" -1))))) + +(ert-deftest python-nav-end-of-block-1 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "def decoratorFunctionWithArguments") + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (goto-char (point-max)) + (python-util-forward-comment -1) + (point)))) + (python-tests-look-at "def wwrap(f):") + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-end-position)))) + (end-of-line) + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-end-position)))) + (python-tests-look-at "f(*args)") + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (python-tests-look-at "print 'After f(*args)'") + (line-end-position)))))) + +(ert-deftest python-nav-forward-block-1 () + "This also accounts as a test for `python-nav-backward-block'." + (python-tests-with-temp-buffer + " +if request.user.is_authenticated(): + # def block(): + # pass + try: + profile = request.user.get_profile() + except Profile.DoesNotExist: + profile = Profile.objects.create(user=request.user) + else: + if profile.stats: + profile.recalculate_stats() + else: + profile.clear_stats() + finally: + profile.views += 1 + profile.save() +" + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "if request.user.is_authenticated():"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "try:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "except Profile.DoesNotExist:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "else:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "if profile.stats:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "else:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "finally:"))) + ;; When point is at the last block, leave it there and return nil + (should (not (save-excursion (python-nav-forward-block)))) + ;; Move backwards, and even if the number of moves is less than the + ;; provided argument return the point. + (should (= (save-excursion (python-nav-forward-block -10)) + (python-tests-look-at + "if request.user.is_authenticated():" -1))))) + +(ert-deftest python-nav-forward-sexp-1 () + (python-tests-with-temp-buffer + " +a() +b() +c() +" + (python-tests-look-at "a()") + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (beginning-of-line) + (looking-at "a()"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (beginning-of-line) + (looking-at "b()"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (beginning-of-line) + (looking-at "c()"))) + ;; The default behavior when next to a paren should do what lisp + ;; does and, otherwise `blink-matching-open' breaks. + (python-nav-forward-sexp -1) + (should (looking-at "()")) + (should (save-excursion + (beginning-of-line) + (looking-at "c()"))) + (end-of-line) + ;; Skipping parens should jump to `bolp' + (python-nav-forward-sexp -1 nil t) + (should (looking-at "c()")) + (forward-line -1) + (end-of-line) + ;; b() + (python-nav-forward-sexp -1) + (should (looking-at "()")) + (python-nav-forward-sexp -1) + (should (looking-at "b()")) + (end-of-line) + (python-nav-forward-sexp -1 nil t) + (should (looking-at "b()")) + (forward-line -1) + (end-of-line) + ;; a() + (python-nav-forward-sexp -1) + (should (looking-at "()")) + (python-nav-forward-sexp -1) + (should (looking-at "a()")) + (end-of-line) + (python-nav-forward-sexp -1 nil t) + (should (looking-at "a()")))) + +(ert-deftest python-nav-forward-sexp-2 () + (python-tests-with-temp-buffer + " +def func(): + if True: + aaa = bbb + ccc = ddd + eee = fff + return ggg +" + (python-tests-look-at "aa =") + (python-nav-forward-sexp) + (should (looking-at " = bbb")) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "aaa = bbb"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "ccc = ddd"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "eee = fff"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "return ggg"))) + (python-nav-forward-sexp -1) + (should (looking-at "def func():")))) + +(ert-deftest python-nav-forward-sexp-3 () + (python-tests-with-temp-buffer + " +from some_module import some_sub_module +from another_module import another_sub_module + +def another_statement(): + pass +" + (python-tests-look-at "some_module") + (python-nav-forward-sexp) + (should (looking-at " import")) + (python-nav-forward-sexp) + (should (looking-at " some_sub_module")) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should + (save-excursion + (back-to-indentation) + (looking-at + "from some_module import some_sub_module"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should + (save-excursion + (back-to-indentation) + (looking-at + "from another_module import another_sub_module"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should + (save-excursion + (back-to-indentation) + (looking-at + "pass"))) + (python-nav-forward-sexp -1) + (should (looking-at "def another_statement():")) + (python-nav-forward-sexp -1) + (should (looking-at "from another_module import another_sub_module")) + (python-nav-forward-sexp -1) + (should (looking-at "from some_module import some_sub_module")))) + +(ert-deftest python-nav-forward-sexp-safe-1 () + (python-tests-with-temp-buffer + " +profile = Profile.objects.create(user=request.user) +profile.notify() +" + (python-tests-look-at "profile =") + (python-nav-forward-sexp-safe 1) + (should (looking-at "$")) + (beginning-of-line 1) + (python-tests-look-at "user=request.user") + (python-nav-forward-sexp-safe -1) + (should (looking-at "(user=request.user)")) + (python-nav-forward-sexp-safe -4) + (should (looking-at "profile =")) + (python-tests-look-at "user=request.user") + (python-nav-forward-sexp-safe 3) + (should (looking-at ")")) + (python-nav-forward-sexp-safe 1) + (should (looking-at "$")) + (python-nav-forward-sexp-safe 1) + (should (looking-at "$")))) + +(ert-deftest python-nav-up-list-1 () + (python-tests-with-temp-buffer + " +def f(): + if True: + return [i for i in range(3)] +" + (python-tests-look-at "3)]") + (python-nav-up-list) + (should (looking-at "]")) + (python-nav-up-list) + (should (looking-at "$")))) + +(ert-deftest python-nav-backward-up-list-1 () + :expected-result :failed + (python-tests-with-temp-buffer + " +def f(): + if True: + return [i for i in range(3)] +" + (python-tests-look-at "3)]") + (python-nav-backward-up-list) + (should (looking-at "(3)\\]")) + (python-nav-backward-up-list) + (should (looking-at + "\\[i for i in range(3)\\]")) + ;; FIXME: Need to move to beginning-of-statement. + (python-nav-backward-up-list) + (should (looking-at + "return \\[i for i in range(3)\\]")) + (python-nav-backward-up-list) + (should (looking-at "if True:")) + (python-nav-backward-up-list) + (should (looking-at "def f():")))) + +(ert-deftest python-indent-dedent-line-backspace-1 () + "Check de-indentation on first call. Bug#18319." + (python-tests-with-temp-buffer + " +if True: + x () + if False: +" + (python-tests-look-at "if False:") + (call-interactively #'python-indent-dedent-line-backspace) + (should (zerop (current-indentation))) + ;; XXX: This should be a call to `undo' but it's triggering errors. + (insert " ") + (should (= (current-indentation) 4)) + (call-interactively #'python-indent-dedent-line-backspace) + (should (zerop (current-indentation))))) + +(ert-deftest python-indent-dedent-line-backspace-2 () + "Check de-indentation with tabs. Bug#19730." + (let ((tab-width 8)) + (python-tests-with-temp-buffer + " +if x: +\tabcdefg +" + (python-tests-look-at "abcdefg") + (goto-char (line-end-position)) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "\tabcdef"))))) + +(ert-deftest python-indent-dedent-line-backspace-3 () + "Paranoid check of de-indentation with tabs. Bug#19730." + (let ((tab-width 8)) + (python-tests-with-temp-buffer + " +if x: +\tif y: +\t abcdefg +" + (python-tests-look-at "abcdefg") + (goto-char (line-end-position)) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "\t abcdef")) + (back-to-indentation) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "\tabcdef")) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + " abcdef")) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "abcdef"))))) + + +;;; Shell integration + +(defvar python-tests-shell-interpreter "python") + +(ert-deftest python-shell-get-process-name-1 () + "Check process name calculation sans `buffer-file-name'." + (python-tests-with-temp-buffer + "" + (should (string= (python-shell-get-process-name nil) + python-shell-buffer-name)) + (should (string= (python-shell-get-process-name t) + (format "%s[%s]" python-shell-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-get-process-name-2 () + "Check process name calculation with `buffer-file-name'." + (python-tests-with-temp-file + "" + ;; `buffer-file-name' is non-nil but the dedicated flag is nil and + ;; should be respected. + (should (string= (python-shell-get-process-name nil) + python-shell-buffer-name)) + (should (string= + (python-shell-get-process-name t) + (format "%s[%s]" python-shell-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-internal-get-process-name-1 () + "Check the internal process name is buffer-unique sans `buffer-file-name'." + (python-tests-with-temp-buffer + "" + (should (string= (python-shell-internal-get-process-name) + (format "%s[%s]" python-shell-internal-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-internal-get-process-name-2 () + "Check the internal process name is buffer-unique with `buffer-file-name'." + (python-tests-with-temp-file + "" + (should (string= (python-shell-internal-get-process-name) + (format "%s[%s]" python-shell-internal-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-calculate-command-1 () + "Check the command to execute is calculated correctly. +Using `python-shell-interpreter' and +`python-shell-interpreter-args'." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((python-shell-interpreter (executable-find + python-tests-shell-interpreter)) + (python-shell-interpreter-args "-B")) + (should (string= + (format "%s %s" + (shell-quote-argument python-shell-interpreter) + python-shell-interpreter-args) + (python-shell-calculate-command))))) + +(ert-deftest python-shell-calculate-pythonpath-1 () + "Test PYTHONPATH calculation." + (let ((process-environment '("PYTHONPATH=/path0")) + (python-shell-extra-pythonpaths '("/path1" "/path2"))) + (should (string= (python-shell-calculate-pythonpath) + (concat "/path1" path-separator + "/path2" path-separator "/path0"))))) + +(ert-deftest python-shell-calculate-pythonpath-2 () + "Test existing paths are moved to front." + (let ((process-environment + (list (concat "PYTHONPATH=/path0" path-separator "/path1"))) + (python-shell-extra-pythonpaths '("/path1" "/path2"))) + (should (string= (python-shell-calculate-pythonpath) + (concat "/path1" path-separator + "/path2" path-separator "/path0"))))) + +(ert-deftest python-shell-calculate-process-environment-1 () + "Test `python-shell-process-environment' modification." + (let* ((python-shell-process-environment + '("TESTVAR1=value1" "TESTVAR2=value2")) + (process-environment (python-shell-calculate-process-environment))) + (should (equal (getenv "TESTVAR1") "value1")) + (should (equal (getenv "TESTVAR2") "value2")))) + +(ert-deftest python-shell-calculate-process-environment-2 () + "Test `python-shell-extra-pythonpaths' modification." + (let* ((process-environment process-environment) + (original-pythonpath (setenv "PYTHONPATH" "/path0")) + (python-shell-extra-pythonpaths '("/path1" "/path2")) + (process-environment (python-shell-calculate-process-environment))) + (should (equal (getenv "PYTHONPATH") + (concat "/path1" path-separator + "/path2" path-separator "/path0"))))) + +(ert-deftest python-shell-calculate-process-environment-3 () + "Test `python-shell-virtualenv-root' modification." + (let* ((python-shell-virtualenv-root "/env") + (process-environment + (let (process-environment process-environment) + (setenv "PYTHONHOME" "/home") + (setenv "VIRTUAL_ENV") + (python-shell-calculate-process-environment)))) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") "/env")))) + +(ert-deftest python-shell-calculate-process-environment-4 () + "Test PYTHONUNBUFFERED when `python-shell-unbuffered' is non-nil." + (let* ((python-shell-unbuffered t) + (process-environment + (let ((process-environment process-environment)) + (setenv "PYTHONUNBUFFERED") + (python-shell-calculate-process-environment)))) + (should (string= (getenv "PYTHONUNBUFFERED") "1")))) + +(ert-deftest python-shell-calculate-process-environment-5 () + "Test PYTHONUNBUFFERED when `python-shell-unbuffered' is nil." + (let* ((python-shell-unbuffered nil) + (process-environment + (let ((process-environment process-environment)) + (setenv "PYTHONUNBUFFERED") + (python-shell-calculate-process-environment)))) + (should (not (getenv "PYTHONUNBUFFERED"))))) + +(ert-deftest python-shell-calculate-process-environment-6 () + "Test PYTHONUNBUFFERED=1 when `python-shell-unbuffered' is nil." + (let* ((python-shell-unbuffered nil) + (process-environment + (let ((process-environment process-environment)) + (setenv "PYTHONUNBUFFERED" "1") + (python-shell-calculate-process-environment)))) + ;; User default settings must remain untouched: + (should (string= (getenv "PYTHONUNBUFFERED") "1")))) + +(ert-deftest python-shell-calculate-process-environment-7 () + "Test no side-effects on `process-environment'." + (let* ((python-shell-process-environment + '("TESTVAR1=value1" "TESTVAR2=value2")) + (python-shell-virtualenv-root "/env") + (python-shell-unbuffered t) + (python-shell-extra-pythonpaths'("/path1" "/path2")) + (original-process-environment (copy-sequence process-environment))) + (python-shell-calculate-process-environment) + (should (equal process-environment original-process-environment)))) + +(ert-deftest python-shell-calculate-process-environment-8 () + "Test no side-effects on `tramp-remote-process-environment'." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-process-environment + '("TESTVAR1=value1" "TESTVAR2=value2")) + (python-shell-virtualenv-root "/env") + (python-shell-unbuffered t) + (python-shell-extra-pythonpaths'("/path1" "/path2")) + (original-process-environment + (copy-sequence tramp-remote-process-environment))) + (python-shell-calculate-process-environment) + (should (equal tramp-remote-process-environment original-process-environment)))) + +(ert-deftest python-shell-calculate-exec-path-1 () + "Test `python-shell-exec-path' modification." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path '("/path1" "/path2" "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-2 () + "Test `python-shell-virtualenv-root' modification." + (let* ((exec-path '("/path0")) + (python-shell-virtualenv-root "/env") + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path + (list (expand-file-name "/env/bin") "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-3 () + "Test complete `python-shell-virtualenv-root' modification." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-4 () + "Test complete `python-shell-virtualenv-root' with remote." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-remote-exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-5 () + "Test no side-effects on `exec-path'." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (original-exec-path (copy-sequence exec-path))) + (python-shell-calculate-exec-path) + (should (equal exec-path original-exec-path)))) + +(ert-deftest python-shell-calculate-exec-path-6 () + "Test no side-effects on `python-shell-remote-exec-path'." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-remote-exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (original-exec-path (copy-sequence python-shell-remote-exec-path))) + (python-shell-calculate-exec-path) + (should (equal python-shell-remote-exec-path original-exec-path)))) + +(ert-deftest python-shell-with-environment-1 () + "Test environment with local `default-directory'." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (original-exec-path exec-path) + (python-shell-virtualenv-root "/env")) + (python-shell-with-environment + (should (equal exec-path + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/path0"))) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") "/env"))) + (should (equal exec-path original-exec-path)))) + +(ert-deftest python-shell-with-environment-2 () + "Test environment with remote `default-directory'." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-remote-exec-path '("/remote1" "/remote2")) + (python-shell-exec-path '("/path1" "/path2")) + (tramp-remote-process-environment '("EMACS=t")) + (original-process-environment (copy-sequence tramp-remote-process-environment)) + (python-shell-virtualenv-root "/env")) + (python-shell-with-environment + (should (equal (python-shell-calculate-exec-path) + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/remote1" "/remote2"))) + (let ((process-environment (python-shell-calculate-process-environment))) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") "/env")) + (should (equal tramp-remote-process-environment process-environment)))) + (should (equal tramp-remote-process-environment original-process-environment)))) + +(ert-deftest python-shell-with-environment-3 () + "Test `python-shell-with-environment' is idempotent." + (let* ((python-shell-extra-pythonpaths '("/example/dir/")) + (python-shell-exec-path '("path1" "path2")) + (python-shell-virtualenv-root "/home/user/env") + (single-call + (python-shell-with-environment + (list exec-path process-environment))) + (nested-call + (python-shell-with-environment + (python-shell-with-environment + (list exec-path process-environment))))) + (should (equal single-call nested-call)))) + +(ert-deftest python-shell-make-comint-1 () + "Check comint creation for global shell buffer." + (skip-unless (executable-find python-tests-shell-interpreter)) + ;; The interpreter can get killed too quickly to allow it to clean + ;; up the tempfiles that the default python-shell-setup-codes create, + ;; so it leaves tempfiles behind, which is a minor irritation. + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (proc-name (python-shell-get-process-name nil)) + (shell-buffer + (python-tests-with-temp-buffer + "" (python-shell-make-comint + (python-shell-calculate-command) proc-name))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (string= (buffer-name) (format "*%s*" proc-name))))) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-make-comint-2 () + "Check comint creation for internal shell buffer." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (proc-name (python-shell-internal-get-process-name)) + (shell-buffer + (python-tests-with-temp-buffer + "" (python-shell-make-comint + (python-shell-calculate-command) proc-name nil t))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (string= (buffer-name) (format " *%s*" proc-name))))) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-make-comint-3 () + "Check comint creation with overridden python interpreter and args. +The command passed to `python-shell-make-comint' as argument must +locally override global values set in `python-shell-interpreter' +and `python-shell-interpreter-args' in the new shell buffer." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter "interpreter") + (python-shell-interpreter-args "--some-args") + (proc-name (python-shell-get-process-name nil)) + (interpreter-override + (concat (executable-find python-tests-shell-interpreter) " " "-i")) + (shell-buffer + (python-tests-with-temp-buffer + "" (python-shell-make-comint interpreter-override proc-name nil))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (file-equal-p + python-shell-interpreter + (executable-find python-tests-shell-interpreter))) + (should (string= python-shell-interpreter-args "-i")))) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-make-comint-4 () + "Check shell calculated prompts regexps are set." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (python-shell-interpreter-args "-i") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled t) + (python-shell-prompt-input-regexps '("extralargeinputprompt" "sml")) + (python-shell-prompt-output-regexps '("extralargeoutputprompt" "sml")) + (python-shell-prompt-regexp "in") + (python-shell-prompt-block-regexp "block") + (python-shell-prompt-pdb-regexp "pdf") + (python-shell-prompt-output-regexp "output") + (startup-code (concat "import sys\n" + "sys.ps1 = 'py> '\n" + "sys.ps2 = '..> '\n" + "sys.ps3 = 'out '\n")) + (startup-file (python-shell--save-temp-file startup-code)) + (proc-name (python-shell-get-process-name nil)) + (shell-buffer + (progn + (setenv "PYTHONSTARTUP" startup-file) + (python-tests-with-temp-buffer + "" (python-shell-make-comint + (python-shell-calculate-command) proc-name nil)))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (string= + python-shell--prompt-calculated-input-regexp + (concat "^\\(extralargeinputprompt\\|\\.\\.> \\|" + "block\\|py> \\|pdf\\|sml\\|in\\)"))) + (should (string= + python-shell--prompt-calculated-output-regexp + "^\\(extralargeoutputprompt\\|output\\|out \\|sml\\)")))) + (delete-file startup-file) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-get-process-1 () + "Check dedicated shell process preference over global." + (skip-unless (executable-find python-tests-shell-interpreter)) + (python-tests-with-temp-file + "" + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (global-proc-name (python-shell-get-process-name nil)) + (dedicated-proc-name (python-shell-get-process-name t)) + (global-shell-buffer + (python-shell-make-comint + (python-shell-calculate-command) global-proc-name)) + (dedicated-shell-buffer + (python-shell-make-comint + (python-shell-calculate-command) dedicated-proc-name)) + (global-process (get-buffer-process global-shell-buffer)) + (dedicated-process (get-buffer-process dedicated-shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag global-process nil) + (set-process-query-on-exit-flag dedicated-process nil) + ;; Prefer dedicated if global also exists. + (should (equal (python-shell-get-process) dedicated-process)) + (kill-buffer dedicated-shell-buffer) + ;; If there's only global, use it. + (should (equal (python-shell-get-process) global-process)) + (kill-buffer global-shell-buffer) + ;; No buffer available. + (should (not (python-shell-get-process)))) + (ignore-errors (kill-buffer global-shell-buffer)) + (ignore-errors (kill-buffer dedicated-shell-buffer)))))) + +(ert-deftest python-shell-internal-get-or-create-process-1 () + "Check internal shell process creation fallback." + (skip-unless (executable-find python-tests-shell-interpreter)) + (python-tests-with-temp-file + "" + (should (not (process-live-p (python-shell-internal-get-process-name)))) + (let* ((python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (internal-process-name (python-shell-internal-get-process-name)) + (internal-process (python-shell-internal-get-or-create-process)) + (internal-shell-buffer (process-buffer internal-process))) + (unwind-protect + (progn + (set-process-query-on-exit-flag internal-process nil) + (should (equal (process-name internal-process) + internal-process-name)) + (should (equal internal-process + (python-shell-internal-get-or-create-process))) + ;; Assert the internal process is not a user process + (should (not (python-shell-get-process))) + (kill-buffer internal-shell-buffer)) + (ignore-errors (kill-buffer internal-shell-buffer)))))) + +(ert-deftest python-shell-prompt-detect-1 () + "Check prompt autodetection." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((process-environment process-environment)) + ;; Ensure no startup file is enabled + (setenv "PYTHONSTARTUP" "") + (should python-shell-prompt-detect-enabled) + (should (equal (python-shell-prompt-detect) '(">>> " "... " ""))))) + +(ert-deftest python-shell-prompt-detect-2 () + "Check prompt autodetection with startup file. Bug#17370." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = 'py> '\n" + "sys.ps2 = '..> '\n" + "sys.ps3 = 'out '\n")) + (startup-file (python-shell--save-temp-file startup-code))) + (unwind-protect + (progn + ;; Ensure startup file is enabled + (setenv "PYTHONSTARTUP" startup-file) + (should python-shell-prompt-detect-enabled) + (should (equal (python-shell-prompt-detect) '("py> " "..> " "out ")))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-detect-3 () + "Check prompts are not autodetected when feature is disabled." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((process-environment process-environment) + (python-shell-prompt-detect-enabled nil)) + ;; Ensure no startup file is enabled + (should (not python-shell-prompt-detect-enabled)) + (should (not (python-shell-prompt-detect))))) + +(ert-deftest python-shell-prompt-detect-4 () + "Check warning is shown when detection fails." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + ;; Trigger failure by removing prompts in the startup file + (startup-code (concat "import sys\n" + "sys.ps1 = ''\n" + "sys.ps2 = ''\n" + "sys.ps3 = ''\n")) + (startup-file (python-shell--save-temp-file startup-code))) + (unwind-protect + (progn + (kill-buffer (get-buffer-create "*Warnings*")) + (should (not (get-buffer "*Warnings*"))) + (setenv "PYTHONSTARTUP" startup-file) + (should python-shell-prompt-detect-failure-warning) + (should python-shell-prompt-detect-enabled) + (should (not (python-shell-prompt-detect))) + (should (get-buffer "*Warnings*"))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-detect-5 () + "Check disabled warnings are not shown when detection fails." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = ''\n" + "sys.ps2 = ''\n" + "sys.ps3 = ''\n")) + (startup-file (python-shell--save-temp-file startup-code)) + (python-shell-prompt-detect-failure-warning nil)) + (unwind-protect + (progn + (kill-buffer (get-buffer-create "*Warnings*")) + (should (not (get-buffer "*Warnings*"))) + (setenv "PYTHONSTARTUP" startup-file) + (should (not python-shell-prompt-detect-failure-warning)) + (should python-shell-prompt-detect-enabled) + (should (not (python-shell-prompt-detect))) + (should (not (get-buffer "*Warnings*")))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-detect-6 () + "Warnings are not shown when detection is disabled." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = ''\n" + "sys.ps2 = ''\n" + "sys.ps3 = ''\n")) + (startup-file (python-shell--save-temp-file startup-code)) + (python-shell-prompt-detect-failure-warning t) + (python-shell-prompt-detect-enabled nil)) + (unwind-protect + (progn + (kill-buffer (get-buffer-create "*Warnings*")) + (should (not (get-buffer "*Warnings*"))) + (setenv "PYTHONSTARTUP" startup-file) + (should python-shell-prompt-detect-failure-warning) + (should (not python-shell-prompt-detect-enabled)) + (should (not (python-shell-prompt-detect))) + (should (not (get-buffer "*Warnings*")))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-validate-regexps-1 () + "Check `python-shell-prompt-input-regexps' are validated." + (let* ((python-shell-prompt-input-regexps '("\\(")) + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-input-regexps'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-2 () + "Check `python-shell-prompt-output-regexps' are validated." + (let* ((python-shell-prompt-output-regexps '("\\(")) + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-output-regexps'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-3 () + "Check `python-shell-prompt-regexp' is validated." + (let* ((python-shell-prompt-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-4 () + "Check `python-shell-prompt-block-regexp' is validated." + (let* ((python-shell-prompt-block-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-block-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-5 () + "Check `python-shell-prompt-pdb-regexp' is validated." + (let* ((python-shell-prompt-pdb-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-pdb-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-6 () + "Check `python-shell-prompt-output-regexp' is validated." + (let* ((python-shell-prompt-output-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-output-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-7 () + "Check default regexps are valid." + ;; should not signal error + (python-shell-prompt-validate-regexps)) + +(ert-deftest python-shell-prompt-set-calculated-regexps-1 () + "Check regexps are validated." + (let* ((python-shell-prompt-output-regexp '("\\(")) + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil) + (error-data (should-error (python-shell-prompt-set-calculated-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-output-regexp'"))))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-2 () + "Check `python-shell-prompt-input-regexps' are set." + (let* ((python-shell-prompt-input-regexps '("my" "prompt")) + (python-shell-prompt-output-regexps '("")) + (python-shell-prompt-regexp "") + (python-shell-prompt-block-regexp "") + (python-shell-prompt-pdb-regexp "") + (python-shell-prompt-output-regexp "") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(prompt\\|my\\|\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-3 () + "Check `python-shell-prompt-output-regexps' are set." + (let* ((python-shell-prompt-input-regexps '("")) + (python-shell-prompt-output-regexps '("my" "prompt")) + (python-shell-prompt-regexp "") + (python-shell-prompt-block-regexp "") + (python-shell-prompt-pdb-regexp "") + (python-shell-prompt-output-regexp "") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(prompt\\|my\\|\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-4 () + "Check user defined prompts are set." + (let* ((python-shell-prompt-input-regexps '("")) + (python-shell-prompt-output-regexps '("")) + (python-shell-prompt-regexp "prompt") + (python-shell-prompt-block-regexp "block") + (python-shell-prompt-pdb-regexp "pdb") + (python-shell-prompt-output-regexp "output") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(prompt\\|block\\|pdb\\|\\)")) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(output\\|\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-5 () + "Check order of regexps (larger first)." + (let* ((python-shell-prompt-input-regexps '("extralargeinputprompt" "sml")) + (python-shell-prompt-output-regexps '("extralargeoutputprompt" "sml")) + (python-shell-prompt-regexp "in") + (python-shell-prompt-block-regexp "block") + (python-shell-prompt-pdb-regexp "pdf") + (python-shell-prompt-output-regexp "output") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(extralargeinputprompt\\|block\\|pdf\\|sml\\|in\\)")) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(extralargeoutputprompt\\|output\\|sml\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-6 () + "Check detected prompts are included `regexp-quote'd." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((python-shell-prompt-input-regexps '("")) + (python-shell-prompt-output-regexps '("")) + (python-shell-prompt-regexp "") + (python-shell-prompt-block-regexp "") + (python-shell-prompt-pdb-regexp "") + (python-shell-prompt-output-regexp "") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled t) + (process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = 'p.> '\n" + "sys.ps2 = '..> '\n" + "sys.ps3 = 'o.t '\n")) + (startup-file (python-shell--save-temp-file startup-code))) + (unwind-protect + (progn + (setenv "PYTHONSTARTUP" startup-file) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(\\.\\.> \\|p\\.> \\|\\)")) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(o\\.t \\|\\)"))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-buffer-substring-1 () + "Selecting a substring of the whole buffer must match its contents." + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + + +class Bar(models.Model): + pass +" + (should (string= (buffer-string) + (python-shell-buffer-substring (point-min) (point-max)))))) + +(ert-deftest python-shell-buffer-substring-2 () + "Main block should be removed if NOMAIN is non-nil." + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + +class Bar(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) +" + (should (string= (python-shell-buffer-substring (point-min) (point-max) t) + " +class Foo(models.Model): + pass + +class Bar(models.Model): + pass + + + + +")))) + +(ert-deftest python-shell-buffer-substring-3 () + "Main block should be removed if NOMAIN is non-nil." + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring (point-min) (point-max) t) + " +class Foo(models.Model): + pass + + + + + +class Bar(models.Model): + pass +")))) + +(ert-deftest python-shell-buffer-substring-4 () + "Coding cookie should be added for substrings." + (python-tests-with-temp-buffer + "# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "class Foo(models.Model):") + (progn (python-nav-forward-sexp) (point))) + "# -*- coding: latin-1 -*- + +class Foo(models.Model): + pass")))) + +(ert-deftest python-shell-buffer-substring-5 () + "The proper amount of blank lines is added for a substring." + (python-tests-with-temp-buffer + "# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "class Bar(models.Model):") + (progn (python-nav-forward-sexp) (point))) + "# -*- coding: latin-1 -*- + + + + + + + + +class Bar(models.Model): + pass")))) + +(ert-deftest python-shell-buffer-substring-6 () + "Handle substring with coding cookie in the second line." + (python-tests-with-temp-buffer + " +# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "# coding: latin-1") + (python-tests-look-at "if __name__ == \"__main__\":")) + "# -*- coding: latin-1 -*- + + +class Foo(models.Model): + pass + +")))) + +(ert-deftest python-shell-buffer-substring-7 () + "Ensure first coding cookie gets precedence." + (python-tests-with-temp-buffer + "# coding: utf-8 +# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "# coding: latin-1") + (python-tests-look-at "if __name__ == \"__main__\":")) + "# -*- coding: utf-8 -*- + + +class Foo(models.Model): + pass + +")))) + +(ert-deftest python-shell-buffer-substring-8 () + "Ensure first coding cookie gets precedence when sending whole buffer." + (python-tests-with-temp-buffer + "# coding: utf-8 +# coding: latin-1 + +class Foo(models.Model): + pass +" + (should (string= (python-shell-buffer-substring (point-min) (point-max)) + "# coding: utf-8 + + +class Foo(models.Model): + pass +")))) + +(ert-deftest python-shell-buffer-substring-9 () + "Check substring starting from `point-min'." + (python-tests-with-temp-buffer + "# coding: utf-8 + +class Foo(models.Model): + pass + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (point-min) + (python-tests-look-at "class Bar(models.Model):")) + "# coding: utf-8 + +class Foo(models.Model): + pass + +")))) + +(ert-deftest python-shell-buffer-substring-10 () + "Check substring from partial block." + (python-tests-with-temp-buffer + " +def foo(): + print ('a') +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "print ('a')") + (point-max)) + "if True: + + print ('a') +")))) + +(ert-deftest python-shell-buffer-substring-11 () + "Check substring from partial block and point within indentation." + (python-tests-with-temp-buffer + " +def foo(): + print ('a') +" + (should (string= (python-shell-buffer-substring + (progn + (python-tests-look-at "print ('a')") + (backward-char 1) + (point)) + (point-max)) + "if True: + + print ('a') +")))) + +(ert-deftest python-shell-buffer-substring-12 () + "Check substring from partial block and point in whitespace." + (python-tests-with-temp-buffer + " +def foo(): + + # Whitespace + + print ('a') +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "# Whitespace") + (point-max)) + "if True: + + + # Whitespace + + print ('a') +")))) + + + +;;; Shell completion + +(ert-deftest python-shell-completion-native-interpreter-disabled-p-1 () + (let* ((python-shell-completion-native-disabled-interpreters (list "pypy")) + (python-shell-interpreter "/some/path/to/bin/pypy")) + (should (python-shell-completion-native-interpreter-disabled-p)))) + + + + +;;; PDB Track integration + + +;;; Symbol completion + + +;;; Fill paragraph + + +;;; Skeletons + + +;;; FFAP + + +;;; Code check + + +;;; Eldoc + +(ert-deftest python-eldoc--get-symbol-at-point-1 () + "Test paren handling." + (python-tests-with-temp-buffer + " +map(xx +map(codecs.open('somefile' +" + (python-tests-look-at "ap(xx") + (should (string= (python-eldoc--get-symbol-at-point) "map")) + (goto-char (line-end-position)) + (should (string= (python-eldoc--get-symbol-at-point) "map")) + (python-tests-look-at "('somefile'") + (should (string= (python-eldoc--get-symbol-at-point) "map")) + (goto-char (line-end-position)) + (should (string= (python-eldoc--get-symbol-at-point) "codecs.open")))) + +(ert-deftest python-eldoc--get-symbol-at-point-2 () + "Ensure self is replaced with the class name." + (python-tests-with-temp-buffer + " +class TheClass: + + def some_method(self, n): + return n + + def other(self): + return self.some_method(1234) + +" + (python-tests-look-at "self.some_method") + (should (string= (python-eldoc--get-symbol-at-point) + "TheClass.some_method")) + (python-tests-look-at "1234)") + (should (string= (python-eldoc--get-symbol-at-point) + "TheClass.some_method")))) + +(ert-deftest python-eldoc--get-symbol-at-point-3 () + "Ensure symbol is found when point is at end of buffer." + (python-tests-with-temp-buffer + " +some_symbol + +" + (goto-char (point-max)) + (should (string= (python-eldoc--get-symbol-at-point) + "some_symbol")))) + +(ert-deftest python-eldoc--get-symbol-at-point-4 () + "Ensure symbol is found when point is at whitespace." + (python-tests-with-temp-buffer + " +some_symbol some_other_symbol +" + (python-tests-look-at " some_other_symbol") + (should (string= (python-eldoc--get-symbol-at-point) + "some_symbol")))) + + +;;; Imenu + +(ert-deftest python-imenu-create-index-1 () + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + + +class Bar(models.Model): + pass + + +def decorator(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decorator('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wrap(f): + print ('wrap') + def wrapped_f(*args): + print ('wrapped_f') + print ('Decorator arguments:', arg1, arg2, arg3) + f(*args) + print ('called f(*args)') + return wrapped_f + return wrap + + +class Baz(object): + + def a(self): + pass + + def b(self): + pass + + class Frob(object): + + def c(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (cons "Foo (class)" (copy-marker 2)) + (cons "Bar (class)" (copy-marker 38)) + (list + "decorator (def)" + (cons "*function definition*" (copy-marker 74)) + (list + "wrap (def)" + (cons "*function definition*" (copy-marker 254)) + (cons "wrapped_f (def)" (copy-marker 294)))) + (list + "Baz (class)" + (cons "*class definition*" (copy-marker 519)) + (cons "a (def)" (copy-marker 539)) + (cons "b (def)" (copy-marker 570)) + (list + "Frob (class)" + (cons "*class definition*" (copy-marker 601)) + (cons "c (def)" (copy-marker 626))))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-index-2 () + (python-tests-with-temp-buffer + " +class Foo(object): + def foo(self): + def foo1(): + pass + + def foobar(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (list + "Foo (class)" + (cons "*class definition*" (copy-marker 2)) + (list + "foo (def)" + (cons "*function definition*" (copy-marker 21)) + (cons "foo1 (def)" (copy-marker 40))) + (cons "foobar (def)" (copy-marker 78)))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-index-3 () + (python-tests-with-temp-buffer + " +class Foo(object): + def foo(self): + def foo1(): + pass + def foo2(): + pass +" + (goto-char (point-max)) + (should (equal + (list + (list + "Foo (class)" + (cons "*class definition*" (copy-marker 2)) + (list + "foo (def)" + (cons "*function definition*" (copy-marker 21)) + (cons "foo1 (def)" (copy-marker 40)) + (cons "foo2 (def)" (copy-marker 77))))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-index-4 () + (python-tests-with-temp-buffer + " +class Foo(object): + class Bar(object): + def __init__(self): + pass + + def __str__(self): + pass + + def __init__(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (list + "Foo (class)" + (cons "*class definition*" (copy-marker 2)) + (list + "Bar (class)" + (cons "*class definition*" (copy-marker 21)) + (cons "__init__ (def)" (copy-marker 44)) + (cons "__str__ (def)" (copy-marker 90))) + (cons "__init__ (def)" (copy-marker 135)))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-flat-index-1 () + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + + +class Bar(models.Model): + pass + + +def decorator(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decorator('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wrap(f): + print ('wrap') + def wrapped_f(*args): + print ('wrapped_f') + print ('Decorator arguments:', arg1, arg2, arg3) + f(*args) + print ('called f(*args)') + return wrapped_f + return wrap + + +class Baz(object): + + def a(self): + pass + + def b(self): + pass + + class Frob(object): + + def c(self): + pass +" + (goto-char (point-max)) + (should (equal + (list (cons "Foo" (copy-marker 2)) + (cons "Bar" (copy-marker 38)) + (cons "decorator" (copy-marker 74)) + (cons "decorator.wrap" (copy-marker 254)) + (cons "decorator.wrap.wrapped_f" (copy-marker 294)) + (cons "Baz" (copy-marker 519)) + (cons "Baz.a" (copy-marker 539)) + (cons "Baz.b" (copy-marker 570)) + (cons "Baz.Frob" (copy-marker 601)) + (cons "Baz.Frob.c" (copy-marker 626))) + (python-imenu-create-flat-index))))) + +(ert-deftest python-imenu-create-flat-index-2 () + (python-tests-with-temp-buffer + " +class Foo(object): + class Bar(object): + def __init__(self): + pass + + def __str__(self): + pass + + def __init__(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (cons "Foo" (copy-marker 2)) + (cons "Foo.Bar" (copy-marker 21)) + (cons "Foo.Bar.__init__" (copy-marker 44)) + (cons "Foo.Bar.__str__" (copy-marker 90)) + (cons "Foo.__init__" (copy-marker 135))) + (python-imenu-create-flat-index))))) + + +;;; Misc helpers + +(ert-deftest python-info-current-defun-1 () + (python-tests-with-temp-buffer + " +def foo(a, b): +" + (forward-line 1) + (should (string= "foo" (python-info-current-defun))) + (should (string= "def foo" (python-info-current-defun t))) + (forward-line 1) + (should (not (python-info-current-defun))) + (indent-for-tab-command) + (should (string= "foo" (python-info-current-defun))) + (should (string= "def foo" (python-info-current-defun t))))) + +(ert-deftest python-info-current-defun-2 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + if True: + return [i for i in range(3)] + else: + return [] + + def b(): + do_b() + + def a(): + do_a() + + def c(self): + do_c() +" + (forward-line 1) + (should (string= "C" (python-info-current-defun))) + (should (string= "class C" (python-info-current-defun t))) + (python-tests-look-at "return [i for ") + (should (string= "C.m" (python-info-current-defun))) + (should (string= "def C.m" (python-info-current-defun t))) + (python-tests-look-at "def b():") + (should (string= "C.m.b" (python-info-current-defun))) + (should (string= "def C.m.b" (python-info-current-defun t))) + (forward-line 2) + (indent-for-tab-command) + (python-indent-dedent-line-backspace 1) + (should (string= "C.m" (python-info-current-defun))) + (should (string= "def C.m" (python-info-current-defun t))) + (python-tests-look-at "def c(self):") + (forward-line -1) + (indent-for-tab-command) + (should (string= "C.m.a" (python-info-current-defun))) + (should (string= "def C.m.a" (python-info-current-defun t))) + (python-indent-dedent-line-backspace 1) + (should (string= "C.m" (python-info-current-defun))) + (should (string= "def C.m" (python-info-current-defun t))) + (python-indent-dedent-line-backspace 1) + (should (string= "C" (python-info-current-defun))) + (should (string= "class C" (python-info-current-defun t))) + (python-tests-look-at "def c(self):") + (should (string= "C.c" (python-info-current-defun))) + (should (string= "def C.c" (python-info-current-defun t))) + (python-tests-look-at "do_c()") + (should (string= "C.c" (python-info-current-defun))) + (should (string= "def C.c" (python-info-current-defun t))))) + +(ert-deftest python-info-current-defun-3 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "def wwrap(f):") + (forward-line -1) + (should (not (python-info-current-defun))) + (indent-for-tab-command 1) + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments")) + (python-tests-look-at "def wrapped_f(*args):") + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments.wwrap.wrapped_f")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments.wwrap.wrapped_f")) + (python-tests-look-at "return wrapped_f") + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments.wwrap")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments.wwrap")) + (end-of-line 1) + (python-tests-look-at "return wwrap") + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments")))) + +(ert-deftest python-info-current-symbol-1 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + self.c() + + def c(self): + print ('a') +" + (python-tests-look-at "self.c()") + (should (string= "self.c" (python-info-current-symbol))) + (should (string= "C.c" (python-info-current-symbol t))))) + +(ert-deftest python-info-current-symbol-2 () + (python-tests-with-temp-buffer + " +class C(object): + + class M(object): + + def a(self): + self.c() + + def c(self): + pass +" + (python-tests-look-at "self.c()") + (should (string= "self.c" (python-info-current-symbol))) + (should (string= "C.M.c" (python-info-current-symbol t))))) + +(ert-deftest python-info-current-symbol-3 () + "Keywords should not be considered symbols." + :expected-result :failed + (python-tests-with-temp-buffer + " +class C(object): + pass +" + ;; FIXME: keywords are not symbols. + (python-tests-look-at "class C") + (should (not (python-info-current-symbol))) + (should (not (python-info-current-symbol t))) + (python-tests-look-at "C(object)") + (should (string= "C" (python-info-current-symbol))) + (should (string= "class C" (python-info-current-symbol t))))) + +(ert-deftest python-info-statement-starts-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (python-info-statement-starts-block-p)) + (python-tests-look-at "print (var_one)") + (python-util-forward-comment -1) + (should (python-info-statement-starts-block-p)))) + +(ert-deftest python-info-statement-starts-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError('sorry, you lose') +" + (python-tests-look-at "if width == 0 and") + (should (python-info-statement-starts-block-p)) + (python-tests-look-at "raise ValueError(") + (python-util-forward-comment -1) + (should (python-info-statement-starts-block-p)))) + +(ert-deftest python-info-statement-ends-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "print (var_one)") + (should (python-info-statement-ends-block-p)))) + +(ert-deftest python-info-statement-ends-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "raise ValueError(") + (should (python-info-statement-ends-block-p)))) + +(ert-deftest python-info-beginning-of-statement-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (python-info-beginning-of-statement-p)) + (forward-char 10) + (should (not (python-info-beginning-of-statement-p))) + (python-tests-look-at "print (var_one)") + (should (python-info-beginning-of-statement-p)) + (goto-char (line-beginning-position)) + (should (not (python-info-beginning-of-statement-p))))) + +(ert-deftest python-info-beginning-of-statement-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (python-info-beginning-of-statement-p)) + (forward-char 10) + (should (not (python-info-beginning-of-statement-p))) + (python-tests-look-at "raise ValueError(") + (should (python-info-beginning-of-statement-p)) + (goto-char (line-beginning-position)) + (should (not (python-info-beginning-of-statement-p))))) + +(ert-deftest python-info-end-of-statement-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (not (python-info-end-of-statement-p))) + (python-tests-look-at "print (var_one)") + (python-util-forward-comment -1) + (should (python-info-end-of-statement-p)) + (python-tests-look-at "print (var_one)") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (python-info-end-of-statement-p)))) + +(ert-deftest python-info-end-of-statement-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (not (python-info-end-of-statement-p))) + (python-tests-look-at "raise ValueError(") + (python-util-forward-comment -1) + (should (python-info-end-of-statement-p)) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (not (python-info-end-of-statement-p))) + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (python-info-end-of-statement-p)))) + +(ert-deftest python-info-beginning-of-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (python-info-beginning-of-block-p)) + (python-tests-look-at "var_one, var_two, var_three,") + (should (not (python-info-beginning-of-block-p))) + (python-tests-look-at "print (var_one)") + (should (not (python-info-beginning-of-block-p))))) + +(ert-deftest python-info-beginning-of-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (python-info-beginning-of-block-p)) + (python-tests-look-at "color == 'red' and emphasis") + (should (not (python-info-beginning-of-block-p))) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-beginning-of-block-p))))) + +(ert-deftest python-info-end-of-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "var_one, var_two, var_three,") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "var_four):") + (end-of-line) + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "print (var_one)") + (should (not (python-info-end-of-block-p))) + (end-of-line 1) + (should (python-info-end-of-block-p)))) + +(ert-deftest python-info-end-of-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "color == 'red' and emphasis == 'strong' or") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "highlight > 100:") + (end-of-line) + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-end-of-block-p))) + (end-of-line 1) + (should (not (python-info-end-of-block-p))) + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (python-info-end-of-block-p)))) + +(ert-deftest python-info-dedenter-opening-block-position-1 () + (python-tests-with-temp-buffer + " +if request.user.is_authenticated(): + try: + profile = request.user.get_profile() + except Profile.DoesNotExist: + profile = Profile.objects.create(user=request.user) + else: + if profile.stats: + profile.recalculate_stats() + else: + profile.clear_stats() + finally: + profile.views += 1 + profile.save() +" + (python-tests-look-at "try:") + (should (not (python-info-dedenter-opening-block-position))) + (python-tests-look-at "except Profile.DoesNotExist:") + (should (= (python-tests-look-at "try:" -1 t) + (python-info-dedenter-opening-block-position))) + (python-tests-look-at "else:") + (should (= (python-tests-look-at "except Profile.DoesNotExist:" -1 t) + (python-info-dedenter-opening-block-position))) + (python-tests-look-at "if profile.stats:") + (should (not (python-info-dedenter-opening-block-position))) + (python-tests-look-at "else:") + (should (= (python-tests-look-at "if profile.stats:" -1 t) + (python-info-dedenter-opening-block-position))) + (python-tests-look-at "finally:") + (should (= (python-tests-look-at "else:" -2 t) + (python-info-dedenter-opening-block-position))))) + +(ert-deftest python-info-dedenter-opening-block-position-2 () + (python-tests-with-temp-buffer + " +if request.user.is_authenticated(): + profile = Profile.objects.get_or_create(user=request.user) + if profile.stats: + profile.recalculate_stats() + +data = { + 'else': 'do it' +} + 'else' +" + (python-tests-look-at "'else': 'do it'") + (should (not (python-info-dedenter-opening-block-position))) + (python-tests-look-at "'else'") + (should (not (python-info-dedenter-opening-block-position))))) + +(ert-deftest python-info-dedenter-opening-block-position-3 () + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + except Exception: + if hide_details: + logger.exception('Unhandled exception') + else + finally: + data.free() +" + (python-tests-look-at "try:") + (should (not (python-info-dedenter-opening-block-position))) + + (python-tests-look-at "except IOError:") + (should (= (python-tests-look-at "try:" -1 t) + (python-info-dedenter-opening-block-position))) + + (python-tests-look-at "except Exception:") + (should (= (python-tests-look-at "except IOError:" -1 t) + (python-info-dedenter-opening-block-position))) + + (python-tests-look-at "if hide_details:") + (should (not (python-info-dedenter-opening-block-position))) + + ;; check indentation modifies the detected opening block + (python-tests-look-at "else") + (should (= (python-tests-look-at "if hide_details:" -1 t) + (python-info-dedenter-opening-block-position))) + + (indent-line-to 8) + (should (= (python-tests-look-at "if hide_details:" -1 t) + (python-info-dedenter-opening-block-position))) + + (indent-line-to 4) + (should (= (python-tests-look-at "except Exception:" -1 t) + (python-info-dedenter-opening-block-position))) + + (indent-line-to 0) + (should (= (python-tests-look-at "if save:" -1 t) + (python-info-dedenter-opening-block-position))))) + +(ert-deftest python-info-dedenter-opening-block-positions-1 () + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + except Exception: + if hide_details: + logger.exception('Unhandled exception') + else + finally: + data.free() +" + (python-tests-look-at "try:") + (should (not (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "except IOError:") + (should + (equal (list + (python-tests-look-at "try:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "except Exception:") + (should + (equal (list + (python-tests-look-at "except IOError:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "if hide_details:") + (should (not (python-info-dedenter-opening-block-positions))) + + ;; check indentation does not modify the detected opening blocks + (python-tests-look-at "else") + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (indent-line-to 8) + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (indent-line-to 4) + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (indent-line-to 0) + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-2 () + "Test detection of opening blocks for elif." + (python-tests-with-temp-buffer + " +if var: + if var2: + something() + elif var3: + something_else() + elif +" + (python-tests-look-at "elif var3:") + (should + (equal (list + (python-tests-look-at "if var2:" -1 t) + (python-tests-look-at "if var:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "elif\n") + (should + (equal (list + (python-tests-look-at "elif var3:" -1 t) + (python-tests-look-at "if var:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-3 () + "Test detection of opening blocks for else." + (python-tests-with-temp-buffer + " +try: + something() +except: + if var: + if var2: + something() + elif var3: + something_else() + else + +if var4: + while var5: + var4.pop() + else + + for value in var6: + if value > 0: + print value + else +" + (python-tests-look-at "else\n") + (should + (equal (list + (python-tests-look-at "elif var3:" -1 t) + (python-tests-look-at "if var:" -1 t) + (python-tests-look-at "except:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "else\n") + (should + (equal (list + (python-tests-look-at "while var5:" -1 t) + (python-tests-look-at "if var4:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "else\n") + (should + (equal (list + (python-tests-look-at "if value > 0:" -1 t) + (python-tests-look-at "for value in var6:" -1 t) + (python-tests-look-at "if var4:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-4 () + "Test detection of opening blocks for except." + (python-tests-with-temp-buffer + " +try: + something() +except ValueError: + something_else() + except +" + (python-tests-look-at "except ValueError:") + (should + (equal (list (python-tests-look-at "try:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "except\n") + (should + (equal (list (python-tests-look-at "except ValueError:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-5 () + "Test detection of opening blocks for finally." + (python-tests-with-temp-buffer + " +try: + something() + finally + +try: + something_else() +except: + logger.exception('something went wrong') + finally + +try: + something_else_else() +except Exception: + logger.exception('something else went wrong') +else: + print ('all good') + finally +" + (python-tests-look-at "finally\n") + (should + (equal (list (python-tests-look-at "try:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "finally\n") + (should + (equal (list (python-tests-look-at "except:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "finally\n") + (should + (equal (list (python-tests-look-at "else:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-message-1 () + "Test dedenters inside strings are ignored." + (python-tests-with-temp-buffer + "''' +try: + something() +except: + logger.exception('something went wrong') +''' +" + (python-tests-look-at "except\n") + (should (not (python-info-dedenter-opening-block-message))))) + +(ert-deftest python-info-dedenter-opening-block-message-2 () + "Test except keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +" + (python-tests-look-at "except:") + (should (string= + "Closes try:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes try:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + +(ert-deftest python-info-dedenter-opening-block-message-3 () + "Test else keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +" + (python-tests-look-at "else:") + (should (string= + "Closes except:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes except:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + +(ert-deftest python-info-dedenter-opening-block-message-4 () + "Test finally keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +finally: + clean() +" + (python-tests-look-at "finally:") + (should (string= + "Closes else:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes else:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + +(ert-deftest python-info-dedenter-opening-block-message-5 () + "Test elif keyword." + (python-tests-with-temp-buffer + " +if a: + something() +elif b: +" + (python-tests-look-at "elif b:") + (should (string= + "Closes if a:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes if a:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + + +(ert-deftest python-info-dedenter-statement-p-1 () + "Test dedenters inside strings are ignored." + (python-tests-with-temp-buffer + "''' +try: + something() +except: + logger.exception('something went wrong') +''' +" + (python-tests-look-at "except\n") + (should (not (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-2 () + "Test except keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +" + (python-tests-look-at "except:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-3 () + "Test else keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +" + (python-tests-look-at "else:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-4 () + "Test finally keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +finally: + clean() +" + (python-tests-look-at "finally:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-5 () + "Test elif keyword." + (python-tests-with-temp-buffer + " +if a: + something() +elif b: +" + (python-tests-look-at "elif b:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-line-ends-backslash-p-1 () + (python-tests-with-temp-buffer + " +objects = Thing.objects.all() \\\\ + .filter( + type='toy', + status='bought' + ) \\\\ + .aggregate( + Sum('amount') + ) \\\\ + .values_list() +" + (should (python-info-line-ends-backslash-p 2)) ; .filter(... + (should (python-info-line-ends-backslash-p 3)) + (should (python-info-line-ends-backslash-p 4)) + (should (python-info-line-ends-backslash-p 5)) + (should (python-info-line-ends-backslash-p 6)) ; ) \... + (should (python-info-line-ends-backslash-p 7)) + (should (python-info-line-ends-backslash-p 8)) + (should (python-info-line-ends-backslash-p 9)) + (should (not (python-info-line-ends-backslash-p 10))))) ; .values_list()... + +(ert-deftest python-info-beginning-of-backslash-1 () + (python-tests-with-temp-buffer + " +objects = Thing.objects.all() \\\\ + .filter( + type='toy', + status='bought' + ) \\\\ + .aggregate( + Sum('amount') + ) \\\\ + .values_list() +" + (let ((first 2) + (second (python-tests-look-at ".filter(")) + (third (python-tests-look-at ".aggregate("))) + (should (= first (python-info-beginning-of-backslash 2))) + (should (= second (python-info-beginning-of-backslash 3))) + (should (= second (python-info-beginning-of-backslash 4))) + (should (= second (python-info-beginning-of-backslash 5))) + (should (= second (python-info-beginning-of-backslash 6))) + (should (= third (python-info-beginning-of-backslash 7))) + (should (= third (python-info-beginning-of-backslash 8))) + (should (= third (python-info-beginning-of-backslash 9))) + (should (not (python-info-beginning-of-backslash 10)))))) + +(ert-deftest python-info-continuation-line-p-1 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and height == 0 and") + (should (not (python-info-continuation-line-p))) + (python-tests-look-at "color == 'red' and emphasis == 'strong' or") + (should (python-info-continuation-line-p)) + (python-tests-look-at "highlight > 100:") + (should (python-info-continuation-line-p)) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-continuation-line-p))) + (python-tests-look-at "'sorry, you lose'") + (should (python-info-continuation-line-p)) + (forward-line 1) + (should (python-info-continuation-line-p)) + (python-tests-look-at ")") + (should (python-info-continuation-line-p)) + (forward-line 1) + (should (not (python-info-continuation-line-p))))) + +(ert-deftest python-info-block-continuation-line-p-1 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (not (python-info-block-continuation-line-p))) + (python-tests-look-at "color == 'red' and emphasis == 'strong' or") + (should (= (python-info-block-continuation-line-p) + (python-tests-look-at "if width == 0 and" -1 t))) + (python-tests-look-at "highlight > 100:") + (should (not (python-info-block-continuation-line-p))))) + +(ert-deftest python-info-block-continuation-line-p-2 () + (python-tests-with-temp-buffer + " +def foo(a, + b, + c): + pass +" + (python-tests-look-at "def foo(a,") + (should (not (python-info-block-continuation-line-p))) + (python-tests-look-at "b,") + (should (= (python-info-block-continuation-line-p) + (python-tests-look-at "def foo(a," -1 t))) + (python-tests-look-at "c):") + (should (not (python-info-block-continuation-line-p))))) + +(ert-deftest python-info-assignment-statement-p-1 () + (python-tests-with-temp-buffer + " +data = foo(), bar() \\\\ + baz(), 4 \\\\ + 5, 6 +" + (python-tests-look-at "data = foo(), bar()") + (should (python-info-assignment-statement-p)) + (should (python-info-assignment-statement-p t)) + (python-tests-look-at "baz(), 4") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))) + (python-tests-look-at "5, 6") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))))) + +(ert-deftest python-info-assignment-statement-p-2 () + (python-tests-with-temp-buffer + " +data = (foo(), bar() + baz(), 4 + 5, 6) +" + (python-tests-look-at "data = (foo(), bar()") + (should (python-info-assignment-statement-p)) + (should (python-info-assignment-statement-p t)) + (python-tests-look-at "baz(), 4") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))) + (python-tests-look-at "5, 6)") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))))) + +(ert-deftest python-info-assignment-statement-p-3 () + (python-tests-with-temp-buffer + " +data '=' 42 +" + (python-tests-look-at "data '=' 42") + (should (not (python-info-assignment-statement-p))) + (should (not (python-info-assignment-statement-p t))))) + +(ert-deftest python-info-assignment-continuation-line-p-1 () + (python-tests-with-temp-buffer + " +data = foo(), bar() \\\\ + baz(), 4 \\\\ + 5, 6 +" + (python-tests-look-at "data = foo(), bar()") + (should (not (python-info-assignment-continuation-line-p))) + (python-tests-look-at "baz(), 4") + (should (= (python-info-assignment-continuation-line-p) + (python-tests-look-at "foo()," -1 t))) + (python-tests-look-at "5, 6") + (should (not (python-info-assignment-continuation-line-p))))) + +(ert-deftest python-info-assignment-continuation-line-p-2 () + (python-tests-with-temp-buffer + " +data = (foo(), bar() + baz(), 4 + 5, 6) +" + (python-tests-look-at "data = (foo(), bar()") + (should (not (python-info-assignment-continuation-line-p))) + (python-tests-look-at "baz(), 4") + (should (= (python-info-assignment-continuation-line-p) + (python-tests-look-at "(foo()," -1 t))) + (python-tests-look-at "5, 6)") + (should (not (python-info-assignment-continuation-line-p))))) + +(ert-deftest python-info-looking-at-beginning-of-defun-1 () + (python-tests-with-temp-buffer + " +def decorat0r(deff): + '''decorates stuff. + + @decorat0r + def foo(arg): + ... + ''' + def wrap(): + deff() + return wwrap +" + (python-tests-look-at "def decorat0r(deff):") + (should (python-info-looking-at-beginning-of-defun)) + (python-tests-look-at "def foo(arg):") + (should (not (python-info-looking-at-beginning-of-defun))) + (python-tests-look-at "def wrap():") + (should (python-info-looking-at-beginning-of-defun)) + (python-tests-look-at "deff()") + (should (not (python-info-looking-at-beginning-of-defun))))) + +(ert-deftest python-info-current-line-comment-p-1 () + (python-tests-with-temp-buffer + " +# this is a comment +foo = True # another comment +'#this is a string' +if foo: + # more comments + print ('bar') # print bar +" + (python-tests-look-at "# this is a comment") + (should (python-info-current-line-comment-p)) + (python-tests-look-at "foo = True # another comment") + (should (not (python-info-current-line-comment-p))) + (python-tests-look-at "'#this is a string'") + (should (not (python-info-current-line-comment-p))) + (python-tests-look-at "# more comments") + (should (python-info-current-line-comment-p)) + (python-tests-look-at "print ('bar') # print bar") + (should (not (python-info-current-line-comment-p))))) + +(ert-deftest python-info-current-line-empty-p () + (python-tests-with-temp-buffer + " +# this is a comment + +foo = True # another comment +" + (should (python-info-current-line-empty-p)) + (python-tests-look-at "# this is a comment") + (should (not (python-info-current-line-empty-p))) + (forward-line 1) + (should (python-info-current-line-empty-p)))) + +(ert-deftest python-info-docstring-p-1 () + "Test module docstring detection." + (python-tests-with-temp-buffer + "# -*- coding: utf-8 -*- +#!/usr/bin/python + +''' +Module Docstring Django style. +''' +u'''Additional module docstring.''' +'''Not a module docstring.''' +" + (python-tests-look-at "Module Docstring Django style.") + (should (python-info-docstring-p)) + (python-tests-look-at "u'''Additional module docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a module docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-2 () + "Test variable docstring detection." + (python-tests-with-temp-buffer + " +variable = 42 +U'''Variable docstring.''' +'''Additional variable docstring.''' +'''Not a variable docstring.''' +" + (python-tests-look-at "Variable docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "u'''Additional variable docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a variable docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-3 () + "Test function docstring detection." + (python-tests-with-temp-buffer + " +def func(a, b): + r''' + Function docstring. + + onetwo style. + ''' + R'''Additional function docstring.''' + '''Not a function docstring.''' + return a + b +" + (python-tests-look-at "Function docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "R'''Additional function docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a function docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-4 () + "Test class docstring detection." + (python-tests-with-temp-buffer + " +class Class: + ur''' + Class docstring. + + symmetric style. + ''' + uR''' + Additional class docstring. + ''' + '''Not a class docstring.''' + pass +" + (python-tests-look-at "Class docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "uR'''") ;; Additional class docstring + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a class docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-5 () + "Test class attribute docstring detection." + (python-tests-with-temp-buffer + " +class Class: + attribute = 42 + Ur''' + Class attribute docstring. + + pep-257 style. + + ''' + UR''' + Additional class attribute docstring. + ''' + '''Not a class attribute docstring.''' + pass +" + (python-tests-look-at "Class attribute docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "UR'''") ;; Additional class attr docstring + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a class attribute docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-6 () + "Test class method docstring detection." + (python-tests-with-temp-buffer + " +class Class: + + def __init__(self, a, b): + self.a = a + self.b = b + + def __call__(self): + '''Method docstring. + + pep-257-nn style. + ''' + '''Additional method docstring.''' + '''Not a method docstring.''' + return self.a + self.b +" + (python-tests-look-at "Method docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Additional method docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a method docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-encoding-from-cookie-1 () + "Should detect it on first line." + (python-tests-with-temp-buffer + "# coding=latin-1 + +foo = True # another comment +" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-2 () + "Should detect it on second line." + (python-tests-with-temp-buffer + " +# coding=latin-1 + +foo = True # another comment +" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-3 () + "Should not be detected on third line (and following ones)." + (python-tests-with-temp-buffer + " + +# coding=latin-1 +foo = True # another comment +" + (should (not (python-info-encoding-from-cookie))))) + +(ert-deftest python-info-encoding-from-cookie-4 () + "Should detect Emacs style." + (python-tests-with-temp-buffer + "# -*- coding: latin-1 -*- + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-5 () + "Should detect Vim style." + (python-tests-with-temp-buffer + "# vim: set fileencoding=latin-1 : + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-6 () + "First cookie wins." + (python-tests-with-temp-buffer + "# -*- coding: iso-8859-1 -*- +# vim: set fileencoding=latin-1 : + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'iso-8859-1)))) + +(ert-deftest python-info-encoding-from-cookie-7 () + "First cookie wins." + (python-tests-with-temp-buffer + "# vim: set fileencoding=latin-1 : +# -*- coding: iso-8859-1 -*- + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-1 () + "Should return the detected encoding from cookie." + (python-tests-with-temp-buffer + "# vim: set fileencoding=latin-1 : + +foo = True # another comment" + (should (eq (python-info-encoding) 'latin-1)))) + +(ert-deftest python-info-encoding-2 () + "Should default to utf-8." + (python-tests-with-temp-buffer + "# No encoding for you + +foo = True # another comment" + (should (eq (python-info-encoding) 'utf-8)))) + + +;;; Utility functions + +(ert-deftest python-util-goto-line-1 () + (python-tests-with-temp-buffer + (concat + "# a comment +# another comment +def foo(a, b, c): + pass" (make-string 20 ?\n)) + (python-util-goto-line 10) + (should (= (line-number-at-pos) 10)) + (python-util-goto-line 20) + (should (= (line-number-at-pos) 20)))) + +(ert-deftest python-util-clone-local-variables-1 () + (let ((buffer (generate-new-buffer + "python-util-clone-local-variables-1")) + (varcons + '((python-fill-docstring-style . django) + (python-shell-interpreter . "python") + (python-shell-interpreter-args . "manage.py shell") + (python-shell-prompt-regexp . "In \\[[0-9]+\\]: ") + (python-shell-prompt-output-regexp . "Out\\[[0-9]+\\]: ") + (python-shell-extra-pythonpaths "/home/user/pylib/") + (python-shell-completion-setup-code + . "from IPython.core.completerlib import module_completion") + (python-shell-completion-string-code + . "';'.join(get_ipython().Completer.all_completions('''%s'''))\n") + (python-shell-virtualenv-root + . "/home/user/.virtualenvs/project")))) + (with-current-buffer buffer + (kill-all-local-variables) + (dolist (ccons varcons) + (set (make-local-variable (car ccons)) (cdr ccons)))) + (python-tests-with-temp-buffer + "" + (python-util-clone-local-variables buffer) + (dolist (ccons varcons) + (should + (equal (symbol-value (car ccons)) (cdr ccons))))) + (kill-buffer buffer))) + +(ert-deftest python-util-strip-string-1 () + (should (string= (python-util-strip-string "\t\r\n str") "str")) + (should (string= (python-util-strip-string "str \n\r") "str")) + (should (string= (python-util-strip-string "\t\r\n str \n\r ") "str")) + (should + (string= (python-util-strip-string "\n str \nin \tg \n\r") "str \nin \tg")) + (should (string= (python-util-strip-string "\n \t \n\r ") "")) + (should (string= (python-util-strip-string "") ""))) + +(ert-deftest python-util-forward-comment-1 () + (python-tests-with-temp-buffer + (concat + "# a comment +# another comment + # bad indented comment +# more comments" (make-string 9999 ?\n)) + (python-util-forward-comment 1) + (should (= (point) (point-max))) + (python-util-forward-comment -1) + (should (= (point) (point-min))))) + +(ert-deftest python-util-valid-regexp-p-1 () + (should (python-util-valid-regexp-p "")) + (should (python-util-valid-regexp-p python-shell-prompt-regexp)) + (should (not (python-util-valid-regexp-p "\\(")))) + + +;;; Electricity + +(ert-deftest python-parens-electric-indent-1 () + (let ((eim electric-indent-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + " +from django.conf.urls import patterns, include, url + +from django.contrib import admin + +from myapp import views + + +urlpatterns = patterns('', + url(r'^$', views.index +) +" + (electric-indent-mode 1) + (python-tests-look-at "views.index") + (end-of-line) + + ;; Inserting commas within the same line should leave + ;; indentation unchanged. + (python-tests-self-insert ",") + (should (= (current-indentation) 4)) + + ;; As well as any other input happening within the same + ;; set of parens. + (python-tests-self-insert " name='index')") + (should (= (current-indentation) 4)) + + ;; But a comma outside it, should trigger indentation. + (python-tests-self-insert ",") + (should (= (current-indentation) 23)) + + ;; Newline indents to the first argument column + (python-tests-self-insert "\n") + (should (= (current-indentation) 23)) + + ;; All this input must not change indentation + (indent-line-to 4) + (python-tests-self-insert "url(r'^/login$', views.login)") + (should (= (current-indentation) 4)) + + ;; But this comma does + (python-tests-self-insert ",") + (should (= (current-indentation) 23)))) + (or eim (electric-indent-mode -1))))) + +(ert-deftest python-triple-quote-pairing () + (let ((epm electric-pair-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + "\"\"\n" + (or epm (electric-pair-mode 1)) + (goto-char (1- (point-max))) + (python-tests-self-insert ?\") + (should (string= (buffer-string) + "\"\"\"\"\"\"\n")) + (should (= (point) 4))) + (python-tests-with-temp-buffer + "\n" + (python-tests-self-insert (list ?\" ?\" ?\")) + (should (string= (buffer-string) + "\"\"\"\"\"\"\n")) + (should (= (point) 4))) + (python-tests-with-temp-buffer + "\"\n\"\"\n" + (goto-char (1- (point-max))) + (python-tests-self-insert ?\") + (should (= (point) (1- (point-max)))) + (should (string= (buffer-string) + "\"\n\"\"\"\n")))) + (or epm (electric-pair-mode -1))))) + + +;;; Hideshow support + +(ert-deftest python-hideshow-hide-levels-1 () + "Should hide all methods when called after class start." + (let ((enabled hs-minor-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + self.arg = arg + self.kwarg = kwarg + + def filter(self, nums): + def fn(item): + return item in [self.arg, self.kwarg] + return filter(fn, nums) + + def __str__(self): + return '%s-%s' % (self.arg, self.kwarg) +" + (hs-minor-mode 1) + (python-tests-look-at "class SomeClass:") + (forward-line) + (hs-hide-level 1) + (should + (string= + (python-tests-visible-string) + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + def filter(self, nums): + def __str__(self):")))) + (or enabled (hs-minor-mode -1))))) + +(ert-deftest python-hideshow-hide-levels-2 () + "Should hide nested methods and parens at end of defun." + (let ((enabled hs-minor-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + self.arg = arg + self.kwarg = kwarg + + def filter(self, nums): + def fn(item): + return item in [self.arg, self.kwarg] + return filter(fn, nums) + + def __str__(self): + return '%s-%s' % (self.arg, self.kwarg) +" + (hs-minor-mode 1) + (python-tests-look-at "def fn(item):") + (hs-hide-block) + (should + (string= + (python-tests-visible-string) + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + self.arg = arg + self.kwarg = kwarg + + def filter(self, nums): + def fn(item): + return filter(fn, nums) + + def __str__(self): + return '%s-%s' % (self.arg, self.kwarg) +")))) + (or enabled (hs-minor-mode -1))))) + + + +(provide 'python-tests) + +;; Local Variables: +;; indent-tabs-mode: nil +;; End: + +;;; python-tests.el ends here diff --cc test/lisp/progmodes/ruby-mode-tests.el index 065aa56a4d5,00000000000..da8d77c5157 mode 100644,000000..100644 --- a/test/lisp/progmodes/ruby-mode-tests.el +++ b/test/lisp/progmodes/ruby-mode-tests.el @@@ -1,713 -1,0 +1,713 @@@ +;;; ruby-mode-tests.el --- Test suite for ruby-mode + - ;; Copyright (C) 2012-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'ruby-mode) + +(defmacro ruby-with-temp-buffer (contents &rest body) + (declare (indent 1) (debug t)) + `(with-temp-buffer + (insert ,contents) + (ruby-mode) + ,@body)) + +(defun ruby-should-indent (content column) + "Assert indentation COLUMN on the last line of CONTENT." + (ruby-with-temp-buffer content + (indent-according-to-mode) + (should (= (current-indentation) column)))) + +(defun ruby-should-indent-buffer (expected content) + "Assert that CONTENT turns into EXPECTED after the buffer is re-indented. + +The whitespace before and including \"|\" on each line is removed." + (ruby-with-temp-buffer (ruby-test-string content) + (indent-region (point-min) (point-max)) + (should (string= (ruby-test-string expected) (buffer-string))))) + +(defun ruby-test-string (s &rest args) + (apply 'format (replace-regexp-in-string "^[ \t]*|" "" s) args)) + +(defun ruby-assert-state (content index value &optional point) + "Assert syntax state values at the end of CONTENT. + +VALUES-PLIST is a list with alternating index and value elements." + (ruby-with-temp-buffer content + (when point (goto-char point)) + (syntax-propertize (point)) + (should (eq (nth index + (parse-partial-sexp (point-min) (point))) + value)))) + +(defun ruby-assert-face (content pos face) + (ruby-with-temp-buffer content + (font-lock-ensure nil nil) + (should (eq face (get-text-property pos 'face))))) + +(ert-deftest ruby-indent-after-symbol-made-from-string-interpolation () + "It can indent the line after symbol made using string interpolation." + (ruby-should-indent "def foo(suffix)\n :\"bar#{suffix}\"\n" + ruby-indent-level)) + +(ert-deftest ruby-indent-after-js-style-symbol-with-block-beg-name () + "JS-style hash symbol can have keyword name." + (ruby-should-indent "link_to \"home\", home_path, class: \"foo\"\n" 0)) + +(ert-deftest ruby-discern-singleton-class-from-heredoc () + (ruby-assert-state "foo < 5 } + | .map { |str| str.downcase }" + "one.two.three + | .four + | + |my_array.select { |str| str.size > 5 } + | .map { |str| str.downcase }"))) + +(ert-deftest ruby-move-to-block-stops-at-indentation () + (ruby-with-temp-buffer "def f\nend" + (beginning-of-line) + (ruby-move-to-block -1) + (should (looking-at "^def")))) + +(ert-deftest ruby-toggle-block-to-do-end () + (ruby-with-temp-buffer "foo {|b|\n}" + (beginning-of-line) + (ruby-toggle-block) + (should (string= "foo do |b|\nend" (buffer-string))))) + +(ert-deftest ruby-toggle-block-to-brace () + (let ((pairs '((17 . "foo { |b| b + 2 }") + (16 . "foo { |b|\n b + 2\n}")))) + (dolist (pair pairs) + (with-temp-buffer + (let ((fill-column (car pair))) + (insert "foo do |b|\n b + 2\nend") + (ruby-mode) + (beginning-of-line) + (ruby-toggle-block) + (should (string= (cdr pair) (buffer-string)))))))) + +(ert-deftest ruby-toggle-block-to-multiline () + (ruby-with-temp-buffer "foo {|b| b + 1}" + (beginning-of-line) + (ruby-toggle-block) + (should (string= "foo do |b|\n b + 1\nend" (buffer-string))))) + +(ert-deftest ruby-toggle-block-with-interpolation () + (ruby-with-temp-buffer "foo do\n \"#{bar}\"\nend" + (beginning-of-line) + (ruby-toggle-block) + (should (string= "foo { \"#{bar}\" }" (buffer-string))))) + +(ert-deftest ruby-recognize-symbols-starting-with-at-character () + (ruby-assert-face ":@abc" 3 font-lock-constant-face)) + +(ert-deftest ruby-hash-character-not-interpolation () + (ruby-assert-face "\"This is #{interpolation}\"" 15 + font-lock-variable-name-face) + (ruby-assert-face "\"This is \\#{no interpolation} despite the #\"" + 15 font-lock-string-face) + (ruby-assert-face "\n#@comment, not ruby code" 5 font-lock-comment-face) + (ruby-assert-state "\n#@comment, not ruby code" 4 t) + (ruby-assert-face "# A comment cannot have #{an interpolation} in it" + 30 font-lock-comment-face) + (ruby-assert-face "# #{comment}\n \"#{interpolation}\"" 16 + font-lock-variable-name-face)) + +(ert-deftest ruby-interpolation-suppresses-quotes-inside () + (let ((s "\"
  • #{@files.join(\"
  • \")}
\"")) + (ruby-assert-state s 8 nil) + (ruby-assert-face s 9 font-lock-string-face) + (ruby-assert-face s 10 font-lock-variable-name-face) + (ruby-assert-face s 41 font-lock-string-face))) + +(ert-deftest ruby-interpolation-suppresses-one-double-quote () + (let ((s "\"foo#{'\"'}\"")) + (ruby-assert-state s 8 nil) + (ruby-assert-face s 8 font-lock-variable-name-face) + (ruby-assert-face s 11 font-lock-string-face))) + +(ert-deftest ruby-interpolation-suppresses-one-backtick () + (let ((s "`as#{'`'}das`")) + (ruby-assert-state s 8 nil))) + +(ert-deftest ruby-interpolation-keeps-non-quote-syntax () + (let ((s "\"foo#{baz.tee}bar\"")) + (ruby-with-temp-buffer s + (goto-char (point-min)) + (ruby-mode) + (syntax-propertize (point-max)) + (search-forward "tee") + (should (string= (thing-at-point 'symbol) "tee"))))) + +(ert-deftest ruby-interpolation-inside-percent-literal () + (let ((s "%( #{boo} )")) + (ruby-assert-face s 1 font-lock-string-face) + (ruby-assert-face s 4 font-lock-variable-name-face) + (ruby-assert-face s 10 font-lock-string-face) + (ruby-assert-state s 8 nil))) + +(ert-deftest ruby-interpolation-inside-percent-literal-with-paren () + :expected-result :failed + (let ((s "%(^#{\")\"}^)")) + (ruby-assert-face s 3 font-lock-string-face) + (ruby-assert-face s 4 font-lock-variable-name-face) + (ruby-assert-face s 10 font-lock-string-face) + ;; It's confused by the closing paren in the middle. + (ruby-assert-state s 8 nil))) + +(ert-deftest ruby-interpolation-inside-double-quoted-percent-literals () + (ruby-assert-face "%Q{foo #@bar}" 8 font-lock-variable-name-face) + (ruby-assert-face "%W{foo #@bar}" 8 font-lock-variable-name-face) + (ruby-assert-face "%r{foo #@bar}" 8 font-lock-variable-name-face) + (ruby-assert-face "%x{foo #@bar}" 8 font-lock-variable-name-face)) + +(ert-deftest ruby-no-interpolation-in-single-quoted-literals () + (ruby-assert-face "'foo #@bar'" 7 font-lock-string-face) + (ruby-assert-face "%q{foo #@bar}" 8 font-lock-string-face) + (ruby-assert-face "%w{foo #@bar}" 8 font-lock-string-face) + (ruby-assert-face "%s{foo #@bar}" 8 font-lock-string-face)) + +(ert-deftest ruby-interpolation-after-dollar-sign () + (ruby-assert-face "\"$#{balance}\"" 2 'font-lock-string-face) + (ruby-assert-face "\"$#{balance}\"" 3 'font-lock-variable-name-face)) + +(ert-deftest ruby-no-unknown-percent-literals () + ;; No folding of case. + (ruby-assert-face "%S{foo}" 4 nil) + (ruby-assert-face "%R{foo}" 4 nil)) + +(ert-deftest ruby-add-log-current-method-examples () + (let ((pairs '(("foo" . "#foo") + ("C.foo" . ".foo") + ("self.foo" . ".foo")))) + (dolist (pair pairs) + (let ((name (car pair)) + (value (cdr pair))) + (ruby-with-temp-buffer (ruby-test-string + "module M + | class C + | def %s + | _ + | end + | end + |end" + name) + (search-backward "_") + (forward-line) + (should (string= (ruby-add-log-current-method) + (format "M::C%s" value)))))))) + +(ert-deftest ruby-add-log-current-method-outside-of-method () + (ruby-with-temp-buffer (ruby-test-string + "module M + | class C + | def foo + | end + | _ + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method)"M::C")))) + +(ert-deftest ruby-add-log-current-method-in-singleton-class () + (ruby-with-temp-buffer (ruby-test-string + "class C + | class << self + | def foo + | _ + | end + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method) "C.foo")))) + +(ert-deftest ruby-add-log-current-method-namespace-shorthand () + (ruby-with-temp-buffer (ruby-test-string + "class C::D + | def foo + | _ + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method) "C::D#foo")))) + +(ert-deftest ruby-add-log-current-method-after-inner-class () + (ruby-with-temp-buffer (ruby-test-string + "module M + | class C + | class D + | end + | def foo + | _ + | end + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method) "M::C#foo")))) + +(defvar ruby-block-test-example + (ruby-test-string + "class C + | def foo + | 1 + | end + | + | def bar + | 2 + | end + | + | def baz + |some do + |3 + | end + | end + |end")) + +(defmacro ruby-deftest-move-to-block (name &rest body) + (declare (indent defun)) + `(ert-deftest ,(intern (format "ruby-move-to-block-%s" name)) () + (with-temp-buffer + (insert ruby-block-test-example) + (ruby-mode) + (goto-char (point-min)) + ,@body))) + +(ruby-deftest-move-to-block works-on-do + (forward-line 10) + (ruby-end-of-block) + (should (= 13 (line-number-at-pos))) + (ruby-beginning-of-block) + (should (= 11 (line-number-at-pos)))) + +(ruby-deftest-move-to-block zero-is-noop + (forward-line 4) + (ruby-move-to-block 0) + (should (= 5 (line-number-at-pos)))) + +(ruby-deftest-move-to-block ok-with-three + (forward-line 1) + (ruby-move-to-block 3) + (should (= 14 (line-number-at-pos)))) + +(ruby-deftest-move-to-block ok-with-minus-two + (forward-line 9) + (ruby-move-to-block -2) + (should (= 2 (line-number-at-pos)))) + +(ert-deftest ruby-move-to-block-skips-percent-literal () + (dolist (s (list (ruby-test-string + "foo do + | a = %%w( + | def yaa + | ) + |end") + (ruby-test-string + "foo do + | a = %%w| + | end + | | + |end"))) + (ruby-with-temp-buffer s + (goto-char (point-min)) + (ruby-end-of-block) + (should (= 5 (line-number-at-pos))) + (ruby-beginning-of-block) + (should (= 1 (line-number-at-pos)))))) + +(ert-deftest ruby-move-to-block-skips-heredoc () + (ruby-with-temp-buffer + (ruby-test-string + "if something_wrong? + | ActiveSupport::Deprecation.warn(<<-eowarn) + | boo hoo + | end + | eowarn + |end") + (goto-char (point-min)) + (ruby-end-of-block) + (should (= 6 (line-number-at-pos))) + (ruby-beginning-of-block) + (should (= 1 (line-number-at-pos))))) + +(ert-deftest ruby-move-to-block-does-not-fold-case () + (ruby-with-temp-buffer + (ruby-test-string + "foo do + | Module.to_s + |end") + (let ((case-fold-search t)) + (ruby-beginning-of-block)) + (should (= 1 (line-number-at-pos))))) + +(ert-deftest ruby-move-to-block-moves-from-else-to-if () + (ruby-with-temp-buffer (ruby-test-string + "if true + | nested_block do + | end + |else + |end") + (goto-char (point-min)) + (forward-line 3) + (ruby-beginning-of-block) + (should (= 1 (line-number-at-pos))))) + +(ert-deftest ruby-beginning-of-defun-does-not-fold-case () + (ruby-with-temp-buffer + (ruby-test-string + "class C + | def bar + | Class.to_s + | end + |end") + (goto-char (point-min)) + (forward-line 3) + (let ((case-fold-search t)) + (beginning-of-defun)) + (should (= 2 (line-number-at-pos))))) + +(ert-deftest ruby-end-of-defun-skips-to-next-line-after-the-method () + (ruby-with-temp-buffer + (ruby-test-string + "class D + | def tee + | 'ho hum' + | end + |end") + (goto-char (point-min)) + (forward-line 1) + (end-of-defun) + (should (= 5 (line-number-at-pos))))) + +(defvar ruby-sexp-test-example + (ruby-test-string + "class C + | def foo + | self.end + | D.new.class + | [1, 2, 3].map do |i| + | i + 1 + | end.sum + | end + |end")) + +(ert-deftest ruby-forward-sexp-skips-method-calls-with-keyword-names () + (ruby-with-temp-buffer ruby-sexp-test-example + (goto-line 2) + (ruby-forward-sexp) + (should (= 8 (line-number-at-pos))))) + +(ert-deftest ruby-backward-sexp-skips-method-calls-with-keyword-names () + (ruby-with-temp-buffer ruby-sexp-test-example + (goto-line 8) + (end-of-line) + (ruby-backward-sexp) + (should (= 2 (line-number-at-pos))))) + +(ert-deftest ruby--insert-coding-comment-ruby-style () + (with-temp-buffer + (let ((ruby-encoding-magic-comment-style 'ruby)) + (ruby--insert-coding-comment "utf-8") + (should (string= "# coding: utf-8\n" (buffer-string)))))) + +(ert-deftest ruby--insert-coding-comment-emacs-style () + (with-temp-buffer + (let ((ruby-encoding-magic-comment-style 'emacs)) + (ruby--insert-coding-comment "utf-8") + (should (string= "# -*- coding: utf-8 -*-\n" (buffer-string)))))) + +(ert-deftest ruby--insert-coding-comment-custom-style () + (with-temp-buffer + (let ((ruby-encoding-magic-comment-style 'custom) + (ruby-custom-encoding-magic-comment-template "# encoding: %s\n")) + (ruby--insert-coding-comment "utf-8") + (should (string= "# encoding: utf-8\n\n" (buffer-string)))))) + + +(provide 'ruby-mode-tests) + +;;; ruby-mode-tests.el ends here diff --cc test/lisp/progmodes/subword-tests.el index bedb1523999,00000000000..5a562765bb1 mode 100644,000000..100644 --- a/test/lisp/progmodes/subword-tests.el +++ b/test/lisp/progmodes/subword-tests.el @@@ -1,81 -1,0 +1,81 @@@ +;;; subword-tests.el --- Testing the subword rules + - ;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'subword) + +(defconst subword-tests-strings + '("ABC^" ;;Bug#13758 + "ABC^ ABC^Foo^ ABC^-Foo^ toto^ ABC^")) + +(ert-deftest subword-tests () + "Test the `subword-mode' rules." + (with-temp-buffer + (dolist (str subword-tests-strings) + (erase-buffer) + (insert str) + (goto-char (point-min)) + (while (search-forward "^" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (not (eobp)) + (subword-forward 1) + (insert "^")) + (should (equal (buffer-string) str))))) + +(ert-deftest subword-tests2 () + "Test that motion in subword-mode stops at the right places." + + (let* ((line "fooBarBAZ quXD g_TESTThingAbc word BLAH test") + (fwrd "* * * * * * * * * * * * *") + (bkwd "* * * * * * * * * * * * *")) + + (with-temp-buffer + (subword-mode 1) + (insert line) + + ;; Test forward motion. + + (goto-char (point-min)) + (let ((stops (make-string (length fwrd) ?\ ))) + (while (progn + (aset stops (1- (point)) ?\*) + (not (eobp))) + (forward-word)) + (should (equal stops fwrd))) + + ;; Test backward motion. + + (goto-char (point-max)) + (let ((stops (make-string (length bkwd) ?\ ))) + (while (progn + (aset stops (1- (point)) ?\*) + (not (bobp))) + (backward-word)) + (should (equal stops bkwd)))))) + +(provide 'subword-tests) +;;; subword-tests.el ends here diff --cc test/lisp/replace-tests.el index f4e474bcafd,00000000000..bfaab6c8944 mode 100644,000000..100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@@ -1,35 -1,0 +1,35 @@@ +;;; replace-tests.el --- tests for replace.el. + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +(ert-deftest query-replace--split-string-tests () + (let ((sep (propertize "\0" 'separator t))) + (dolist (before '("" "b")) + (dolist (after '("" "a")) + (should (equal + (query-replace--split-string (concat before sep after)) + (cons before after))) + (should (equal + (query-replace--split-string (concat before "\0" after)) + (concat before "\0" after))))))) + +;;; replace-tests.el ends here diff --cc test/lisp/simple-tests.el index 771241ad7ef,00000000000..12ebc75ea92 mode 100644,000000..100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@@ -1,315 -1,0 +1,315 @@@ +;;; simple-test.el --- Tests for simple.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) + +(defmacro simple-test--dummy-buffer (&rest body) + (declare (indent 0) + (debug t)) + `(with-temp-buffer + (emacs-lisp-mode) + (setq indent-tabs-mode nil) + (insert "(a b") + (save-excursion (insert " c d)")) + ,@body + (cons (buffer-substring (point-min) (point)) + (buffer-substring (point) (point-max))))) + + +(defmacro simple-test--transpositions (&rest body) + (declare (indent 0) + (debug t)) + `(with-temp-buffer + (emacs-lisp-mode) + (insert "(s1) (s2) (s3) (s4) (s5)") + (backward-sexp 1) + ,@body + (cons (buffer-substring (point-min) (point)) + (buffer-substring (point) (point-max))))) + + +;;; `newline' +(ert-deftest newline () + (should-error (newline -1)) + (should (equal (simple-test--dummy-buffer (newline 1)) + '("(a b\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-mode -1) + (call-interactively #'newline)) + '("(a b\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (let ((current-prefix-arg 5)) + (call-interactively #'newline))) + '("(a b\n\n\n\n\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer (newline 5)) + '("(a b\n\n\n\n\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (newline 1)) + '("(a b \n" . "c d)")))) + +(ert-deftest newline-indent () + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (newline 1)) + '("(a b\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (newline 1 'interactive)) + '("(a b\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg nil)) + (call-interactively #'newline) + (call-interactively #'newline))) + '("(a b\n\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (newline 5 'interactive)) + '("(a b\n\n\n\n\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg 5)) + (call-interactively #'newline))) + '("(a b\n\n\n\n\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (electric-indent-local-mode 1) + (newline 1 'interactive)) + '("(a b\n " . "c d)")))) + + +;;; `open-line' +(ert-deftest open-line () + (should-error (open-line -1)) + (should-error (open-line)) + (should (equal (simple-test--dummy-buffer (open-line 1)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-mode -1) + (call-interactively #'open-line)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (let ((current-prefix-arg 5)) + (call-interactively #'open-line))) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer (open-line 5)) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (open-line 1)) + '("(a b " . "\nc d)")))) + +(ert-deftest open-line-margin-and-prefix () + (should (equal (simple-test--dummy-buffer + (let ((left-margin 10)) + (open-line 3))) + '("(a b" . "\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-line 0) + (let ((left-margin 2)) + (open-line 1))) + '(" " . "\n (a b c d)"))) + (should (equal (simple-test--dummy-buffer + (let ((fill-prefix "- - ")) + (open-line 1))) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-line 0) + (let ((fill-prefix "- - ")) + (open-line 1))) + '("- - " . "\n(a b c d)")))) + +;; For a while, from 24 Oct - 21 Nov 2015, `open-line' in the Emacs +;; development tree became sensitive to `electric-indent-mode', which +;; it had not been before. This sensitivity was reverted for the +;; Emacs 25 release, so it could be discussed further (see thread +;; "Questioning the new behavior of `open-line'." on the Emacs Devel +;; mailing list, and bug #21884). +(ert-deftest open-line-indent () + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (open-line 1)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (open-line 1)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg nil)) + (call-interactively #'open-line) + (call-interactively #'open-line))) + '("(a b" . "\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (open-line 5)) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg 5)) + (call-interactively #'open-line))) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (electric-indent-local-mode 1) + (open-line 1)) + '("(a b " . "\nc d)")))) + +;; From 24 Oct - 21 Nov 2015, `open-line' took a second argument +;; INTERACTIVE and ran `post-self-insert-hook' if the argument was +;; true. This test tested that. Currently, however, `open-line' +;; does not run run `post-self-insert-hook' at all, so for now +;; this test just makes sure that it doesn't. +(ert-deftest open-line-hook () + (let* ((x 0) + (inc (lambda () (setq x (1+ x))))) + (simple-test--dummy-buffer + (add-hook 'post-self-insert-hook inc nil 'local) + (open-line 1)) + (should (= x 0)) + (simple-test--dummy-buffer + (add-hook 'post-self-insert-hook inc nil 'local) + (open-line 1)) + (should (= x 0)) + + (unwind-protect + (progn + (add-hook 'post-self-insert-hook inc) + (simple-test--dummy-buffer + (open-line 1)) + (should (= x 0)) + (simple-test--dummy-buffer + (open-line 10)) + (should (= x 0))) + (remove-hook 'post-self-insert-hook inc)))) + + +;;; `delete-trailing-whitespace' +(ert-deftest simple-delete-trailing-whitespace () + "Test bug#21766: delete-whitespace sometimes deletes non-whitespace." + (defvar python-indent-guess-indent-offset) ; to avoid a warning + (let ((python (featurep 'python)) + (python-indent-guess-indent-offset nil) + (delete-trailing-lines t)) + (unwind-protect + (with-temp-buffer + (python-mode) + (insert (concat "query = \"\"\"WITH filtered AS \n" + "WHERE \n" + "\"\"\".format(fv_)\n" + "\n" + "\n")) + (delete-trailing-whitespace) + (should (equal (count-lines (point-min) (point-max)) 3))) + ;; Let's clean up if running interactive + (unless (or noninteractive python) + (unload-feature 'python))))) + + +;;; auto-boundary tests +(ert-deftest undo-auto-boundary-timer () + (should + undo-auto-current-boundary-timer)) + +(ert-deftest undo-auto--boundaries-added () + ;; The change in the buffer should have caused addition + ;; to undo-auto--undoably-changed-buffers. + (should + (with-temp-buffer + (setq buffer-undo-list nil) + (insert "hello") + (member (current-buffer) undo-auto--undoably-changed-buffers))) + ;; The head of buffer-undo-list should be the insertion event, and + ;; therefore not nil + (should + (with-temp-buffer + (setq buffer-undo-list nil) + (insert "hello") + (car buffer-undo-list))) + ;; Now the head of the buffer-undo-list should be a boundary and so + ;; nil. We have to call auto-boundary explicitly because we are out + ;; of the command loop + (should-not + (with-temp-buffer + (setq buffer-undo-list nil) + (insert "hello") + (car buffer-undo-list) + (undo-auto--boundaries 'test)))) + +;;; Transposition with negative args (bug#20698, bug#21885) +(ert-deftest simple-transpose-subr () + (should (equal (simple-test--transpositions (transpose-sexps -1)) + '("(s1) (s2) (s4)" . " (s3) (s5)"))) + (should (equal (simple-test--transpositions (transpose-sexps -2)) + '("(s1) (s4)" . " (s2) (s3) (s5)")))) + + +;; Test for a regression introduced by undo-auto--boundaries changes. +;; https://lists.gnu.org/archive/html/emacs-devel/2015-11/msg01652.html +(defun undo-test-kill-c-a-then-undo () + (with-temp-buffer + (switch-to-buffer (current-buffer)) + (setq buffer-undo-list nil) + (insert "a\nb\n\c\n") + (goto-char (point-max)) + ;; We use a keyboard macro because it adds undo events in the same + ;; way as if a user were involved. + (kmacro-call-macro nil nil nil + [left + ;; Delete "c" + backspace + left left left + ;; Delete "a" + backspace + ;; C-/ or undo + 67108911 + ]) + (point))) + +(defun undo-test-point-after-forward-kill () + (with-temp-buffer + (switch-to-buffer (current-buffer)) + (setq buffer-undo-list nil) + (insert "kill word forward") + ;; Move to word "word". + (goto-char 6) + (kmacro-call-macro nil nil nil + [ + ;; kill-word + C-delete + ;; undo + 67108911 + ]) + (point))) + +(ert-deftest undo-point-in-wrong-place () + (should + ;; returns 5 with the bug + (= 2 + (undo-test-kill-c-a-then-undo))) + (should + (= 6 + (undo-test-point-after-forward-kill)))) + + +(provide 'simple-test) +;;; simple-test.el ends here diff --cc test/lisp/sort-tests.el index 22acb83e26a,00000000000..52973297818 mode 100644,000000..100644 --- a/test/lisp/sort-tests.el +++ b/test/lisp/sort-tests.el @@@ -1,106 -1,0 +1,106 @@@ +;;; sort-tests.el --- Tests for sort.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) +(require 'sort) + +(defun sort-tests-random-word (n) + (mapconcat (lambda (_) (string (let ((c (random 52))) + (+ (if (> c 25) 71 65) + c)))) + (make-list n nil) "")) + +(defun sort-tests--insert-words-sort-and-compare (words separator function reverse less-predicate) + (with-temp-buffer + (let ((aux words)) + (while aux + (insert (pop aux)) + (when aux + (insert separator)))) + ;; Final newline. + (insert "\n") + (funcall function reverse (point-min) (point-max)) + (let ((sorted-words + (mapconcat #'identity + (let ((x (sort (copy-sequence words) less-predicate))) + (if reverse (reverse x) x)) + separator))) + (should (string= (substring (buffer-string) 0 -1) sorted-words))))) + +;;; This function uses randomly generated tests and should satisfy +;;; most needs for this lib. +(cl-defun sort-tests-test-sorter-function (separator function &key generator less-pred noreverse) + "Check that FUNCTION correctly sorts words separated by SEPARATOR. +This checks whether it is equivalent to sorting a list of such +words via LESS-PREDICATE, and then inserting them separated by +SEPARATOR. +LESS-PREDICATE defaults to `string-lessp'. +GENERATOR is a function called with one argument that returns a +word, it defaults to `sort-tests-random-word'. +NOREVERSE means that the first arg of FUNCTION is not used for +reversing the sort." + (dotimes (n 20) + ;; Sort n words of length n. + (let ((words (mapcar (or generator #'sort-tests-random-word) (make-list n n))) + (sort-fold-case nil) + (less-pred (or less-pred #'string<))) + (sort-tests--insert-words-sort-and-compare words separator function nil less-pred) + (unless noreverse + (sort-tests--insert-words-sort-and-compare + words separator function 'reverse less-pred)) + (let ((less-pred-case (lambda (a b) (funcall less-pred (downcase a) (downcase b)))) + (sort-fold-case t)) + (sort-tests--insert-words-sort-and-compare words separator function nil less-pred-case) + (unless noreverse + (sort-tests--insert-words-sort-and-compare + words separator function 'reverse less-pred-case)))))) + +(ert-deftest sort-tests--lines () + (sort-tests-test-sorter-function "\n" #'sort-lines)) + +(ert-deftest sort-tests--paragraphs () + (let ((paragraph-separate "[\s\t\f]*$")) + (sort-tests-test-sorter-function "\n\n" #'sort-paragraphs))) + +(ert-deftest sort-tests--numeric-fields () + (cl-labels ((field-to-number (f) (string-to-number (car (split-string f))))) + (sort-tests-test-sorter-function "\n" (lambda (_ l r) (sort-numeric-fields 1 l (1- r))) + :noreverse t + :generator (lambda (_) (format "%s %s" (random) (sort-tests-random-word 20))) + :less-pred (lambda (a b) (< (field-to-number a) + (field-to-number b)))))) + +(ert-deftest sort-tests--fields-1 () + (cl-labels ((field-n (f n) (elt (split-string f) (1- n)))) + (sort-tests-test-sorter-function "\n" (lambda (_ l r) (sort-fields 1 l (1- r))) + :noreverse t + :generator (lambda (n) (concat (sort-tests-random-word n) " " (sort-tests-random-word n))) + :less-pred (lambda (a b) (string< (field-n a 1) (field-n b 1)))))) + +(ert-deftest sort-tests--fields-2 () + (cl-labels ((field-n (f n) (elt (split-string f) (1- n)))) + (sort-tests-test-sorter-function "\n" (lambda (_ l r) (sort-fields 2 l (1- r))) + :noreverse t + :generator (lambda (n) (concat (sort-tests-random-word n) " " (sort-tests-random-word n))) + :less-pred (lambda (a b) (string< (field-n a 2) (field-n b 2)))))) + +(provide 'sort-tests) +;;; sort-tests.el ends here diff --cc test/lisp/subr-tests.el index 3fcb7d346a3,00000000000..7906a207a96 mode 100644,000000..100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@@ -1,219 -1,0 +1,219 @@@ +;;; subr-tests.el --- Tests for subr.el + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Oleh Krehel , +;; Nicolas Petton +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) + +(ert-deftest let-when-compile () + ;; good case + (should (equal (macroexpand '(let-when-compile ((foo (+ 2 3))) + (setq bar (eval-when-compile (+ foo foo))) + (setq boo (eval-when-compile (* foo foo))))) + '(progn + (setq bar (quote 10)) + (setq boo (quote 25))))) + ;; bad case: `eval-when-compile' omitted, byte compiler should catch this + (should (equal (macroexpand + '(let-when-compile ((foo (+ 2 3))) + (setq bar (+ foo foo)) + (setq boo (eval-when-compile (* foo foo))))) + '(progn + (setq bar (+ foo foo)) + (setq boo (quote 25))))) + ;; something practical + (should (equal (macroexpand + '(let-when-compile ((keywords '("true" "false"))) + (font-lock-add-keywords + 'c++-mode + `((,(eval-when-compile + (format "\\<%s\\>" (regexp-opt keywords))) + 0 font-lock-keyword-face))))) + '(font-lock-add-keywords + (quote c++-mode) + (list + (cons (quote + "\\<\\(?:\\(?:fals\\|tru\\)e\\)\\>") + (quote + (0 font-lock-keyword-face)))))))) + +(ert-deftest string-comparison-test () + (should (string-lessp "abc" "acb")) + (should (string-lessp "aBc" "abc")) + (should (string-lessp "abc" "abcd")) + (should (string-lessp "abc" "abcd")) + (should-not (string-lessp "abc" "abc")) + (should-not (string-lessp "" "")) + + (should (string-greaterp "acb" "abc")) + (should (string-greaterp "abc" "aBc")) + (should (string-greaterp "abcd" "abc")) + (should (string-greaterp "abcd" "abc")) + (should-not (string-greaterp "abc" "abc")) + (should-not (string-greaterp "" "")) + + ;; Symbols are also accepted + (should (string-lessp 'abc 'acb)) + (should (string-lessp "abc" 'acb)) + (should (string-greaterp 'acb 'abc)) + (should (string-greaterp "acb" 'abc))) + +(ert-deftest subr-test-when () + (should (equal (when t 1) 1)) + (should (equal (when t 2) 2)) + (should (equal (when nil 1) nil)) + (should (equal (when nil 2) nil)) + (should (equal (when t 'x 1) 1)) + (should (equal (when t 'x 2) 2)) + (should (equal (when nil 'x 1) nil)) + (should (equal (when nil 'x 2) nil)) + (let ((x 1)) + (should-not (when nil + (setq x (1+ x)) + x)) + (should (= x 1)) + (should (= 2 (when t + (setq x (1+ x)) + x))) + (should (= x 2))) + (should (equal (macroexpand-all '(when a b c d)) + '(if a (progn b c d))))) + +(ert-deftest subr-test-version-parsing () + (should (equal (version-to-list ".5") '(0 5))) + (should (equal (version-to-list "0.9 alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0.9 snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9-alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0.9-snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9.snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9_snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0.9snapshot") '(0 9 -4))) + (should (equal (version-to-list "1.0 git") '(1 0 -4))) + (should (equal (version-to-list "1.0 pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0-git") '(1 0 -4))) + (should (equal (version-to-list "1.0-pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0.1-a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1-f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.1.a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1.f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.1_a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1_f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.1a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.7.5") '(1 0 7 5))) + (should (equal (version-to-list "1.0.git") '(1 0 -4))) + (should (equal (version-to-list "1.0.pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0_git") '(1 0 -4))) + (should (equal (version-to-list "1.0_pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0git") '(1 0 -4))) + (should (equal (version-to-list "1.0pre2") '(1 0 -1 2))) + (should (equal (version-to-list "22.8 beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8-beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8.beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8_beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8beta3") '(22 8 -2 3))) + (should (equal (version-to-list "6.9.30 Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30-Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30.Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30_Beta") '(6 9 30 -2))) + + (should (equal + (error-message-string (should-error (version-to-list "OTP-18.1.5"))) + "Invalid version syntax: `OTP-18.1.5' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list ""))) + "Invalid version syntax: `' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list "1.0..7.5"))) + "Invalid version syntax: `1.0..7.5'")) + (should (equal + (error-message-string (should-error (version-to-list "1.0prepre2"))) + "Invalid version syntax: `1.0prepre2'")) + (should (equal + (error-message-string (should-error (version-to-list "22.8X3"))) + "Invalid version syntax: `22.8X3'")) + (should (equal + (error-message-string (should-error (version-to-list "beta22.8alpha3"))) + "Invalid version syntax: `beta22.8alpha3' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list "honk"))) + "Invalid version syntax: `honk' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list 9))) + "Version must be a string")) + + (let ((version-separator "_")) + (should (equal (version-to-list "_5") '(0 5))) + (should (equal (version-to-list "0_9 alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9 snapshot") '(0 9 -4))) + (should (equal (version-to-list "0_9-alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9-snapshot") '(0 9 -4))) + (should (equal (version-to-list "0_9.alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9.snapshot") '(0 9 -4))) + (should (equal (version-to-list "0_9alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9snapshot") '(0 9 -4))) + (should (equal (version-to-list "1_0 git") '(1 0 -4))) + (should (equal (version-to-list "1_0 pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1_0-git") '(1 0 -4))) + (should (equal (version-to-list "1_0.pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1_0_1-a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1-f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_1.a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1.f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_1_a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1_f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_1a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_7_5") '(1 0 7 5))) + (should (equal (version-to-list "1_0_git") '(1 0 -4))) + (should (equal (version-to-list "1_0pre2") '(1 0 -1 2))) + (should (equal (version-to-list "22_8 beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22_8-beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22_8.beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22_8beta3") '(22 8 -2 3))) + (should (equal (version-to-list "6_9_30 Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6_9_30-Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6_9_30.Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6_9_30Beta") '(6 9 30 -2))) + + (should (equal + (error-message-string (should-error (version-to-list "1_0__7_5"))) + "Invalid version syntax: `1_0__7_5'")) + (should (equal + (error-message-string (should-error (version-to-list "1_0prepre2"))) + "Invalid version syntax: `1_0prepre2'")) + (should (equal + (error-message-string (should-error (version-to-list "22.8X3"))) + "Invalid version syntax: `22.8X3'")) + (should (equal + (error-message-string (should-error (version-to-list "beta22_8alpha3"))) + "Invalid version syntax: `beta22_8alpha3' (must start with a number)")))) + +(provide 'subr-tests) +;;; subr-tests.el ends here diff --cc test/lisp/textmodes/reftex-tests.el index a7af58f74c0,00000000000..12ec7f5a394 mode 100644,000000..100644 --- a/test/lisp/textmodes/reftex-tests.el +++ b/test/lisp/textmodes/reftex-tests.el @@@ -1,223 -1,0 +1,223 @@@ +;;; reftex-tests.el --- Test suite for reftex. -*- lexical-binding: t -*- + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Rüdiger Sonderfeld +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +;;; reftex +(require 'reftex) + +;;; reftex-parse +(require 'reftex-parse) + +(ert-deftest reftex-locate-bibliography-files () + "Test `reftex-locate-bibliography-files'." + (let ((temp-dir (make-temp-file "reftex-bib" 'dir)) + (files '("ref1.bib" "ref2.bib")) + (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) + ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) + ("\\begin{document}\n\\bibliographystyle{plain}\n +\\bibliography{ref1,ref2}\n\\end{document}" . ("ref1.bib" "ref2.bib")))) + (reftex-bibliography-commands + ;; Default value: See reftex-vars.el `reftex-bibliography-commands' + '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" + "addbibresource"))) + (with-temp-buffer + (insert "test\n") + (mapc + (lambda (file) + (write-region (point-min) (point-max) (expand-file-name file + temp-dir))) + files)) + (mapc + (lambda (data) + (with-temp-buffer + (insert (car data)) + (let ((res (mapcar #'file-name-nondirectory + (reftex-locate-bibliography-files temp-dir)))) + (should (equal res (cdr data)))))) + test) + (delete-directory temp-dir 'recursive))) + +(ert-deftest reftex-what-environment-test () + "Test `reftex-what-environment'." + (with-temp-buffer + (insert "\\begin{equation}\n x=y^2\n") + (let ((pt (point)) + pt2) + (insert "\\end{equation}\n") + (goto-char pt) + + (should (equal (reftex-what-environment 1) '("equation" . 1))) + (should (equal (reftex-what-environment t) '(("equation" . 1)))) + + (insert "\\begin{something}\nxxx") + (setq pt2 (point)) + (insert "\\end{something}") + (goto-char pt2) + (should (equal (reftex-what-environment 1) `("something" . ,pt))) + (should (equal (reftex-what-environment t) `(("something" . ,pt) + ("equation" . 1)))) + (should (equal (reftex-what-environment t pt) `(("something" . ,pt)))) + (should (equal (reftex-what-environment '("equation")) + '("equation" . 1)))))) + +(ert-deftest reftex-roman-number-test () + "Test `reftex-roman-number'." + (let ((hindu-arabic '(1 2 4 9 14 1050)) + (roman '("I" "II" "IV" "IX" "XIV" "ML"))) + (while (and hindu-arabic roman) + (should (string= (reftex-roman-number (car hindu-arabic)) + (car roman))) + (pop roman) + (pop hindu-arabic)))) + +(ert-deftest reftex-parse-from-file-test () + "Test `reftex-parse-from-file'." + ;; Use file-truename to convert 8+3 aliases in $TEMP value on + ;; MS-Windows into their long file-name equivalents, which is + ;; necessary for the 'equal' and 'string=' comparisons below. This + ;; also resolves any symlinks, which cannot be bad for the same + ;; reason. (An alternative solution would be to use file-equal-p, + ;; but I'm too lazy to do that, as one of the tests compares a + ;; list.) + (let* ((temp-dir (file-truename (make-temp-file "reftex-parse" 'dir))) + (tex-file (expand-file-name "test.tex" temp-dir)) + (bib-file (expand-file-name "ref.bib" temp-dir))) + (with-temp-buffer + (insert +"\\begin{document} +\\section{test}\\label{sec:test} +\\subsection{subtest} + +\\begin{align*}\\label{eq:foo} + x &= y^2 +\\end{align*} + +\\bibliographystyle{plain} +\\bibliography{ref} +\\end{document}") + (write-region (point-min) (point-max) tex-file)) + (with-temp-buffer + (insert "test\n") + (write-region (point-min) (point-max) bib-file)) + (reftex-ensure-compiled-variables) + (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) + (should (equal (car parsed) `(eof ,tex-file))) + (pop parsed) + (while parsed + (let ((entry (pop parsed))) + (cond + ((eq (car entry) 'bib) + (should (string= (cadr entry) bib-file))) + ((eq (car entry) 'toc)) ;; ... + ((string= (car entry) "eq:foo")) + ((string= (car entry) "sec:test")) + ((eq (car entry) 'bof) + (should (string= (cadr entry) tex-file)) + (should (null parsed))) + (t (should-not t))))) + (delete-directory temp-dir 'recursive)))) + +;;; reftex-cite +(require 'reftex-cite) + +(ert-deftest reftex-parse-bibtex-entry-test () + "Test `reftex-parse-bibtex-entry'." + (let ((entry "@Book{Stallman12, + author = {Richard Stallman\net al.}, + title = {The Emacs Editor}, + publisher = {GNU Press}, + year = 2012, + edition = {17th}, + note = {Updated for Emacs Version 24.2} +}") + (check (function + (lambda (parsed) + (should (string= (reftex-get-bib-field "&key" parsed) + "Stallman12")) + (should (string= (reftex-get-bib-field "&type" parsed) + "book")) + (should (string= (reftex-get-bib-field "author" parsed) + "Richard Stallman et al.")) + (should (string= (reftex-get-bib-field "title" parsed) + "The Emacs Editor")) + (should (string= (reftex-get-bib-field "publisher" parsed) + "GNU Press")) + (should (string= (reftex-get-bib-field "year" parsed) + "2012")) + (should (string= (reftex-get-bib-field "edition" parsed) + "17th")) + (should (string= (reftex-get-bib-field "note" parsed) + "Updated for Emacs Version 24.2")))))) + (funcall check (reftex-parse-bibtex-entry entry)) + (with-temp-buffer + (insert entry) + (funcall check (reftex-parse-bibtex-entry nil (point-min) + (point-max)))))) + +(ert-deftest reftex-get-bib-names-test () + "Test `reftex-get-bib-names'." + (let ((entry (reftex-parse-bibtex-entry "@article{Foo123, + author = {Jane Roe and\tJohn Doe and W. Public}, +}"))) + (should (equal (reftex-get-bib-names "author" entry) + '("Jane Roe" "John Doe" "Public")))) + (let ((entry (reftex-parse-bibtex-entry "@article{Foo123, + editor = {Jane Roe and\tJohn Doe and W. Public}, +}"))) + (should (equal (reftex-get-bib-names "author" entry) + '("Jane Roe" "John Doe" "Public"))))) + +(ert-deftest reftex-format-citation-test () + "Test `reftex-format-citation'." + (let ((entry (reftex-parse-bibtex-entry +"@article{Foo13, + author = {Jane Roe and John Doe and Jane Q. Taxpayer}, + title = {Some Article}, + journal = {Some Journal}, + year = 2013, + pages = {1--333} +}"))) + (should (string= (reftex-format-citation entry nil) "\\cite{Foo13}")) + (should (string= (reftex-format-citation entry "%l:%A:%y:%t %j %P %a") + "Foo13:Jane Roe:2013:Some Article Some Journal 1 Jane Roe, John Doe \\& Jane Taxpayer")))) + + +;;; Autoload tests + +;; Test to check whether reftex autoloading mechanisms are working +;; correctly. +(ert-deftest reftex-autoload-auc () + "Tests to see whether reftex-auc has been autoloaded" + (should + (fboundp 'reftex-arg-label)) + (should + (autoloadp + (symbol-function + 'reftex-arg-label)))) + + +(provide 'reftex-tests) +;;; reftex-tests.el ends here. diff --cc test/lisp/textmodes/sgml-mode-tests.el index eeb5c7d60ae,00000000000..4184e2c3802 mode 100644,000000..100644 --- a/test/lisp/textmodes/sgml-mode-tests.el +++ b/test/lisp/textmodes/sgml-mode-tests.el @@@ -1,135 -1,0 +1,135 @@@ +;;; sgml-mode-tests.el --- Tests for sgml-mode + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Przemysław Wojnowski +;; Keywords: tests + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'sgml-mode) +(require 'ert) + +(defmacro sgml-with-content (content &rest body) + "Insert CONTENT into a temporary `sgml-mode' buffer and execute BODY on it. +The point is set to the beginning of the buffer." + `(with-temp-buffer + (sgml-mode) + (insert ,content) + (goto-char (point-min)) + ,@body)) + +;;; sgml-delete-tag + +(ert-deftest sgml-delete-tag-should-not-delete-tags-when-wrong-args () + "Don't delete tag, when number of tags to delete is not positive number." + (let ((content "

Valar Morghulis

")) + (sgml-with-content + content + (sgml-delete-tag -1) + (should (string= content (buffer-string))) + (sgml-delete-tag 0) + (should (string= content (buffer-string)))))) + +(ert-deftest sgml-delete-tag-should-delete-tags-n-times () + ;; Delete only 1, when 1 available: + (sgml-with-content + "
" + (sgml-delete-tag 1) + (should (string= "" (buffer-string)))) + ;; Delete from position on whitespaces before tag: + (sgml-with-content + " \t\n
" + (sgml-delete-tag 1) + (should (string= "" (buffer-string)))) + ;; Delete from position on tag: + (sgml-with-content + "
" + (goto-char 3) + (sgml-delete-tag 1) + (should (string= "" (buffer-string)))) + ;; Delete one by one: + (sgml-with-content + "

You know nothing, Jon Snow.

" + (sgml-delete-tag 1) + (should (string= "

You know nothing, Jon Snow.

" (buffer-string))) + (sgml-delete-tag 1) + (should (string= "You know nothing, Jon Snow." (buffer-string)))) + ;; Delete 2 at a time, when 2 available: + (sgml-with-content + "

You know nothing, Jon Snow.

" + (sgml-delete-tag 2) + (should (string= "You know nothing, Jon Snow." (buffer-string))))) + +(ert-deftest sgml-delete-tag-should-delete-unclosed-tag () + (sgml-with-content + "
  • Keep your stones connected.
" + (goto-char 5) ; position on "li" tag + (sgml-delete-tag 1) + (should (string= "
    Keep your stones connected.
" (buffer-string))))) + +(ert-deftest sgml-delete-tag-should-signal-error-for-malformed-tags () + (let ((content "

Drakaris!

")) + ;; Delete outside tag: + (sgml-with-content + content + (sgml-delete-tag 1) + (should (string= "

Drakaris!

" (buffer-string)))) + ;; Delete inner tag: + (sgml-with-content + content + (goto-char 5) ; position the inner tag + (sgml-delete-tag 1) + (should (string= "

Drakaris!

" (buffer-string)))))) + +(ert-deftest sgml-delete-tag-should-signal-error-when-deleting-too-much () + (let ((content "Drakaris!")) + ;; No tags to delete: + (sgml-with-content + "Drakaris!" + (should-error (sgml-delete-tag 1) :type 'error) + (should (string= "Drakaris!" (buffer-string)))) + ;; Trying to delete 2 tags, when only 1 available: + (sgml-with-content + content + (should-error (sgml-delete-tag 2) :type 'error) + (should (string= "Drakaris!" (buffer-string)))) + ;; Trying to delete a tag, but not on/before a tag: + (sgml-with-content + content + (goto-char 7) ; D in Drakaris + (should-error (sgml-delete-tag 1) :type 'error) + (should (string= content (buffer-string)))) + ;; Trying to delete a tag from position outside tag: + (sgml-with-content + content + (goto-char (point-max)) + (should-error (sgml-delete-tag 1) :type 'error) + (should (string= content (buffer-string)))))) + +(ert-deftest sgml-delete-tag-bug-8203-should-not-delete-apostrophe () + :expected-result :failed + (sgml-with-content + "Winter is comin'" + (sgml-delete-tag 1) + (should (string= "Winter is comin'" (buffer-string))))) + +(provide 'sgml-mode-tests) +;;; sgml-mode-tests.el ends here diff --cc test/lisp/textmodes/tildify-tests.el index 788abe7f731,00000000000..8b50cf72868 mode 100644,000000..100644 --- a/test/lisp/textmodes/tildify-tests.el +++ b/test/lisp/textmodes/tildify-tests.el @@@ -1,264 -1,0 +1,264 @@@ +;;; tildify-test.el --- ERT tests for tildify.el -*- lexical-binding: t -*- + - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Michal Nazarewicz +;; Version: 4.5 +;; Keywords: text, TeX, SGML, wp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This package defines regression tests for the tildify package. + +;;; Code: + +(require 'ert) +(require 'tildify) + +(defun tildify-test--example-sentence (space) + "Return an example sentence with SPACE where hard space is required." + (concat "Lorem ipsum v" space "dolor sit amet, a" space + "consectetur adipiscing elit.")) + + +(defun tildify-test--example-html (sentence &optional with-nbsp is-xml) + "Return an example HTML code. +SENTENCE is placed where spaces should not be replaced with hard spaces, and +WITH-NBSP is placed where spaces should be replaced with hard spaces. If the +latter is missing, SENTENCE will be used in all placeholder positions. +If IS-XML is non-nil,
 tag is not treated specially."
 +  (let ((with-nbsp (or with-nbsp sentence)))
 +    (concat "

" with-nbsp "

\n" + "
" (if is-xml with-nbsp sentence) "
\n" + "\n" + "

" with-nbsp "

\n" + "<" sentence ">\n"))) + + +(defun tildify-test--test (modes input expected) + "Test tildify running in MODES. +INPUT is the initial content of the buffer and EXPECTED is expected result +after `tildify-buffer' is run." + (with-temp-buffer + (setq-local buffer-file-coding-system 'utf-8) + (dolist (mode modes) + (erase-buffer) + (funcall mode) + (let ((header (concat "Testing `tildify-buffer' in " + (symbol-name mode) "\n"))) + (insert header input) + (tildify-buffer t) + (should (string-equal (concat header expected) (buffer-string)))) + (erase-buffer) + (let ((header (concat "Testing `tildify-region' in " + (symbol-name mode) "\n"))) + (insert header input) + (tildify-region (point-min) (point-max) t) + (should (string-equal (concat header expected) (buffer-string))))))) + +(ert-deftest tildify-test-html () + "Tests tildification in an HTML document" + (let* ((sentence (tildify-test--example-sentence " ")) + (with-nbsp (tildify-test--example-sentence " "))) + (tildify-test--test '(html-mode sgml-mode) + (tildify-test--example-html sentence sentence) + (tildify-test--example-html sentence with-nbsp)))) + +(ert-deftest tildify-test-xml () + "Tests tildification in an XML document" + (let* ((sentence (tildify-test--example-sentence " ")) + (with-nbsp (tildify-test--example-sentence " "))) + (tildify-test--test '(nxml-mode) + (tildify-test--example-html sentence sentence t) + (tildify-test--example-html sentence with-nbsp t)))) + + +(defun tildify-test--example-tex (sentence &optional with-nbsp) + "Return an example (La)Tex code. +SENTENCE is placed where spaces should not be replaced with hard spaces, and +WITH-NBSP is placed where spaces should be replaced with hard spaces. If the +latter is missing, SENTENCE will be used in all placeholder positions." + (let ((with-nbsp (or with-nbsp sentence))) + (concat with-nbsp "\n" + "\\begin{verbatim}\n" sentence "\n\\end{verbatim}\n" + "\\verb#" sentence "#\n" + "$$" sentence "$$\n" + "$" sentence "$\n" + "\\[" sentence "\\]\n" + "\\v A % " sentence "\n" + with-nbsp "\n"))) + +(ert-deftest tildify-test-tex () + "Tests tildification in a (La)TeX document" + (let* ((sentence (tildify-test--example-sentence " ")) + (with-nbsp (tildify-test--example-sentence "~"))) + (tildify-test--test '(tex-mode latex-mode plain-tex-mode) + (tildify-test--example-tex sentence sentence) + (tildify-test--example-tex sentence with-nbsp)))) + + +(ert-deftest tildify-test-find-env-end-re-bug () + "Tests generation of end-regex using mix of indexes and strings" + (with-temp-buffer + (insert "foo whatever end-foo") + (goto-char (point-min)) + (should (string-equal "end-foo" + (tildify--find-env "foo\\|bar" + '(("foo\\|bar" . ("end-" 0)))))))) + + +(ert-deftest tildify-test-find-env-group-index-bug () + "Tests generation of match-string indexes" + (with-temp-buffer + (let ((pairs '(("start-\\(foo\\|bar\\)" . ("end-" 1)) + ("open-\\(foo\\|bar\\)" . ("close-" 1)))) + (beg-re "start-\\(foo\\|bar\\)\\|open-\\(foo\\|bar\\)")) + (insert "open-foo whatever close-foo") + (goto-char (point-min)) + (should (string-equal "close-foo" (tildify--find-env beg-re pairs)))))) + + +(defmacro with-test-foreach (expected &rest body) + "Helper macro for testing foreach functions. +BODY has access to pairs variable and called lambda." + (declare (indent 1)) + (let ((got (make-symbol "got"))) + `(with-temp-buffer + (insert "1 /- 2 -/ 3 V~ 4 ~ 5 /- 6 -/ 7") + (let* ((pairs '(("/-" . "-/") ("V\\(.\\)" . (1)))) + (,got "") + (called (lambda (s e) + (setq ,got (concat ,got (buffer-substring s e)))))) + (setq-local tildify-foreach-region-function + (apply-partially 'tildify-foreach-ignore-environments + pairs)) + ,@body + (should (string-equal ,expected ,got)))))) + +(ert-deftest tildify-test-foreach-ignore-environments () + "Basic test of `tildify-foreach-ignore-environments'" + (with-test-foreach "1 3 5 7" + (tildify-foreach-ignore-environments pairs called (point-min) (point-max)))) + + +(ert-deftest tildify-test-foreach-ignore-environments-early-return () + "Test whether `tildify-foreach-ignore-environments' returns early +The function must terminate as soon as callback returns nil." + (with-test-foreach "1 " + (tildify-foreach-ignore-environments + pairs (lambda (start end) (funcall called start end) nil) + (point-min) (point-max)))) + +(ert-deftest tildify-test-foreach-region () + "Basic test of `tildify--foreach-region'" + (with-test-foreach "1 3 5 7" + (tildify--foreach-region called (point-min) (point-max)))) + +(ert-deftest tildify-test-foreach-region-early-return () + "Test whether `tildify--foreach-ignore' returns early +The function must terminate as soon as callback returns nil." + (with-test-foreach "1 " + (tildify--foreach-region (lambda (start end) (funcall called start end) nil) + (point-min) (point-max)))) + +(ert-deftest tildify-test-foreach-region-limit-region () + "Test whether `tildify--foreach-ignore' limits callback to given region" + (with-test-foreach "3 " + (tildify--foreach-region called + (+ (point-min) 10) (+ (point-min) 16))) ; start at "3" end past "4" + (with-test-foreach "3 5" + (tildify--foreach-region called + (+ (point-min) 10) (+ (point-min) 20)))) ; start at "3" end past "5" + + +(defun tildify-space-test--test (modes nbsp env-open &optional set-space-string) + (with-temp-buffer + (setq-local buffer-file-coding-system 'utf-8) + (dolist (mode modes) + (funcall mode) + (when set-space-string + (setq-local tildify-space-string nbsp)) + (let ((header (concat "Testing `tildify-space' in " + (symbol-name mode) "\n"))) + ;; Replace space with hard space. + (erase-buffer) + (insert header "Lorem v ") + (should (tildify-space)) + (should (string-equal (concat header "Lorem v" nbsp) (buffer-string))) + ;; Inside and ignore environment, replacing does not happen. + (erase-buffer) + (insert header env-open "Lorem v ") + (should (not (tildify-space))) + (should (string-equal (concat header env-open "Lorem v ") + (buffer-string))))))) + +(ert-deftest tildify-space-test-html () + "Tests auto-tildification in an HTML document" + (tildify-space-test--test '(html-mode sgml-mode) " " "
"))
 +
 +(ert-deftest tildify-space-test-html-nbsp ()
 +  "Tests auto-tildification in an HTML document"
 +  (tildify-space-test--test '(html-mode sgml-mode) " " "
" t))
 +
 +(ert-deftest tildify-space-test-xml ()
 +  "Tests auto-tildification in an XML document"
 +  (tildify-space-test--test '(nxml-mode) " " ""))
 +
 +(ert-deftest tildify-space-undo-test-html-nbsp ()
 +  "Tests auto-tildification in an HTML document"
 +  (tildify-space-undo-test--test '(html-mode sgml-mode) " " "
" t))
 +
 +(ert-deftest tildify-space-undo-test-xml ()
 +  "Tests auto-tildification in an XML document"
 +  (tildify-space-undo-test--test '(nxml-mode) " " ".
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(defvar thing-at-point-test-data
 +  '(("http://1.gnu.org" 1  url "http://1.gnu.org")
 +    ("http://2.gnu.org" 6 url "http://2.gnu.org")
 +    ("http://3.gnu.org" 19 url "http://3.gnu.org")
 +    ("https://4.gnu.org" 1  url "https://4.gnu.org")
 +    ("A geo URI (geo:3.14159,-2.71828)." 12 url "geo:3.14159,-2.71828")
 +    ("Visit http://5.gnu.org now." 5 url nil)
 +    ("Visit http://6.gnu.org now." 7 url "http://6.gnu.org")
 +    ("Visit http://7.gnu.org now." 22 url "http://7.gnu.org")
 +    ("Visit http://8.gnu.org now." 22 url "http://8.gnu.org")
 +    ("Visit http://9.gnu.org now." 24 url nil)
 +    ;; Invalid URIs
 +    ("<<<<" 2 url nil)
 +    ("<>" 1 url nil)
 +    ("" 1 url nil)
 +    ("http://" 1 url nil)
 +    ;; Invalid schema
 +    ("foo://www.gnu.org" 1 url nil)
 +    ("foohttp://www.gnu.org" 1 url nil)
 +    ;; Non alphanumeric characters can be found in URIs
 +    ("ftp://example.net/~foo!;#bar=baz&goo=bob" 3 url "ftp://example.net/~foo!;#bar=baz&goo=bob")
 +    ("bzr+ssh://user@example.net:5/a%20d,5" 34 url "bzr+ssh://user@example.net:5/a%20d,5")
 +    ;;  markup
 +    ("Url: ..." 8 url "foo://1.example.com")
 +    ("Url: ..." 30 url "foo://2.example.com")
 +    ("Url: ..." 20 url "foo://www.gnu.org/a bc")
 +    ;; Hack used by thing-at-point: drop punctuation at end of URI.
 +    ("Go to http://www.gnu.org, for details" 7 url "http://www.gnu.org")
 +    ("Go to http://www.gnu.org." 24 url "http://www.gnu.org")
 +    ;; Standard URI delimiters
 +    ("Go to \"http://10.gnu.org\"." 8 url "http://10.gnu.org")
 +    ("Go to \"http://11.gnu.org/\"." 26 url "http://11.gnu.org/")
 +    ("Go to  now." 8 url "http://12.gnu.org")
 +    ("Go to  now." 24 url "http://13.gnu.org")
 +    ;; Parenthesis handling (non-standard)
 +    ("http://example.com/a(b)c" 21 url "http://example.com/a(b)c")
 +    ("http://example.com/a(b)" 21 url "http://example.com/a(b)")
 +    ("(http://example.com/abc)" 2 url "http://example.com/abc")
 +    ("This (http://example.com/a(b))" 7 url "http://example.com/a(b)")
 +    ("This (http://example.com/a(b))" 30 url "http://example.com/a(b)")
 +    ("This (http://example.com/a(b))" 5 url nil)
 +    ("http://example.com/ab)c" 4 url "http://example.com/ab)c")
 +    ;; URL markup, lacking schema
 +    ("" 1 url "mailto:foo@example.com")
 +    ("" 1 url "ftp://ftp.example.net/abc/"))
 +  "List of thing-at-point tests.
 +Each list element should have the form
 +
 +  (STRING POS THING RESULT)
 +
 +where STRING is a string of buffer contents, POS is the value of
 +point, THING is a symbol argument for `thing-at-point', and
 +RESULT should be the result of calling `thing-at-point' from that
 +position to retrieve THING.")
 +
 +(ert-deftest thing-at-point-tests ()
 +  "Test the file-local variables implementation."
 +  (dolist (test thing-at-point-test-data)
 +    (with-temp-buffer
 +      (insert (nth 0 test))
 +      (goto-char (nth 1 test))
 +      (should (equal (thing-at-point (nth 2 test)) (nth 3 test))))))
 +
 +;;; thingatpt.el ends here
diff --cc test/lisp/url/url-expand-tests.el
index 2bd28687f8d,00000000000..6d1d54d4ffc
mode 100644,000000..100644
--- a/test/lisp/url/url-expand-tests.el
+++ b/test/lisp/url/url-expand-tests.el
@@@ -1,105 -1,0 +1,105 @@@
 +;;; url-expand-tests.el --- Test suite for relative URI/URL resolution.
 +
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
 +
 +;; Author: Alain Schneble 
 +;; Version: 1.0
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Test cases covering URI reference resolution as described in RFC3986,
 +;; section 5. Reference Resolution and especially the relative resolution
 +;; rules specified in section 5.2. Relative Resolution.
 +
 +;; Each test calls `url-expand-file-name', typically with a relative
 +;; reference URI and a base URI as string and compares the result (Actual)
 +;; against a manually specified URI (Expected)
 +
 +;;; Code:
 +
 +(require 'url-expand)
 +(require 'ert)
 +
 +(ert-deftest url-expand-file-name/relative-resolution-normal-examples ()
 +  "RFC 3986, Section 5.4 Reference Resolution Examples / Section 5.4.1. Normal Examples"
 +  (should (equal (url-expand-file-name "g:h"     "http://a/b/c/d;p?q") "g:h"))
 +  (should (equal (url-expand-file-name "g"       "http://a/b/c/d;p?q") "http://a/b/c/g"))
 +  (should (equal (url-expand-file-name "./g"     "http://a/b/c/d;p?q") "http://a/b/c/g"))
 +  (should (equal (url-expand-file-name "g/"      "http://a/b/c/d;p?q") "http://a/b/c/g/"))
 +  (should (equal (url-expand-file-name "/g"      "http://a/b/c/d;p?q") "http://a/g"))
 +  (should (equal (url-expand-file-name "//g"     "http://a/b/c/d;p?q") "http://g"))
 +  (should (equal (url-expand-file-name "?y"      "http://a/b/c/d;p?q") "http://a/b/c/d;p?y"))
 +  (should (equal (url-expand-file-name "g?y"     "http://a/b/c/d;p?q") "http://a/b/c/g?y"))
 +  (should (equal (url-expand-file-name "#s"      "http://a/b/c/d;p?q") "http://a/b/c/d;p?q#s"))
 +  (should (equal (url-expand-file-name "g#s"     "http://a/b/c/d;p?q") "http://a/b/c/g#s"))
 +  (should (equal (url-expand-file-name "g?y#s"   "http://a/b/c/d;p?q") "http://a/b/c/g?y#s"))
 +  (should (equal (url-expand-file-name ";x"      "http://a/b/c/d;p?q") "http://a/b/c/;x"))
 +  (should (equal (url-expand-file-name "g;x"     "http://a/b/c/d;p?q") "http://a/b/c/g;x"))
 +  (should (equal (url-expand-file-name "g;x?y#s" "http://a/b/c/d;p?q") "http://a/b/c/g;x?y#s"))
 +  (should (equal (url-expand-file-name ""        "http://a/b/c/d;p?q") "http://a/b/c/d;p?q"))
 +  (should (equal (url-expand-file-name "."       "http://a/b/c/d;p?q") "http://a/b/c/"))
 +  (should (equal (url-expand-file-name "./"      "http://a/b/c/d;p?q") "http://a/b/c/"))
 +  (should (equal (url-expand-file-name ".."      "http://a/b/c/d;p?q") "http://a/b/"))
 +  (should (equal (url-expand-file-name "../"     "http://a/b/c/d;p?q") "http://a/b/"))
 +  (should (equal (url-expand-file-name "../g"    "http://a/b/c/d;p?q") "http://a/b/g"))
 +  (should (equal (url-expand-file-name "../.."   "http://a/b/c/d;p?q") "http://a/"))
 +  (should (equal (url-expand-file-name "../../"  "http://a/b/c/d;p?q") "http://a/"))
 +  (should (equal (url-expand-file-name "../../g" "http://a/b/c/d;p?q") "http://a/g")))
 +
 +(ert-deftest url-expand-file-name/relative-resolution-absolute-examples ()
 +  "RFC 3986, Section 5.4 Reference Resolution Examples / Section 5.4.2. Abnormal Examples"
 +  (should (equal (url-expand-file-name "../../../g"    "http://a/b/c/d;p?q") "http://a/g"))
 +  (should (equal (url-expand-file-name "../../../../g" "http://a/b/c/d;p?q") "http://a/g"))
 +
 +  (should (equal (url-expand-file-name "/./g"          "http://a/b/c/d;p?q") "http://a/g"))
 +  (should (equal (url-expand-file-name "/../g"         "http://a/b/c/d;p?q") "http://a/g"))
 +  (should (equal (url-expand-file-name "g."            "http://a/b/c/d;p?q") "http://a/b/c/g."))
 +  (should (equal (url-expand-file-name ".g"            "http://a/b/c/d;p?q") "http://a/b/c/.g"))
 +  (should (equal (url-expand-file-name "g.."           "http://a/b/c/d;p?q") "http://a/b/c/g.."))
 +  (should (equal (url-expand-file-name "..g"           "http://a/b/c/d;p?q") "http://a/b/c/..g"))
 +
 +  (should (equal (url-expand-file-name "./../g"        "http://a/b/c/d;p?q") "http://a/b/g"))
 +  (should (equal (url-expand-file-name "./g/."         "http://a/b/c/d;p?q") "http://a/b/c/g/"))
 +  (should (equal (url-expand-file-name "g/./h"         "http://a/b/c/d;p?q") "http://a/b/c/g/h"))
 +  (should (equal (url-expand-file-name "g/../h"        "http://a/b/c/d;p?q") "http://a/b/c/h"))
 +  (should (equal (url-expand-file-name "g;x=1/./y"     "http://a/b/c/d;p?q") "http://a/b/c/g;x=1/y"))
 +  (should (equal (url-expand-file-name "g;x=1/../y"    "http://a/b/c/d;p?q") "http://a/b/c/y"))
 +
 +  (should (equal (url-expand-file-name "g?y/./x"       "http://a/b/c/d;p?q") "http://a/b/c/g?y/./x"))
 +  (should (equal (url-expand-file-name "g?y/../x"      "http://a/b/c/d;p?q") "http://a/b/c/g?y/../x"))
 +  (should (equal (url-expand-file-name "g#s/./x"       "http://a/b/c/d;p?q") "http://a/b/c/g#s/./x"))
 +  (should (equal (url-expand-file-name "g#s/../x"      "http://a/b/c/d;p?q") "http://a/b/c/g#s/../x"))
 +
 +  (should (equal (url-expand-file-name "http:g"        "http://a/b/c/d;p?q") "http:g")) ; for strict parsers
 +  )
 +
 +(ert-deftest url-expand-file-name/relative-resolution-additional-examples ()
 +  "Reference Resolution Examples / Arbitrary Examples"
 +  (should (equal (url-expand-file-name "" "http://host/foobar") "http://host/foobar"))
 +  (should (equal (url-expand-file-name "?y"      "http://a/b/c/d") "http://a/b/c/d?y"))
 +  (should (equal (url-expand-file-name "?y"      "http://a/b/c/d/") "http://a/b/c/d/?y"))
 +  (should (equal (url-expand-file-name "?y#fragment"      "http://a/b/c/d;p?q") "http://a/b/c/d;p?y#fragment"))
 +  (should (equal (url-expand-file-name "#bar" "http://host") "http://host#bar"))
 +  (should (equal (url-expand-file-name "#bar" "http://host/") "http://host/#bar"))
 +  (should (equal (url-expand-file-name "#bar" "http://host/foo") "http://host/foo#bar"))
 +  (should (equal (url-expand-file-name "foo#bar" "http://host/foobar") "http://host/foo#bar"))
 +  (should (equal (url-expand-file-name "foo#bar" "http://host/foobar/") "http://host/foobar/foo#bar")))
 +
 +(provide 'url-expand-tests)
 +
 +;;; url-expand-tests.el ends here
diff --cc test/lisp/url/url-future-tests.el
index 66ce7d632f3,00000000000..87298cc1b96
mode 100644,000000..100644
--- a/test/lisp/url/url-future-tests.el
+++ b/test/lisp/url/url-future-tests.el
@@@ -1,57 -1,0 +1,57 @@@
 +;;; url-future-tests.el --- Test suite for url-future.
 +
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
 +
 +;; Author: Teodor Zlatanov 
 +;; Keywords: data
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'url-future)
 +
 +(ert-deftest url-future-tests ()
 +  (let* (saver
 +         (text "running future")
 +         (good (make-url-future :value (lambda () (format text))
 +                                :callback (lambda (f) (set 'saver f))))
 +         (bad (make-url-future :value (lambda () (/ 1 0))
 +                               :errorback (lambda (&rest d) (set 'saver d))))
 +         (tocancel (make-url-future :value (lambda () (/ 1 0))
 +                                    :callback (lambda (f) (set 'saver f))
 +                                    :errorback (lambda (&rest d)
 +                                                 (set 'saver d)))))
 +    (should (equal good (url-future-call good)))
 +    (should (equal good saver))
 +    (should (equal text (url-future-value good)))
 +    (should (url-future-completed-p good))
 +    (should-error (url-future-call good))
 +    (setq saver nil)
 +    (should (equal bad (url-future-call bad)))
 +    (should-error (url-future-call bad))
 +    (should (equal saver (list bad '(arith-error))))
 +    (should (url-future-errored-p bad))
 +    (setq saver nil)
 +    (should (equal (url-future-cancel tocancel) tocancel))
 +    (should-error (url-future-call tocancel))
 +    (should (null saver))
 +    (should (url-future-cancelled-p tocancel))))
 +
 +(provide 'url-future-tests)
 +
 +;;; url-future-tests.el ends here
diff --cc test/lisp/url/url-parse-tests.el
index 443034a603e,00000000000..77c5320e351
mode 100644,000000..100644
--- a/test/lisp/url/url-parse-tests.el
+++ b/test/lisp/url/url-parse-tests.el
@@@ -1,167 -1,0 +1,167 @@@
 +;;; url-parse-tests.el --- Test suite for URI/URL parsing.
 +
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
 +
 +;; Author: Alain Schneble 
 +;; Version: 1.0
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Test cases covering generic URI syntax as described in RFC3986,
 +;; section 3. Syntax Components and 4. Usage. See also appendix
 +;; A. Collected ABNF for URI, as the example given here are all
 +;; productions of this grammar.
 +
 +;; Each tests parses a given URI string - whether relative or absolute -
 +;; using `url-generic-parse-url' and compares the constructed
 +;; URL-struct (Actual) against a manually `url-parse-make-urlobj'-
 +;; constructed URL-struct (Expected).
 +
 +;;; Code:
 +
 +(require 'url-parse)
 +(require 'ert)
 +
 +(ert-deftest url-generic-parse-url/generic-uri-examples ()
 +  "RFC 3986, section 1.1.2. Examples / Example illustrating several URI schemes and variations in their common syntax components"
 +  (should (equal (url-generic-parse-url "ftp://ftp.is.co.za/rfc/rfc1808.txt") (url-parse-make-urlobj "ftp" nil nil "ftp.is.co.za" nil "/rfc/rfc1808.txt" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://www.ietf.org/rfc/rfc2396.txt") (url-parse-make-urlobj "http" nil nil "www.ietf.org" nil "/rfc/rfc2396.txt" nil nil t)))
 +  (should (equal (url-generic-parse-url "ldap://[2001:db8::7]/c=GB?objectClass?one") (url-parse-make-urlobj "ldap" nil nil "[2001:db8::7]" nil "/c=GB?objectClass?one" nil nil t)))
 +  (should (equal (url-generic-parse-url "mailto:John.Doe@example.com") (url-parse-make-urlobj "mailto" nil nil nil nil "John.Doe@example.com" nil nil nil)))
 +  (should (equal (url-generic-parse-url "news:comp.infosystems.www.servers.unix") (url-parse-make-urlobj "news" nil nil nil nil "comp.infosystems.www.servers.unix" nil nil nil)))
 +  (should (equal (url-generic-parse-url "tel:+1-816-555-1212") (url-parse-make-urlobj "tel" nil nil nil nil "+1-816-555-1212" nil nil nil)))
 +  (should (equal (url-generic-parse-url "telnet://192.0.2.16:80/") (url-parse-make-urlobj "telnet" nil nil "192.0.2.16" 80 "/" nil nil t)))
 +  (should (equal (url-generic-parse-url "urn:oasis:names:specification:docbook:dtd:xml:4.1.2") (url-parse-make-urlobj "urn" nil nil nil nil "oasis:names:specification:docbook:dtd:xml:4.1.2" nil nil nil))))
 +
 +(ert-deftest url-generic-parse-url/generic-uri ()
 +  "RFC 3986, section 3. Syntax Components / generic URI syntax"
 +  ;; empty path
 +  (should (equal (url-generic-parse-url "http://host#") (url-parse-make-urlobj "http" nil nil "host" nil "" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host?#") (url-parse-make-urlobj "http" nil nil "host" nil "?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host?query#") (url-parse-make-urlobj "http" nil nil "host" nil "?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "?query" "fragment" nil t)))
 +  ;; absolute path /
 +  (should (equal (url-generic-parse-url "http://host/#") (url-parse-make-urlobj "http" nil nil "host" nil "/" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?#") (url-parse-make-urlobj "http" nil nil "host" nil "/?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/?query" "fragment" nil t)))
 +  ;; absolute path /foo
 +  (should (equal (url-generic-parse-url "http://host/foo#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?query" "fragment" nil t)))
 +  ;; absolute path /foo/
 +  (should (equal (url-generic-parse-url "http://host/foo/#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?query" "fragment" nil t)))
 +  ;; absolute path /foo/bar
 +  (should (equal (url-generic-parse-url "http://host/foo/bar#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?query" "fragment" nil t)))
 +  ;; absolute path /foo/bar/
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?query" "fragment" nil t)))
 +  ;; for more examples of URIs without fragments, see tests covering section 4.3. Absolute URI
 +  )
 +
 +(ert-deftest url-generic-parse-url/network-path-reference ()
 +  "RFC 3986, section 4.2. Relative Reference / network-path reference: a relative reference that begins with two slash characters"
 +  (should (equal (url-generic-parse-url "//host") (url-parse-make-urlobj nil nil nil "host" nil "" nil nil t)))
 +  (should (equal (url-generic-parse-url "//host/") (url-parse-make-urlobj nil nil nil "host" nil "/" nil nil t)))
 +  (should (equal (url-generic-parse-url "//host/foo") (url-parse-make-urlobj nil nil nil "host" nil "/foo" nil nil t)))
 +  (should (equal (url-generic-parse-url "//host/foo/bar") (url-parse-make-urlobj nil nil nil "host" nil "/foo/bar" nil nil t)))
 +  (should (equal (url-generic-parse-url "//host/foo/bar/") (url-parse-make-urlobj nil nil nil "host" nil "/foo/bar/" nil nil t))))
 +
 +(ert-deftest url-generic-parse-url/absolute-path-reference ()
 +  "RFC 3986, section 4.2. Relative Reference / absolute-path reference: a relative reference that begins with a single slash character"
 +  (should (equal (url-generic-parse-url "/") (url-parse-make-urlobj nil nil nil nil nil "/" nil nil nil)))
 +  (should (equal (url-generic-parse-url "/foo") (url-parse-make-urlobj nil nil nil nil nil "/foo" nil nil nil)))
 +  (should (equal (url-generic-parse-url "/foo/bar") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar" nil nil nil)))
 +  (should (equal (url-generic-parse-url "/foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar/" nil nil nil)))
 +  (should (equal (url-generic-parse-url "/foo/bar#") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar" "" nil nil)))
 +  (should (equal (url-generic-parse-url "/foo/bar/#") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar/" "" nil nil))))
 +
 +(ert-deftest url-generic-parse-url/relative-path-reference ()
 +  "RFC 3986, section 4.2. Relative Reference / relative-path reference: a relative reference that does not begin with a slash character"
 +  (should (equal (url-generic-parse-url "foo") (url-parse-make-urlobj nil nil nil nil nil "foo" nil nil nil)))
 +  (should (equal (url-generic-parse-url "foo/bar") (url-parse-make-urlobj nil nil nil nil nil "foo/bar" nil nil nil)))
 +  (should (equal (url-generic-parse-url "foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "foo/bar/" nil nil nil)))
 +  (should (equal (url-generic-parse-url "./foo") (url-parse-make-urlobj nil nil nil nil nil "./foo" nil nil nil)))
 +  (should (equal (url-generic-parse-url "./foo/bar") (url-parse-make-urlobj nil nil nil nil nil "./foo/bar" nil nil nil)))
 +  (should (equal (url-generic-parse-url "./foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "./foo/bar/" nil nil nil)))
 +  (should (equal (url-generic-parse-url "../foo") (url-parse-make-urlobj nil nil nil nil nil "../foo" nil nil nil)))
 +  (should (equal (url-generic-parse-url "../foo/bar") (url-parse-make-urlobj nil nil nil nil nil "../foo/bar" nil nil nil)))
 +  (should (equal (url-generic-parse-url "../foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "../foo/bar/" nil nil nil)))
 +  (should (equal (url-generic-parse-url "./this:that") (url-parse-make-urlobj nil nil nil nil nil "./this:that" nil nil nil)))
 +  ;; for more examples of relative-path references, see tests covering section 4.4. Same-Document Reference
 +  )
 +
 +(ert-deftest url-generic-parse-url/absolute-uri ()
 +  "RFC 3986, section 4.3. Absolute URI / absolute URI: absolute form of a URI without a fragment identifier"
 +  ;; empty path
 +  (should (equal (url-generic-parse-url "http://host") (url-parse-make-urlobj "http" nil nil "host" nil "" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host?") (url-parse-make-urlobj "http" nil nil "host" nil "?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host?query") (url-parse-make-urlobj "http" nil nil "host" nil "?query" nil nil t)))
 +  ;; absolute path /
 +  (should (equal (url-generic-parse-url "http://host/") (url-parse-make-urlobj "http" nil nil "host" nil "/" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?") (url-parse-make-urlobj "http" nil nil "host" nil "/?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?query") (url-parse-make-urlobj "http" nil nil "host" nil "/?query" nil nil t)))
 +  ;; absolute path /foo
 +  (should (equal (url-generic-parse-url "http://host/foo") (url-parse-make-urlobj "http" nil nil "host" nil "/foo" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?query" nil nil t)))
 +  ;; absolute path /foo/
 +  (should (equal (url-generic-parse-url "http://host/foo/") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?query" nil nil t)))
 +  ;; absolute path /foo/bar
 +  (should (equal (url-generic-parse-url "http://host/foo/bar") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?query" nil nil t)))
 +  ;; absolute path /foo/bar/
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?query" nil nil t)))
 +  ;; example mentioned in RFC3986, section 5.4. Reference Resolution Examples
 +  (should (equal (url-generic-parse-url "http://a/b/c/d;p?q") (url-parse-make-urlobj "http" nil nil "a" nil "/b/c/d;p?q" nil nil t))))
 +
 +(ert-deftest url-generic-parse-url/same-document-reference ()
 +  "RFC 3986, section 4.4. Same-Document Reference / same-document reference: empty or number sign (\"#\") followed by a fragment identifier"
 +  (should (equal (url-generic-parse-url "") (url-parse-make-urlobj nil nil nil nil nil "" nil nil nil)))
 +  (should (equal (url-generic-parse-url "#") (url-parse-make-urlobj nil nil nil nil nil "" "" nil nil)))
 +  (should (equal (url-generic-parse-url "#foo") (url-parse-make-urlobj nil nil nil nil nil "" "foo" nil nil))))
 +
 +(provide 'url-parse-tests)
 +
 +;;; url-parse-tests.el ends here
diff --cc test/lisp/url/url-util-tests.el
index 21ddeb50fd5,00000000000..2f1de5103d6
mode 100644,000000..100644
--- a/test/lisp/url/url-util-tests.el
+++ b/test/lisp/url/url-util-tests.el
@@@ -1,51 -1,0 +1,51 @@@
 +;;; url-util-tests.el --- Test suite for url-util.
 +
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
 +
 +;; Author: Teodor Zlatanov 
 +;; Keywords: data
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'url-util)
 +
 +(ert-deftest url-util-tests ()
 +  (let ((tests
 +         '(("key1=val1&key2=val2&key3=val1&key3=val2&key4&key5"
 +            ((key1 val1) (key2 "val2") (key3 val1 val2) (key4) (key5 "")))
 +           ("key1=val1;key2=val2;key3=val1;key3=val2;key4;key5"
 +            ((key1 "val1") (key2 val2) (key3 val1 val2) ("key4") (key5 "")) t)
 +           ("key1=val1;key2=val2;key3=val1;key3=val2;key4=;key5="
 +            ((key1 val1) (key2 val2) ("key3" val1 val2) (key4) (key5 "")) t t)))
 +        test)
 +    (while tests
 +      (setq test (car tests)
 +            tests (cdr tests))
 +      (should (equal (apply 'url-build-query-string (cdr test)) (car test)))))
 +  (should (equal (url-parse-query-string
 +                  "key1=val1&key2=val2&key3=val1&key3=val2&key4=&key5")
 +                 '(("key5" "")
 +                   ("key4" "")
 +                   ("key3" "val2" "val1")
 +                   ("key2" "val2")
 +                   ("key1" "val1")))))
 +
 +(provide 'url-util-tests)
 +
 +;;; url-util-tests.el ends here
diff --cc test/lisp/vc/add-log-tests.el
index 9909db06022,00000000000..71be5a9eadc
mode 100644,000000..100644
--- a/test/lisp/vc/add-log-tests.el
+++ b/test/lisp/vc/add-log-tests.el
@@@ -1,85 -1,0 +1,85 @@@
 +;;; add-log-tests.el --- Test suite for add-log.
 +
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
 +
 +;; Author: Masatake YAMATO 
 +;; Keywords: vc tools
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'add-log)
 +
 +(defmacro add-log-current-defun-deftest (name doc major-mode
 +					      content marker expected-defun)
 +  "Generate an ert test for mode-own `add-log-current-defun-function'.
 +Run `add-log-current-defun' at the point where MARKER specifies in a
 +buffer which content is CONTENT under MAJOR-MODE. Then it compares the
 +result with EXPECTED-DEFUN."
 +  (let ((xname (intern (concat "add-log-current-defun-test-"
 +			       (symbol-name name)
 +			       ))))
 +    `(ert-deftest ,xname ()
 +	 ,doc
 +       (with-temp-buffer
 +	 (insert ,content)
 +	 (goto-char (point-min))
 +	 (funcall ',major-mode)
 +	 (should (equal (when (search-forward ,marker nil t)
 +			  (replace-match "" nil t)
 +			  (add-log-current-defun))
 +			,expected-defun))))))
 +
 +(add-log-current-defun-deftest
 + sh-func1
 + "Test sh-current-defun-name can find function."
 + sh-mode "
 +function foo
 +{
 +	><
 +}" "><" "foo")
 +
 +(add-log-current-defun-deftest
 + sh-func2
 + "Test sh-current-defun-name can find function."
 + sh-mode "
 +foo()
 +{
 +	><
 +}" "><" "foo")
 +
 +(add-log-current-defun-deftest
 + sh-func3
 + "Test sh-current-defun-name can find function."
 + sh-mode "
 +function foo()
 +{
 +	><
 +}" "><" "foo")
 +
 +(add-log-current-defun-deftest
 + sh-var
 + "Test sh-current-defun-name can find variable definition."
 + sh-mode "
 +PATH=a:/ab:/usr/abc
 +DIR=/pr><" "DIR")
 +
 +(provide 'add-log-tests)
 +
 +;;; add-log-tests.el ends here
diff --cc test/lisp/vc/vc-bzr-tests.el
index c548562ba0f,00000000000..82721eeee4e
mode 100644,000000..100644
--- a/test/lisp/vc/vc-bzr-tests.el
+++ b/test/lisp/vc/vc-bzr-tests.el
@@@ -1,144 -1,0 +1,144 @@@
 +;;; vc-bzr.el --- tests for vc/vc-bzr.el
 +
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
 +
 +;; Author: Glenn Morris 
 +;; Maintainer: emacs-devel@gnu.org
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'vc-bzr)
 +(require 'vc-dir)
 +
 +(ert-deftest vc-bzr-test-bug9726 ()
 +  "Test for http://debbugs.gnu.org/9726 ."
 +  (skip-unless (executable-find vc-bzr-program))
 +  ;; Bzr wants to access HOME, e.g. to write ~/.bzr.log.
 +  ;; This is a problem on hydra, where HOME is non-existent.
 +  ;; You can disable logging with BZR_LOG=/dev/null, but then some
 +  ;; commands (eg `bzr status') want to access ~/.bazaar, and will
 +  ;; abort if they cannot.  I could not figure out how to stop bzr
 +  ;; doing that, so just give it a temporary homedir for the duration.
 +  ;; http://bugs.launchpad.net/bzr/+bug/137407 ?
 +  (let* ((homedir (make-temp-file "vc-bzr-test" t))
 +         (bzrdir (expand-file-name "bzr" homedir))
 +         (ignored-dir (progn
 +                        (make-directory bzrdir)
 +                        (expand-file-name "ignored-dir" bzrdir)))
 +         (default-directory (file-name-as-directory bzrdir))
 +         (process-environment (cons (format "BZR_HOME=%s" homedir)
 +                                    process-environment)))
 +    (unwind-protect
 +        (progn
 +          (make-directory ignored-dir)
 +          (with-temp-buffer
 +            (insert (file-name-nondirectory ignored-dir))
 +            (write-region nil nil (expand-file-name ".bzrignore" bzrdir)
 +                          nil 'silent))
 +          (call-process vc-bzr-program nil nil nil "init")
 +          (call-process vc-bzr-program nil nil nil "add")
 +          (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
 +          (with-temp-buffer
 +            (insert "unregistered file")
 +            (write-region nil nil (expand-file-name "testfile2" ignored-dir)
 +                          nil 'silent))
 +          (vc-dir ignored-dir)
 +          (while (vc-dir-busy)
 +            (sit-for 0.1))
 +          ;; FIXME better to explicitly test for error from process sentinel.
 +          (with-current-buffer "*vc-dir*"
 +            (goto-char (point-min))
 +            (should (search-forward "unregistered" nil t))))
 +      (delete-directory homedir t))))
 +
 +;; Not specific to bzr.
 +(ert-deftest vc-bzr-test-bug9781 ()
 +  "Test for http://debbugs.gnu.org/9781 ."
 +  (skip-unless (executable-find vc-bzr-program))
 +  (let* ((homedir (make-temp-file "vc-bzr-test" t))
 +         (bzrdir (expand-file-name "bzr" homedir))
 +         (subdir (progn
 +                   (make-directory bzrdir)
 +                   (expand-file-name "subdir" bzrdir)))
 +         (file (expand-file-name "file" bzrdir))
 +         (default-directory (file-name-as-directory bzrdir))
 +         (process-environment (cons (format "BZR_HOME=%s" homedir)
 +                                    process-environment)))
 +    (unwind-protect
 +        (progn
 +          (call-process vc-bzr-program nil nil nil "init")
 +          (make-directory subdir)
 +          (with-temp-buffer
 +            (insert "text")
 +            (write-region nil nil file nil 'silent)
 +            (write-region nil nil (expand-file-name "subfile" subdir)
 +                          nil 'silent))
 +          (call-process vc-bzr-program nil nil nil "add")
 +          (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
 +          (call-process vc-bzr-program nil nil nil "remove" subdir)
 +          (with-temp-buffer
 +            (insert "different text")
 +            (write-region nil nil file nil 'silent))
 +          (vc-dir bzrdir)
 +          (while (vc-dir-busy)
 +            (sit-for 0.1))
 +          (vc-dir-mark-all-files t)
 +          (let ((f (symbol-function 'y-or-n-p)))
 +            (unwind-protect
 +                (progn
 +                  (fset 'y-or-n-p (lambda (prompt) t))
 +                  (vc-next-action nil))
 +              (fset 'y-or-n-p f)))
 +          (should (get-buffer "*vc-log*")))
 +      (delete-directory homedir t))))
 +
 +;; http://lists.gnu.org/archive/html/help-gnu-emacs/2012-04/msg00145.html
 +(ert-deftest vc-bzr-test-faulty-bzr-autoloads ()
 +  "Test we can generate autoloads in a bzr directory when bzr is faulty."
 +  (skip-unless (executable-find vc-bzr-program))
 +  (let* ((homedir (make-temp-file "vc-bzr-test" t))
 +         (bzrdir (expand-file-name "bzr" homedir))
 +         (file (progn
 +                 (make-directory bzrdir)
 +                 (expand-file-name "foo.el" bzrdir)))
 +         (default-directory (file-name-as-directory bzrdir))
 +         (generated-autoload-file (expand-file-name "loaddefs.el" bzrdir))
 +         (process-environment (cons (format "BZR_HOME=%s" homedir)
 +                                    process-environment)))
 +    (unwind-protect
 +        (progn
 +          (call-process vc-bzr-program nil nil nil "init")
 +          (with-temp-buffer
 +            (insert ";;;###autoload
 +\(defun foo () \"foo\" (interactive) (message \"foo!\"))")
 +            (write-region nil nil file nil 'silent))
 +          (call-process vc-bzr-program nil nil nil "add")
 +          (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
 +          ;; Deleting dirstate ensures both that vc-bzr's status heuristic
 +          ;; fails, so it has to call the external bzr status, and
 +          ;; causes bzr status to fail.  This simulates a broken bzr
 +          ;; installation.
 +          (delete-file ".bzr/checkout/dirstate")
 +          (should (progn (update-directory-autoloads default-directory)
 +                         t)))
 +      (delete-directory homedir t))))
 +
 +;;; vc-bzr.el ends here
diff --cc test/lisp/vc/vc-tests.el
index 847e0768da8,00000000000..2faa1436522
mode 100644,000000..100644
--- a/test/lisp/vc/vc-tests.el
+++ b/test/lisp/vc/vc-tests.el
@@@ -1,618 -1,0 +1,618 @@@
 +;;; vc-tests.el --- Tests of different backends of vc.el
 +
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
 +
 +;; Author: Michael Albinus 
 +
 +;; This program is free software: you can redistribute it and/or
 +;; modify it under the terms of the GNU General Public License as
 +;; published by the Free Software Foundation, either version 3 of the
 +;; License, or (at your option) any later version.
 +;;
 +;; This program is distributed in the hope that it will be useful, but
 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +;; General Public License for more details.
 +;;
 +;; You should have received a copy of the GNU General Public License
 +;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
 +
 +;;; Commentary:
 +
 +;; For every supported VC on the machine, different test cases are
 +;; generated automatically.
 +
 +;; Functions to be tested (see Commentary of vc.el).  Mandatory
 +;; functions are marked with `*', optional functions are marked with `-':
 +
 +;; BACKEND PROPERTIES
 +;;
 +;; * revision-granularity                                       DONE
 +
 +;; STATE-QUERYING FUNCTIONS
 +;;
 +;; * registered (file)                                          DONE
 +;; * state (file)                                               DONE
 +;; - dir-status (dir update-function)
 +;; - dir-status-files (dir files default-state update-function)
 +;; - dir-extra-headers (dir)
 +;; - dir-printer (fileinfo)
 +;; - status-fileinfo-extra (file)
 +;; * working-revision (file)                                    DONE
 +;; - latest-on-branch-p (file)
 +;; * checkout-model (files)                                     DONE
 +;; - mode-line-string (file)
 +
 +;; STATE-CHANGING FUNCTIONS
 +;;
 +;; * create-repo (backend)                                      DONE
 +;; * register (files &optional comment)                         DONE
 +;; - responsible-p (file)
 +;; - receive-file (file rev)
 +;; - unregister (file)                                          DONE
 +;; * checkin (files comment)
 +;; * find-revision (file rev buffer)
 +;; * checkout (file &optional rev)
 +;; * revert (file &optional contents-done)
 +;; - rollback (files)
 +;; - merge-file (file rev1 rev2)
 +;; - merge-branch ()
 +;; - merge-news (file)
 +;; - pull (prompt)
 +;; - steal-lock (file &optional revision)
 +;; - modify-change-comment (files rev comment)
 +;; - mark-resolved (files)
 +;; - find-admin-dir (file)
 +
 +;; HISTORY FUNCTIONS
 +;;
 +;; * print-log (files buffer &optional shortlog start-revision limit)
 +;; * log-outgoing (backend remote-location)
 +;; * log-incoming (backend remote-location)
 +;; - log-view-mode ()
 +;; - show-log-entry (revision)
 +;; - comment-history (file)
 +;; - update-changelog (files)
 +;; * diff (files &optional async rev1 rev2 buffer)
 +;; - revision-completion-table (files)
 +;; - annotate-command (file buf &optional rev)
 +;; - annotate-time ()
 +;; - annotate-current-time ()
 +;; - annotate-extract-revision-at-line ()
 +;; - region-history (FILE BUFFER LFROM LTO)
 +;; - region-history-mode ()
 +
 +;; TAG SYSTEM
 +;;
 +;; - create-tag (dir name branchp)
 +;; - retrieve-tag (dir name update)
 +
 +;; MISCELLANEOUS
 +;;
 +;; - make-version-backups-p (file)
 +;; - root (file)
 +;; - ignore (file &optional directory)
 +;; - ignore-completion-table
 +;; - previous-revision (file rev)
 +;; - next-revision (file rev)
 +;; - log-edit-mode ()
 +;; - check-headers ()
 +;; - delete-file (file)
 +;; - rename-file (old new)
 +;; - find-file-hook ()
 +;; - extra-menu ()
 +;; - extra-dir-menu ()
 +;; - conflicted-files (dir)
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'vc)
 +
 +;; The working horses.
 +
 +(defvar vc-test--cleanup-hook nil
 +  "Functions for cleanup at the end of an ert test.
 +Don't set it globally, the functions shall be let-bound.")
 +
 +(defun vc-test--revision-granularity-function (backend)
 +  "Run the `vc-revision-granularity' backend function."
 +  (funcall (intern (downcase (format "vc-%s-revision-granularity" backend)))))
 +
 +(defun vc-test--create-repo-function (backend)
 +  "Run the `vc-create-repo' backend function.
 +For backends which dont support it, it is emulated."
 +
 +  (cond
 +   ((eq backend 'CVS)
 +    (let ((tmp-dir
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +      (make-directory (expand-file-name "module" tmp-dir) 'parents)
 +      (make-directory (expand-file-name "CVSROOT" tmp-dir) 'parents)
 +      (if (not (fboundp 'w32-application-type))
 +          (shell-command-to-string (format "cvs -Q -d:local:%s co module"
 +                                           tmp-dir))
 +        (let ((cvs-prog (executable-find "cvs"))
 +              (tdir tmp-dir))
 +          ;; If CVS executable is an MSYS program, reformat the file
 +          ;; name of TMP-DIR to have the /d/foo/bar form supported by
 +          ;; MSYS programs.  (FIXME: What about Cygwin cvs.exe?)
 +          (if (eq (w32-application-type cvs-prog) 'msys)
 +              (setq tdir
 +                    (concat "/" (substring tmp-dir 0 1) (substring tmp-dir 2))))
 +          (shell-command-to-string (format "cvs -Q -d:local:%s co module"
 +                                           tdir))))
 +      (rename-file "module/CVS" default-directory)
 +      (delete-directory "module" 'recursive)
 +      ;; We must cleanup the "remote" CVS repo as well.
 +      (add-hook 'vc-test--cleanup-hook
 +		`(lambda () (delete-directory ,tmp-dir 'recursive)))))
 +
 +   ((eq backend 'Arch)
 +    (let ((archive-name (format "%s--%s" user-mail-address (random))))
 +      (when (string-match
 +	     "no arch user id set" (shell-command-to-string "tla my-id"))
 +	(shell-command-to-string
 +	 (format "tla my-id \"<%s>\"" user-mail-address)))
 +      (shell-command-to-string
 +       (format "tla make-archive %s %s" archive-name default-directory))
 +      (shell-command-to-string
 +       (format "tla my-default-archive %s" archive-name))))
 +
 +   ((eq backend 'Mtn)
 +    (let ((archive-name "foo.mtn"))
 +      (shell-command-to-string
 +       (format
 +	"mtn db init --db=%s"
 +	(expand-file-name archive-name default-directory)))
 +      (shell-command-to-string
 +       (format "mtn --db=%s --branch=foo setup ." archive-name))))
 +
 +   (t (vc-create-repo backend))))
 +
 +(defun vc-test--create-repo (backend)
 +  "Create a test repository in `default-directory', a temporary directory."
 +
 +  (let ((vc-handled-backends `(,backend))
 +	(default-directory
 +	  (file-name-as-directory
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +	vc-test--cleanup-hook)
 +
 +    (unwind-protect
 +	(progn
 +	  ;; Cleanup.
 +	  (add-hook
 +	   'vc-test--cleanup-hook
 +	   `(lambda () (delete-directory ,default-directory 'recursive)))
 +
 +	  ;; Check the revision granularity.
 +	  (should (memq (vc-test--revision-granularity-function backend)
 +			'(file repository)))
 +
 +	  ;; Create empty repository.
 +	  (make-directory default-directory)
 +	  (should (file-directory-p default-directory))
 +	  (vc-test--create-repo-function backend)
 +	  (should (eq (vc-responsible-backend default-directory) backend)))
 +
 +      ;; Save exit.
 +      (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 +
 +;; Why isn't there `vc-unregister'?
 +(defun vc-test--unregister-function (backend file)
 +  "Run the `vc-unregister' backend function.
 +For backends which dont support it, `vc-not-supported' is signalled."
 +
 +  (let ((symbol (intern (downcase (format "vc-%s-unregister" backend)))))
 +    (if (functionp symbol)
 +	(funcall symbol file)
 +      ;; CVS, SVN, SCCS, SRC and Mtn are not supported.
 +      (signal 'vc-not-supported (list 'unregister backend)))))
 +
 +(defun vc-test--register (backend)
 +  "Register and unregister a file."
 +
 +  (let ((vc-handled-backends `(,backend))
 +	(default-directory
 +	  (file-name-as-directory
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +	vc-test--cleanup-hook)
 +
 +    (unwind-protect
 +	(progn
 +	  ;; Cleanup.
 +	  (add-hook
 +	   'vc-test--cleanup-hook
 +	   `(lambda () (delete-directory ,default-directory 'recursive)))
 +
 +	  ;; Create empty repository.
 +	  (make-directory default-directory)
 +	  (vc-test--create-repo-function backend)
 +
 +	  (let ((tmp-name1 (expand-file-name "foo" default-directory))
 +		(tmp-name2 "bla"))
 +	    ;; Register files.  Check for it.
 +	    (write-region "foo" nil tmp-name1 nil 'nomessage)
 +	    (should (file-exists-p tmp-name1))
 +	    (should-not (vc-registered tmp-name1))
 +	    (write-region "bla" nil tmp-name2 nil 'nomessage)
 +	    (should (file-exists-p tmp-name2))
 +	    (should-not (vc-registered tmp-name2))
 +	    (vc-register (list backend (list tmp-name1 tmp-name2)))
 +	    (should (file-exists-p tmp-name1))
 +	    (should (vc-registered tmp-name1))
 +	    (should (file-exists-p tmp-name2))
 +	    (should (vc-registered tmp-name2))
 +
 +	    ;; Unregister the files.
 +	    (condition-case err
 +		(progn
 +		  (vc-test--unregister-function backend tmp-name1)
 +		  (should-not (vc-registered tmp-name1))
 +		  (vc-test--unregister-function backend tmp-name2)
 +		  (should-not (vc-registered tmp-name2)))
 +	      ;; CVS, SVN, SCCS, SRC and Mtn are not supported.
 +	      (vc-not-supported t))
 +	    ;; The files shall still exist.
 +	    (should (file-exists-p tmp-name1))
 +	    (should (file-exists-p tmp-name2))))
 +
 +      ;; Save exit.
 +      (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 +
 +(defun vc-test--state (backend)
 +  "Check the different states of a file."
 +
 +  (let ((vc-handled-backends `(,backend))
 +	(default-directory
 +	  (file-name-as-directory
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +	vc-test--cleanup-hook)
 +
 +    (unwind-protect
 +	(progn
 +	  ;; Cleanup.
 +	  (add-hook
 +	   'vc-test--cleanup-hook
 +	   `(lambda () (delete-directory ,default-directory 'recursive)))
 +
 +	  ;; Create empty repository.  Check repository state.
 +	  (make-directory default-directory)
 +	  (vc-test--create-repo-function backend)
 +
 +	  ;; nil: Hg Mtn RCS
 +          ;; added: Git
 +          ;; unregistered: CVS SCCS SRC
 +	  ;; up-to-date: Bzr SVN
 +          (message "vc-state1 %s" (vc-state default-directory))
 +	  (should (eq (vc-state default-directory)
 +		      (vc-state default-directory backend)))
 +	  (should (memq (vc-state default-directory)
 +			'(nil added unregistered up-to-date)))
 +
 +	  (let ((tmp-name (expand-file-name "foo" default-directory)))
 +	    ;; Check state of an empty file.
 +
 +	    ;; nil: Hg Mtn SRC SVN
 +            ;; added: Git
 +	    ;; unregistered: RCS SCCS
 +	    ;; up-to-date: Bzr CVS
 +            (message "vc-state2 %s" (vc-state tmp-name))
 +	    (should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
 +	    (should (memq (vc-state tmp-name)
 +			  '(nil added unregistered up-to-date)))
 +
 +	    ;; Write a new file.  Check state.
 +	    (write-region "foo" nil tmp-name nil 'nomessage)
 +
 +            ;; nil: Mtn
 +            ;; added: Git
 +            ;; unregistered: Hg RCS SCCS SRC SVN
 +            ;; up-to-date: Bzr CVS
 +            (message "vc-state3 %s" (vc-state tmp-name))
 +	    (should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
 +	    (should (memq (vc-state tmp-name)
 +			  '(nil added unregistered up-to-date)))
 +
 +	    ;; Register a file.  Check state.
 +	    (vc-register
 +	     (list backend (list (file-name-nondirectory tmp-name))))
 +
 +            ;; added: Git Mtn
 +            ;; unregistered: Hg RCS SCCS SRC SVN
 +            ;; up-to-date: Bzr CVS
 +            (message "vc-state4 %s" (vc-state tmp-name))
 +	    (should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
 +	    (should (memq (vc-state tmp-name) '(added unregistered up-to-date)))
 +
 +	    ;; Unregister the file.  Check state.
 +	    (condition-case nil
 +		(progn
 +		  (vc-test--unregister-function backend tmp-name)
 +
 +		  ;; added: Git
 +		  ;; unregistered: Hg RCS
 +		  ;; unsupported: CVS Mtn SCCS SRC SVN
 +		  ;; up-to-date: Bzr
 +                  (message "vc-state5 %s" (vc-state tmp-name))
 +		  (should (eq (vc-state tmp-name) (vc-state tmp-name backend)))
 +		  (should (memq (vc-state tmp-name)
 +				'(added unregistered up-to-date))))
 +	      (vc-not-supported (message "vc-state5 unsupported")))))
 +
 +      ;; Save exit.
 +      (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 +
 +(defun vc-test--working-revision (backend)
 +  "Check the working revision of a repository."
 +
 +  (let ((vc-handled-backends `(,backend))
 +	(default-directory
 +	  (file-name-as-directory
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +	vc-test--cleanup-hook)
 +
 +    (unwind-protect
 +	(progn
 +	  ;; Cleanup.
 +	  (add-hook
 +	   'vc-test--cleanup-hook
 +	   `(lambda () (delete-directory ,default-directory 'recursive)))
 +
 +	  ;; Create empty repository.  Check working revision of
 +	  ;; repository, should be nil.
 +	  (make-directory default-directory)
 +	  (vc-test--create-repo-function backend)
 +
 +	  ;; nil: CVS Git Mtn RCS SCCS
 +	  ;; "0": Bzr Hg SRC SVN
 +          (message
 +           "vc-working-revision1 %s" (vc-working-revision default-directory))
 +	  (should (eq (vc-working-revision default-directory)
 +		      (vc-working-revision default-directory backend)))
 +	  (should (member (vc-working-revision default-directory) '(nil "0")))
 +
 +	  (let ((tmp-name (expand-file-name "foo" default-directory)))
 +	    ;; Check initial working revision, should be nil until
 +            ;; it's registered.
 +
 +	    ;; nil: CVS Git Mtn RCS SCCS SVN
 +	    ;; "0": Bzr Hg SRC
 +            (message "vc-working-revision2 %s" (vc-working-revision tmp-name))
 +	    (should (eq (vc-working-revision tmp-name)
 +			(vc-working-revision tmp-name backend)))
 +	    (should (member (vc-working-revision tmp-name) '(nil "0")))
 +
 +	    ;; Write a new file.  Check working revision.
 +	    (write-region "foo" nil tmp-name nil 'nomessage)
 +
 +	    ;; nil: CVS Git Mtn RCS SCCS SVN
 +	    ;; "0": Bzr Hg SRC
 +            (message "vc-working-revision3 %s" (vc-working-revision tmp-name))
 +	    (should (eq (vc-working-revision tmp-name)
 +			(vc-working-revision tmp-name backend)))
 +	    (should (member (vc-working-revision tmp-name) '(nil "0")))
 +
 +	    ;; Register a file.  Check working revision.
 +	    (vc-register
 +	     (list backend (list (file-name-nondirectory tmp-name))))
 +
 +	    ;; nil: Mtn Git RCS SCCS
 +	    ;; "0": Bzr CVS Hg SRC SVN
 +            (message "vc-working-revision4 %s" (vc-working-revision tmp-name))
 +	    (should (eq (vc-working-revision tmp-name)
 +			(vc-working-revision tmp-name backend)))
 +	    (should (member (vc-working-revision tmp-name) '(nil "0")))
 +
 +	    ;; Unregister the file.  Check working revision.
 +	    (condition-case nil
 +		(progn
 +		  (vc-test--unregister-function backend tmp-name)
 +
 +		  ;; nil: Git RCS
 +		  ;; "0": Bzr Hg
 +		  ;; unsupported: CVS Mtn SCCS SRC SVN
 +                  (message
 +                   "vc-working-revision5 %s" (vc-working-revision tmp-name))
 +		  (should (eq (vc-working-revision tmp-name)
 +			      (vc-working-revision tmp-name backend)))
 +		  (should (member (vc-working-revision tmp-name) '(nil "0"))))
 +	      (vc-not-supported (message "vc-working-revision5 unsupported")))))
 +
 +      ;; Save exit.
 +      (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 +
 +(defun vc-test--checkout-model (backend)
 +  "Check the checkout model of a repository."
 +
 +  (let ((vc-handled-backends `(,backend))
 +	(default-directory
 +	  (file-name-as-directory
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +	vc-test--cleanup-hook)
 +
 +    (unwind-protect
 +	(progn
 +	  ;; Cleanup.
 +	  (add-hook
 +	   'vc-test--cleanup-hook
 +	   `(lambda () (delete-directory ,default-directory 'recursive)))
 +
 +	  ;; Create empty repository.  Check repository checkout model.
 +	  (make-directory default-directory)
 +	  (vc-test--create-repo-function backend)
 +
 +	  ;; Surprisingly, none of the backends returns 'announce.
 +	  ;; nil: RCS
 +          ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 +          ;; locking: SCCS
 +          (message
 +           "vc-checkout-model1 %s"
 +           (vc-checkout-model backend default-directory))
 +          (should (memq (vc-checkout-model backend default-directory)
 +			'(announce implicit locking)))
 +
 +	  (let ((tmp-name (expand-file-name "foo" default-directory)))
 +	    ;; Check checkout model of an empty file.
 +
 +	    ;; nil: RCS
 +	    ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 +	    ;; locking: SCCS
 +            (message
 +             "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name))
 +	    (should (memq (vc-checkout-model backend tmp-name)
 +			  '(announce implicit locking)))
 +
 +	    ;; Write a new file.  Check checkout model.
 +	    (write-region "foo" nil tmp-name nil 'nomessage)
 +
 +	    ;; nil: RCS
 +	    ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 +	    ;; locking: SCCS
 +            (message
 +             "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name))
 +	    (should (memq (vc-checkout-model backend tmp-name)
 +			  '(announce implicit locking)))
 +
 +	    ;; Register a file.  Check checkout model.
 +	    (vc-register
 +	     (list backend (list (file-name-nondirectory tmp-name))))
 +
 +	    ;; nil: RCS
 +	    ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 +	    ;; locking: SCCS
 +            (message
 +             "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name))
 +	    (should (memq (vc-checkout-model backend tmp-name)
 +			  '(announce implicit locking)))
 +
 +	    ;; Unregister the file.  Check checkout model.
 +	    (condition-case nil
 +		(progn
 +		  (vc-test--unregister-function backend tmp-name)
 +
 +		  ;; nil: RCS
 +		  ;; implicit: Bzr Git Hg
 +		  ;; unsupported: CVS Mtn SCCS SRC SVN
 +                  (message
 +                   "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name))
 +		  (should (memq (vc-checkout-model backend tmp-name)
 +				'(announce implicit locking))))
 +	      (vc-not-supported (message "vc-checkout-model5 unsupported")))))
 +
 +      ;; Save exit.
 +      (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 +
 +;; Create the test cases.
 +
 +(defun vc-test--rcs-enabled ()
 +  (executable-find "rcs"))
 +
 +(defun vc-test--cvs-enabled ()
 +  (executable-find "cvs"))
 +
 +(defvar vc-svn-program)
 +(defun vc-test--svn-enabled ()
 +  (executable-find vc-svn-program))
 +
 +(defun vc-test--sccs-enabled ()
 +  (executable-find "sccs"))
 +
 +(defvar vc-src-program)
 +(defun vc-test--src-enabled ()
 +  (executable-find vc-src-program))
 +
 +(defvar vc-bzr-program)
 +(defun vc-test--bzr-enabled ()
 +  (executable-find vc-bzr-program))
 +
 +(defvar vc-git-program)
 +(defun vc-test--git-enabled ()
 +  (executable-find vc-git-program))
 +
 +(defvar vc-hg-program)
 +(defun vc-test--hg-enabled ()
 +  (executable-find vc-hg-program))
 +
 +(defvar vc-mtn-program)
 +(defun vc-test--mtn-enabled ()
 +  (executable-find vc-mtn-program))
 +
 +;; Obsoleted.
 +(defvar vc-arch-program)
 +(defun vc-test--arch-enabled ()
 +  (executable-find vc-arch-program))
 +
 +;; Create the test cases.
 +(dolist (backend vc-handled-backends)
 +  (let ((backend-string (downcase (symbol-name backend))))
 +    (require (intern (format "vc-%s" backend-string)))
 +    (eval
 +     ;; Check, whether the backend is supported.
 +     `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string)))
 +
 +	(ert-deftest
 +	    ,(intern (format "vc-test-%s00-create-repo" backend-string)) ()
 +	  ,(format "Check `vc-create-repo' for the %s backend."
 +		   backend-string)
 +	  (vc-test--create-repo ',backend))
 +
 +	(ert-deftest
 +	    ,(intern (format "vc-test-%s01-register" backend-string)) ()
 +	  ,(format
 +	    "Check `vc-register' and `vc-registered' for the %s backend."
 +	    backend-string)
 +	  (skip-unless
 +	   (ert-test-passed-p
 +	    (ert-test-most-recent-result
 +	     (ert-get-test
 +	      ',(intern
 +		 (format "vc-test-%s00-create-repo" backend-string))))))
 +	  (vc-test--register ',backend))
 +
 +	(ert-deftest
 +	    ,(intern (format "vc-test-%s02-state" backend-string)) ()
 +	  ,(format "Check `vc-state' for the %s backend." backend-string)
 +	  (skip-unless
 +	   (ert-test-passed-p
 +	    (ert-test-most-recent-result
 +	     (ert-get-test
 +	      ',(intern
 +		 (format "vc-test-%s01-register" backend-string))))))
 +	  (vc-test--state ',backend))
 +
 +	(ert-deftest
 +	    ,(intern (format "vc-test-%s03-working-revision" backend-string)) ()
 +	  ,(format "Check `vc-working-revision' for the %s backend."
 +		   backend-string)
 +	  (skip-unless
 +	   (ert-test-passed-p
 +	    (ert-test-most-recent-result
 +	     (ert-get-test
 +	      ',(intern
 +		 (format "vc-test-%s01-register" backend-string))))))
 +	  (vc-test--working-revision ',backend))
 +
 +	(ert-deftest
 +	    ,(intern (format "vc-test-%s04-checkout-model" backend-string)) ()
 +	  ,(format "Check `vc-checkout-model' for the %s backend."
 +		   backend-string)
 +	  ;; FIXME make this pass.
 +	  :expected-result ,(if (equal backend 'RCS) :failed :passed)
 +	  (skip-unless
 +	   (ert-test-passed-p
 +	    (ert-test-most-recent-result
 +	     (ert-get-test
 +	      ',(intern
 +		 (format "vc-test-%s01-register" backend-string))))))
 +	  (vc-test--checkout-model ',backend))))))
 +
 +(provide 'vc-tests)
 +;;; vc-tests.el ends here
diff --cc test/lisp/xml-tests.el
index 95eb2865afc,00000000000..763febb9b69
mode 100644,000000..100644
--- a/test/lisp/xml-tests.el
+++ b/test/lisp/xml-tests.el
@@@ -1,136 -1,0 +1,136 @@@
 +;;; xml-parse-tests.el --- Test suite for XML parsing.
 +
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
 +
 +;; Author: Chong Yidong 
 +;; Keywords:       internal
 +;; Human-Keywords: internal
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Type M-x test-xml-parse RET to generate the test buffer.
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'xml)
 +
 +(defvar xml-parse-tests--data
 +  `(;; General entity substitution
 +    ("]>&ent;;" .
 +     ((foo ((a . "b")) (bar nil "AbC;"))))
 +    ("&amp;&apos;'<>"" .
 +     ((foo () "&''<>\"")))
 +    ;; Parameter entity substitution
 +    ("]>&ent;;" .
 +     ((foo ((a . "b")) (bar nil "AbC;"))))
 +    ;; Tricky parameter entity substitution (like XML spec Appendix D)
 +    ("' > %xx; ]>A&ent;C" .
 +     ((foo () "AbC")))
 +    ;; Bug#7172
 +    (" ]>" .
 +     ((foo ())))
 +    ;; Entities referencing entities, in character data
 +    ("]>&abc;" .
 +     ((foo () "aBc")))
 +    ;; Entities referencing entities, in attribute values
 +    ("]>1" .
 +     ((foo ((a . "-aBc-")) "1")))
 +    ;; Character references must be treated as character data
 +    ("AT&T;" . ((foo () "AT&T;")))
 +    ("&amp;" . ((foo () "&")))
 +    ("&amp;" . ((foo () "&")))
 +    ;; Unusual but valid XML names [5]
 +    ("<ÀÖØö.3·-‿⁀󯿿>abc" . ((,(intern "ÀÖØö.3·-‿⁀󯿿") () "abc")))
 +    ("<:>abc" . ((,(intern ":") () "abc"))))
 +  "Alist of XML strings and their expected parse trees.")
 +
 +(defvar xml-parse-tests--bad-data
 +  '(;; XML bomb in content
 +    "]>&lol2;"
 +    ;; XML bomb in attribute value
 +    "]>!"
 +    ;; Non-terminating DTD
 +    ""
 +    "asdf"
 +    "asdf&abc;"
 +    ;; Invalid XML names
 +    "<0foo>abc"
 +    "<‿foo>abc"
 +    "abc")
 +  "List of XML strings that should signal an error in the parser")
 +
 +(defvar xml-parse-tests--qnames
 +  '( ;; Test data for name expansion
 +    ("/calendar/events/HTTP/1.1 200 OK"
 +    ;; Result with qnames as cons
 +    ((("DAV:" . "multistatus")
 +      ((("http://www.w3.org/2000/xmlns/" . "D") . "DAV:"))
 +      (("DAV:" . "response") nil (("DAV:" . "href") nil "/calendar/events/")
 +       (("DAV:" . "propstat") nil (("DAV:" . "status") nil "HTTP/1.1 200 OK")))))
 +    ;; Result with qnames as symbols
 +    ((DAV:multistatus
 +      ((("http://www.w3.org/2000/xmlns/" . "D") . "DAV:"))
 +      (DAV:response nil (DAV:href nil "/calendar/events/")
 +		    (DAV:propstat nil (DAV:status nil "HTTP/1.1 200 OK"))))))
 +    ("hi there"
 +     ((("FOOBAR:" . "something") nil "hi there"))
 +     ((FOOBAR:something nil "hi there"))))
 +  "List of strings which are parsed using namespace expansion.
 +Parser is called with and without 'symbol-qnames argument.")
 +
 +(ert-deftest xml-parse-tests ()
 +  "Test XML parsing."
 +  (with-temp-buffer
 +    (dolist (test xml-parse-tests--data)
 +      (erase-buffer)
 +      (insert (car test))
 +      (should (equal (cdr test) (xml-parse-region))))
 +    (let ((xml-entity-expansion-limit 50))
 +      (dolist (test xml-parse-tests--bad-data)
 +	(erase-buffer)
 +	(insert test)
 +	(should-error (xml-parse-region))))
 +    (let ((testdata (car xml-parse-tests--qnames)))
 +      (erase-buffer)
 +      (insert (car testdata))
 +      (should (equal (nth 1 testdata)
 +		     (xml-parse-region nil nil nil nil t)))
 +      (should (equal (nth 2 testdata)
 +		     (xml-parse-region nil nil nil nil 'symbol-qnames))))
 +    (let ((testdata (nth 1 xml-parse-tests--qnames)))
 +      (erase-buffer)
 +      (insert (car testdata))
 +      ;; Provide additional namespace-URI mapping
 +      (should (equal (nth 1 testdata)
 +		     (xml-parse-region
 +		      nil nil nil nil
 +		      (append xml-default-ns
 +			      '(("F" . "FOOBAR:"))))))
 +      (should (equal (nth 2 testdata)
 +		     (xml-parse-region
 +		      nil nil nil nil
 +		      (cons 'symbol-qnames
 +			    (append xml-default-ns
 +				    '(("F" . "FOOBAR:"))))))))))
 +
 +;; Local Variables:
 +;; no-byte-compile: t
 +;; End:
 +
 +;;; xml-parse-tests.el ends here.
diff --cc test/manual/biditest.el
index e2212083830,00000000000..3545c50734f
mode 100644,000000..100644
--- a/test/manual/biditest.el
+++ b/test/manual/biditest.el
@@@ -1,121 -1,0 +1,121 @@@
 +;;; biditest.el --- test bidi reordering in GNU Emacs display engine.
 +
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
 +
 +;; Author: Eli Zaretskii
 +;; Maintainer: emacs-devel@gnu.org
 +;; Package: emacs
 +
 +;; This program is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; This program is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Produce a specially-formatted text file from BidiCharacterTest.txt
 +;; file that is part of the Unicode Standard's UCD package.  The file
 +;; shows the expected results of reordering according to the UBA.  The
 +;; file is supposed to be visited in Emacs, and the resulting display
 +;; compared with the expected one.
 +
 +;;; Code:
 +
 +(defun biditest-generate-testfile (input-file output-file)
 +  "Generate a bidi test file OUTPUT-FILE from data in INPUT-FILE.
 +
 +INPUT-FILE should be in the format of the BidiCharacterTest.txt file
 +available from the Unicode site, as part of the UCD database, see
 +http://www.unicode.org/Public/UCD/latest/ucd/BidiCharacterTest.txt.
 +
 +The resulting file should be viewed with `inhibit-bidi-mirroring' set to t."
 +  (let ((output-buf (get-buffer-create "*biditest-output*"))
 +	(lnum 1)
 +	tbuf)
 +    (with-temp-buffer
 +      (message "Generating output in %s ..." output-file)
 +      (setq tbuf (current-buffer))
 +      (insert-file-contents input-file)
 +      (goto-char (point-min))
 +      (while (not (eobp))
 +	(when (looking-at "^\\([0-9A-F ]+\\);\\([012]\\);\\([01]\\);\\([0-9 ]+\\);\\([0-9 ]+\\)$")
 +	  (let ((codes (match-string 1))
 +		(default-paragraph (match-string 2))
 +		(resolved-paragraph (match-string 3))
 +		;; FIXME: Should compare LEVELS with what the display
 +		;; engine actually produced.
 +		(levels (match-string 4))
 +		(indices (match-string 5)))
 +	    (setq codes (split-string codes " ")
 +		  indices (split-string indices " "))
 +	    (switch-to-buffer output-buf)
 +	    (insert (format "Test on line %d:\n\n" lnum))
 +	    ;; Force paragraph direction to what the UCD test
 +	    ;; specifies.
 +	    (insert (cond
 +		     ((string= default-paragraph "0") ;L2R
 +		      #x200e)
 +		     ((string= default-paragraph "1") ;R2L
 +		      #x200f)
 +		     (t "")))	; dynamic
 +	    ;; Insert the characters
 +	    (mapc (lambda (code)
 +		    (insert (string-to-number code 16)))
 +		  codes)
 +	    (insert "\n\n")
 +	    ;; Insert the expected results
 +	    (insert "Expected result:\n\n")
 +	    ;; We want the expected results displayed exactly as
 +	    ;; specified in the test file, without any reordering, so
 +	    ;; we override the directional properties of all of the
 +	    ;; characters in the expected result by prepending
 +	    ;; LRO/RLO.
 +	    (cond ((string= resolved-paragraph "0")
 +		   (insert #x200e #x202d))
 +		  ((string= resolved-paragraph "1")
 +		   (insert #x200f #x202e)
 +		   ;; We need to reverse the list of indices for R2L
 +		   ;; paragraphs, so that their logical order on
 +		   ;; display matches user expectations.
 +		   (setq indices (nreverse indices))))
 +	    (mapc (lambda (index)
 +		    (insert (string-to-number
 +			     (nth (string-to-number index 10) codes)
 +			     16)))
 +		  indices)
 +	    (insert #x202c)	; end the embedding
 +	    (insert "\n\n"))
 +	  (switch-to-buffer tbuf))
 +	(forward-line 1)
 +	(setq lnum (1+ lnum)))
 +      (switch-to-buffer output-buf)
 +      (let ((coding-system-for-write 'utf-8-unix))
 +	(write-file output-file))
 +      (message "Generating output in %s ... done" output-file))))
 +
 +(defun biditest-create-test ()
 +  "Create a test file for testing the Emacs bidirectional display.
 +
 +The resulting file should be viewed with `inhibit-bidi-mirroring' set to t."
 +  (biditest-generate-testfile (pop command-line-args-left)
 +			      (or (pop command-line-args-left)
 +				  "biditest.txt")))
 +
 +;; A handy function for displaying the resolved bidi levels.
 +(defun bidi-levels ()
 +  "Display the resolved bidirectional levels of characters on current line.
 +
 +The results can be compared with the levels stated in the
 +BidiCharacterTest.txt file."
 +  (interactive)
 +  (message "%s" (bidi-resolved-levels)))
 +
 +(define-key global-map [f8] 'bidi-levels)
diff --cc test/manual/cedet/cedet-utests.el
index 76903639c3a,00000000000..ae9d576f0f5
mode 100644,000000..100644
--- a/test/manual/cedet/cedet-utests.el
+++ b/test/manual/cedet/cedet-utests.el
@@@ -1,515 -1,0 +1,515 @@@
 +;;; cedet-utests.el --- Run all unit tests in the CEDET suite.
 +
- ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +;;
 +;; Remembering to run all the unit tests available in CEDET one at a
 +;; time is a bit time consuming.  This links all the tests together
 +;; into one command.
 +
 +(require 'cedet)
 +;;; Code:
 +(defvar cedet-utest-test-alist
 +  '(
 +    ;;
 +    ;; COMMON
 +    ;;
 +
 +    ;; Test inversion
 +    ("inversion" . inversion-unit-test)
 +
 +    ;; EZ Image dumping.
 +    ("ezimage associations" . ezimage-image-association-dump)
 +    ("ezimage images" . ezimage-image-dump)
 +
 +    ;; Pulse
 +    ("pulse interactive test" . (lambda () (pulse-test t)))
 +
 +    ;; Files
 +    ("cedet file conversion" . cedet-files-utest)
 +
 +    ;;
 +    ;; EIEIO
 +    ;;
 +    ("eieio" . (lambda () (let ((lib (locate-library "eieio-tests.el"
 +						     t)))
 +			    (load-file lib))))
 +    ("eieio: browser" . eieio-browse)
 +    ("eieio: custom" . (lambda ()
 +			 (require 'eieio-custom)
 +			 (customize-variable 'eieio-widget-test)))
 +    ("eieio: chart" . (lambda ()
 +			(if (cedet-utest-noninteractive)
 +			    (message " ** Skipping test in noninteractive mode.")
 +			  (chart-test-it-all))))
 +    ;;
 +    ;; EDE
 +    ;;
 +
 +    ;; @todo - Currently handled in the integration tests.  Need
 +    ;;         some simpler unit tests here.
 +
 +    ;;
 +    ;; SEMANTIC
 +    ;;
 +    ("semantic: lex spp table write" . semantic-lex-spp-write-utest)
 +    ("semantic: multi-lang parsing" . semantic-utest-main)
 +    ("semantic: C preprocessor" . semantic-utest-c)
 +    ("semantic: analyzer tests" . semantic-ia-utest)
 +    ("semanticdb: data cache" . semantic-test-data-cache)
 +    ("semantic: throw-on-input" .
 +     (lambda ()
 +       (if (cedet-utest-noninteractive)
 +	   (message " ** Skipping test in noninteractive mode.")
 +	 (semantic-test-throw-on-input))))
 +
 +    ("semantic: gcc: output parse test" . semantic-gcc-test-output-parser)
 +    ;;
 +    ;; SRECODE
 +    ;;
 +    ("srecode: fields" . srecode-field-utest)
 +    ("srecode: templates" . srecode-utest-template-output)
 +    ("srecode: show maps" . srecode-get-maps)
 +    ("srecode: getset" . srecode-utest-getset-output)
 +   )
 +  "Alist of all the tests in CEDET we should run.")
 +
 +(defvar cedet-running-master-tests nil
 +  "Non-nil when CEDET-utest is running all the tests.")
 +
 +(defun cedet-utest (&optional exit-on-error)
 +  "Run the CEDET unit tests.
 +EXIT-ON-ERROR causes the test suite to exit on an error, instead
 +of just logging the error."
 +  (interactive)
 +  (if (or (not (featurep 'semanticdb-mode))
 +	  (not (semanticdb-minor-mode-p)))
 +      (error "CEDET Tests require: M-x semantic-load-enable-minimum-features"))
 +  (cedet-utest-log-setup "ALL TESTS")
 +  (let ((tl cedet-utest-test-alist)
 +	(notes nil)
 +	(err nil)
 +	(start (current-time))
 +	(end nil)
 +	(cedet-running-master-tests t)
 +	)
 +    (dolist (T tl)
 +      (cedet-utest-add-log-item-start (car T))
 +      (setq notes nil err nil)
 +      (condition-case Cerr
 +	  (progn
 +	    (funcall (cdr T))
 +	    )
 +	(error
 +	 (setq err (format "ERROR: %S" Cerr))
 +	 ;;(message "Error caught: %s" Cerr)
 +	 ))
 +
 +      ;; Cleanup stray input and events that are in the way.
 +      ;; Not doing this causes sit-for to not refresh the screen.
 +      ;; Doing this causes the user to need to press keys more frequently.
 +      (when (and (interactive-p) (input-pending-p))
 +	(if (fboundp 'read-event)
 +	    (read-event)
 +	  (read-char)))
 +
 +      (cedet-utest-add-log-item-done notes err)
 +      (when (and exit-on-error err)
 +	(message "to debug this test point, execute:")
 +	(message "%S" (cdr T))
 +	(message "\n ** Exiting Test Suite. ** \n")
 +	(throw 'cedet-utest-exit-on-error t)
 +	)
 +      )
 +    (setq end (current-time))
 +    (cedet-utest-log-shutdown-msg "ALL TESTS" start end)
 +    nil))
 +
 +(defun cedet-utest-noninteractive ()
 +  "Return non-nil if running non-interactively."
 +  (if (featurep 'xemacs)
 +      (noninteractive)
 +    noninteractive))
 +
 +;;;###autoload
 +(defun cedet-utest-batch ()
 +  "Run the CEDET unit test in BATCH mode."
 +  (unless (cedet-utest-noninteractive)
 +    (error "`cedet-utest-batch' is to be used only with -batch"))
 +  (condition-case err
 +      (when (catch 'cedet-utest-exit-on-error
 +	      ;; Get basic semantic features up.
 +	      (semantic-load-enable-minimum-features)
 +	      ;; Disables all caches related to semantic DB so all
 +	      ;; tests run as if we have bootstrapped CEDET for the
 +	      ;; first time.
 +	      (setq-default semanticdb-new-database-class 'semanticdb-project-database)
 +	      (message "Disabling existing Semantic Database Caches.")
 +
 +	      ;; Disabling the srecoder map, we won't load a pre-existing one
 +	      ;; and will be forced to bootstrap a new one.
 +	      (setq srecode-map-save-file nil)
 +
 +	      ;; Run the tests
 +	      (cedet-utest t)
 +	      )
 +	(kill-emacs 1))
 +    (error
 +     (error "Error in unit test harness:\n  %S" err))
 +    )
 +  )
 +
 +;;; Logging utility.
 +;;
 +(defvar cedet-utest-frame nil
 +  "Frame used during cedet unit test logging.")
 +(defvar cedet-utest-buffer nil
 +  "Frame used during cedet unit test logging.")
 +(defvar cedet-utest-frame-parameters
 +  '((name . "CEDET-UTEST")
 +    (width . 80)
 +    (height . 25)
 +    (minibuffer . t))
 +  "Frame parameters used for the cedet utest log frame.")
 +
 +(defvar cedet-utest-last-log-item nil
 +  "Remember the last item we were logging for.")
 +
 +(defvar cedet-utest-log-timer nil
 +  "During a test, track the start time.")
 +
 +(defun cedet-utest-log-setup (&optional title)
 +  "Setup a frame and buffer for unit testing.
 +Optional argument TITLE is the title of this testing session."
 +  (setq cedet-utest-log-timer (current-time))
 +  (if (cedet-utest-noninteractive)
 +      (message "\n>> Setting up %s tests to run @ %s\n"
 +	       (or title "")
 +	       (current-time-string))
 +
 +    ;; Interactive mode needs a frame and buffer.
 +    (when (or (not cedet-utest-frame) (not (frame-live-p cedet-utest-frame)))
 +      (setq cedet-utest-frame (make-frame cedet-utest-frame-parameters)))
 +    (when (or (not cedet-utest-buffer) (not (buffer-live-p cedet-utest-buffer)))
 +      (setq cedet-utest-buffer (get-buffer-create "*CEDET utest log*")))
 +    (save-excursion
 +      (set-buffer cedet-utest-buffer)
 +      (setq cedet-utest-last-log-item nil)
 +      (when (not cedet-running-master-tests)
 +	(erase-buffer))
 +      (insert "\n\nSetting up "
 +	      (or title "")
 +	      " tests to run @ " (current-time-string) "\n\n"))
 +    (let ((oframe (selected-frame)))
 +      (unwind-protect
 +	  (progn
 +	    (select-frame cedet-utest-frame)
 +	    (switch-to-buffer cedet-utest-buffer t))
 +	(select-frame oframe)))
 +    ))
 +
 +(defun cedet-utest-elapsed-time (start end)
 +  "Copied from elp.el.  Was elp-elapsed-time.
 +Argument START and END bound the time being calculated."
 +  (+ (* (- (car end) (car start)) 65536.0)
 +     (- (car (cdr end)) (car (cdr start)))
 +     (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0)))
 +
 +(defun cedet-utest-log-shutdown (title &optional errorcondition)
 +  "Shut-down a larger test suite.
 +TITLE is the section that is done.
 +ERRORCONDITION is some error that may have occurred during testing."
 +  (let ((endtime (current-time))
 +	)
 +    (cedet-utest-log-shutdown-msg title cedet-utest-log-timer endtime)
 +    (setq cedet-utest-log-timer nil)
 +    ))
 +
 +(defun cedet-utest-log-shutdown-msg (title startime endtime)
 +  "Show a shutdown message with TITLE, STARTIME, and ENDTIME."
 +  (if (cedet-utest-noninteractive)
 +      (progn
 +	(message "\n>> Test Suite %s ended at @ %s"
 +		 title
 +		 (format-time-string "%c" endtime))
 +	(message "     Elapsed Time %.2f Seconds\n"
 +		 (cedet-utest-elapsed-time startime endtime)))
 +
 +    (save-excursion
 +      (set-buffer cedet-utest-buffer)
 +      (goto-char (point-max))
 +      (insert "\n>> Test Suite " title " ended at @ "
 +	      (format-time-string "%c" endtime) "\n"
 +	      "     Elapsed Time "
 +	      (number-to-string
 +	       (cedet-utest-elapsed-time startime endtime))
 +	      " Seconds\n * "))
 +    ))
 +
 +(defun cedet-utest-show-log-end ()
 +  "Show the end of the current unit test log."
 +  (unless (cedet-utest-noninteractive)
 +    (let* ((cb (current-buffer))
 +	   (cf (selected-frame))
 +	   (bw (or (get-buffer-window cedet-utest-buffer t)
 +		   (get-buffer-window (switch-to-buffer cedet-utest-buffer) t)))
 +	   (lf (window-frame bw))
 +	   )
 +      (select-frame lf)
 +      (select-window bw)
 +      (goto-char (point-max))
 +      (select-frame cf)
 +      (set-buffer cb)
 +      )))
 +
 +(defun cedet-utest-post-command-hook ()
 +  "Hook run after the current log command was run."
 +    (if (cedet-utest-noninteractive)
 +	(message "")
 +      (save-excursion
 +	(set-buffer cedet-utest-buffer)
 +	(goto-char (point-max))
 +	(insert "\n\n")))
 +    (setq cedet-utest-last-log-item nil)
 +    (remove-hook 'post-command-hook 'cedet-utest-post-command-hook)
 +    )
 +
 +(defun cedet-utest-add-log-item-start (item)
 +  "Add ITEM into the log as being started."
 +  (unless (equal item cedet-utest-last-log-item)
 +    (setq cedet-utest-last-log-item item)
 +    ;; This next line makes sure we clear out status during logging.
 +    (add-hook 'post-command-hook 'cedet-utest-post-command-hook)
 +
 +    (if (cedet-utest-noninteractive)
 +	(message " - Running %s ..." item)
 +      (save-excursion
 +	(set-buffer cedet-utest-buffer)
 +	(goto-char (point-max))
 +	(when (not (bolp)) (insert "\n"))
 +	(insert "Running " item " ... ")
 +	(sit-for 0)
 +	))
 +    (cedet-utest-show-log-end)
 +    ))
 +
 +(defun cedet-utest-add-log-item-done (&optional notes err precr)
 +  "Add into the log that the last item is done.
 +Apply NOTES to the doneness of the log.
 +Apply ERR if there was an error in previous item.
 +Optional argument PRECR indicates to prefix the done msg w/ a newline."
 +  (if (cedet-utest-noninteractive)
 +      ;; Non-interactive-mode - show a message.
 +      (if notes
 +	  (message "   * %s {%s}" (or err "done") notes)
 +	(message "   * %s" (or err "done")))
 +    ;; Interactive-mode - insert into the buffer.
 +    (save-excursion
 +      (set-buffer cedet-utest-buffer)
 +      (goto-char (point-max))
 +      (when precr (insert "\n"))
 +      (if err
 +	  (insert err)
 +	(insert "done")
 +	(when notes (insert " (" notes ")")))
 +      (insert "\n")
 +      (setq cedet-utest-last-log-item nil)
 +      (sit-for 0)
 +      )))
 +
 +;;; INDIVIDUAL TEST API
 +;;
 +;; Use these APIs to start and log information.
 +;;
 +;; The other fcns will be used to log across all the tests at once.
 +(defun cedet-utest-log-start (testname)
 +  "Setup the log for the test TESTNAME."
 +  ;; Make sure we have a log buffer.
 +  (save-window-excursion
 +    (when (or (not cedet-utest-buffer)
 +	      (not (buffer-live-p cedet-utest-buffer))
 +	      (not (get-buffer-window cedet-utest-buffer t))
 +	      )
 +      (cedet-utest-log-setup))
 +    ;; Add our startup message.
 +    (cedet-utest-add-log-item-start testname)
 +    ))
 +
 +(defun cedet-utest-log(format &rest args)
 +  "Log the text string FORMAT.
 +The rest of the ARGS are used to fill in FORMAT with `format'."
 +  (if (cedet-utest-noninteractive)
 +      (apply 'message format args)
 +    (save-excursion
 +      (set-buffer cedet-utest-buffer)
 +      (goto-char (point-max))
 +      (when (not (bolp)) (insert "\n"))
 +      (insert (apply 'format format args))
 +      (insert "\n")
 +      (sit-for 0)
 +      ))
 +  (cedet-utest-show-log-end)
 +  )
 +
 +;;; Inversion tests
 +
 +(defun inversion-unit-test ()
 +  "Test inversion to make sure it can identify different version strings."
 +  (interactive)
 +  (let ((c1 (inversion-package-version 'inversion))
 +	(c1i (inversion-package-incompatibility-version 'inversion))
 +	(c2 (inversion-decode-version  "1.3alpha2"))
 +	(c3 (inversion-decode-version  "1.3beta4"))
 +	(c4 (inversion-decode-version  "1.3 beta5"))
 +	(c5 (inversion-decode-version  "1.3.4"))
 +	(c6 (inversion-decode-version  "2.3alpha"))
 +	(c7 (inversion-decode-version  "1.3"))
 +	(c8 (inversion-decode-version  "1.3pre1"))
 +	(c9 (inversion-decode-version  "2.4 (patch 2)"))
 +	(c10 (inversion-decode-version "2.4 (patch 3)"))
 +	(c11 (inversion-decode-version "2.4.2.1"))
 +	(c12 (inversion-decode-version "2.4.2.2"))
 +	)
 +    (if (not (and
 +	      (inversion-= c1 c1)
 +	      (inversion-< c1i c1)
 +	      (inversion-< c2 c3)
 +	      (inversion-< c3 c4)
 +	      (inversion-< c4 c5)
 +	      (inversion-< c5 c6)
 +	      (inversion-< c2 c4)
 +	      (inversion-< c2 c5)
 +	      (inversion-< c2 c6)
 +	      (inversion-< c3 c5)
 +	      (inversion-< c3 c6)
 +	      (inversion-< c7 c6)
 +	      (inversion-< c4 c7)
 +	      (inversion-< c2 c7)
 +	      (inversion-< c8 c6)
 +	      (inversion-< c8 c7)
 +	      (inversion-< c4 c8)
 +	      (inversion-< c2 c8)
 +	      (inversion-< c9 c10)
 +	      (inversion-< c10 c11)
 +	      (inversion-< c11 c12)
 +	      ;; Negatives
 +	      (not (inversion-< c3 c2))
 +	      (not (inversion-< c4 c3))
 +	      (not (inversion-< c5 c4))
 +	      (not (inversion-< c6 c5))
 +	      (not (inversion-< c7 c2))
 +	      (not (inversion-< c7 c8))
 +	      (not (inversion-< c12 c11))
 +	      ;; Test the tester on inversion
 +	      (not (inversion-test 'inversion inversion-version))
 +	      ;; Test that we throw an error
 +	      (inversion-test 'inversion "0.0.0")
 +	      (inversion-test 'inversion "1000.0")
 +	      ))
 +	(error "Inversion tests failed")
 +      (message "Inversion tests passed."))))
 +
 +;;; cedet-files unit test
 +
 +(defvar cedet-files-utest-list
 +  '(
 +    ( "/home/me/src/myproj/src/foo.c" . "!home!me!src!myproj!src!foo.c" )
 +    ( "c:/work/myproj/foo.el" . "!drive_c!work!myproj!foo.el" )
 +    ( "//windows/proj/foo.java" . "!!windows!proj!foo.java" )
 +    ( "/home/me/proj!bang/foo.c" . "!home!me!proj!!bang!foo.c" )
 +    )
 +  "List of different file names to test.
 +Each entry is a cons cell of ( FNAME . CONVERTED )
 +where FNAME is some file name, and CONVERTED is what it should be
 +converted into.")
 +
 +(defun cedet-files-utest ()
 +  "Test out some file name conversions."
 +  (interactive)
 +  (let ((idx 0))
 +    (dolist (FT cedet-files-utest-list)
 +
 +      (setq idx (+ idx 1))
 +
 +      (let ((dir->file (cedet-directory-name-to-file-name (car FT) t))
 +	    (file->dir (cedet-file-name-to-directory-name (cdr FT) t))
 +	    )
 +
 +	(unless (string= (cdr FT) dir->file)
 +	  (error "Failed: %d.  Found: %S Wanted: %S"
 +		 idx dir->file (cdr FT))
 +	  )
 +
 +	(unless (string= file->dir (car FT))
 +	  (error "Failed: %d.  Found: %S Wanted: %S"
 +		 idx file->dir (car FT)))))))
 +
 +;;; pulse test
 +
 +(defun pulse-test (&optional no-error)
 +  "Test the lightening function for pulsing a line.
 +When optional NO-ERROR don't throw an error if we can't run tests."
 +  (interactive)
 +  (if (or (not pulse-flag) (not (pulse-available-p)))
 +      (if no-error
 +	  nil
 +	(error (concat "Pulse test only works on versions of Emacs"
 +		       " that support pulsing")))
 +    ;; Run the tests
 +    (when (interactive-p)
 +      (message " Pulse one line.")
 +      (read-char))
 +    (pulse-momentary-highlight-one-line (point))
 +    (when (interactive-p)
 +      (message " Pulse a region.")
 +      (read-char))
 +    (pulse-momentary-highlight-region (point)
 +				      (save-excursion
 +					(condition-case nil
 +					    (forward-char 30)
 +					  (error nil))
 +					(point)))
 +    (when (interactive-p)
 +      (message " Pulse line a specific color.")
 +      (read-char))
 +    (pulse-momentary-highlight-one-line (point) 'modeline)
 +    (when (interactive-p)
 +      (message " Pulse a pre-existing overlay.")
 +      (read-char))
 +    (let* ((start (point-at-bol))
 +	   (end (save-excursion
 +		  (end-of-line)
 +		  (when (not (eobp))
 +		    (forward-char 1))
 +		  (point)))
 +	   (o (make-overlay start end))
 +	   )
 +      (pulse-momentary-highlight-overlay o)
 +      (if (overlay-buffer o)
 +	  (delete-overlay o)
 +	(error "Non-temporary overlay was deleted!"))
 +      )
 +    (when (interactive-p)
 +      (message "Done!"))))
 +
 +(provide 'cedet-utests)
 +
 +;;; cedet-utests.el ends here
diff --cc test/manual/cedet/ede-tests.el
index 293c037ebd1,00000000000..32971e441ef
mode 100644,000000..100644
--- a/test/manual/cedet/ede-tests.el
+++ b/test/manual/cedet/ede-tests.el
@@@ -1,87 -1,0 +1,87 @@@
 +;;; ede-tests.el --- Some tests for the Emacs Development Environment
 +
- ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Extracted from ede-locate.el in the CEDET distribution.
 +
 +;;; Code:
 +
 +;;; From ede-locate:
 +
 +(require 'ede/locate)
 +
 +;;; TESTS
 +;;
 +;; Some testing routines.
 +(defun ede-locate-test-locate (file)
 +  "Test EDE Locate on FILE using LOCATE type.
 +The search is done with the current EDE root."
 +  (interactive "sFile: ")
 +  (let ((loc (ede-locate-locate
 +	      "test"
 +	      :root (ede-project-root-directory
 +		     (ede-toplevel)))))
 +    (data-debug-new-buffer "*EDE Locate ADEBUG*")
 +    (ede-locate-file-in-project loc file)
 +    (data-debug-insert-object-slots loc "]"))
 +  )
 +
 +(defun ede-locate-test-global (file)
 +  "Test EDE Locate on FILE using GNU Global type.
 +The search is done with the current EDE root."
 +  (interactive "sFile: ")
 +  (let ((loc (ede-locate-global
 +	      "test"
 +	      :root (ede-project-root-directory
 +		     (ede-toplevel)))))
 +    (data-debug-new-buffer "*EDE Locate ADEBUG*")
 +    (ede-locate-file-in-project loc file)
 +    (data-debug-insert-object-slots loc "]"))
 +  )
 +
 +(defun ede-locate-test-idutils (file)
 +  "Test EDE Locate on FILE using ID Utils type.
 +The search is done with the current EDE root."
 +  (interactive "sFile: ")
 +  (let ((loc (ede-locate-idutils
 +	      "test"
 +	      :root (ede-project-root-directory
 +		     (ede-toplevel)))))
 +    (data-debug-new-buffer "*EDE Locate ADEBUG*")
 +    (ede-locate-file-in-project loc file)
 +    (data-debug-insert-object-slots loc "]"))
 +  )
 +
 +(defun ede-locate-test-cscope (file)
 +  "Test EDE Locate on FILE using CScope type.
 +The search is done with the current EDE root."
 +  (interactive "sFile: ")
 +  (let ((loc (ede-locate-cscope
 +	      "test"
 +	      :root (ede-project-root-directory
 +		     (ede-toplevel)))))
 +    (data-debug-new-buffer "*EDE Locate ADEBUG*")
 +    (ede-locate-file-in-project loc file)
 +    (data-debug-insert-object-slots loc "]"))
 +  )
 +
 +;;; ede-test.el ends here
diff --cc test/manual/cedet/semantic-ia-utest.el
index 71736c816f7,00000000000..a5b70b8326f
mode 100644,000000..100644
--- a/test/manual/cedet/semantic-ia-utest.el
+++ b/test/manual/cedet/semantic-ia-utest.el
@@@ -1,528 -1,0 +1,528 @@@
 +;;; semantic-ia-utest.el --- Analyzer unit tests
 +
- ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +;;
 +;; Use marked-up files in the test directory and run the analyzer
 +;; on them.  Make sure the answers are correct.
 +;;
 +;; Each file has cursor keys in them of the form:
 +;;   // -#- ("ans1" "ans2" )
 +;; where # is 1, 2, 3, etc, and some sort of answer list.
 +
 +;;; Code:
 +(require 'semantic)
 +(require 'semantic/analyze)
 +(require 'semantic/analyze/refs)
 +(require 'semantic/symref)
 +(require 'semantic/symref/filter)
 +
 +(load-file "cedet-utests.el")
 +
 +(defvar semantic-ia-utest-file-list
 +  '(
 +    "tests/testdoublens.cpp"
 +    "tests/testsubclass.cpp"
 +    "tests/testtypedefs.cpp"
 +    "tests/testfriends.cpp"
 +    "tests/testnsp.cpp"
 +    "tests/testsppcomplete.c"
 +    "tests/testvarnames.c"
 +    "tests/testjavacomp.java"
 +    )
 +  "List of files with analyzer completion test points.")
 +
 +(defvar semantic-ia-utest-error-log-list nil
 +  "List of errors occurring during a run.")
 +
 +;;;###autoload
 +(defun semantic-ia-utest (&optional arg)
 +  "Run the semantic ia unit test against stored sources.
 +Argument ARG specifies which set of tests to run.
 + 1 - ia utests
 + 2 - regs utests
 + 3 - symrefs utests
 + 4 - symref count utests"
 +  (interactive "P")
 +  (save-excursion
 +
 +    (let ((fl semantic-ia-utest-file-list)
 +	  (semantic-ia-utest-error-log-list nil)
 +	  )
 +
 +      (cedet-utest-log-setup "ANALYZER")
 +
 +      (set-buffer (semantic-find-file-noselect
 +		   (or (locate-library "semantic-ia-utest.el")
 +		       "semantic-ia-utest.el")))
 +
 +      (while fl
 +
 +	;; Make sure we have the files we think we have.
 +	(when (not (file-exists-p (car fl)))
 +	  (error "Cannot find unit test file: %s" (car fl)))
 +
 +	;; Run the tests.
 +	(let ((fb (find-buffer-visiting (car fl)))
 +	      (b (semantic-find-file-noselect (car fl) t)))
 +
 +	  ;; Run the test on it.
 +	  (save-excursion
 +	    (set-buffer b)
 +
 +	    ;; This line will also force the include, scope, and typecache.
 +	    (semantic-clear-toplevel-cache)
 +	    ;; Force tags to be parsed.
 +	    (semantic-fetch-tags)
 +
 +	    (semantic-ia-utest-log "  ** Starting tests in %s"
 +				   (buffer-name))
 +
 +	    (when (or (not arg) (= arg 1))
 +	      (semantic-ia-utest-buffer))
 +
 +	    (when (or (not arg) (= arg 2))
 +	      (set-buffer b)
 +	      (semantic-ia-utest-buffer-refs))
 +
 +	    (when (or (not arg) (= arg 3))
 +	      (set-buffer b)
 +	      (semantic-sr-utest-buffer-refs))
 +
 +	    (when (or (not arg) (= arg 4))
 +	      (set-buffer b)
 +	      (semantic-src-utest-buffer-refs))
 +
 +	    (semantic-ia-utest-log "  ** Completed tests in %s\n"
 +				   (buffer-name))
 +	    )
 +
 +	  ;; If it wasn't already in memory, whack it.
 +	  (when (not fb)
 +	    (kill-buffer b))
 +	  )
 +	(setq fl (cdr fl)))
 +
 +      (cedet-utest-log-shutdown
 +       "ANALYZER"
 +       (when semantic-ia-utest-error-log-list
 +	 (format "%s Failures found."
 +		 (length semantic-ia-utest-error-log-list))))
 +      (when semantic-ia-utest-error-log-list
 +	(error "Failures found during analyzer unit tests"))
 +      ))
 +  )
 +
 +(defun semantic-ia-utest-buffer ()
 +  "Run analyzer completion unit-test pass in the current buffer."
 +
 +  (let* ((idx 1)
 +	 (regex-p nil)
 +	 (regex-a nil)
 +	 (p nil)
 +	 (a nil)
 +	 (pass nil)
 +	 (fail nil)
 +	 (actual nil)
 +	 (desired nil)
 +	 ;; Exclude unpredictable system files in the
 +	 ;; header include list.
 +	 (semanticdb-find-default-throttle
 +	  (remq 'system semanticdb-find-default-throttle))
 +	 )
 +    ;; Keep looking for test points until we run out.
 +    (while (save-excursion
 +	     (setq regex-p (concat "//\\s-*-" (number-to-string idx) "-" )
 +		   regex-a (concat "//\\s-*#" (number-to-string idx) "#" ))
 +	     (goto-char (point-min))
 +	     (save-match-data
 +	       (when (re-search-forward regex-p nil t)
 +		 (setq p (match-beginning 0))))
 +	     (save-match-data
 +	       (when (re-search-forward regex-a nil t)
 +		 (setq a (match-end 0))))
 +	     (and p a))
 +
 +      (save-excursion
 +
 +	(goto-char p)
 +
 +	(let* ((ctxt (semantic-analyze-current-context))
 +	       (acomp
 +		(condition-case nil
 +		    (semantic-analyze-possible-completions ctxt)
 +		  (error nil))))
 +	  (setq actual (mapcar 'semantic-tag-name acomp)))
 +
 +	(goto-char a)
 +
 +	(let ((bss (buffer-substring-no-properties (point) (point-at-eol))))
 +	  (condition-case nil
 +	      (setq desired (read bss))
 +	    (error (setq desired (format "  FAILED TO PARSE: %S"
 +					 bss)))))
 +
 +	(if (equal actual desired)
 +	    (setq pass (cons idx pass))
 +	  (setq fail (cons idx fail))
 +	  (semantic-ia-utest-log
 +	   "    Failed %d.  Desired: %S Actual %S"
 +	   idx desired actual)
 +	  (add-to-list 'semantic-ia-utest-error-log-list
 +		       (list (buffer-name) idx desired actual)
 +		       )
 +
 +	  )
 +	)
 +
 +      (setq p nil a nil)
 +      (setq idx (1+ idx)))
 +
 +    (if fail
 +	(progn
 +	  (semantic-ia-utest-log
 +	   "    Unit tests (completions) failed tests %S"
 +	   (reverse fail))
 +	  )
 +      (semantic-ia-utest-log "    Unit tests (completions) passed (%d total)"
 +			     (- idx 1)))
 +
 +    ))
 +
 +(defun semantic-ia-utest-buffer-refs ()
 +  "Run an analyze-refs unit-test pass in the current buffer."
 +
 +  (let* ((idx 1)
 +	 (regex-p nil)
 +	 (p nil)
 +	 (pass nil)
 +	 (fail nil)
 +	 ;; Exclude unpredictable system files in the
 +	 ;; header include list.
 +	 (semanticdb-find-default-throttle
 +	  (remq 'system semanticdb-find-default-throttle))
 +	 )
 +    ;; Keep looking for test points until we run out.
 +    (while (save-excursion
 +	     (setq regex-p (concat "//\\s-*\\^" (number-to-string idx) "^" )
 +		   )
 +	     (goto-char (point-min))
 +	     (save-match-data
 +	       (when (re-search-forward regex-p nil t)
 +		 (setq p (match-beginning 0))))
 +	     p)
 +
 +      (save-excursion
 +
 +	(goto-char p)
 +	(forward-char -1)
 +
 +	(let* ((ct (semantic-current-tag))
 +	       (refs (semantic-analyze-tag-references ct))
 +	       (impl (semantic-analyze-refs-impl refs t))
 +	       (proto (semantic-analyze-refs-proto refs t))
 +	       (pf nil)
 +	       )
 +	  (setq
 +	   pf
 +	   (catch 'failed
 +	     (if (and impl proto (car impl) (car proto))
 +		 (let (ct2 ref2 impl2 proto2
 +			   newstart)
 +		   (cond
 +		    ((semantic-equivalent-tag-p (car impl) ct)
 +		     ;; We are on an IMPL.  Go To the proto, and find matches.
 +		     (semantic-go-to-tag (car proto))
 +		     (setq newstart (car proto))
 +		     )
 +		    ((semantic-equivalent-tag-p (car proto) ct)
 +		     ;; We are on a PROTO.  Go to the imple, and find matches
 +		     (semantic-go-to-tag (car impl))
 +		     (setq newstart (car impl))
 +		     )
 +		    (t
 +		     ;; No matches is a fail.
 +		     (throw 'failed t)
 +		     ))
 +		   ;; Get the new tag, does it match?
 +		   (setq ct2 (semantic-current-tag))
 +
 +		   ;; Does it match?
 +		   (when (not (semantic-equivalent-tag-p ct2 newstart))
 +		     (throw 'failed t))
 +
 +		   ;; Can we double-jump?
 +		   (setq ref2 (semantic-analyze-tag-references ct)
 +			 impl2 (semantic-analyze-refs-impl ref2 t)
 +			 proto2 (semantic-analyze-refs-proto ref2 t))
 +
 +		   (when (or (not (and impl2 proto2))
 +			     (not
 +			      (and (semantic-equivalent-tag-p
 +				    (car impl) (car impl2))
 +				   (semantic-equivalent-tag-p
 +				    (car proto) (car proto2)))))
 +		     (throw 'failed t))
 +		   )
 +
 +	       ;; Else, no matches at all, so another fail.
 +	       (throw 'failed t)
 +	       )))
 +
 +	   (if (not pf)
 +	      ;; We passed
 +	      (setq pass (cons idx pass))
 +	    ;; We failed.
 +	    (setq fail (cons idx fail))
 +	    (semantic-ia-utest-log
 +	     "    Failed %d.  For %s (Num impls %d) (Num protos %d)"
 +	     idx (if ct (semantic-tag-name ct) "")
 +	     (length impl) (length proto))
 +	    (add-to-list 'semantic-ia-utest-error-log-list
 +			 (list (buffer-name) idx)
 +			 )
 +	    ))
 +
 +	(setq p nil)
 +	(setq idx (1+ idx))
 +
 +	))
 +
 +    (if fail
 +	(progn
 +	  (semantic-ia-utest-log
 +	   "    Unit tests (refs) failed tests")
 +	  )
 +      (semantic-ia-utest-log "    Unit tests (refs) passed (%d total)"
 +			     (- idx 1)))
 +
 +    ))
 +
 +(defun semantic-sr-utest-buffer-refs ()
 +  "Run a symref unit-test pass in the current buffer."
 +
 +  ;; This line will also force the include, scope, and typecache.
 +  (semantic-clear-toplevel-cache)
 +  ;; Force tags to be parsed.
 +  (semantic-fetch-tags)
 +
 +  (let* ((idx 1)
 +	 (tag nil)
 +	 (regex-p nil)
 +	 (desired nil)
 +	 (actual-result nil)
 +	 (actual nil)
 +	 (pass nil)
 +	 (fail nil)
 +	 (symref-tool-used nil)
 +	 ;; Exclude unpredictable system files in the
 +	 ;; header include list.
 +	 (semanticdb-find-default-throttle
 +	  (remq 'system semanticdb-find-default-throttle))
 +	 )
 +    ;; Keep looking for test points until we run out.
 +    (while (save-excursion
 +	     (setq regex-p (concat "//\\s-*\\%" (number-to-string idx) "%" )
 +		   )
 +	     (goto-char (point-min))
 +	     (save-match-data
 +	       (when (re-search-forward regex-p nil t)
 +		 (setq tag (semantic-current-tag))
 +		 (goto-char (match-end 0))
 +		 (setq desired (read (buffer-substring (point) (point-at-eol))))
 +		 ))
 +	     tag)
 +
 +      (setq actual-result (semantic-symref-find-references-by-name
 +			   (semantic-tag-name tag) 'target
 +			   'symref-tool-used))
 +
 +      (if (not actual-result)
 +	  (progn
 +	    (setq fail (cons idx fail))
 +	    (semantic-ia-utest-log
 +	     "  Failed FNames %d: No results." idx)
 +	    (semantic-ia-utest-log
 +	     "  Failed Tool: %s" (object-name symref-tool-used))
 +
 +	    (add-to-list 'semantic-ia-utest-error-log-list
 +			 (list (buffer-name) idx)
 +			 )
 +	    )
 +
 +	(setq actual (list (sort (mapcar
 +				  'file-name-nondirectory
 +				  (semantic-symref-result-get-files actual-result))
 +				 'string<)
 +			   (sort
 +			    (mapcar
 +			     'semantic-format-tag-canonical-name
 +			     (semantic-symref-result-get-tags actual-result))
 +			    'string<)))
 +
 +
 +	(if (equal desired actual)
 +	    ;; We passed
 +	    (setq pass (cons idx pass))
 +	  ;; We failed.
 +	  (setq fail (cons idx fail))
 +	  (when (not (equal (car actual) (car desired)))
 +	    (semantic-ia-utest-log
 +	     "  Failed FNames %d: Actual: %S Desired: %S"
 +	     idx (car actual) (car desired))
 +	    (semantic-ia-utest-log
 +	     "  Failed Tool: %s" (object-name symref-tool-used))
 +	    )
 +	  (when (not (equal (car (cdr actual)) (car (cdr desired))))
 +	    (semantic-ia-utest-log
 +	     "  Failed TNames %d: Actual: %S Desired: %S"
 +	     idx (car (cdr actual)) (car (cdr desired)))
 +	    (semantic-ia-utest-log
 +	     "  Failed Tool: %s" (object-name symref-tool-used))
 +	    )
 +	  (add-to-list 'semantic-ia-utest-error-log-list
 +		       (list (buffer-name) idx)
 +		       )
 +	  ))
 +
 +      (setq idx (1+ idx))
 +      (setq tag nil))
 +
 +    (if fail
 +	(progn
 +	  (semantic-ia-utest-log
 +	   "    Unit tests (symrefs) failed tests")
 +	  )
 +      (semantic-ia-utest-log "    Unit tests (symrefs) passed (%d total)"
 +			     (- idx 1)))
 +
 +    ))
 +
 +(defun semantic-symref-test-count-hits-in-tag ()
 +  "Lookup in the current tag the symbol under point.
 +Then count all the other references to the same symbol within the
 +tag that contains point, and return that."
 +  (interactive)
 +  (let* ((ctxt (semantic-analyze-current-context))
 +	 (target (car (reverse (oref ctxt prefix))))
 +	 (tag (semantic-current-tag))
 +	 (start (current-time))
 +	 (Lcount 0))
 +    (when (semantic-tag-p target)
 +      (semantic-symref-hits-in-region
 +       target (lambda (start end prefix) (setq Lcount (1+ Lcount)))
 +       (semantic-tag-start tag)
 +       (semantic-tag-end tag))
 +      (when (interactive-p)
 +	(message "Found %d occurrences of %s in %.2f seconds"
 +		 Lcount (semantic-tag-name target)
 +		 (semantic-elapsed-time start (current-time))))
 +      Lcount)))
 +
 +(defun semantic-src-utest-buffer-refs ()
 +  "Run a sym-ref counting unit-test pass in the current buffer."
 +
 +  ;; This line will also force the include, scope, and typecache.
 +  (semantic-clear-toplevel-cache)
 +  ;; Force tags to be parsed.
 +  (semantic-fetch-tags)
 +
 +  (let* ((idx 1)
 +	 (start nil)
 +	 (regex-p nil)
 +	 (desired nil)
 +	 (actual nil)
 +	 (pass nil)
 +	 (fail nil)
 +	 ;; Exclude unpredictable system files in the
 +	 ;; header include list.
 +	 (semanticdb-find-default-throttle
 +	  (remq 'system semanticdb-find-default-throttle))
 +	 )
 +    ;; Keep looking for test points until we run out.
 +    (while (save-excursion
 +	     (setq regex-p (concat "//\\s-*@"
 +				   (number-to-string idx)
 +				   "@\\s-+\\(\\w+\\)" ))
 +	     (goto-char (point-min))
 +	     (save-match-data
 +	       (when (re-search-forward regex-p nil t)
 +		 (goto-char (match-beginning 1))
 +		 (setq desired (read (buffer-substring (point) (point-at-eol))))
 +		 (setq start (match-beginning 0))
 +		 (goto-char start)
 +		 (setq actual (semantic-symref-test-count-hits-in-tag))
 +		 start)))
 +
 +      (if (not actual)
 +	  (progn
 +	    (setq fail (cons idx fail))
 +	    (semantic-ia-utest-log
 +	     "  Failed symref count %d: No results." idx)
 +
 +	    (add-to-list 'semantic-ia-utest-error-log-list
 +			 (list (buffer-name) idx)
 +			 )
 +	    )
 +
 +	(if (equal desired actual)
 +	    ;; We passed
 +	    (setq pass (cons idx pass))
 +	  ;; We failed.
 +	  (setq fail (cons idx fail))
 +	  (when (not (equal actual desired))
 +	    (semantic-ia-utest-log
 +	     "  Failed symref count %d: Actual: %S Desired: %S"
 +	     idx actual desired)
 +	    )
 +
 +	  (add-to-list 'semantic-ia-utest-error-log-list
 +		       (list (buffer-name) idx)
 +		       )
 +	  ))
 +
 +      (setq idx (1+ idx))
 +      )
 +
 +    (if fail
 +	(progn
 +	  (semantic-ia-utest-log
 +	   "    Unit tests (symrefs counter) failed tests")
 +	  )
 +      (semantic-ia-utest-log "    Unit tests (symrefs counter) passed (%d total)"
 +			     (- idx 1)))
 +
 +    ))
 +
 +(defun semantic-ia-utest-start-log ()
 +  "Start up a testlog for a run."
 +  ;; Redo w/ CEDET utest framework.
 +  (cedet-utest-log-start "semantic: analyzer tests"))
 +
 +(defun semantic-ia-utest-log (&rest args)
 +  "Log some test results.
 +Pass ARGS to format to create the log message."
 +  ;; Forward to CEDET utest framework.
 +  (apply 'cedet-utest-log args))
 +
 +(provide 'semantic-ia-utest)
 +
 +;;; semantic-ia-utest.el ends here
diff --cc test/manual/cedet/semantic-tests.el
index 0d9b688ee32,00000000000..179851fafeb
mode 100644,000000..100644
--- a/test/manual/cedet/semantic-tests.el
+++ b/test/manual/cedet/semantic-tests.el
@@@ -1,389 -1,0 +1,389 @@@
 +;;; semantic-utest.el --- Miscellaneous Semantic tests.
 +
- ;;; Copyright (C) 2003-2004, 2007-2015 Free Software Foundation, Inc.
++;;; Copyright (C) 2003-2004, 2007-2016 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Originally, there are many test functions scattered among the
 +;; Semantic source files.  This file consolidates them.
 +
 +(require 'data-debug)
 +
 +;;; From semantic-complete
 +
 +(require 'semantic/complete)
 +
 +(defun semantic-complete-test ()
 +  "Test completion mechanisms."
 +  (interactive)
 +  (message "%S"
 +   (semantic-format-tag-prototype
 +    (semantic-complete-read-tag-project "Symbol: "))))
 +
 +;;; From semanticdb-ebrowse
 +
 +(require 'semantic/db-ebrowse)
 +
 +(defun semanticdb-ebrowse-run-tests ()
 +  "Run some tests of the semanticdb-ebrowse system.
 +All systems are different.  Ask questions along the way."
 +  (interactive)
 +  (let ((doload nil))
 +    (when (y-or-n-p "Create a system database to test with? ")
 +      (call-interactively 'semanticdb-create-ebrowse-database)
 +      (setq doload t))
 +    ;;  Should we load in caches
 +    (when (if doload
 +	      (y-or-n-p "New database created.  Reload system databases? ")
 +	    (y-or-n-p "Load in all system databases? "))
 +      (semanticdb-load-ebrowse-caches)))
 +  ;; Ok, databases were created.  Let's try some searching.
 +  (when (not (or (eq major-mode 'c-mode)
 +		 (eq major-mode 'c++-mode)))
 +    (error "Please make your default buffer be a C or C++ file, then
 +run the test again")))
 +
 +(defun semanticdb-ebrowse-dump ()
 +  "Find the first loaded ebrowse table, and dump out the contents."
 +  (interactive)
 +  (let ((db semanticdb-database-list)
 +	(ab nil))
 +    (while db
 +      (when (semanticdb-project-database-ebrowse-p (car db))
 +	(setq ab (data-debug-new-buffer "*EBROWSE Database*"))
 +	(data-debug-insert-thing (car db) "*" "")
 +	(setq db nil)
 +	)
 +      (setq db (cdr db)))))
 +
 +;;; From semanticdb-global:
 +
 +(require 'semantic/db-global)
 +
 +(defvar semanticdb-test-gnu-global-startfile "~/src/global-5.7.3/global/global.c"
 +  "File to use for testing.")
 +
 +(defun semanticdb-test-gnu-global (searchfor &optional standardfile)
 +  "Test the GNU Global semanticdb.
 +Argument SEARCHFOR is the text to search for.
 +If optional arg STANDARDFILE is non-nil, use a standard file w/ global enabled."
 +  (interactive "sSearch For Tag: \nP")
 +
 +  (require 'data-debug)
 +  (save-excursion
 +    (when standardfile
 +      (save-match-data
 +	(set-buffer (find-file-noselect semanticdb-test-gnu-global-startfile))))
 +
 +    (condition-case err
 +	(semanticdb-enable-gnu-global-in-buffer)
 +      (error (if standardfile
 +		 (error err)
 +	       (save-match-data
 +		 (set-buffer (find-file-noselect semanticdb-test-gnu-global-startfile)))
 +	       (semanticdb-enable-gnu-global-in-buffer))))
 +
 +    (let* ((db (semanticdb-project-database-global "global"))
 +	   (tab (semanticdb-file-table db (buffer-file-name)))
 +	   (result (semanticdb-deep-find-tags-for-completion-method tab searchfor))
 +	   )
 +      (data-debug-new-buffer "*SemanticDB Gnu Global Result*")
 +      (data-debug-insert-thing result "?" ""))))
 +
 +;;; From semantic-format
 +
 +(require 'semantic/format)
 +
 +(defun semantic-test-all-format-tag-functions (&optional arg)
 +  "Test all outputs from `semantic-format-tag-functions'.
 +Output is generated from the function under `point'.
 +Optional argument ARG specifies not to use color."
 +  (interactive "P")
 +  (semantic-fetch-tags)
 +  (let* ((tag (semantic-current-tag))
 +	 (par (semantic-current-tag-parent))
 +	 (fns semantic-format-tag-functions))
 +    (with-output-to-temp-buffer "*format-tag*"
 +      (princ "Tag->format function tests:")
 +      (while fns
 +	(princ "\n")
 +	(princ (car fns))
 +	(princ ":\n ")
 +	(let ((s (funcall (car fns) tag par (not arg))))
 +	  (save-excursion
 +	    (set-buffer "*format-tag*")
 +	    (goto-char (point-max))
 +	    (insert s)))
 +	(setq fns (cdr fns))))
 +      ))
 +
 +;;; From semantic-fw:
 +
 +(require 'semantic/fw)
 +
 +(defun semantic-test-data-cache ()
 +  "Test the data cache."
 +  (interactive)
 +  (let ((data '(a b c)))
 +    (save-excursion
 +      (set-buffer (get-buffer-create " *semantic-test-data-cache*"))
 +      (erase-buffer)
 +      (insert "The Moose is Loose")
 +      (goto-char (point-min))
 +      (semantic-cache-data-to-buffer (current-buffer) (point) (+ (point) 5)
 +				     data 'moose 'exit-cache-zone)
 +      (if (equal (semantic-get-cache-data 'moose) data)
 +	  (message "Successfully retrieved cached data.")
 +	(error "Failed to retrieve cached data")))))
 +
 +(defun semantic-test-throw-on-input ()
 +  "Test that throw on input will work."
 +  (interactive)
 +  (semantic-throw-on-input 'done-die)
 +  (message "Exit Code: %s"
 +	   (semantic-exit-on-input 'testing
 +	     (let ((inhibit-quit nil)
 +		   (message-log-max nil))
 +	       (while t
 +		 (message "Looping ... press a key to test")
 +		 (semantic-throw-on-input 'test-inner-loop))
 +	       'exit)))
 +  (when (input-pending-p)
 +    (if (fboundp 'read-event)
 +	(read-event)
 +      (read-char))))
 +
 +;;; From semantic-idle:
 +
 +(require 'semantic/idle)
 +
 +(defun semantic-idle-pnf-test ()
 +  "Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it."
 +  (interactive)
 +  (let ((start (current-time))
 +	(junk (semantic-idle-scheduler-work-parse-neighboring-files))
 +	(end (current-time)))
 +    (message "Work took %.2f seconds." (semantic-elapsed-time start end))))
 +
 +;;; From semantic-lex:
 +
 +(require 'semantic/lex)
 +
 +(defun semantic-lex-test-full-depth (arg)
 +  "Test the semantic lexer in the current buffer parsing through lists.
 +Usually the lexer parses.
 +If universal argument ARG, then try the whole buffer."
 +  (interactive "P")
 +  (let* ((start (current-time))
 +	 (result (semantic-lex
 +		  (if arg (point-min) (point))
 +		  (point-max)
 +		  100))
 +	 (end (current-time)))
 +    (message "Elapsed Time: %.2f seconds."
 +	     (semantic-elapsed-time start end))
 +    (pop-to-buffer "*Lexer Output*")
 +    (require 'pp)
 +    (erase-buffer)
 +    (insert (pp-to-string result))
 +    (goto-char (point-min))))
 +
 +(defun semantic-lex-test-region (beg end)
 +  "Test the semantic lexer in the current buffer.
 +Analyze the area between BEG and END."
 +  (interactive "r")
 +  (let ((result (semantic-lex beg end)))
 +    (pop-to-buffer "*Lexer Output*")
 +    (require 'pp)
 +    (erase-buffer)
 +    (insert (pp-to-string result))
 +    (goto-char (point-min))))
 +
 +;;; From semantic-lex-spp:
 +
 +(require 'semantic/lex-spp)
 +
 +(defun semantic-lex-spp-write-test ()
 +  "Test the semantic tag writer against the current buffer."
 +  (interactive)
 +  (with-output-to-temp-buffer "*SPP Write Test*"
 +    (semantic-lex-spp-table-write-slot-value
 +     (semantic-lex-spp-save-table))))
 +
 +(defun semantic-lex-spp-write-utest ()
 +  "Unit test using the test spp file to test the slot write fcn."
 +  (interactive)
 +  (let* ((sem (locate-library "semantic-lex-spp.el"))
 +	 (dir (file-name-directory sem)))
 +    (save-excursion
 +      (set-buffer (find-file-noselect
 +		   (expand-file-name "tests/testsppreplace.c"
 +				     dir)))
 +      (semantic-lex-spp-write-test))))
 +
 +;;; From semantic-tag-write:
 +
 +;;; TESTING.
 +
 +(require 'semantic/tag-write)
 +
 +(defun semantic-tag-write-test ()
 +  "Test the semantic tag writer against the tag under point."
 +  (interactive)
 +  (with-output-to-temp-buffer "*Tag Write Test*"
 +    (semantic-tag-write-one-tag (semantic-current-tag))))
 +
 +(defun semantic-tag-write-list-test ()
 +  "Test the semantic tag writer against the tag under point."
 +  (interactive)
 +  (with-output-to-temp-buffer "*Tag Write Test*"
 +    (semantic-tag-write-tag-list (semantic-fetch-tags))))
 +
 +;;; From semantic-symref-filter:
 +
 +(require 'semantic/symref/filter)
 +
 +(defun semantic-symref-test-count-hits-in-tag ()
 +  "Lookup in the current tag the symbol under point.
 +Then count all the other references to the same symbol within the
 +tag that contains point, and return that."
 +  (interactive)
 +  (let* ((ctxt (semantic-analyze-current-context))
 +	 (target (car (reverse (oref ctxt prefix))))
 +	 (tag (semantic-current-tag))
 +	 (start (current-time))
 +	 (Lcount 0))
 +    (when (semantic-tag-p target)
 +      (semantic-symref-hits-in-region
 +       target (lambda (start end prefix) (setq Lcount (1+ Lcount)))
 +       (semantic-tag-start tag)
 +       (semantic-tag-end tag))
 +      (when (interactive-p)
 +	(message "Found %d occurrences of %s in %.2f seconds"
 +		 Lcount (semantic-tag-name target)
 +		 (semantic-elapsed-time start (current-time))))
 +      Lcount)))
 +
 +;;; From bovine-gcc:
 +
 +(require 'semantic/bovine/gcc)
 +
 +;; Example output of "gcc -v"
 +(defvar semantic-gcc-test-strings
 +  '(;; My old box:
 +    "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs
 +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --host=i386-redhat-linux
 +Thread model: posix
 +gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)"
 +    ;; Alex Ott:
 +    "Using built-in specs.
 +Target: i486-linux-gnu
 +Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.1-9ubuntu1' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu
 +Thread model: posix
 +gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)"
 +    ;; My debian box:
 +    "Using built-in specs.
 +Target: x86_64-unknown-linux-gnu
 +Configured with: ../../../sources/gcc/configure --prefix=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3 --with-gmp=/usr/local/gcc/gmp --with-mpfr=/usr/local/gcc/mpfr --enable-languages=c,c++,fortran --with-as=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/as --with-ld=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/ld --disable-multilib
 +Thread model: posix
 +gcc version 4.2.3"
 +    ;; My mac:
 +    "Using built-in specs.
 +Target: i686-apple-darwin8
 +Configured with: /private/var/tmp/gcc/gcc-5341.obj~1/src/configure --disable-checking -enable-werror --prefix=/usr --mandir=/share/man --enable-languages=c,objc,c++,obj-c++ --program-transform-name=/^[cg][^.-]*$/s/$/-4.0/ --with-gxx-include-dir=/include/c++/4.0.0 --with-slibdir=/usr/lib --build=powerpc-apple-darwin8 --with-arch=pentium-m --with-tune=prescott --program-prefix= --host=i686-apple-darwin8 --target=i686-apple-darwin8
 +Thread model: posix
 +gcc version 4.0.1 (Apple Computer, Inc. build 5341)"
 +    ;; Ubuntu Intrepid
 +    "Using built-in specs.
 +Target: x86_64-linux-gnu
 +Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-checking=release --build=x86_64-linux-gnu --host=x86_64-linux-gnu --target=x86_64-linux-gnu
 +Thread model: posix
 +gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"
 +    ;; Red Hat EL4
 +    "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs
 +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-java-awt=gtk --host=x86_64-redhat-linux
 +Thread model: posix
 +gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)"
 +    ;; Red Hat EL5
 +    "Using built-in specs.
 +Target: x86_64-redhat-linux
 +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --enable-checking=release --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-libgcj-multifile --enable-languages=c,c++,objc,obj-c++,java,fortran,ada --enable-java-awt=gtk --disable-dssi --enable-plugin --with-java-home=/usr/lib/jvm/java-1.4.2-gcj-1.4.2.0/jre --with-cpu=generic --host=x86_64-redhat-linux
 +Thread model: posix
 +gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)"
 +    ;; David Engster's german gcc on ubuntu 4.3
 +    "Es werden eingebaute Spezifikationen verwendet.
 +Ziel: i486-linux-gnu
 +Konfiguriert mit: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu
 +Thread-Modell: posix
 +gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"
 +    ;; Damien Deville bsd
 +    "Using built-in specs.
 +Target: i386-undermydesk-freebsd
 +Configured with: FreeBSD/i386 system compiler
 +Thread model: posix
 +gcc version 4.2.1 20070719  [FreeBSD]"
 +    )
 +  "A bunch of sample gcc -v outputs from different machines.")
 +
 +(defvar semantic-gcc-test-strings-fail
 +  '(;; A really old solaris box I found
 +    "Reading specs from /usr/local/gcc-2.95.2/lib/gcc-lib/sparc-sun-solaris2.6/2.95.2/specs
 +gcc version 2.95.2 19991024 (release)"
 +    )
 +  "A bunch of sample gcc -v outputs that fail to provide the info we want.")
 +
 +(defun semantic-gcc-test-output-parser ()
 +  "Test the output parser against some collected strings."
 +  (interactive)
 +  (let ((fail nil))
 +    (dolist (S semantic-gcc-test-strings)
 +      (let* ((fields (semantic-gcc-fields S))
 +             (v (cdr (assoc 'version fields)))
 +             (h (or (cdr (assoc 'target fields))
 +                    (cdr (assoc '--target fields))
 +                    (cdr (assoc '--host fields))))
 +             (p (cdr (assoc '--prefix fields)))
 +             )
 +	;; No longer test for prefixes.
 +        (when (not (and v h))
 +          (let ((strs (split-string S "\n")))
 +            (message "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p))
 +          (setq fail t))
 +        ))
 +    (dolist (S semantic-gcc-test-strings-fail)
 +      (let* ((fields (semantic-gcc-fields S))
 +             (v (cdr (assoc 'version fields)))
 +             (h (or (cdr (assoc '--host fields))
 +                    (cdr (assoc 'target fields))))
 +             (p (cdr (assoc '--prefix fields)))
 +             )
 +        (when (and v h p)
 +          (message "Negative test failed on %S" S)
 +          (setq fail t))
 +        ))
 +    (if (not fail) (message "Tests passed."))
 +    ))
 +
 +(defun semantic-gcc-test-output-parser-this-machine ()
 +  "Test the output parser against the machine currently running Emacs."
 +  (interactive)
 +  (let ((semantic-gcc-test-strings (list (semantic-gcc-query "gcc" "-v"))))
 +    (semantic-gcc-test-output-parser))
 +  )
diff --cc test/manual/cedet/semantic-utest-c.el
index ccf57076e4c,00000000000..ec09b96211f
mode 100644,000000..100644
--- a/test/manual/cedet/semantic-utest-c.el
+++ b/test/manual/cedet/semantic-utest-c.el
@@@ -1,72 -1,0 +1,72 @@@
 +;;; semantic-utest-c.el --- C based parsing tests.
 +
- ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
++;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +;;
 +;; Run some C based parsing tests.
 +
 +(require 'semantic)
 +
 +(defvar semantic-utest-c-comparisons
 +  '( ("testsppreplace.c" . "testsppreplaced.c")
 +     )
 +  "List of files to parse and compare against each other.")
 +
 +;;; Code:
 +;;;###autoload
 +(defun semantic-utest-c ()
 +  "Run parsing test for C from the test directory."
 +  (interactive)
 +  (dolist (fp semantic-utest-c-comparisons)
 +    (let* ((sem (locate-library "semantic"))
 +	   (sdir (file-name-directory sem))
 +	   (semantic-lex-c-nested-namespace-ignore-second nil)
 +	   (tags-actual
 +	    (save-excursion
 +	      (set-buffer (find-file-noselect (expand-file-name (concat "tests/" (car fp)) sdir)))
 +	      (semantic-clear-toplevel-cache)
 +	      (semantic-fetch-tags)))
 +	   (tags-expected
 +	    (save-excursion
 +	      (set-buffer (find-file-noselect (expand-file-name (concat "tests/" (cdr fp)) sdir)))
 +	      (semantic-clear-toplevel-cache)
 +	      (semantic-fetch-tags))))
 +      ;; Now that we have the tags, compare them for SPP accuracy.
 +      (dolist (tag tags-actual)
 +	(if (and (semantic-tag-of-class-p tag 'variable)
 +		 (semantic-tag-variable-constant-p tag))
 +	    nil				; skip the macros.
 +	  (if (semantic-tag-similar-with-subtags-p tag (car tags-expected))
 +	      (setq tags-expected (cdr tags-expected))
 +	    (with-mode-local c-mode
 +	      (error "Found: >> %s << Expected: >>  %s <<"
 +		     (semantic-format-tag-prototype tag nil t)
 +		     (semantic-format-tag-prototype (car tags-expected) nil t)
 +		     )))
 +	  ))
 +      ;; Passed?
 +      (message "PASSED!")
 +      )))
 +
 +
 +(provide 'semantic-utest-c)
 +
 +;;; semantic-utest-c.el ends here
diff --cc test/manual/cedet/semantic-utest.el
index 2c9ccd37e62,00000000000..d26d6118d2d
mode 100644,000000..100644
--- a/test/manual/cedet/semantic-utest.el
+++ b/test/manual/cedet/semantic-utest.el
@@@ -1,867 -1,0 +1,867 @@@
 +;;; semantic-utest.el --- Tests for semantic's parsing system.
 +
- ;;; Copyright (C) 2003-2004, 2007-2015 Free Software Foundation, Inc.
++;;; Copyright (C) 2003-2004, 2007-2016 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +;;
 +;; Semantic's parsing and partial parsing system is pretty complex.
 +;; These unit tests attempt to emulate semantic's partial reparsing
 +;; and full reparsing system, and anything else I may feel the urge
 +;; to write a test for.
 +
 +(require 'semantic)
 +
 +(load-file "cedet-utests.el")
 +
 +(defvar semantic-utest-temp-directory (if (fboundp 'temp-directory)
 +					  (temp-directory)
 +					temporary-file-directory)
 +  "Temporary directory to use when creating files.")
 +
 +(defun semantic-utest-fname (name)
 +  "Create a filename for NAME in /tmp."
 +  (expand-file-name name semantic-utest-temp-directory))
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for C tests
 +
 +(defvar semantic-utest-C-buffer-contents
 +  "/* Test file for C language for Unit Tests */
 +
 +#include 
 +#include \"sutest.h\"
 +
 +struct mystruct1 {
 +  int slot11;
 +  char slot12;
 +  float slot13;
 +};
 +
 +int var1;
 +
 +float funp1(char arg11, char arg12);
 +
 +char fun2(int arg_21, int arg_22) /*1*/
 +{
 +  struct mystruct1 *ms1 = malloc(sizeof(struct mystruct1));
 +
 +  char sv = calc_sv(var1);
 +
 +  if (var1 == 0) {
 +     sv = 1;
 +  } else if (arg_21 == 0) {
 +     sv = 2;
 +  } else if (arg_22 == 0) {
 +     sv = 3;
 +  } else {
 +     sv = 4;
 +  }
 +
 +  printf(\"SV = %d\\n\", sv);
 +
 +  /* Memory Leak */
 +  ms1.slot1 = sv;
 +
 +  return 'A' + sv;
 +}
 +"
 +  "Contents of a C buffer initialized by this unit test.
 +Be sure to change `semantic-utest-C-name-contents' when you
 +change this variable.")
 +
 +(defvar semantic-utest-C-h-buffer-contents
 +  "/* Test file for C language header file for Unit Tests */
 +
 +int calc_sv(int);
 +
 +"
 +  "Contents of a C header file buffer initialized by this unit test.")
 +
 +(defvar semantic-utest-C-filename (semantic-utest-fname "sutest.c")
 +  "File to open and erase during this test for C.")
 +
 +(defvar semantic-utest-C-filename-h
 +  (concat (file-name-sans-extension semantic-utest-C-filename)
 +	  ".h")
 +  "Header file filename for C")
 +
 +
 +(defvar semantic-utest-C-name-contents
 +  '(("stdio.h" include
 +     (:system-flag t)
 +     nil (overlay 48 66 "sutest.c"))
 +    ("sutest.h" include nil nil (overlay 67 86 "sutest.c"))
 +    ("mystruct1" type
 +     (:members
 +      (("slot11" variable
 +	(:type "int")
 +	(reparse-symbol classsubparts)
 +	(overlay 109 120 "sutest.c"))
 +       ("slot12" variable
 +	(:type "char")
 +	(reparse-symbol classsubparts)
 +	(overlay 123 135 "sutest.c"))
 +       ("slot13" variable
 +	(:type "float")
 +	(reparse-symbol classsubparts)
 +	(overlay 138 151 "sutest.c")))
 +      :type "struct")
 +     nil (overlay 88 154 "sutest.c"))
 +    ("var1" variable
 +     (:type "int")
 +     nil (overlay 156 165 "sutest.c"))
 +    ("funp1" function
 +     (:prototype-flag t :arguments
 +		      (("arg11" variable
 +			(:type "char")
 +			(reparse-symbol arg-sub-list)
 +			(overlay 179 190 "sutest.c"))
 +		       ("arg12" variable
 +			(:type "char")
 +			(reparse-symbol arg-sub-list)
 +			(overlay 191 202 "sutest.c")))
 +		      :type "float")
 +     nil (overlay 167 203 "sutest.c"))
 +    ("fun2" function
 +     (:arguments
 +      (("arg_21" variable
 +	(:type "int")
 +	(reparse-symbol arg-sub-list)
 +	(overlay 215 226 "sutest.c"))
 +       ("arg_22" variable
 +	(:type "int")
 +	(reparse-symbol arg-sub-list)
 +	(overlay 227 238 "sutest.c")))
 +      :type "char")
 +     nil (overlay 205 566 "sutest.c")))
 +  "List of expected tag names for C.")
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Python tests
 +
 +(defvar semantic-utest-Python-buffer-contents
 +"
 +def fun1(a,b,c):
 +  return a
 +
 +def fun2(a,b,c): #1
 +  return b
 +
 +"
 +
 +
 +)
 +;  "python test case. notice that python is indentation sensitive
 +
 +
 +(defvar semantic-utest-Python-name-contents
 +  '(("fun1" function
 +     (:arguments
 +      (("a" variable nil
 +        (reparse-symbol function_parameters)
 +	(overlay 10 11 "tst.py"))
 +       ("b" variable nil
 +        (reparse-symbol function_parameters)
 +        (overlay 12 13 "tst.py"))
 +       ("c" variable nil
 +        (reparse-symbol function_parameters)
 +        (overlay 14 15 "tst.py"))))
 +     nil (overlay 1 31 "tst.py"))
 +    ("fun2" function
 +     (:arguments
 +      (("a" variable nil
 +        (reparse-symbol function_parameters)
 +        (overlay 41 42 "tst.py"))
 +       ("b" variable nil
 +        (reparse-symbol function_parameters)
 +        (overlay 43 44 "tst.py"))
 +       ("c" variable nil
 +        (reparse-symbol function_parameters)
 +        (overlay 45 46 "tst.py"))))
 +     nil (overlay 32 65 "tst.py")))
 +
 +  "List of expected tag names for Python.")
 +
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Java tests
 +
 +(defvar semantic-utest-Java-buffer-contents
 +"
 +class JavaTest{
 +  void fun1(int a,int b){
 +    return a;
 +  }
 +
 +  void fun2(int a,int b){ //1
 +    return b;
 +  }
 +
 +}
 +"
 +)
 +
 +(defvar semantic-utest-Java-name-contents
 +  '(("JavaTest" type
 +     (:members
 +      (("fun1" function
 +        (:arguments
 +         (("a" variable
 +           (:type "int")
 +           (reparse-symbol formal_parameters)
 +           (overlay 30 35 "JavaTest.java"))
 +	  ("b" variable
 +	   (:type "int")
 +	   (reparse-symbol formal_parameters)
 +	   (overlay 36 41 "JavaTest.java")))
 +         :type "void")
 +        (reparse-symbol class_member_declaration)
 +        (overlay 20 61 "JavaTest.java"))
 +       ("fun2" function
 +	(:arguments
 +	 (("a" variable
 +	   (:type "int")
 +	   (reparse-symbol formal_parameters)
 +	   (overlay 75 80 "JavaTest.java"))
 +	  ("b" variable
 +	   (:type "int")
 +	   (reparse-symbol formal_parameters)
 +	   (overlay 81 86 "JavaTest.java")))
 +	 :type "void")
 +	(reparse-symbol class_member_declaration)
 +	(overlay 65 110 "JavaTest.java")))
 +      :type "class")
 +     nil (overlay 2 113 "JavaTest.java")))
 +  "List of expected tag names for Java."
 +  )
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Javascript tests
 +
 +(defvar semantic-utest-Javascript-buffer-contents
 +"
 +function fun1(a, b){
 +    return a;
 +  }
 +
 +function fun2(a,b){ //1
 +    return b;
 +  }
 +"
 +)
 +
 +
 +(defvar semantic-utest-Javascript-name-contents
 +  '(("fun1" function
 +     (:arguments
 +      (("a" variable nil
 +	(reparse-symbol FormalParameterList)
 +	(overlay 15 16 "tst.js"))
 +       ("b" variable nil
 +	(reparse-symbol FormalParameterList)
 +	(overlay 18 19 "tst.js"))))
 +     nil (overlay 1 39 "tst.js"))
 +    ("fun2" function
 +     (:arguments
 +      (("a" variable nil
 +	(reparse-symbol FormalParameterList)
 +	(overlay 55 56 "tst.js"))
 +       ("b" variable nil
 +	(reparse-symbol FormalParameterList)
 +	(overlay 57 58 "tst.js"))))
 +     nil (overlay 41 82 "tst.js")))
 +
 +  "List of expected tag names for Javascript.")
 +
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Makefile tests
 +
 +(defvar semantic-utest-Makefile-buffer-contents
 +"
 +t1:
 +\techo t1
 +
 +t2:t1 #1
 +\techo t2
 +
 +
 +"
 +)
 +
 +
 +(defvar semantic-utest-Makefile-name-contents
 +  '(("t1" function nil nil (overlay 1 9 "Makefile"))
 +    ("t2" function
 +     (:arguments
 +      ("t1"))
 +     nil (overlay 18 28 "Makefile")))
 +  "List of expected tag names for Makefile.")
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Scheme tests
 +
 +(defvar semantic-utest-Scheme-buffer-contents
 +  "
 + (define fun1 2)
 +
 + (define fun2 3  ;1
 +              )
 +")
 +
 +(defvar semantic-utest-Scheme-name-contents
 +  '(("fun1" variable
 +     (:default-value ("2"))
 +     nil (overlay 3 18 "tst.scm"))
 +    ("fun2" variable
 +     (:default-value ("3"))
 +     nil (overlay 21 55 "tst.scm")))
 +  )
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Html tests
 +
 +(defvar semantic-utest-Html-buffer-contents
 +  "
 +
 +  
 +    

hello

+ + +" + ) + +(defvar semantic-utest-Html-name-contents + '(("hello" section + (:members + (("hello" section nil nil (overlay 21 24 "tst.html")))) + nil (overlay 10 15 "tst.html"))) + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Data for PHP tests + +(defvar semantic-utest-PHP-buffer-contents + " " + ) + +(defvar semantic-utest-PHP-name-contents + '(("fun1" function nil + nil (overlay 9 45 "phptest.php")) + ("fun2" function + (:arguments (("$arg1" variable nil (reparse-symbol formal_parameters) (overlay 61 66 "phptest.php")))) + nil + (overlay 47 132 "phptest.php")) + ("aClass" type + (:members (("fun1" function + (:typemodifiers ("public") :arguments + (("$a" variable nil (reparse-symbol formal_parameters) (overlay 174 176 "phptest.php")) + ("$b" variable nil (reparse-symbol formal_parameters) (overlay 178 180 "phptest.php")))) + + nil + (overlay 153 204 "phptest.php")) + + ("fun2" function + (:typemodifiers ("public") :arguments + (("$a" variable nil (reparse-symbol formal_parameters) (overlay 230 232 "phptest.php")) + ("$b" variable nil (reparse-symbol formal_parameters) (overlay 234 236 "phptest.php")) + )) + nil + (overlay 209 260 "phptest.php"))) :type "class") + nil + (overlay 135 262 "phptest.php")) + ) + "Expected results from the PHP Unit test" + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Data for Csharp C# tests + +(defvar semantic-utest-Csharp-buffer-contents +" +class someClass { + int fun1(int a, int b) { + return a; } + int fun2(int a, int b) { + return b; } +} +") + +(defvar semantic-utest-Csharp-name-contents + '(("someClass" type + (:members + (("fun1" function + (:arguments + (("a" variable + (:type "int") + (reparse-symbol formal_parameters) + (overlay 30 35 "tst.cs")) + ("b" variable + (:type "int") + (reparse-symbol formal_parameters) + (overlay 37 42 "tst.cs"))) + :type "int") + (reparse-symbol class_member_declaration) + (overlay 21 61 "tst.cs")) + ("fun2" function + (:arguments + (("a" variable + (:type "int") + (reparse-symbol formal_parameters) + (overlay 73 78 "tst.cs")) + ("b" variable + (:type "int") + (reparse-symbol formal_parameters) + (overlay 80 85 "tst.cs"))) + :type "int") + (reparse-symbol class_member_declaration) + (overlay 64 104 "tst.cs"))) + :type "class") + nil (overlay 1 106 "tst.cs"))) + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +(defun semantic-utest-makebuffer (filename contents) + "Create a buffer for FILENAME for use in a unit test. +Pre-fill the buffer with CONTENTS." + (let ((buff (semantic-find-file-noselect filename))) + (set-buffer buff) + (setq buffer-offer-save nil) + (font-lock-mode -1) ;; Font lock has issues in Emacs 23 + (toggle-read-only -1) ;; In case /tmp doesn't exist. + (erase-buffer) + (insert contents) + ;(semantic-fetch-tags) ;JAVE could this go here? + (set-buffer-modified-p nil) + buff + ) + ) + +(defun semantic-utest-C () + "Run semantic's C unit test." + (interactive) + (save-excursion + (let ((buff (semantic-utest-makebuffer semantic-utest-C-filename semantic-utest-C-buffer-contents)) + (buff2 (semantic-utest-makebuffer semantic-utest-C-filename-h semantic-utest-C-h-buffer-contents)) + ) + (semantic-fetch-tags) + (set-buffer buff) + + ;; Turn off a range of modes + (semantic-idle-scheduler-mode -1) + + ;; Turn on some modes + (semantic-highlight-edits-mode 1) + + ;; Update tags, and show it. + (semantic-fetch-tags) + + (switch-to-buffer buff) + (sit-for 0) + + ;; Run the tests. + ;;(message "First parsing test.") + (semantic-utest-verify-names semantic-utest-C-name-contents) + + ;;(message "Invalid tag test.") + (semantic-utest-last-invalid semantic-utest-C-name-contents '("fun2") "/\\*1\\*/" "/* Deleted this line */") + (semantic-utest-verify-names semantic-utest-C-name-contents) + + (set-buffer-modified-p nil) + ;; Clean up + ;; (kill-buffer buff) + ;; (kill-buffer buff2) + )) + (message "All C tests passed.") + ) + + + + +(defun semantic-utest-generic (testname filename contents name-contents names-removed killme insertme) + "Generic unit test according to template. +Should work for languages without .h files, python javascript java. +TESTNAME is the name of the test. +FILENAME is the name of the file to create. +CONTENTS is the contents of the file to test. +NAME-CONTENTS is the list of names that should be in the contents. +NAMES-REMOVED is the list of names that gets removed in the removal step. +KILLME is the name of items to be killed. +INSERTME is the text to be inserted after the deletion." + (save-excursion + (let ((buff (semantic-utest-makebuffer filename contents)) + ) + ;; Turn off a range of modes + (semantic-idle-scheduler-mode -1) + + ;; Turn on some modes + (semantic-highlight-edits-mode 1) + + ;; Update tags, and show it. + (semantic-fetch-tags) + (switch-to-buffer buff) + (sit-for 0) + + ;; Run the tests. + ;;(message "First parsing test %s." testname) + (semantic-utest-verify-names name-contents) + + ;;(message "Invalid tag test %s." testname) + (semantic-utest-last-invalid name-contents names-removed killme insertme) + (semantic-utest-verify-names name-contents) + + (set-buffer-modified-p nil) + ;; Clean up + ;; (kill-buffer buff) + )) + (message "All %s tests passed." testname) + ) + +(defun semantic-utest-Python() + (interactive) + (if (fboundp 'python-mode) + (semantic-utest-generic "Python" (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents semantic-utest-Python-name-contents '("fun2") "#1" "#deleted line") + (message "Skilling Python test: NO major mode.")) + ) + + +(defun semantic-utest-Javascript() + (interactive) + (if (fboundp 'javascript-mode) + (semantic-utest-generic "Javascript" (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line") + (message "Skipping JavaScript test: NO major mode.")) + ) + +(defun semantic-utest-Java() + (interactive) + ;; If JDE is installed, it might mess things up depending on the version + ;; that was installed. + (let ((auto-mode-alist '(("\\.java\\'" . java-mode)))) + (semantic-utest-generic "Java" (semantic-utest-fname "JavaTest.java") semantic-utest-Java-buffer-contents semantic-utest-Java-name-contents '("fun2") "//1" "//deleted line") + )) + +(defun semantic-utest-Makefile() + (interactive) + (semantic-utest-generic "Makefile" (semantic-utest-fname "Makefile") semantic-utest-Makefile-buffer-contents semantic-utest-Makefile-name-contents '("fun2") "#1" "#deleted line") + ) + +(defun semantic-utest-Scheme() + (interactive) + (semantic-utest-generic "Scheme" (semantic-utest-fname "tst.scm") semantic-utest-Scheme-buffer-contents semantic-utest-Scheme-name-contents '("fun2") ";1" ";deleted line") + ) + + +(defun semantic-utest-Html() + (interactive) + ;; Disable html-helper auto-fill-in mode. + (let ((html-helper-build-new-buffer nil)) + (semantic-utest-generic "HTML" (semantic-utest-fname "tst.html") semantic-utest-Html-buffer-contents semantic-utest-Html-name-contents '("fun2") "" "") + )) + +(defun semantic-utest-PHP() + (interactive) + (if (fboundp 'php-mode) + (semantic-utest-generic "PHP" (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@") + (message "Skipping PHP Test. No php-mode loaded.")) + ) + +;look at http://mfgames.com/linux/csharp-mode +(defun semantic-utest-Csharp() ;; hmm i don't even know how to edit a scharp file. need a csharp mode implementation i suppose + (interactive) + (if (fboundp 'csharp-mode) + (semantic-utest-generic "C#" (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents semantic-utest-Csharp-name-contents '("fun2") "//1" "//deleted line") + (message "Skipping C# test. No csharp-mode loaded.")) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; stubs + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; stuff for Erlang +;;-module(hello). +;-export([hello_world/0]). +; +;hello_world()-> +; io:format("Hello World ~n"). +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;(defun semantic-utest-Erlang() +; (interactive) +; (semantic-utest-generic "Erlang" (semantic-utest-fname "tst.erl") semantic-utest-Erlang-buffer-contents semantic-utest-Erlang-name-contents '("fun2") "//1" "//deleted line") +; ) +; +;;texi is also supported +;(defun semantic-utest-Texi() +; (interactive) +; (semantic-utest-generic "texi" (semantic-utest-fname "tst.texi") semantic-utest-Texi-buffer-contents semantic-utest-Texi-name-contents '("fun2") "//1" "//deleted line") +; ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;###autoload +(defun semantic-utest-main() + (interactive) + "call all utests" + (cedet-utest-log-start "multi-lang parsing") + (cedet-utest-log " * C tests...") + (semantic-utest-C) + (cedet-utest-log " * Python tests...") + (semantic-utest-Python) + (cedet-utest-log " * Java tests...") + (semantic-utest-Java) + (cedet-utest-log " * Javascript tests...") + (semantic-utest-Javascript) + (cedet-utest-log " * Makefile tests...") + (semantic-utest-Makefile) + (cedet-utest-log " * Scheme tests...") + (semantic-utest-Scheme) + (cedet-utest-log " * Html tests...") + (semantic-utest-Html) + (cedet-utest-log " * PHP tests...") + (semantic-utest-PHP) + (cedet-utest-log " * Csharp tests...") + (semantic-utest-Csharp) + + (cedet-utest-log-shutdown "multi-lang parsing") + ) + +;;; Buffer contents validation +;; +(defun semantic-utest-match-attributes (attr1 attr2 skipnames) + "Compare attribute lists ATTR1 and ATTR2. +Argument SKIPNAMES is a list of names that may be child nodes to skip." + (let ((res t)) + (while (and res attr1 attr2) + + ;; Compare + (setq res + (cond ((and (listp (car attr1)) + (semantic-tag-p (car (car attr1)))) + ;; Compare the list of tags... + (semantic-utest-taglists-equivalent-p + (car attr2) (car attr1) skipnames) + ) + (t + (equal (car attr1) (car attr2))))) + + (if (not res) + (error "TAG INTERNAL DIFF: %S %S" + (car attr1) (car attr2))) + + (setq attr1 (cdr attr1) + attr2 (cdr attr2))) + res)) + +(defun semantic-utest-equivalent-tag-p (tag1 tag2 skipnames) + "Determine if TAG1 and TAG2 are the same. +SKIPNAMES includes lists of possible child nodes that should be missing." + (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2)) + (semantic-tag-of-class-p tag1 (semantic-tag-class tag2)) + (semantic-utest-match-attributes + (semantic-tag-attributes tag1) (semantic-tag-attributes tag2) + skipnames) + )) + +(defun semantic-utest-taglists-equivalent-p (table names skipnames) + "Compare TABLE and NAMES, where skipnames allow list1 to be different. +SKIPNAMES is a list of names that should be skipped in the NAMES list." + (let ((SN skipnames)) + (while SN + (setq names (remove (car SN) names)) + (setq SN (cdr SN)))) + (while (and names table) + (if (not (semantic-utest-equivalent-tag-p (car names) + (car table) + skipnames)) + (error "Expected %s, found %s" + (semantic-format-tag-prototype (car names)) + (semantic-format-tag-prototype (car table)))) + (setq names (cdr names) + table (cdr table))) + (when names (error "Items forgotten: %S" + (mapcar 'semantic-tag-name names) + )) + (when table (error "Items extra: %S" + (mapcar 'semantic-tag-name table))) + t) + +(defun semantic-utest-verify-names (name-contents &optional skipnames) + "Verify the names of the test buffer from NAME-CONTENTS. +Argument SKIPNAMES is a list of names that should be skipped +when analyzing the file. + +JAVE this thing would need to be recursive to handle java and csharp" + (let ((names name-contents) + (table (semantic-fetch-tags)) + ) + (semantic-utest-taglists-equivalent-p table names skipnames) + )) + +;;;;;;;;;;;;;;;;;;;;;;;; +; JAVE redefine a new validation function +; is not quite as good as the old one yet +(defun semantic-utest-verify-names-jave (name-contents &optional skipnames) + "JAVE version of `semantic-utest-verify-names'. +NAME-CONTENTS is a sample of the tags buffer to test against. +SKIPNAMES is a list of names to remove from NAME-CONTENTS" + (assert (semantic-utest-verify-names-2 name-contents (semantic-fetch-tags)) + nil "failed test") +) + +(defun semantic-utest-verify-names-2 (l1 l2) + (cond ( (and (consp l1) (equal (car l1) 'overlay)) + (overlayp l2)) + ((not (consp l1)) + (equal l1 l2)) + ((consp l1) + (and (semantic-utest-verify-names-2 (car l1) (car l2)) (semantic-utest-verify-names-2 (cdr l1) (cdr l2)))) + (t (error "internal error")))) + + + + + +;;; Kill indicator line +;; +(defvar semantic-utest-last-kill-text nil + "The text from the last kill.") + +(defvar semantic-utest-last-kill-pos nil + "The position of the last kill.") + +(defun semantic-utest-kill-indicator ( killme insertme) + "Kill the line with KILLME on it and insert INSERTME in its place." + (goto-char (point-min)) +; (re-search-forward (concat "/\\*" indicator "\\*/")); JAVE this isn't generic enough for different languages + (re-search-forward killme) + (beginning-of-line) + (setq semantic-utest-last-kill-pos (point)) + (setq semantic-utest-last-kill-text + (buffer-substring (point) (point-at-eol))) + (delete-region (point) (point-at-eol)) + (insert insertme) + (sit-for 0) +) + +(defun semantic-utest-unkill-indicator () + "Unkill the last indicator." + (goto-char semantic-utest-last-kill-pos) + (delete-region (point) (point-at-eol)) + (insert semantic-utest-last-kill-text) + (sit-for 0) + ) + +;;; EDITING TESTS +;; + +(defun semantic-utest-last-invalid (name-contents names-removed killme insertme) + "Make the last fcn invalid." + (semantic-utest-kill-indicator killme insertme) +; (semantic-utest-verify-names name-contents names-removed); verify its gone ;new validator doesn't handle skipnames yet + (semantic-utest-unkill-indicator);put back killed stuff + ) + + + + +;"#]*\\)>" +;#]*\)> +;(overlay \1 \2 "\3") + + +;; JAVE +;; these are some unit tests for cedet that I got from Eric and modified a bit for: +;; python +;; javascript +;; java +;; I tried to generalize the structure of the tests a bit to make it easier to add languages + +;; Mail from Eric: +;; Many items in the checklist look like: + +;; M-x global-semantic-highlight-edits-mode RET +;; - Edit a file. See the highlight of newly inserted text. +;; - Customize `semantic-edits-verbose-flag' to be non-nil. +;; - Wait for the idle scheduler, it should clean up the edits. +;; - observe messages from incremental parser. Do they relate +;; to the edits? +;; - M-x bovinate RET - verify your changes are reflected. + +;; It's all about watching the behavior. Timers go off, things get +;; cleaned up, you type in new changes, etc. An example I tried to +;; do is below, but covers only 1 language, and not very well at that. +;; I seem to remember seeing a unit test framework going by one of the +;; lists. I'm not sure if that would help. + +;; Another that might be automatable: + +;; M-x semantic-analyze-current-context RET +;; - Do this in different contexts in your language +;; files. Verify that reasonable results are returned +;; such as identification of assignments, function arguments, etc. + +;; Anyway, those are some ideas. Any effort you put it will be helpful! + +;; Thanks +;; Eric + +;; ----------- + + + +;;; semantic-utest.el ends here diff --cc test/manual/cedet/srecode-tests.el index f7529ecb5e3,00000000000..18beb9291fa mode 100644,000000..100644 --- a/test/manual/cedet/srecode-tests.el +++ b/test/manual/cedet/srecode-tests.el @@@ -1,296 -1,0 +1,296 @@@ +;;; srecode-tests.el --- Some tests for CEDET's srecode + - ;; Copyright (C) 2008-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2008-2016 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Extracted from srecode-fields.el and srecode-document.el in the +;; CEDET distribution. + +;;; Code: + +;;; From srecode-fields: + +(require 'srecode/fields) + +(defvar srecode-field-utest-text + "This is a test buffer. + +It is filled with some text." + "Text for tests.") + +(defun srecode-field-utest () + "Test the srecode field manager." + (interactive) + (if (featurep 'xemacs) + (message "There is no XEmacs support for SRecode Fields.") + (srecode-field-utest-impl))) + +(defun srecode-field-utest-impl () + "Implementation of the SRecode field utest." + (save-excursion + (find-file "/tmp/srecode-field-test.txt") + + (erase-buffer) + (goto-char (point-min)) + (insert srecode-field-utest-text) + (set-buffer-modified-p nil) + + ;; Test basic field generation. + (let ((srecode-field-archive nil) + (f nil)) + + (end-of-line) + (forward-word -1) + + (setq f (srecode-field "Test" + :name "TEST" + :start 6 + :end 8)) + + (when (or (not (slot-boundp f 'overlay)) (not (oref f overlay))) + (error "Field test: Overlay info not created for field")) + + (when (and (overlay-p (oref f overlay)) + (not (overlay-get (oref f overlay) 'srecode-init-only))) + (error "Field creation overlay is not tagged w/ init flag")) + + (srecode-overlaid-activate f) + + (when (or (not (overlay-p (oref f overlay))) + (overlay-get (oref f overlay) 'srecode-init-only)) + (error "New field overlay not created during activation")) + + (when (not (= (length srecode-field-archive) 1)) + (error "Field test: Incorrect number of elements in the field archive")) + (when (not (eq f (car srecode-field-archive))) + (error "Field test: Field did not auto-add itself to the field archive")) + + (when (not (overlay-get (oref f overlay) 'keymap)) + (error "Field test: Overlay keymap not set")) + + (when (not (string= "is" (srecode-overlaid-text f))) + (error "Field test: Expected field text 'is', not %s" + (srecode-overlaid-text f))) + + ;; Test deletion. + (srecode-delete f) + + (when (slot-boundp f 'overlay) + (error "Field test: Overlay not deleted after object delete")) + ) + + ;; Test basic region construction. + (let* ((srecode-field-archive nil) + (reg nil) + (fields + (list + (srecode-field "Test1" :name "TEST-1" :start 5 :end 10) + (srecode-field "Test2" :name "TEST-2" :start 15 :end 20) + (srecode-field "Test3" :name "TEST-3" :start 25 :end 30) + + (srecode-field "Test4" :name "TEST-4" :start 35 :end 35)) + )) + + (when (not (= (length srecode-field-archive) 4)) + (error "Region Test: Found %d fields. Expected 4" + (length srecode-field-archive))) + + (setq reg (srecode-template-inserted-region "REG" + :start 4 + :end 40)) + + (srecode-overlaid-activate reg) + + ;; Make sure it was cleared. + (when srecode-field-archive + (error "Region Test: Did not clear field archive")) + + ;; Auto-positioning. + (when (not (eq (point) 5)) + (error "Region Test: Did not reposition on first field")) + + ;; Active region + (when (not (eq (srecode-active-template-region) reg)) + (error "Region Test: Active region not set")) + + ;; Various sizes + (mapc (lambda (T) + (if (string= (object-name-string T) "Test4") + (progn + (when (not (srecode-empty-region-p T)) + (error "Field %s is not empty" + (object-name T))) + ) + (when (not (= (srecode-region-size T) 5)) + (error "Calculated size of %s was not 5" + (object-name T))))) + fields) + + ;; Make sure things stay up after a 'command'. + (srecode-field-post-command) + (when (not (eq (srecode-active-template-region) reg)) + (error "Region Test: Active region did not stay up")) + + ;; Test field movement. + (when (not (eq (srecode-overlaid-at-point 'srecode-field) + (nth 0 fields))) + (error "Region Test: Field %s not under point" + (object-name (nth 0 fields)))) + + (srecode-field-next) + + (when (not (eq (srecode-overlaid-at-point 'srecode-field) + (nth 1 fields))) + (error "Region Test: Field %s not under point" + (object-name (nth 1 fields)))) + + (srecode-field-prev) + + (when (not (eq (srecode-overlaid-at-point 'srecode-field) + (nth 0 fields))) + (error "Region Test: Field %s not under point" + (object-name (nth 0 fields)))) + + ;; Move cursor out of the region and have everything cleaned up. + (goto-char 42) + (srecode-field-post-command) + (when (srecode-active-template-region) + (error "Region Test: Active region did not clear on move out")) + + (mapc (lambda (T) + (when (slot-boundp T 'overlay) + (error "Overlay did not clear off of field %s" + (object-name T)))) + fields) + + ;; End of LET + ) + + ;; Test variable linkage. + (let* ((srecode-field-archive nil) + (f1 (srecode-field "Test1" :name "TEST" :start 6 :end 8)) + (f2 (srecode-field "Test2" :name "TEST" :start 28 :end 30)) + (f3 (srecode-field "Test3" :name "NOTTEST" :start 35 :end 40)) + (reg (srecode-template-inserted-region "REG" :start 4 :end 40)) + ) + (srecode-overlaid-activate reg) + + (when (not (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f2))) + (error "Linkage Test: Init strings are not =")) + (when (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f3)) + (error "Linkage Test: Init string on dissimilar fields is now the same")) + + (goto-char 7) + (insert "a") + + (when (not (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f2))) + (error "Linkage Test: mid-insert strings are not =")) + (when (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f3)) + (error "Linkage Test: mid-insert string on dissimilar fields is now the same")) + + (goto-char 9) + (insert "t") + + (when (not (string= (srecode-overlaid-text f1) "iast")) + (error "Linkage Test: tail-insert failed to captured added char")) + (when (not (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f2))) + (error "Linkage Test: tail-insert strings are not =")) + (when (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f3)) + (error "Linkage Test: tail-insert string on dissimilar fields is now the same")) + + (goto-char 6) + (insert "b") + + (when (not (string= (srecode-overlaid-text f1) "biast")) + (error "Linkage Test: tail-insert failed to captured added char")) + (when (not (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f2))) + (error "Linkage Test: tail-insert strings are not =")) + (when (string= (srecode-overlaid-text f1) + (srecode-overlaid-text f3)) + (error "Linkage Test: tail-insert string on dissimilar fields is now the same")) + + ;; Cleanup + (srecode-delete reg) + ) + + (set-buffer-modified-p nil) + + (message " All field tests passed.") + )) + +;;; From srecode-document: + +(require 'srecode/doc) + +(defun srecode-document-function-comment-extract-test () + "Test old comment extraction. +Dump out the extracted dictionary." + (interactive) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'document) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let* ((temp (srecode-template-get-table (srecode-table) + "function-comment" + "declaration" + 'document)) + (fcn-in (semantic-current-tag))) + + (if (not temp) + (error "No templates for function comments")) + + ;; Try to figure out the tag we want to use. + (when (or (not fcn-in) + (not (semantic-tag-of-class-p fcn-in 'function))) + (error "No tag of class 'function to insert comment for")) + + (let ((lextok (semantic-documentation-comment-preceding-tag fcn-in 'lex)) + ) + + (when (not lextok) + (error "No comment to attempt an extraction")) + + (let ((s (semantic-lex-token-start lextok)) + (e (semantic-lex-token-end lextok)) + (extract nil)) + + (pulse-momentary-highlight-region s e) + + ;; Extract text from the existing comment. + (setq extract (srecode-extract temp s e)) + + (with-output-to-temp-buffer "*SRECODE DUMP*" + (princ "EXTRACTED DICTIONARY FOR ") + (princ (semantic-tag-name fcn-in)) + (princ "\n--------------------------------------------\n") + (srecode-dump extract)))))) + +;;; srecode-tests.el ends here diff --cc test/manual/cedet/tests/test.c index 8f7208783ff,00000000000..0aa8852b8a9 mode 100644,000000..100644 --- a/test/manual/cedet/tests/test.c +++ b/test/manual/cedet/tests/test.c @@@ -1,242 -1,0 +1,242 @@@ +/* test.c --- Semantic unit test for C. + - Copyright (C) 2001-2015 Free Software Foundation, Inc. ++ Copyright (C) 2001-2016 Free Software Foundation, Inc. + + Author: Eric M. Ludlam + + This file is part of GNU Emacs. + + GNU Emacs is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + GNU Emacs is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GNU Emacs. If not, see . +*/ + +/* Attempt to include as many aspects of the C language as possible. + */ + +/* types of include files */ +#include "includeme1.h" +#include +#include +#include +#include +#include + +#if 0 +int dont_show_function() +{ +} +#endif + +/* Global types */ +struct mystruct1 { + int slot11; + char slot12; + float slot13; +}; + +struct mystruct2 { + int slot21; + char slot22; + float slot23; +} var_of_type_mystruct2; + +struct { + int slot31; + char slot32; + float slot33; +} var_of_anonymous_struct; + +typedef struct mystruct1 typedef_of_mystruct1; +typedef struct mystruct1 *typedef_of_pointer_mystruct1; +typedef struct { int slot_a; } typedef_of_anonymous_struct; +typedef struct A { +} B; + +typedef struct mystruct1 td1, td2; + +union myunion1 { + int slot41; + char slot42; + float slot43; +}; + +union myunion2 { + int slot51; + char slot52; + float slot53; +} var_of_type_myunion2; + +struct { + int slot61; + char slot72; + float slot83; +} var_of_anonymous_union; + +typedef union myunion1 typedef_of_myunion1; +typedef union myunion1 *typedef_of_pointer_myunion1; +typedef union { int slot_a; } typedef_of_anonymous_union; + +enum myenum1 { enum11 = 1, enum12 }; +enum myenum2 { enum21, enum22 = 2 } var_of_type_myenum2; +enum { enum31, enum32 } var_of_anonymous_enum; + +typedef enum myenum1 typedef_of_myenum1; +typedef enum myenum1 *typedef_of_pointer_myenum1; +typedef enum { enum_a = 3, enum_b } typedef_of_anonymous_enum; + +typedef int typedef_of_int; + +/* Here are some simpler variable types */ +int var1; +int varbit1:1; +char var2; +float var3; +mystruct1 var3; +struct mystruct1 var4; +union myunion1 var5; +enum myenum1 var6; + +char *varp1; +char **varp2; +char varv1[1]; +char varv2[1][2]; + +char *varpa1 = "moose"; +struct mystruct2 vara2 = { 1, 'a', 0.0 }; +enum myenum1 vara3 = enum11; +int vara4 = (int)0.0; +int vara5 = funcall(); + +int mvar1, mvar2, mvar3; +char *mvarp1, *mvarp2, *mvarp3; +char *mvarpa1 = 'a', *mvarpa2 = 'b', *mvarpa3 = 'c'; +char mvaras1[10], mvaras2[12][13], *mvaras3 = 'd'; + +static register const unsigned int tmvar1; + +#define MACRO1 1 +#define MACRO2(foo) (1+foo) + +/* Here are some function prototypes */ + +/* This is legal, but I decided not to support inferred integer + * types on functions and variables. + */ +fun0(); +int funp1(); +char funp2(int arg11); +float funp3(char arg21, char arg22); +struct mystrct1 funp4(struct mystruct2 arg31, union myunion2 arg32); +enum myenum1 funp5(char *arg41, union myunion1 *arg42); + +char funpp1 __P(char argp1, struct mystruct2 argp2, char *arg4p); + +int fun1(); + +/* Here is a function pointer */ +int (*funcptr)(int a, int b); + +/* Function Definitions */ + +/* This is legal, but I decided not to support inferred integer + * types on functions and variables. + */ +fun0() +{ + int sv = 0; +} + +int fun1 () +{ + int sv = 1; +} + +int fun1p1 (void) +{ + int sv = 1; +} + +char fun2(int arg_11) +{ + char sv = 2; +} + +float fun3(char arg_21, char arg_22) +{ + char sv = 3; +} + +struct mystrct1 fun4(struct mystruct2 arg31, union myunion2 arg32) +{ + sv = 4; +} + +enum myenum1 fun5(char *arg41, union myunion1 *arg42) +{ + sv = 5; +} + +/* Functions with K&R syntax. */ +struct mystrct1 funk1(arg_31, arg_32) + struct mystruct2 arg_31; + union myunion2 arg32; +{ + sv = 4; +} + +enum myenum1 *funk2(arg_41, arg_42) + char *arg_41; + union myunion1 *arg_42; +{ + sv = 5; + + if(foo) { + } +} + +int funk3(arg_51, arg_53) + int arg_51; + char arg_53; +{ + char q = 'a'; + int sv = 6; + td1 ms1; + enum myenum1 testconst; + + /* Function argument analysis */ + funk3(ms1.slot11, arg_53 ); + sv = 7; + + /* Slot deref on assignee */ + ms1.slot11 = s; + + /* Enum/const completion */ + testconst = e; + + /* Bad var/slot and param */ + blah.notafunction(moose); + + /* Print something. */ + printf("Moose", ); + + tan(); +} + +int funk4_fixme(arg_61, arg_62) + int arg_61, arg_62; +{ + +} + +/* End of C tests */ + diff --cc test/manual/cedet/tests/test.el index 28b97750df2,00000000000..0b8f9dee619 mode 100644,000000..100644 --- a/test/manual/cedet/tests/test.el +++ b/test/manual/cedet/tests/test.el @@@ -1,158 -1,0 +1,158 @@@ +;;; test.el --- Unit test file for Semantic Emacs Lisp support. + - ;; Copyright (C) 2005-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2005-2016 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Require +;; +(require 'semantic) +(require 'eieio "../eieio") + +;; tags encapsulated in eval-when-compile and eval-and-compile +;; should be expanded out into the outer environment. +(eval-when-compile + (require 'semantic-imenu) + ) + +(eval-and-compile + (defconst const-1 nil) + (defun function-1 (arg) + nil) + ) + +;;; Functions +;; +(defun a-defun (arg1 arg2 &optional arg3) + "doc a" + nil) + +(defun a-defun-interactive (arg1 arg2 &optional arg3) + "doc a that is a command" + (interactive "R") + nil) + +(defun* a-defun* (arg1 arg2 &optional arg3) + "doc a*" + nil) + +(defsubst a-defsubst (arg1 arg2 &optional arg3) + "doc a-subst" + nil) + +(defmacro a-defmacro (arg1 arg2 &optional arg3) + "doc a-macro" + nil) + +(define-overload a-overload (arg) + "doc a-overload" + nil) + +;;; Methods +;; +(defmethod a-method ((obj some-class) &optional arg2) + "Doc String for a method." + (call-next-method)) + +(defgeneric a-generic (arg1 arg2) + "General description of a-generic.") + +;;; Advice +;; +(defadvice existing-function-to-advise (around test activate) + "Do something special to this fcn." + (ad-do-it)) + +;;; Variables +;; +(defvar a-defvar (cons 1 2) + "Variable a") + +(defvar a-defvar-star (cons 1 2) + "*User visible var a") + +(defconst a-defconst 'a "var doc const") + +(defcustom a-defcustom nil + "*doc custom" + :group 'a-defgroup + :type 'boolean) + +(defface a-defface 'bold + "A face that is bold.") + +(defimage ezimage-page-minus + ((:type xpm :file "page-minus.xpm" :ascent center)) + "Image used for open files with stuff in them.") + +;;; Autoloads +;; +(autoload (quote a-autoload) "somefile" + "Non-interactive autoload." nil nil) + +(autoload (quote a-autoload-interactive) "somefile" +"Interactive autoload." t nil) + + +(defgroup a-defgroup nil + "Group for `emacs-lisp' regression-test") + +;;; Classes +;; +(defclass a-class (a-parent) + ((slot-1) + (slot-2 :initarg :slot-2) + (slot-3 :documentation "Doc about slot3") + (slot-4 :type 'boolean) + ) + "Doc String for class.") + +(defclass a-class-abstract () + nil + "Doc string for abstract class." + :abstract t) + +;;; Structures +;; +(defstruct (test-struct-1 :test 'equal) + (slot-1 :equal 'eq) + slot-2) + +(defstruct test-struct-2 + slot-1 + slot-2) + +;;; Semantic specific macros +;; +(define-lex a-lexer + "Doc String" + this + that) + +(define-mode-local-override a-overridden-function + emacs-lisp-mode (tag) + "A function that is overloaded." + nil) + +(defvar-mode-local emacs-lisp-mode a-mode-local-def + "some value") + + +;;; Provide +;; +(provide 'test) diff --cc test/manual/cedet/tests/test.make index ac8c599ee35,00000000000..1eb71f7ccc8 mode 100644,000000..100644 --- a/test/manual/cedet/tests/test.make +++ b/test/manual/cedet/tests/test.make @@@ -1,79 -1,0 +1,79 @@@ +# test.make --- Semantic unit test for Make -*- makefile -*- + - # Copyright (C) 2001-2002, 2010-2015 Free Software Foundation, Inc. ++# Copyright (C) 2001-2002, 2010-2016 Free Software Foundation, Inc. + +# Author: Eric M. Ludlam + +# This file is part of GNU Emacs. + +# GNU Emacs is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# GNU Emacs is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GNU Emacs. If not, see . + +top= +ede_FILES=Project.ede Makefile + +example_MISC=semantic-skel.el skeleton.bnf +init_LISP=semantic-load.el +DISTDIR=$(top)semantic-$(VERSION) + +# really goofy & variables tabs +A= B +A =B +A=B C +A=B\ + C + +A= http://${B} \ + ftp://${B} +B= test + +all: example semantic Languages tools senator semantic.info + +test ${B}: foo bar + @echo ${A} + +example: + @ + +init: $(init_LISP) + @echo "(add-to-list 'load-path nil)" > $@-compile-script + @if test ! -z "${LOADPATH}" ; then\ + for loadpath in ${LOADPATH}; do \ + echo "(add-to-list 'load-path \"$$loadpath\")" >> $@-compile-script; \ + done;\ + fi + @echo "(setq debug-on-error t)" >> $@-compile-script + $(EMACS) -batch -l $@-compile-script -f batch-byte-compile $^ + +include tesset.mk tusset.mk +include oneset.mk + +ifdef SOME_SYMBOL + VAR1 = foo +else + VAR1 = bar +endif + +ifndef SOME_OTHER_SYMBOL + VAR1 = baz +endif + +ifeq ($(VAR1), foo) + VAR2 = gleep +else + ifneq ($(VAR1), foo) + VAR2 = glop + endif +endif + +# End of Makefile diff --cc test/manual/cedet/tests/testdoublens.cpp index b503c211790,00000000000..63c4deedd08 mode 100644,000000..100644 --- a/test/manual/cedet/tests/testdoublens.cpp +++ b/test/manual/cedet/tests/testdoublens.cpp @@@ -1,166 -1,0 +1,166 @@@ +// testdoublens.cpp --- semantic-ia-utest completion engine unit tests + - // Copyright (C) 2008-2015 Free Software Foundation, Inc. ++// Copyright (C) 2008-2016 Free Software Foundation, Inc. + +// Author: Eric M. Ludlam + +// This file is part of GNU Emacs. + +// GNU Emacs is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. + +// GNU Emacs is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. + +// You should have received a copy of the GNU General Public License +// along with GNU Emacs. If not, see . + +#include "testdoublens.hpp" + +namespace Name1 { + namespace Name2 { + + Foo::Foo() + { + p// -1- + // #1# ( "pMumble" "publishStuff" ) + ; + } + + int Foo::get() // ^1^ + { + p// -2- + // #2# ( "pMumble" "publishStuff" ) + ; + return 0; + } + + void Foo::publishStuff(int /* a */, int /* b */) // ^2^ + { + } + + void Foo::sendStuff(int /* a */, int /* b */) // ^3^ + { + } + + } // namespace Name2 +} // namespace Name1 + +// Test multiple levels of metatype expansion +int test_fcn () { + stage3_Foo MyFoo; + + MyFoo.// -3- + // #3# ( "Mumble" "get" ) + ; + + Name1::Name2::F//-4- + // #4# ( "Foo" ) + ; + + // @TODO - get this working... + Name1::stage2_Foo::M//-5- + /// #5# ( "Mumble" ) + ; +} + +stage3_Foo foo_fcn() { + // Can we go "up" to foo with senator-go-to-up-reference? +} + + +// Second test from Ravikiran Rajagopal + +namespace A { + class foo { + public: + void aa(); + void bb(); + }; +} +namespace A { + class bar { + public: + void xx(); + public: + foo myFoo; + }; + + void bar::xx() + { + myFoo.// -6- <--- cursor is here after the dot + // #6# ( "aa" "bb" ) + ; + } +} + +// Double namespace example from Hannu Koivisto +// +// This is tricky because the parent class "Foo" is found within the +// scope of B, so the scope calculation needs to put that together +// before searching for parents in scope. +namespace a { + namespace b { + + class Bar : public Foo + { + int baz(); + }; + + int Bar::baz() + { + return dum// -7- + // #7# ( "dumdum" ) + ; + } + + } // namespace b +} // namespace a + +// Three namespace example from Hannu Koivisto +// +// This one is special in that the name e::Foo, where "e" is in +// the scope, and not referenced from the global namespace. This +// wasn't previously handled, so the fullscope needed to be added +// to the list of things searched when in split-name decent search mode +// for scopes. + +namespace d { + namespace e { + + class Foo + { + public: + int write(); + }; + + } // namespace d +} // namespace e + + +namespace d { + namespace f { + + class Bar + { + public: + int baz(); + + private: + e::Foo &foo; + }; + + int Bar::baz() + { + return foo.w// -8- + // #8# ( "write" ) + ; + } + + } // namespace f +} // namespace d + diff --cc test/manual/cedet/tests/testdoublens.hpp index 609ea74615e,00000000000..6d2a0f0755e mode 100644,000000..100644 --- a/test/manual/cedet/tests/testdoublens.hpp +++ b/test/manual/cedet/tests/testdoublens.hpp @@@ -1,70 -1,0 +1,70 @@@ +// testdoublens.hpp --- Header file used in one of the Semantic tests + - // Copyright (C) 2008-2015 Free Software Foundation, Inc. ++// Copyright (C) 2008-2016 Free Software Foundation, Inc. + +// Author: Eric M. Ludlam + +// This file is part of GNU Emacs. + +// GNU Emacs is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. + +// GNU Emacs is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. + +// You should have received a copy of the GNU General Public License +// along with GNU Emacs. If not, see . + +namespace Name1 { + namespace Name2 { + + class Foo + { + typedef unsigned int Mumble; + public: + Foo(); + ~Foo(); + int get(); + + private: + void publishStuff(int a, int b); + + void sendStuff(int a, int b); + + Mumble* pMumble; + }; + + typedef Foo stage1_Foo; + + } // namespace Name2 + + typedef Name2::stage1_Foo stage2_Foo; + + typedef Name2::Foo decl_stage1_Foo; + +} // namespace Name1 + +typedef Name1::stage2_Foo stage3_Foo; + + +// Double namespace from Hannu Koivisto +namespace a { + namespace b { + + class Foo + { + struct Dum { + int diDum; + }; + + protected: + mutable a::b::Foo::Dum dumdum; + }; + + } // namespace b +} // namespace a + diff --cc test/manual/cedet/tests/testjavacomp.java index d17f3049b62,00000000000..f0abfc97b06 mode 100644,000000..100644 --- a/test/manual/cedet/tests/testjavacomp.java +++ b/test/manual/cedet/tests/testjavacomp.java @@@ -1,67 -1,0 +1,67 @@@ +// testjavacomp.java --- Semantic unit test for Java + - // Copyright (C) 2009-2015 Free Software Foundation, Inc. ++// Copyright (C) 2009-2016 Free Software Foundation, Inc. + +// Author: Eric M. Ludlam + +// This file is part of GNU Emacs. + +// GNU Emacs is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. + +// GNU Emacs is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. + +// You should have received a copy of the GNU General Public License +// along with GNU Emacs. If not, see . + +package tests.testjavacomp; + +class secondClass { + private void scFuncOne() { } + public void scFuncOne() { } +} + + +public class testjavacomp { + + private int funcOne() { } + private int funcTwo() { } + private char funcThree() { } + + class nestedClass { + private void ncFuncOne() { } + public void ncFuncOne() { } + } + + public void publicFunc() { + + int i; + + i = fu// -1- + // #1# ( "funcOne" "funcTwo" ) + ; + + fu// -2- + // #2# ( "funcOne" "funcThree" "funcTwo" ) + ; + + secondClass SC; + + SC.//-3- + // #3# ( "scFuncOne" ) + ; + + nestedClass NC; + + // @todo - need to fix this? I don't know if this is legal java. + NC.// - 4- + // #4# ( "ncFuncOne" ) + ; + } + +} // testjavacomp diff --cc test/manual/cedet/tests/testpolymorph.cpp index 9195bb670c2,00000000000..94ae9d90413 mode 100644,000000..100644 --- a/test/manual/cedet/tests/testpolymorph.cpp +++ b/test/manual/cedet/tests/testpolymorph.cpp @@@ -1,130 -1,0 +1,130 @@@ +/** testpolymorph.cpp --- A sequence of polymorphism examples. + * - * Copyright (C) 2009-2015 Free Software Foundation, Inc. ++ * Copyright (C) 2009-2016 Free Software Foundation, Inc. + * + * Author: Eric M. Ludlam + * + * This file is part of GNU Emacs. + * + * GNU Emacs is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * GNU Emacs is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with GNU Emacs. If not, see . + */ + +#include + +// Test 1 - Functions w/ prototypes +namespace proto { + + int pt_func1(int arg1); + int pt_func1(int arg1) { + return 0; + } + +} + +// Test 2 - Functions w/ different arg lists. +namespace fcn_poly { + + int pm_func(void) { + return 0; + } + int pm_func(int a) { + return a; + } + int pm_func(char a) { + return int(a); + } + int pm_func(double a) { + return int(floor(a)); + } + +} + +// Test 3 - Methods w/ different arg lists. +class meth_poly { +public: + int pm_meth(void) { + return 0; + } + int pm_meth(int a) { + return a; + } + int pm_meth(char a) { + return int(a); + } + int pm_meth(double a) { + return int(floor(a)); + } + +}; + +// Test 4 - Templates w/ partial specifiers. +namespace template_partial_spec { + template class test + { + public: + void doSomething(T t) { }; + }; + + template class test + { + public: + void doSomething(T* t) { }; + }; +} + +// Test 5 - Templates w/ full specialization which may or may not share +// common functions. +namespace template_full_spec { + template class test + { + public: + void doSomething(T t) { }; + void doSomethingElse(T t) { }; + }; + + template <> class test + { + public: + void doSomethingElse(int t) { }; + void doSomethingCompletelyDifferent(int t) { }; + }; +} + +// Test 6 - Dto., but for templates with multiple parameters. +namespace template_multiple_spec { + template class test + { + public: + void doSomething(T1 t) { }; + void doSomethingElse(T2 t) { }; + }; + + template class test + { + public: + void doSomething(int t) { }; + void doSomethingElse(T2 t) { }; + }; + + template <> class test + { + public: + void doSomething(float t) { }; + void doSomethingElse(int t) { }; + void doNothing(void) { }; + }; +} + + +// End of polymorphism test file. diff --cc test/manual/cedet/tests/testspp.c index 168898a4a3e,00000000000..cfb3996db47 mode 100644,000000..100644 --- a/test/manual/cedet/tests/testspp.c +++ b/test/manual/cedet/tests/testspp.c @@@ -1,102 -1,0 +1,102 @@@ +/* testspp.cpp --- Semantic unit test for the C preprocessor + - Copyright (C) 2007-2015 Free Software Foundation, Inc. ++ Copyright (C) 2007-2016 Free Software Foundation, Inc. + + Author: Eric M. Ludlam + + This file is part of GNU Emacs. + + GNU Emacs is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + GNU Emacs is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GNU Emacs. If not, see . +*/ + +int some_fcn (){} + + +#ifndef MOOSE +int pre_show_moose(){} +#endif + +#ifdef MOOSE +int pre_dont_show_moose(){} +#endif + +#if !defined(MOOSE) +int pre_show_moose_if(){} +#endif + +#if defined(MOOSE) +int pre_dont_show_moose_if(){} +#endif + +#define MOOSE + +#if 0 +int dont_show_function_if_0(){} +#endif + +#if 1 +int show_function_if_1(){} +#endif + +#ifdef MOOSE +int moose_function(){} +#endif + +#ifndef MOOSE +int dont_show_moose(){} +#endif + +#if defined(MOOSE) +int moose_function_if(){} +#endif + +#if !defined(MOOSE) +int dont_show_moose_if() {} +#endif + +#undef MOOSE + +#ifdef MOOSE +int no_handy_moose(){} +#endif + +#ifndef MOOSE +int show_moose_else() {} +#else +int no_show_moose_else(){} +#endif + + +#ifdef MOOSE +int no_show_moose_else_2() {} +#else +int show_moose_else_2() {} +#endif + +#if defined(MOOSE) +int no_show_moose_elif() {} +#elif !defined(MOOSE) +int show_moose_elif() {} +#else +int no_show_moose_elif_else() {} +#endif + +#if defined(MOOSE) +int no_show_moose_if_elif_2() {} +#elif defined(COW) +int no_show_moose_elif_2() {} +#else +int show_moose_elif_else() {} +#endif + diff --cc test/manual/cedet/tests/testsppreplace.c index e831ea152e5,00000000000..fbbaa75fee1 mode 100644,000000..100644 --- a/test/manual/cedet/tests/testsppreplace.c +++ b/test/manual/cedet/tests/testsppreplace.c @@@ -1,154 -1,0 +1,154 @@@ +/* testsppreplace.c --- unit test for CPP/SPP Replacement - Copyright (C) 2007-2015 Free Software Foundation, Inc. ++ Copyright (C) 2007-2016 Free Software Foundation, Inc. + + Author: Eric M. Ludlam + + This file is part of GNU Emacs. + + GNU Emacs is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + GNU Emacs is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GNU Emacs. If not, see . +*/ + +/* TEST: The EMU keyword doesn't screw up the function defn. */ +#define EMU +#define EMU2 /*comment*/ +char EMU parse_around_emu EMU2 (EMU) +{ +} + +/* TEST: A simple word can be replaced in a definition. */ +#define SUBFLOAT /* Some Float */ float +SUBFLOAT returnanfloat() +{ +} + +/* TEST: Punctuation an be replaced in a definition. */ +#define COLON : +int foo COLON COLON bar () +{ +} + +/* TEST: Multiple lexical characters in a definition */ +#define SUPER mysuper:: +int SUPER baz () +{ +} + +/* TEST: Macro replacement. */ +#define INT_FCN(name) int name (int in) + +INT_FCN(increment) { + return in+1; +} + +/* TEST: Macro replacement with complex args */ +#define P_(proto) () + +int myFcn1 P_((a,b)); + +#define P__(proto) proto + +int myFcn2 P__((int a, int b)); +int myFcn3 (int a, int b); + +/* TEST: Multiple args to a macro. */ +#define MULTI_ARGS(name, field1, field2, field3) struct name { int field1; int field2; int field3; } + +MULTI_ARGS(ma_struct, moose, penguin, emu); + +/* TEST: Macro w/ args, but no body. */ +#define NO_BODY(name) + +NO_BODY(Moose); + +/* TEST: Not a macro with args, but close. */ +#define NOT_WITH_ARGS (moose) + +int not_with_args_fcn NOT_WITH_ARGS +{ +} + +/* TEST: macro w/ continuation. */ +#define WITH_CONT \ + continuation_symbol + +int WITH_CONT () { }; + +/* TEST: macros in a macro - tail processing */ +#define tail_with_args_and_long_name(a) (int a) +#define int_arg tail_with_args_and_long_name + +int tail int_arg(q) {} + +/* TEST: macros used improperly. */ +#define tail_fail tail_with_args_and_long_name(q) + +int tail_fcn tail_fail(q); + +/* TEST: feature of CPP from LSD */ +#define __gthrw_(name) __gthrw_ ## name + +int __gthrw_(foo) (int arg1) { } + +/* TEST: macros using macros */ +#define macro_foo foo +#define mf_declare int macro_foo + +mf_declare; + +/* TEST: macros with args using macros */ +#define Amacro(A) (int A) +#define mf_Amacro(B) int B Amacro(B) + +mf_Amacro(noodle); + +/* TEST: Double macro using the argument stack. */ +#define MACRO0(name) int that_ ## name(int i); +#define MACRO1(name) int this_ ## name(int i); +#define MACRO2(name) MACRO0(name) MACRO1(name) + +MACRO2(foo) + +/* TEST: The G++ namespace macro hack. Not really part of SPP. */ +_GLIBCXX_BEGIN_NAMESPACE(baz) + + int bazfnc(int b) { } + +_GLIBCXX_END_NAMESPACE; + +_GLIBCXX_BEGIN_NESTED_NAMESPACE(foo,bar) + + int foo_bar_func(int a) { } + +_GLIBCXX_END_NESTED_NAMESPACE; + + +/* TEST: The VC++ macro hack. */ +_STD_BEGIN + + int inside_std_namespace(int a) { } + +_STD_END + +/* TEST: Recursion prevention. CPP doesn't allow even 1 level of recursion. */ +#define STARTMACRO MACROA +#define MACROA MACROB +#define MACROB MACROA + +int STARTMACRO () { + +} + + +/* END */ + diff --cc test/manual/cedet/tests/testsppreplaced.c index bb6a5522cf1,00000000000..8cbe05bd4f7 mode 100644,000000..100644 --- a/test/manual/cedet/tests/testsppreplaced.c +++ b/test/manual/cedet/tests/testsppreplaced.c @@@ -1,117 -1,0 +1,117 @@@ +/* testsppreplaced.c --- unit test for CPP/SPP Replacement - Copyright (C) 2007-2015 Free Software Foundation, Inc. ++ Copyright (C) 2007-2016 Free Software Foundation, Inc. + + Author: Eric M. Ludlam + + This file is part of GNU Emacs. + + GNU Emacs is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + GNU Emacs is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GNU Emacs. If not, see . +*/ + +/* What the SPP replace file would looklike with MACROS replaced: */ + +/* TEST: The EMU keyword doesn't screw up the function defn. */ +char parse_around_emu () +{ +} + +/* TEST: A simple word can be replaced in a definition. */ +float returnanfloat() +{ +} + +/* TEST: Punctuation an be replaced in a definition. */ +int foo::bar () +{ +} + +/* TEST: Multiple lexical characters in a definition */ +int mysuper::baz () +{ +} + +/* TEST: Macro replacement. */ +int increment (int in) { + return in+1; +} + +/* TEST: Macro replacement with complex args */ +int myFcn1 (); + +int myFcn2 (int a, int b); +int myFcn3 (int a, int b); + +/* TEST: Multiple args to a macro. */ +struct ma_struct { int moose; int penguin; int emu; }; + +/* TEST: Macro w/ args, but no body. */ + +/* TEST: Not a macro with args, but close. */ +int not_with_args_fcn (moose) +{ +} + +/* TEST: macro w/ continuation. */ +int continuation_symbol () { }; + +/* TEST: macros in a macro - tail processing */ + +int tail (int q) {} + +/* TEST: macros used improperly */ + +int tail_fcn(int q); + +/* TEST: feature of CPP from LSD */ + +int __gthrw_foo (int arg1) { } + +/* TEST: macros using macros */ +int foo; + +/* TEST: macros with args using macros */ +int noodle(int noodle); + +/* TEST: Double macro using the argument stack. */ +int that_foo(int i); +int this_foo(int i); + +/* TEST: The G++ namespace macro hack. Not really part of SPP. */ +namespace baz { + + int bazfnc(int b) { } + +} + +namespace foo { namespace bar { + + int foo_bar_func(int a) { } + + } +} + +/* TEST: The VC++ macro hack. */ +namespace std { + + int inside_std_namespace(int a) { } + +} + +/* TEST: Recursion prevention. CPP doesn't allow even 1 level of recursion. */ +int MACROA () { + +} + + +/* End */ diff --cc test/manual/cedet/tests/testsubclass.cpp index 6dee867b794,00000000000..2cb9e763888 mode 100644,000000..100644 --- a/test/manual/cedet/tests/testsubclass.cpp +++ b/test/manual/cedet/tests/testsubclass.cpp @@@ -1,249 -1,0 +1,249 @@@ +// testsubclass.cpp --- unit test for analyzer and complex C++ inheritance + - // Copyright (C) 2007-2015 Free Software Foundation, Inc. ++// Copyright (C) 2007-2016 Free Software Foundation, Inc. + +// Author: Eric M. Ludlam + +// This file is part of GNU Emacs. + +// GNU Emacs is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. + +// GNU Emacs is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. + +// You should have received a copy of the GNU General Public License +// along with GNU Emacs. If not, see . + +//#include +#include "testsubclass.hh" + +void animal::moose::setFeet(int numfeet) //^1^ +{ + if (numfeet > 4) { + std::cerr << "Why would a moose have more than 4 feet?" << std::endl; + return; + } + + fFeet = numfeet; +} + +int animal::moose::getFeet() //^2^ +{ + return fFeet; +} + +void animal::moose::doNothing() //^3^ +{ + animal::moose foo(); + + fFeet = N// -15- + ; // #15# ( "NAME1" "NAME2" "NAME3" ) +} + + +void deer::moose::setAntlers(bool have_antlers) //^4^ +{ + fAntlers = have_antlers; +} + +bool deer::moose::getAntlers() //^5^ +// %1% ( ( "testsubclass.cpp" "testsubclass.hh" ) ( "deer::moose::doSomething" "deer::moose::getAntlers" "moose" ) ) +{ + return fAntlers; +} + +bool i_dont_have_symrefs() +// %2% ( ("testsubclass.cpp" ) ("i_dont_have_symrefs")) +{ +} + +void deer::moose::doSomething() //^6^ +{ + // All these functions should be identified by semantic analyzer. + getAntlers(); + setAntlers(true); + + getFeet(); + setFeet(true); + + doNothing(); + + fSomeField = true; + + fIsValid = true; +} + +void deer::alces::setLatin(bool l) { + fLatin = l; +} + +bool deer::alces::getLatin() { + return fLatin; +} + +void deer::alces::doLatinStuff(moose moosein) { + // All these functions should be identified by semantic analyzer. + getFeet(); + setFeet(true); + + getLatin(); + setLatin(true); + + doNothing(); + + deer::moose foo(); + + +} + +moose deer::alces::createMoose() +{ + moose MooseVariableName; + bool tmp; + int itmp; + bool fool; + int fast; + + MooseVariableName = createMoose(); + + doLatinStuff(MooseVariableName); + + tmp = this.f// -1- + // #1# ( "fAlcesBool" "fIsValid" "fLatin" ) + ; + + itmp = this.f// -2- + // #2# ( "fAlcesInt" "fGreek" "fIsProtectedInt" ) + ; + + tmp = f// -3- + // #3# ( "fAlcesBool" "fIsValid" "fLatin" "fool" ) + ; + + itmp = f// -4- + // #4# ( "fAlcesInt" "fGreek" "fIsProtectedInt" "fast" ) + ; + + MooseVariableName = m// -5- + // #5# ( "moose" ) + + return MooseVariableName; +} + +/** Test Scope Changes + * + * This function is rigged to make sure the scope changes to account + * for different locations in local variable parsing. + */ +int someFunction(int mPickle) +{ + moose mMoose = deer::alces::createMoose(); + + if (mPickle == 1) { + + int mOption1 = 2; + + m// -5- + // #5# ( "mMoose" "mOption1" "mPickle" ) + ; + + } else { + + int mOption2 = 2; + + m// -6- + // #6# ( "mMoose" "mOption2" "mPickle" ) + ; + } + +} + +// Thanks Ming-Wei Chang for this next example. + +namespace pub_priv { + + class A{ + private: + void private_a(){} + public: + void public_a(); + }; + + void A::public_a() { + A other_a; + + other_a.p// -7- + // #7# ( "private_a" "public_a" ) + ; + } + + int some_regular_function(){ + A a; + a.p// -8- + // #8# ( "public_a" ) + ; + return 0; + } + +} + + +/** Test Scope w/in a function (non-method) with classes using + * different levels of inheritance. + */ +int otherFunction() +{ + sneaky::antelope Antelope(1); + sneaky::jackalope Jackalope(1); + sneaky::bugalope Bugalope(1); + + Antelope.// -9- + // #9# ( "fAntyPublic" "fQuadPublic" "testAccess") + ; + + Jackalope.// -10- + // #10# ( "fBunnyPublic" "testAccess") + ; + + Jackalope// @1@ 6 + ; + Jackalope; + Jackalope; + Jackalope; + + Bugalope.// -11- + // #11# ( "fBugPublic" "testAccess") + ; + Bugalope// @2@ 3 + ; +} + +/** Test methods within each class for types of access to the baseclass. + */ + +bool sneaky::antelope::testAccess() //^7^ +{ + this.// -12- + // #12# ( "fAntyPrivate" "fAntyProtected" "fAntyPublic" "fQuadProtected" "fQuadPublic" "testAccess" ) + ; +} + +bool sneaky::jackalope::testAccess() //^8^ +{ + this.// -13- + // #13# ( "fBunnyPrivate" "fBunnyProtected" "fBunnyPublic" "fQuadProtected" "fQuadPublic" "testAccess" ) + ; +} + +bool sneaky::bugalope::testAccess() //^9^ +{ + this.// -14- + // #14# ( "fBugPrivate" "fBugProtected" "fBugPublic" "fQuadPublic" "testAccess" ) + ; +} + diff --cc test/manual/cedet/tests/testsubclass.hh index 13e907da887,00000000000..7c93f8ec02d mode 100644,000000..100644 --- a/test/manual/cedet/tests/testsubclass.hh +++ b/test/manual/cedet/tests/testsubclass.hh @@@ -1,191 -1,0 +1,191 @@@ +// testsubclass.hh --- unit test for analyzer and complex C++ inheritance + - // Copyright (C) 2007-2015 Free Software Foundation, Inc. ++// Copyright (C) 2007-2016 Free Software Foundation, Inc. + +// Author: Eric M. Ludlam + +// This file is part of GNU Emacs. + +// GNU Emacs is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. + +// GNU Emacs is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. + +// You should have received a copy of the GNU General Public License +// along with GNU Emacs. If not, see . + +//#include +// #include + +#ifndef TESTSUBCLASS_HH +#define TESTSUBCLASS_HH + +namespace animal { + + class moose { + public: + moose() : fFeet(0), + fIsValid(false) + { } + + virtual void setFeet(int); + int getFeet(); + + void doNothing(); + + enum moose_enum { + NAME1, NAME2, NAME3 }; + + + protected: + + bool fIsValid; + int fIsProtectedInt; + + private: + int fFeet; // Usually 2 or 4. + bool fIsPrivateBool; + + }; // moose + + int two_prototypes(); + int two_prototypes(); + + class quadruped { + public: + quadruped(int a) : fQuadPrivate(a) + { } + + int fQuadPublic; + + protected: + int fQuadProtected; + + private: + int fQuadPrivate; + + }; + +} + + +namespace deer { + + class moose : public animal::moose { + public: + moose() : fAntlers(false) + { } + + void setAntlers(bool); + bool getAntlers(); + + void doSomething(); + + protected: + + bool fSomeField; + + private: + bool fAntlers; + + }; + +} // deer + +// A second namespace of the same name will test the +// namespace merging needed to resolve deer::alces +namespace deer { + + class alces : public animal::moose { + public: + alces(int lat) : fLatin(lat) + { } + + void setLatin(bool); + bool getLatin(); + + void doLatinStuff(moose moosein); // for completion testing + + moose createMoose(); // for completion testing. + + protected: + bool fAlcesBool; + int fAlcesInt; + + private: + bool fLatin; + int fGreek; + }; + +}; + +// A third namespace with classes that does protected and private inheritance. +namespace sneaky { + + class antelope : public animal::quadruped { + + public: + antelope(int a) : animal::quadruped(), + fAntyProtected(a) + {} + + int fAntyPublic; + + bool testAccess(); + + protected: + int fAntyProtected; + + private : + int fAntyPrivate; + + }; + + class jackalope : protected animal::quadruped { + + public: + jackalope(int a) : animal::quadruped(), + fBunny(a) + {} + + int fBunnyPublic; + + bool testAccess(); + + protected: + bool fBunnyProtected; + + private : + bool fBunnyPrivate; + + }; + + // Nothing specified means private. + class bugalope : /* private*/ animal::quadruped { + + public: + bugalope(int a) : animal::quadruped(), + fBug(a) + {} + + int fBugPublic; + + bool testAccess(); + protected: + bool fBugProtected; + + private : + bool fBugPrivate; + + }; + + +}; + +#endif + diff --cc test/manual/cedet/tests/testtypedefs.cpp index fa94af3596f,00000000000..312a77f0058 mode 100644,000000..100644 --- a/test/manual/cedet/tests/testtypedefs.cpp +++ b/test/manual/cedet/tests/testtypedefs.cpp @@@ -1,81 -1,0 +1,81 @@@ +// testtypedefs.cpp --- Sample with some fake bits out of std::string + - // Copyright (C) 2008-2015 Free Software Foundation, Inc. ++// Copyright (C) 2008-2016 Free Software Foundation, Inc. + +// Author: Eric M. Ludlam + +// This file is part of GNU Emacs. + +// GNU Emacs is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. + +// GNU Emacs is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. + +// You should have received a copy of the GNU General Public License +// along with GNU Emacs. If not, see . + +// Thanks Ming-Wei Chang for these examples. + +namespace std { + template class basic_string { + public: + void resize(int); + }; +} + +typedef std::basic_string mstring; + +using namespace std; +typedef basic_string bstring; + +int main(){ + mstring a; + a.// -1- + ; + // #1# ( "resize" ) + bstring b; + // It doesn't work here. + b.// -2- + ; + // #2# ( "resize" ) + return 0; +} + +// ------------------ + +class Bar +{ +public: + void someFunc() {} +}; + +typedef Bar new_Bar; + +template +class TBar +{ +public: + void otherFunc() {} +}; + +typedef TBar new_TBar; + +int main() +{ + new_Bar nb; + new_TBar ntb; + + nb.// -3- + ; + // #3# ("someFunc") + ntb.// -4- + ; + // #4# ("otherFunc") + return 0; +} + diff --cc test/manual/cedet/tests/testvarnames.c index f08b773bd4b,00000000000..419361d1dbc mode 100644,000000..100644 --- a/test/manual/cedet/tests/testvarnames.c +++ b/test/manual/cedet/tests/testvarnames.c @@@ -1,90 -1,0 +1,90 @@@ +/* testvarnames.cpp + Test variable and function names, lists of variables on one line, etc. + - Copyright (C) 2008-2015 Free Software Foundation, Inc. ++ Copyright (C) 2008-2016 Free Software Foundation, Inc. + + Author: Eric M. Ludlam + + This file is part of GNU Emacs. + + GNU Emacs is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + GNU Emacs is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GNU Emacs. If not, see . +*/ + +struct independent { + int indep_1; + int indep_2; +}; + +struct independent var_indep_struct; + +struct { + int unnamed_1; + int unnamed_2; +} var_unnamed_struct; + +struct { + int unnamed_3; + int unnamed_4; +} var_un_2, var_un_3; + +struct inlinestruct { + int named_1; + int named_2; +} var_named_struct; + +struct inline2struct { + int named_3; + int named_4; +} var_n_2, var_n_3; + +/* Structures with names that then declare variables + * should also be completable. + * + * Getting this to work is the bugfix in semantic-c.el CVS v 1.122 + */ +struct inlinestruct in_var1; +struct inline2struct in_var2; + +int test_1(int var_arg1) { + + var_// -1- + ; // #1# ("var_arg1" "var_indep_struct" "var_n_2" "var_n_3" "var_named_struct" "var_un_2" "var_un_3" "var_unnamed_struct") + + var_indep_struct.// -2- + ; // #2# ( "indep_1" "indep_2" ) + + var_unnamed_struct.// -3- + ; // #3# ( "unnamed_1" "unnamed_2" ) + + var_named_struct.// -4- + ; // #4# ( "named_1" "named_2" ) + + var_un_2.// -5- + ; // #5# ( "unnamed_3" "unnamed_4" ) + var_un_3.// -6- + ; // #6# ( "unnamed_3" "unnamed_4" ) + + var_n_2.// -7- + ; // #7# ( "named_3" "named_4" ) + var_n_3.// -8- + ; // #8# ( "named_3" "named_4" ) + + in_// -9- + ; // #9# ( "in_var1" "in_var2" ) + + in_var1.// -10- + ; // #10# ( "named_1" "named_2") + in_var2.// -11- + ; // #11# ( "named_3" "named_4") +} diff --cc test/manual/etags/c-src/abbrev.c index f30986db343,00000000000..b7d137cd9bd mode 100644,000000..100644 --- a/test/manual/etags/c-src/abbrev.c +++ b/test/manual/etags/c-src/abbrev.c @@@ -1,616 -1,0 +1,617 @@@ +/* Primitives for word-abbrev mode. - Copyright (C) 1985, 1986, 1993, 1996, 1998 Free Software Foundation, Inc. ++ Copyright (C) 1985-1986, 1993, 1996, 1998, 2016 Free Software ++ Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include +#include +#include "lisp.h" +#include "commands.h" +#include "buffer.h" +#include "window.h" +#include "charset.h" +#include "syntax.h" + +/* An abbrev table is an obarray. + Each defined abbrev is represented by a symbol in that obarray + whose print name is the abbreviation. + The symbol's value is a string which is the expansion. + If its function definition is non-nil, it is called + after the expansion is done. + The plist slot of the abbrev symbol is its usage count. */ + +/* List of all abbrev-table name symbols: + symbols whose values are abbrev tables. */ + +Lisp_Object Vabbrev_table_name_list; + +/* The table of global abbrevs. These are in effect + in any buffer in which abbrev mode is turned on. */ + +Lisp_Object Vglobal_abbrev_table; + +/* The local abbrev table used by default (in Fundamental Mode buffers) */ + +Lisp_Object Vfundamental_mode_abbrev_table; + +/* Set nonzero when an abbrev definition is changed */ + +int abbrevs_changed; + +int abbrev_all_caps; + +/* Non-nil => use this location as the start of abbrev to expand + (rather than taking the word before point as the abbrev) */ + +Lisp_Object Vabbrev_start_location; + +/* Buffer that Vabbrev_start_location applies to */ +Lisp_Object Vabbrev_start_location_buffer; + +/* The symbol representing the abbrev most recently expanded */ + +Lisp_Object Vlast_abbrev; + +/* A string for the actual text of the abbrev most recently expanded. + This has more info than Vlast_abbrev since case is significant. */ + +Lisp_Object Vlast_abbrev_text; + +/* Character address of start of last abbrev expanded */ + +int last_abbrev_point; + +/* Hook to run before expanding any abbrev. */ + +Lisp_Object Vpre_abbrev_expand_hook, Qpre_abbrev_expand_hook; + +DEFUN ("make-abbrev-table", Fmake_abbrev_table, Smake_abbrev_table, 0, 0, 0, + "Create a new, empty abbrev table object.") + () +{ + return Fmake_vector (make_number (59), make_number (0)); +} + +DEFUN ("clear-abbrev-table", Fclear_abbrev_table, Sclear_abbrev_table, 1, 1, 0, + "Undefine all abbrevs in abbrev table TABLE, leaving it empty.") + (table) + Lisp_Object table; +{ + int i, size; + + CHECK_VECTOR (table, 0); + size = XVECTOR (table)->size; + abbrevs_changed = 1; + for (i = 0; i < size; i++) + XVECTOR (table)->contents[i] = make_number (0); + return Qnil; +} + +DEFUN ("define-abbrev", Fdefine_abbrev, Sdefine_abbrev, 3, 5, 0, + "Define an abbrev in TABLE named NAME, to expand to EXPANSION and call HOOK.\n\ +NAME must be a string.\n\ +EXPANSION should usually be a string.\n\ +To undefine an abbrev, define it with EXPANSION = nil.\n\ +If HOOK is non-nil, it should be a function of no arguments;\n\ +it is called after EXPANSION is inserted.\n\ +If EXPANSION is not a string, the abbrev is a special one,\n\ + which does not expand in the usual way but only runs HOOK.\n\ +COUNT, if specified, initializes the abbrev's usage-count\n\ +which is incremented each time the abbrev is used.") + (table, name, expansion, hook, count) + Lisp_Object table, name, expansion, hook, count; +{ + Lisp_Object sym, oexp, ohook, tem; + CHECK_VECTOR (table, 0); + CHECK_STRING (name, 1); + + if (NILP (count)) + count = make_number (0); + else + CHECK_NUMBER (count, 0); + + sym = Fintern (name, table); + + oexp = XSYMBOL (sym)->value; + ohook = XSYMBOL (sym)->function; + if (!((EQ (oexp, expansion) + || (STRINGP (oexp) && STRINGP (expansion) + && (tem = Fstring_equal (oexp, expansion), !NILP (tem)))) + && + (EQ (ohook, hook) + || (tem = Fequal (ohook, hook), !NILP (tem))))) + abbrevs_changed = 1; + + Fset (sym, expansion); + Ffset (sym, hook); + Fsetplist (sym, count); + + return name; +} + +DEFUN ("define-global-abbrev", Fdefine_global_abbrev, Sdefine_global_abbrev, 2, 2, + "sDefine global abbrev: \nsExpansion for %s: ", + "Define ABBREV as a global abbreviation for EXPANSION.") + (abbrev, expansion) + Lisp_Object abbrev, expansion; +{ + Fdefine_abbrev (Vglobal_abbrev_table, Fdowncase (abbrev), + expansion, Qnil, make_number (0)); + return abbrev; +} + +DEFUN ("define-mode-abbrev", Fdefine_mode_abbrev, Sdefine_mode_abbrev, 2, 2, + "sDefine mode abbrev: \nsExpansion for %s: ", + "Define ABBREV as a mode-specific abbreviation for EXPANSION.") + (abbrev, expansion) + Lisp_Object abbrev, expansion; +{ + if (NILP (current_buffer->abbrev_table)) + error ("Major mode has no abbrev table"); + + Fdefine_abbrev (current_buffer->abbrev_table, Fdowncase (abbrev), + expansion, Qnil, make_number (0)); + return abbrev; +} + +DEFUN ("abbrev-symbol", Fabbrev_symbol, Sabbrev_symbol, 1, 2, 0, + "Return the symbol representing abbrev named ABBREV.\n\ +This symbol's name is ABBREV, but it is not the canonical symbol of that name;\n\ +it is interned in an abbrev-table rather than the normal obarray.\n\ +The value is nil if that abbrev is not defined.\n\ +Optional second arg TABLE is abbrev table to look it up in.\n\ +The default is to try buffer's mode-specific abbrev table, then global table.") + (abbrev, table) + Lisp_Object abbrev, table; +{ + Lisp_Object sym; + CHECK_STRING (abbrev, 0); + if (!NILP (table)) + sym = Fintern_soft (abbrev, table); + else + { + sym = Qnil; + if (!NILP (current_buffer->abbrev_table)) + sym = Fintern_soft (abbrev, current_buffer->abbrev_table); + if (NILP (XSYMBOL (sym)->value)) + sym = Qnil; + if (NILP (sym)) + sym = Fintern_soft (abbrev, Vglobal_abbrev_table); + } + if (NILP (XSYMBOL (sym)->value)) return Qnil; + return sym; +} + +DEFUN ("abbrev-expansion", Fabbrev_expansion, Sabbrev_expansion, 1, 2, 0, + "Return the string that ABBREV expands into in the current buffer.\n\ +Optionally specify an abbrev table as second arg;\n\ +then ABBREV is looked up in that table only.") + (abbrev, table) + Lisp_Object abbrev, table; +{ + Lisp_Object sym; + sym = Fabbrev_symbol (abbrev, table); + if (NILP (sym)) return sym; + return Fsymbol_value (sym); +} + +/* Expand the word before point, if it is an abbrev. + Returns 1 if an expansion is done. */ + +DEFUN ("expand-abbrev", Fexpand_abbrev, Sexpand_abbrev, 0, 0, "", + "Expand the abbrev before point, if there is an abbrev there.\n\ +Effective when explicitly called even when `abbrev-mode' is nil.\n\ +Returns the abbrev symbol, if expansion took place.") + () +{ + register char *buffer, *p; + int wordstart, wordend; + register int wordstart_byte, wordend_byte, idx; + int whitecnt; + int uccount = 0, lccount = 0; + register Lisp_Object sym; + Lisp_Object expansion, hook, tem; + Lisp_Object value; + + value = Qnil; + + if (!NILP (Vrun_hooks)) + call1 (Vrun_hooks, Qpre_abbrev_expand_hook); + + wordstart = 0; + if (!(BUFFERP (Vabbrev_start_location_buffer) + && XBUFFER (Vabbrev_start_location_buffer) == current_buffer)) + Vabbrev_start_location = Qnil; + if (!NILP (Vabbrev_start_location)) + { + tem = Vabbrev_start_location; + CHECK_NUMBER_COERCE_MARKER (tem, 0); + wordstart = XINT (tem); + Vabbrev_start_location = Qnil; + if (wordstart < BEGV || wordstart > ZV) + wordstart = 0; + if (wordstart && wordstart != ZV) + { + wordstart_byte = CHAR_TO_BYTE (wordstart); + if (FETCH_BYTE (wordstart_byte) == '-') + del_range (wordstart, wordstart + 1); + } + } + if (!wordstart) + wordstart = scan_words (PT, -1); + + if (!wordstart) + return value; + + wordstart_byte = CHAR_TO_BYTE (wordstart); + wordend = scan_words (wordstart, 1); + if (!wordend) + return value; + + if (wordend > PT) + wordend = PT; + + wordend_byte = CHAR_TO_BYTE (wordend); + whitecnt = PT - wordend; + if (wordend <= wordstart) + return value; + + p = buffer = (char *) alloca (wordend_byte - wordstart_byte); + + for (idx = wordstart_byte; idx < wordend_byte; idx++) + { + /* ??? This loop needs to go by characters! */ + register int c = FETCH_BYTE (idx); + if (UPPERCASEP (c)) + c = DOWNCASE (c), uccount++; + else if (! NOCASEP (c)) + lccount++; + *p++ = c; + } + + if (VECTORP (current_buffer->abbrev_table)) + sym = oblookup (current_buffer->abbrev_table, buffer, + wordend - wordstart, wordend_byte - wordstart_byte); + else + XSETFASTINT (sym, 0); + if (INTEGERP (sym) || NILP (XSYMBOL (sym)->value)) + sym = oblookup (Vglobal_abbrev_table, buffer, + wordend - wordstart, wordend_byte - wordstart_byte); + if (INTEGERP (sym) || NILP (XSYMBOL (sym)->value)) + return value; + + if (INTERACTIVE && !EQ (minibuf_window, selected_window)) + { + /* Add an undo boundary, in case we are doing this for + a self-inserting command which has avoided making one so far. */ + SET_PT (wordend); + Fundo_boundary (); + } + + Vlast_abbrev_text + = Fbuffer_substring (make_number (wordstart), make_number (wordend)); + + /* Now sym is the abbrev symbol. */ + Vlast_abbrev = sym; + value = sym; + last_abbrev_point = wordstart; + + if (INTEGERP (XSYMBOL (sym)->plist)) + XSETINT (XSYMBOL (sym)->plist, + XINT (XSYMBOL (sym)->plist) + 1); /* Increment use count */ + + /* If this abbrev has an expansion, delete the abbrev + and insert the expansion. */ + expansion = XSYMBOL (sym)->value; + if (STRINGP (expansion)) + { + SET_PT (wordstart); + + del_range_both (wordstart, wordstart_byte, wordend, wordend_byte, 1); + + insert_from_string (expansion, 0, 0, XSTRING (expansion)->size, + STRING_BYTES (XSTRING (expansion)), 1); + SET_PT (PT + whitecnt); + + if (uccount && !lccount) + { + /* Abbrev was all caps */ + /* If expansion is multiple words, normally capitalize each word */ + /* This used to be if (!... && ... >= ...) Fcapitalize; else Fupcase + but Megatest 68000 compiler can't handle that */ + if (!abbrev_all_caps) + if (scan_words (PT, -1) > scan_words (wordstart, 1)) + { + Fupcase_initials_region (make_number (wordstart), + make_number (PT)); + goto caped; + } + /* If expansion is one word, or if user says so, upcase it all. */ + Fupcase_region (make_number (wordstart), make_number (PT)); + caped: ; + } + else if (uccount) + { + /* Abbrev included some caps. Cap first initial of expansion */ + int pos = wordstart_byte; + + /* Find the initial. */ + while (pos < PT_BYTE + && SYNTAX (*BUF_BYTE_ADDRESS (current_buffer, pos)) != Sword) + pos++; + + /* Change just that. */ + pos = BYTE_TO_CHAR (pos); + Fupcase_initials_region (make_number (pos), make_number (pos + 1)); + } + } + + hook = XSYMBOL (sym)->function; + if (!NILP (hook)) + { + Lisp_Object expanded, prop; + + /* If the abbrev has a hook function, run it. */ + expanded = call0 (hook); + + /* In addition, if the hook function is a symbol with a a + non-nil `no-self-insert' property, let the value it returned + specify whether we consider that an expansion took place. If + it returns nil, no expansion has been done. */ + + if (SYMBOLP (hook) + && NILP (expanded) + && (prop = Fget (hook, intern ("no-self-insert")), + !NILP (prop))) + value = Qnil; + } + + return value; +} + +DEFUN ("unexpand-abbrev", Funexpand_abbrev, Sunexpand_abbrev, 0, 0, "", + "Undo the expansion of the last abbrev that expanded.\n\ +This differs from ordinary undo in that other editing done since then\n\ +is not undone.") + () +{ + int opoint = PT; + int adjust = 0; + if (last_abbrev_point < BEGV + || last_abbrev_point > ZV) + return Qnil; + SET_PT (last_abbrev_point); + if (STRINGP (Vlast_abbrev_text)) + { + /* This isn't correct if Vlast_abbrev->function was used + to do the expansion */ + Lisp_Object val; + int zv_before; + + val = XSYMBOL (Vlast_abbrev)->value; + if (!STRINGP (val)) + error ("value of abbrev-symbol must be a string"); + zv_before = ZV; + del_range_byte (PT_BYTE, PT_BYTE + STRING_BYTES (XSTRING (val)), 1); + /* Don't inherit properties here; just copy from old contents. */ + insert_from_string (Vlast_abbrev_text, 0, 0, + XSTRING (Vlast_abbrev_text)->size, + STRING_BYTES (XSTRING (Vlast_abbrev_text)), 0); + Vlast_abbrev_text = Qnil; + /* Total number of characters deleted. */ + adjust = ZV - zv_before; + } + SET_PT (last_abbrev_point < opoint ? opoint + adjust : opoint); + return Qnil; +} + +static void +write_abbrev (sym, stream) + Lisp_Object sym, stream; +{ + Lisp_Object name; + if (NILP (XSYMBOL (sym)->value)) + return; + insert (" (", 5); + XSETSTRING (name, XSYMBOL (sym)->name); + Fprin1 (name, stream); + insert (" ", 1); + Fprin1 (XSYMBOL (sym)->value, stream); + insert (" ", 1); + Fprin1 (XSYMBOL (sym)->function, stream); + insert (" ", 1); + Fprin1 (XSYMBOL (sym)->plist, stream); + insert (")\n", 2); +} + +static void +describe_abbrev (sym, stream) + Lisp_Object sym, stream; +{ + Lisp_Object one; + + if (NILP (XSYMBOL (sym)->value)) + return; + one = make_number (1); + Fprin1 (Fsymbol_name (sym), stream); + Findent_to (make_number (15), one); + Fprin1 (XSYMBOL (sym)->plist, stream); + Findent_to (make_number (20), one); + Fprin1 (XSYMBOL (sym)->value, stream); + if (!NILP (XSYMBOL (sym)->function)) + { + Findent_to (make_number (45), one); + Fprin1 (XSYMBOL (sym)->function, stream); + } + Fterpri (stream); +} + +DEFUN ("insert-abbrev-table-description", Finsert_abbrev_table_description, + Sinsert_abbrev_table_description, 1, 2, 0, + "Insert before point a full description of abbrev table named NAME.\n\ +NAME is a symbol whose value is an abbrev table.\n\ +If optional 2nd arg READABLE is non-nil, a human-readable description\n\ +is inserted. Otherwise the description is an expression,\n\ +a call to `define-abbrev-table', which would\n\ +define the abbrev table NAME exactly as it is currently defined.") + (name, readable) + Lisp_Object name, readable; +{ + Lisp_Object table; + Lisp_Object stream; + + CHECK_SYMBOL (name, 0); + table = Fsymbol_value (name); + CHECK_VECTOR (table, 0); + + XSETBUFFER (stream, current_buffer); + + if (!NILP (readable)) + { + insert_string ("("); + Fprin1 (name, stream); + insert_string (")\n\n"); + map_obarray (table, describe_abbrev, stream); + insert_string ("\n\n"); + } + else + { + insert_string ("(define-abbrev-table '"); + Fprin1 (name, stream); + insert_string (" '(\n"); + map_obarray (table, write_abbrev, stream); + insert_string (" ))\n\n"); + } + + return Qnil; +} + +DEFUN ("define-abbrev-table", Fdefine_abbrev_table, Sdefine_abbrev_table, + 2, 2, 0, + "Define TABLENAME (a symbol) as an abbrev table name.\n\ +Define abbrevs in it according to DEFINITIONS, which is a list of elements\n\ +of the form (ABBREVNAME EXPANSION HOOK USECOUNT).") + (tablename, definitions) + Lisp_Object tablename, definitions; +{ + Lisp_Object name, exp, hook, count; + Lisp_Object table, elt; + + CHECK_SYMBOL (tablename, 0); + table = Fboundp (tablename); + if (NILP (table) || (table = Fsymbol_value (tablename), NILP (table))) + { + table = Fmake_abbrev_table (); + Fset (tablename, table); + Vabbrev_table_name_list = Fcons (tablename, Vabbrev_table_name_list); + } + CHECK_VECTOR (table, 0); + + for (; !NILP (definitions); definitions = Fcdr (definitions)) + { + elt = Fcar (definitions); + name = Fcar (elt); elt = Fcdr (elt); + exp = Fcar (elt); elt = Fcdr (elt); + hook = Fcar (elt); elt = Fcdr (elt); + count = Fcar (elt); + Fdefine_abbrev (table, name, exp, hook, count); + } + return Qnil; +} + +void +syms_of_abbrev () +{ + DEFVAR_LISP ("abbrev-table-name-list", &Vabbrev_table_name_list, + "List of symbols whose values are abbrev tables."); + Vabbrev_table_name_list = Fcons (intern ("fundamental-mode-abbrev-table"), + Fcons (intern ("global-abbrev-table"), + Qnil)); + + DEFVAR_LISP ("global-abbrev-table", &Vglobal_abbrev_table, + "The abbrev table whose abbrevs affect all buffers.\n\ +Each buffer may also have a local abbrev table.\n\ +If it does, the local table overrides the global one\n\ +for any particular abbrev defined in both."); + Vglobal_abbrev_table = Fmake_abbrev_table (); + + DEFVAR_LISP ("fundamental-mode-abbrev-table", &Vfundamental_mode_abbrev_table, + "The abbrev table of mode-specific abbrevs for Fundamental Mode."); + Vfundamental_mode_abbrev_table = Fmake_abbrev_table (); + current_buffer->abbrev_table = Vfundamental_mode_abbrev_table; + buffer_defaults.abbrev_table = Vfundamental_mode_abbrev_table; + + DEFVAR_LISP ("last-abbrev", &Vlast_abbrev, + "The abbrev-symbol of the last abbrev expanded. See `abbrev-symbol'."); + + DEFVAR_LISP ("last-abbrev-text", &Vlast_abbrev_text, + "The exact text of the last abbrev expanded.\n\ +nil if the abbrev has already been unexpanded."); + + DEFVAR_INT ("last-abbrev-location", &last_abbrev_point, + "The location of the start of the last abbrev expanded."); + + Vlast_abbrev = Qnil; + Vlast_abbrev_text = Qnil; + last_abbrev_point = 0; + + DEFVAR_LISP ("abbrev-start-location", &Vabbrev_start_location, + "Buffer position for `expand-abbrev' to use as the start of the abbrev.\n\ +nil means use the word before point as the abbrev.\n\ +Calling `expand-abbrev' sets this to nil."); + Vabbrev_start_location = Qnil; + + DEFVAR_LISP ("abbrev-start-location-buffer", &Vabbrev_start_location_buffer, + "Buffer that `abbrev-start-location' has been set for.\n\ +Trying to expand an abbrev in any other buffer clears `abbrev-start-location'."); + Vabbrev_start_location_buffer = Qnil; + + DEFVAR_PER_BUFFER ("local-abbrev-table", ¤t_buffer->abbrev_table, Qnil, + "Local (mode-specific) abbrev table of current buffer."); + + DEFVAR_BOOL ("abbrevs-changed", &abbrevs_changed, + "Set non-nil by defining or altering any word abbrevs.\n\ +This causes `save-some-buffers' to offer to save the abbrevs."); + abbrevs_changed = 0; + + DEFVAR_BOOL ("abbrev-all-caps", &abbrev_all_caps, + "*Set non-nil means expand multi-word abbrevs all caps if abbrev was so."); + abbrev_all_caps = 0; + + DEFVAR_LISP ("pre-abbrev-expand-hook", &Vpre_abbrev_expand_hook, + "Function or functions to be called before abbrev expansion is done.\n\ +This is the first thing that `expand-abbrev' does, and so this may change\n\ +the current abbrev table before abbrev lookup happens."); + Vpre_abbrev_expand_hook = Qnil; + Qpre_abbrev_expand_hook = intern ("pre-abbrev-expand-hook"); + staticpro (&Qpre_abbrev_expand_hook); + + defsubr (&Smake_abbrev_table); + defsubr (&Sclear_abbrev_table); + defsubr (&Sdefine_abbrev); + defsubr (&Sdefine_global_abbrev); + defsubr (&Sdefine_mode_abbrev); + defsubr (&Sabbrev_expansion); + defsubr (&Sabbrev_symbol); + defsubr (&Sexpand_abbrev); + defsubr (&Sunexpand_abbrev); + defsubr (&Sinsert_abbrev_table_description); + defsubr (&Sdefine_abbrev_table); +} diff --cc test/manual/etags/c-src/emacs/src/gmalloc.c index a88f4ab75e0,00000000000..683ee0c9502 mode 100644,000000..100644 --- a/test/manual/etags/c-src/emacs/src/gmalloc.c +++ b/test/manual/etags/c-src/emacs/src/gmalloc.c @@@ -1,2040 -1,0 +1,2040 @@@ +/* Declarations for `malloc' and friends. - Copyright (C) 1990-1993, 1995-1996, 1999, 2002-2007, 2013-2015 Free ++ Copyright (C) 1990-1993, 1995-1996, 1999, 2002-2007, 2013-2016 Free + Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public +License along with this library. If not, see . + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#include + +#if defined HAVE_PTHREAD && !defined HYBRID_MALLOC +#define USE_PTHREAD +#endif + +#include +#include +#include + +#ifdef HYBRID_GET_CURRENT_DIR_NAME +#undef get_current_dir_name +#endif + +#include + +#ifdef USE_PTHREAD +#include +#endif + +#ifdef WINDOWSNT +#include /* for sbrk */ +#endif + +#ifdef emacs +extern void emacs_abort (void); +#endif + +/* If HYBRID_MALLOC is defined, then temacs will use malloc, + realloc... as defined in this file (and renamed gmalloc, + grealloc... via the macros that follow). The dumped emacs, + however, will use the system malloc, realloc.... In other source + files, malloc, realloc... are renamed hybrid_malloc, + hybrid_realloc... via macros in conf_post.h. hybrid_malloc and + friends are wrapper functions defined later in this file. + aligned_alloc is defined as a macro only in alloc.c. + + As of this writing (August 2014), Cygwin is the only platform on + which HYBRID_MACRO is defined. Any other platform that wants to + define it will have to define the macros DUMPED and + ALLOCATED_BEFORE_DUMPING, defined below for Cygwin. */ +#ifdef HYBRID_MALLOC +#undef malloc +#undef realloc +#undef calloc +#undef free +#define malloc gmalloc +#define realloc grealloc +#define calloc gcalloc +#define aligned_alloc galigned_alloc +#define free gfree +#endif /* HYBRID_MALLOC */ + +#ifdef CYGWIN +extern void *bss_sbrk (ptrdiff_t size); +extern int bss_sbrk_did_unexec; +extern char bss_sbrk_buffer[]; +extern void *bss_sbrk_buffer_end; +#define DUMPED bss_sbrk_did_unexec +#define ALLOCATED_BEFORE_DUMPING(P) \ + ((P) < bss_sbrk_buffer_end && (P) >= (void *) bss_sbrk_buffer) +#endif + +#ifdef __cplusplus +extern "C" +{ +#endif + +#include + + +/* Allocate SIZE bytes of memory. */ +extern void *malloc (size_t size) ATTRIBUTE_MALLOC_SIZE ((1)); +/* Re-allocate the previously allocated block + in ptr, making the new block SIZE bytes long. */ +extern void *realloc (void *ptr, size_t size) ATTRIBUTE_ALLOC_SIZE ((2)); +/* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */ +extern void *calloc (size_t nmemb, size_t size) ATTRIBUTE_MALLOC_SIZE ((1,2)); +/* Free a block allocated by `malloc', `realloc' or `calloc'. */ +extern void free (void *ptr); + +/* Allocate SIZE bytes allocated to ALIGNMENT bytes. */ +#ifdef MSDOS +extern void *aligned_alloc (size_t, size_t); +extern void *memalign (size_t, size_t); +extern int posix_memalign (void **, size_t, size_t); +#endif + +#ifdef USE_PTHREAD +/* Set up mutexes and make malloc etc. thread-safe. */ +extern void malloc_enable_thread (void); +#endif + +#ifdef emacs +extern void emacs_abort (void); +#endif + +/* The allocator divides the heap into blocks of fixed size; large + requests receive one or more whole blocks, and small requests + receive a fragment of a block. Fragment sizes are powers of two, + and all fragments of a block are the same size. When all the + fragments in a block have been freed, the block itself is freed. */ +#define INT_BIT (CHAR_BIT * sizeof (int)) +#define BLOCKLOG (INT_BIT > 16 ? 12 : 9) +#define BLOCKSIZE (1 << BLOCKLOG) +#define BLOCKIFY(SIZE) (((SIZE) + BLOCKSIZE - 1) / BLOCKSIZE) + +/* Determine the amount of memory spanned by the initial heap table + (not an absolute limit). */ +#define HEAP (INT_BIT > 16 ? 4194304 : 65536) + +/* Number of contiguous free blocks allowed to build up at the end of + memory before they will be returned to the system. */ +#define FINAL_FREE_BLOCKS 8 + +/* Data structure giving per-block information. */ +typedef union + { + /* Heap information for a busy block. */ + struct + { + /* Zero for a large (multiblock) object, or positive giving the + logarithm to the base two of the fragment size. */ + int type; + union + { + struct + { + size_t nfree; /* Free frags in a fragmented block. */ + size_t first; /* First free fragment of the block. */ + } frag; + /* For a large object, in its first block, this has the number + of blocks in the object. In the other blocks, this has a + negative number which says how far back the first block is. */ + ptrdiff_t size; + } info; + } busy; + /* Heap information for a free block + (that may be the first of a free cluster). */ + struct + { + size_t size; /* Size (in blocks) of a free cluster. */ + size_t next; /* Index of next free cluster. */ + size_t prev; /* Index of previous free cluster. */ + } free; + } malloc_info; + +/* Pointer to first block of the heap. */ +extern char *_heapbase; + +/* Table indexed by block number giving per-block information. */ +extern malloc_info *_heapinfo; + +/* Address to block number and vice versa. */ +#define BLOCK(A) (((char *) (A) - _heapbase) / BLOCKSIZE + 1) +#define ADDRESS(B) ((void *) (((B) - 1) * BLOCKSIZE + _heapbase)) + +/* Current search index for the heap table. */ +extern size_t _heapindex; + +/* Limit of valid info table indices. */ +extern size_t _heaplimit; + +/* Doubly linked lists of free fragments. */ +struct list + { + struct list *next; + struct list *prev; + }; + +/* Free list headers for each fragment size. */ +extern struct list _fraghead[]; + +/* List of blocks allocated with aligned_alloc and friends. */ +struct alignlist + { + struct alignlist *next; + void *aligned; /* The address that aligned_alloc returned. */ + void *exact; /* The address that malloc returned. */ + }; +extern struct alignlist *_aligned_blocks; + +/* Instrumentation. */ +extern size_t _chunks_used; +extern size_t _bytes_used; +extern size_t _chunks_free; +extern size_t _bytes_free; + +/* Internal versions of `malloc', `realloc', and `free' + used when these functions need to call each other. + They are the same but don't call the hooks. */ +extern void *_malloc_internal (size_t); +extern void *_realloc_internal (void *, size_t); +extern void _free_internal (void *); +extern void *_malloc_internal_nolock (size_t); +extern void *_realloc_internal_nolock (void *, size_t); +extern void _free_internal_nolock (void *); + +#ifdef USE_PTHREAD +extern pthread_mutex_t _malloc_mutex, _aligned_blocks_mutex; +extern int _malloc_thread_enabled_p; +#define LOCK() \ + do { \ + if (_malloc_thread_enabled_p) \ + pthread_mutex_lock (&_malloc_mutex); \ + } while (0) +#define UNLOCK() \ + do { \ + if (_malloc_thread_enabled_p) \ + pthread_mutex_unlock (&_malloc_mutex); \ + } while (0) +#define LOCK_ALIGNED_BLOCKS() \ + do { \ + if (_malloc_thread_enabled_p) \ + pthread_mutex_lock (&_aligned_blocks_mutex); \ + } while (0) +#define UNLOCK_ALIGNED_BLOCKS() \ + do { \ + if (_malloc_thread_enabled_p) \ + pthread_mutex_unlock (&_aligned_blocks_mutex); \ + } while (0) +#else +#define LOCK() +#define UNLOCK() +#define LOCK_ALIGNED_BLOCKS() +#define UNLOCK_ALIGNED_BLOCKS() +#endif + +/* Given an address in the middle of a malloc'd object, + return the address of the beginning of the object. */ +extern void *malloc_find_object_address (void *ptr); + +/* Underlying allocation function; successive calls should + return contiguous pieces of memory. */ +extern void *(*__morecore) (ptrdiff_t size); + +/* Default value of `__morecore'. */ +extern void *__default_morecore (ptrdiff_t size); + +/* If not NULL, this function is called after each time + `__morecore' is called to increase the data size. */ +extern void (*__after_morecore_hook) (void); + +/* Number of extra blocks to get each time we ask for more core. + This reduces the frequency of calling `(*__morecore)'. */ +extern size_t __malloc_extra_blocks; + +/* Nonzero if `malloc' has been called and done its initialization. */ +extern int __malloc_initialized; +/* Function called to initialize malloc data structures. */ +extern int __malloc_initialize (void); + +/* Hooks for debugging versions. */ +extern void (*__malloc_initialize_hook) (void); +extern void (*__free_hook) (void *ptr); +extern void *(*__malloc_hook) (size_t size); +extern void *(*__realloc_hook) (void *ptr, size_t size); +extern void *(*__memalign_hook) (size_t size, size_t alignment); + +/* Return values for `mprobe': these are the kinds of inconsistencies that + `mcheck' enables detection of. */ +enum mcheck_status + { + MCHECK_DISABLED = -1, /* Consistency checking is not turned on. */ + MCHECK_OK, /* Block is fine. */ + MCHECK_FREE, /* Block freed twice. */ + MCHECK_HEAD, /* Memory before the block was clobbered. */ + MCHECK_TAIL /* Memory after the block was clobbered. */ + }; + +/* Activate a standard collection of debugging hooks. This must be called + before `malloc' is ever called. ABORTFUNC is called with an error code + (see enum above) when an inconsistency is detected. If ABORTFUNC is + null, the standard function prints on stderr and then calls `abort'. */ +extern int mcheck (void (*abortfunc) (enum mcheck_status)); + +/* Check for aberrations in a particular malloc'd block. You must have + called `mcheck' already. These are the same checks that `mcheck' does + when you free or reallocate a block. */ +extern enum mcheck_status mprobe (void *ptr); + +/* Activate a standard collection of tracing hooks. */ +extern void mtrace (void); +extern void muntrace (void); + +/* Statistics available to the user. */ +struct mstats + { + size_t bytes_total; /* Total size of the heap. */ + size_t chunks_used; /* Chunks allocated by the user. */ + size_t bytes_used; /* Byte total of user-allocated chunks. */ + size_t chunks_free; /* Chunks in the free list. */ + size_t bytes_free; /* Byte total of chunks in the free list. */ + }; + +/* Pick up the current statistics. */ +extern struct mstats mstats (void); + +/* Call WARNFUN with a warning message when memory usage is high. */ +extern void memory_warnings (void *start, void (*warnfun) (const char *)); + +#ifdef __cplusplus +} +#endif + +/* Memory allocator `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public +License along with this library. If not, see . + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#include + +void *(*__morecore) (ptrdiff_t size) = __default_morecore; + +/* Debugging hook for `malloc'. */ +void *(*__malloc_hook) (size_t size); + +/* Pointer to the base of the first block. */ +char *_heapbase; + +/* Block information table. Allocated with align/__free (not malloc/free). */ +malloc_info *_heapinfo; + +/* Number of info entries. */ +static size_t heapsize; + +/* Search index in the info table. */ +size_t _heapindex; + +/* Limit of valid info table indices. */ +size_t _heaplimit; + +/* Free lists for each fragment size. */ +struct list _fraghead[BLOCKLOG]; + +/* Instrumentation. */ +size_t _chunks_used; +size_t _bytes_used; +size_t _chunks_free; +size_t _bytes_free; + +/* Are you experienced? */ +int __malloc_initialized; + +size_t __malloc_extra_blocks; + +void (*__malloc_initialize_hook) (void); +void (*__after_morecore_hook) (void); + +#if defined GC_MALLOC_CHECK && defined GC_PROTECT_MALLOC_STATE + +/* Some code for hunting a bug writing into _heapinfo. + + Call this macro with argument PROT non-zero to protect internal + malloc state against writing to it, call it with a zero argument to + make it readable and writable. + + Note that this only works if BLOCKSIZE == page size, which is + the case on the i386. */ + +#include +#include + +static int state_protected_p; +static size_t last_state_size; +static malloc_info *last_heapinfo; + +void +protect_malloc_state (int protect_p) +{ + /* If _heapinfo has been relocated, make sure its old location + isn't left read-only; it will be reused by malloc. */ + if (_heapinfo != last_heapinfo + && last_heapinfo + && state_protected_p) + mprotect (last_heapinfo, last_state_size, PROT_READ | PROT_WRITE); + + last_state_size = _heaplimit * sizeof *_heapinfo; + last_heapinfo = _heapinfo; + + if (protect_p != state_protected_p) + { + state_protected_p = protect_p; + if (mprotect (_heapinfo, last_state_size, + protect_p ? PROT_READ : PROT_READ | PROT_WRITE) != 0) + abort (); + } +} + +#define PROTECT_MALLOC_STATE(PROT) protect_malloc_state (PROT) + +#else +#define PROTECT_MALLOC_STATE(PROT) /* empty */ +#endif + + +/* Aligned allocation. */ +static void * +align (size_t size) +{ + void *result; + ptrdiff_t adj; + + /* align accepts an unsigned argument, but __morecore accepts a + signed one. This could lead to trouble if SIZE overflows the + ptrdiff_t type accepted by __morecore. We just punt in that + case, since they are requesting a ludicrous amount anyway. */ + if (PTRDIFF_MAX < size) + result = 0; + else + result = (*__morecore) (size); + adj = (uintptr_t) result % BLOCKSIZE; + if (adj != 0) + { + adj = BLOCKSIZE - adj; + (*__morecore) (adj); + result = (char *) result + adj; + } + + if (__after_morecore_hook) + (*__after_morecore_hook) (); + + return result; +} + +/* Get SIZE bytes, if we can get them starting at END. + Return the address of the space we got. + If we cannot get space at END, fail and return 0. */ +static void * +get_contiguous_space (ptrdiff_t size, void *position) +{ + void *before; + void *after; + + before = (*__morecore) (0); + /* If we can tell in advance that the break is at the wrong place, + fail now. */ + if (before != position) + return 0; + + /* Allocate SIZE bytes and get the address of them. */ + after = (*__morecore) (size); + if (!after) + return 0; + + /* It was not contiguous--reject it. */ + if (after != position) + { + (*__morecore) (- size); + return 0; + } + + return after; +} + + +/* This is called when `_heapinfo' and `heapsize' have just + been set to describe a new info table. Set up the table + to describe itself and account for it in the statistics. */ +static void +register_heapinfo (void) +{ + size_t block, blocks; + + block = BLOCK (_heapinfo); + blocks = BLOCKIFY (heapsize * sizeof (malloc_info)); + + /* Account for the _heapinfo block itself in the statistics. */ + _bytes_used += blocks * BLOCKSIZE; + ++_chunks_used; + + /* Describe the heapinfo block itself in the heapinfo. */ + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = blocks; + /* Leave back-pointers for malloc_find_address. */ + while (--blocks > 0) + _heapinfo[block + blocks].busy.info.size = -blocks; +} + +#ifdef USE_PTHREAD +pthread_mutex_t _malloc_mutex = PTHREAD_MUTEX_INITIALIZER; +pthread_mutex_t _aligned_blocks_mutex = PTHREAD_MUTEX_INITIALIZER; +int _malloc_thread_enabled_p; + +static void +malloc_atfork_handler_prepare (void) +{ + LOCK (); + LOCK_ALIGNED_BLOCKS (); +} + +static void +malloc_atfork_handler_parent (void) +{ + UNLOCK_ALIGNED_BLOCKS (); + UNLOCK (); +} + +static void +malloc_atfork_handler_child (void) +{ + UNLOCK_ALIGNED_BLOCKS (); + UNLOCK (); +} + +/* Set up mutexes and make malloc etc. thread-safe. */ +void +malloc_enable_thread (void) +{ + if (_malloc_thread_enabled_p) + return; + + /* Some pthread implementations call malloc for statically + initialized mutexes when they are used first. To avoid such a + situation, we initialize mutexes here while their use is + disabled in malloc etc. */ + pthread_mutex_init (&_malloc_mutex, NULL); + pthread_mutex_init (&_aligned_blocks_mutex, NULL); + pthread_atfork (malloc_atfork_handler_prepare, + malloc_atfork_handler_parent, + malloc_atfork_handler_child); + _malloc_thread_enabled_p = 1; +} +#endif /* USE_PTHREAD */ + +static void +malloc_initialize_1 (void) +{ +#ifdef GC_MCHECK + mcheck (NULL); +#endif + + if (__malloc_initialize_hook) + (*__malloc_initialize_hook) (); + + heapsize = HEAP / BLOCKSIZE; + _heapinfo = align (heapsize * sizeof (malloc_info)); + if (_heapinfo == NULL) + return; + memset (_heapinfo, 0, heapsize * sizeof (malloc_info)); + _heapinfo[0].free.size = 0; + _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; + _heapindex = 0; + _heapbase = (char *) _heapinfo; + _heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info)); + + register_heapinfo (); + + __malloc_initialized = 1; + PROTECT_MALLOC_STATE (1); + return; +} + +/* Set everything up and remember that we have. + main will call malloc which calls this function. That is before any threads + or signal handlers has been set up, so we don't need thread protection. */ +int +__malloc_initialize (void) +{ + if (__malloc_initialized) + return 0; + + malloc_initialize_1 (); + + return __malloc_initialized; +} + +static int morecore_recursing; + +/* Get neatly aligned memory, initializing or + growing the heap info table as necessary. */ +static void * +morecore_nolock (size_t size) +{ + void *result; + malloc_info *newinfo, *oldinfo; + size_t newsize; + + if (morecore_recursing) + /* Avoid recursion. The caller will know how to handle a null return. */ + return NULL; + + result = align (size); + if (result == NULL) + return NULL; + + PROTECT_MALLOC_STATE (0); + + /* Check if we need to grow the info table. */ + if ((size_t) BLOCK ((char *) result + size) > heapsize) + { + /* Calculate the new _heapinfo table size. We do not account for the + added blocks in the table itself, as we hope to place them in + existing free space, which is already covered by part of the + existing table. */ + newsize = heapsize; + do + newsize *= 2; + while ((size_t) BLOCK ((char *) result + size) > newsize); + + /* We must not reuse existing core for the new info table when called + from realloc in the case of growing a large block, because the + block being grown is momentarily marked as free. In this case + _heaplimit is zero so we know not to reuse space for internal + allocation. */ + if (_heaplimit != 0) + { + /* First try to allocate the new info table in core we already + have, in the usual way using realloc. If realloc cannot + extend it in place or relocate it to existing sufficient core, + we will get called again, and the code above will notice the + `morecore_recursing' flag and return null. */ + int save = errno; /* Don't want to clobber errno with ENOMEM. */ + morecore_recursing = 1; + newinfo = _realloc_internal_nolock (_heapinfo, + newsize * sizeof (malloc_info)); + morecore_recursing = 0; + if (newinfo == NULL) + errno = save; + else + { + /* We found some space in core, and realloc has put the old + table's blocks on the free list. Now zero the new part + of the table and install the new table location. */ + memset (&newinfo[heapsize], 0, + (newsize - heapsize) * sizeof (malloc_info)); + _heapinfo = newinfo; + heapsize = newsize; + goto got_heap; + } + } + + /* Allocate new space for the malloc info table. */ + while (1) + { + newinfo = align (newsize * sizeof (malloc_info)); + + /* Did it fail? */ + if (newinfo == NULL) + { + (*__morecore) (-size); + return NULL; + } + + /* Is it big enough to record status for its own space? + If so, we win. */ + if ((size_t) BLOCK ((char *) newinfo + + newsize * sizeof (malloc_info)) + < newsize) + break; + + /* Must try again. First give back most of what we just got. */ + (*__morecore) (- newsize * sizeof (malloc_info)); + newsize *= 2; + } + + /* Copy the old table to the beginning of the new, + and zero the rest of the new table. */ + memcpy (newinfo, _heapinfo, heapsize * sizeof (malloc_info)); + memset (&newinfo[heapsize], 0, + (newsize - heapsize) * sizeof (malloc_info)); + oldinfo = _heapinfo; + _heapinfo = newinfo; + heapsize = newsize; + + register_heapinfo (); + + /* Reset _heaplimit so _free_internal never decides + it can relocate or resize the info table. */ + _heaplimit = 0; + _free_internal_nolock (oldinfo); + PROTECT_MALLOC_STATE (0); + + /* The new heap limit includes the new table just allocated. */ + _heaplimit = BLOCK ((char *) newinfo + heapsize * sizeof (malloc_info)); + return result; + } + + got_heap: + _heaplimit = BLOCK ((char *) result + size); + return result; +} + +/* Allocate memory from the heap. */ +void * +_malloc_internal_nolock (size_t size) +{ + void *result; + size_t block, blocks, lastblocks, start; + register size_t i; + struct list *next; + + /* ANSI C allows `malloc (0)' to either return NULL, or to return a + valid address you can realloc and free (though not dereference). + + It turns out that some extant code (sunrpc, at least Ultrix's version) + expects `malloc (0)' to return non-NULL and breaks otherwise. + Be compatible. */ + +#if 0 + if (size == 0) + return NULL; +#endif + + PROTECT_MALLOC_STATE (0); + + if (size < sizeof (struct list)) + size = sizeof (struct list); + + /* Determine the allocation policy based on the request size. */ + if (size <= BLOCKSIZE / 2) + { + /* Small allocation to receive a fragment of a block. + Determine the logarithm to base two of the fragment size. */ + register size_t log = 1; + --size; + while ((size /= 2) != 0) + ++log; + + /* Look in the fragment lists for a + free fragment of the desired size. */ + next = _fraghead[log].next; + if (next != NULL) + { + /* There are free fragments of this size. + Pop a fragment out of the fragment list and return it. + Update the block's nfree and first counters. */ + result = next; + next->prev->next = next->next; + if (next->next != NULL) + next->next->prev = next->prev; + block = BLOCK (result); + if (--_heapinfo[block].busy.info.frag.nfree != 0) + _heapinfo[block].busy.info.frag.first = + (uintptr_t) next->next % BLOCKSIZE >> log; + + /* Update the statistics. */ + ++_chunks_used; + _bytes_used += 1 << log; + --_chunks_free; + _bytes_free -= 1 << log; + } + else + { + /* No free fragments of the desired size, so get a new block + and break it into fragments, returning the first. */ +#ifdef GC_MALLOC_CHECK + result = _malloc_internal_nolock (BLOCKSIZE); + PROTECT_MALLOC_STATE (0); +#elif defined (USE_PTHREAD) + result = _malloc_internal_nolock (BLOCKSIZE); +#else + result = malloc (BLOCKSIZE); +#endif + if (result == NULL) + { + PROTECT_MALLOC_STATE (1); + goto out; + } + + /* Link all fragments but the first into the free list. */ + next = (struct list *) ((char *) result + (1 << log)); + next->next = NULL; + next->prev = &_fraghead[log]; + _fraghead[log].next = next; + + for (i = 2; i < (size_t) (BLOCKSIZE >> log); ++i) + { + next = (struct list *) ((char *) result + (i << log)); + next->next = _fraghead[log].next; + next->prev = &_fraghead[log]; + next->prev->next = next; + next->next->prev = next; + } + + /* Initialize the nfree and first counters for this block. */ + block = BLOCK (result); + _heapinfo[block].busy.type = log; + _heapinfo[block].busy.info.frag.nfree = i - 1; + _heapinfo[block].busy.info.frag.first = i - 1; + + _chunks_free += (BLOCKSIZE >> log) - 1; + _bytes_free += BLOCKSIZE - (1 << log); + _bytes_used -= BLOCKSIZE - (1 << log); + } + } + else + { + /* Large allocation to receive one or more blocks. + Search the free list in a circle starting at the last place visited. + If we loop completely around without finding a large enough + space we will have to get more memory from the system. */ + blocks = BLOCKIFY (size); + start = block = _heapindex; + while (_heapinfo[block].free.size < blocks) + { + block = _heapinfo[block].free.next; + if (block == start) + { + /* Need to get more from the system. Get a little extra. */ + size_t wantblocks = blocks + __malloc_extra_blocks; + block = _heapinfo[0].free.prev; + lastblocks = _heapinfo[block].free.size; + /* Check to see if the new core will be contiguous with the + final free block; if so we don't need to get as much. */ + if (_heaplimit != 0 && block + lastblocks == _heaplimit && + /* We can't do this if we will have to make the heap info + table bigger to accommodate the new space. */ + block + wantblocks <= heapsize && + get_contiguous_space ((wantblocks - lastblocks) * BLOCKSIZE, + ADDRESS (block + lastblocks))) + { + /* We got it contiguously. Which block we are extending + (the `final free block' referred to above) might have + changed, if it got combined with a freed info table. */ + block = _heapinfo[0].free.prev; + _heapinfo[block].free.size += (wantblocks - lastblocks); + _bytes_free += (wantblocks - lastblocks) * BLOCKSIZE; + _heaplimit += wantblocks - lastblocks; + continue; + } + result = morecore_nolock (wantblocks * BLOCKSIZE); + if (result == NULL) + goto out; + block = BLOCK (result); + /* Put the new block at the end of the free list. */ + _heapinfo[block].free.size = wantblocks; + _heapinfo[block].free.prev = _heapinfo[0].free.prev; + _heapinfo[block].free.next = 0; + _heapinfo[0].free.prev = block; + _heapinfo[_heapinfo[block].free.prev].free.next = block; + ++_chunks_free; + /* Now loop to use some of that block for this allocation. */ + } + } + + /* At this point we have found a suitable free list entry. + Figure out how to remove what we need from the list. */ + result = ADDRESS (block); + if (_heapinfo[block].free.size > blocks) + { + /* The block we found has a bit left over, + so relink the tail end back into the free list. */ + _heapinfo[block + blocks].free.size + = _heapinfo[block].free.size - blocks; + _heapinfo[block + blocks].free.next + = _heapinfo[block].free.next; + _heapinfo[block + blocks].free.prev + = _heapinfo[block].free.prev; + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapinfo[_heapinfo[block].free.next].free.prev + = _heapindex = block + blocks; + } + else + { + /* The block exactly matches our requirements, + so just remove it from the list. */ + _heapinfo[_heapinfo[block].free.next].free.prev + = _heapinfo[block].free.prev; + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapindex = _heapinfo[block].free.next; + --_chunks_free; + } + + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = blocks; + ++_chunks_used; + _bytes_used += blocks * BLOCKSIZE; + _bytes_free -= blocks * BLOCKSIZE; + + /* Mark all the blocks of the object just allocated except for the + first with a negative number so you can find the first block by + adding that adjustment. */ + while (--blocks > 0) + _heapinfo[block + blocks].busy.info.size = -blocks; + } + + PROTECT_MALLOC_STATE (1); + out: + return result; +} + +void * +_malloc_internal (size_t size) +{ + void *result; + + LOCK (); + result = _malloc_internal_nolock (size); + UNLOCK (); + + return result; +} + +void * +malloc (size_t size) +{ + void *(*hook) (size_t); + + if (!__malloc_initialized && !__malloc_initialize ()) + return NULL; + + /* Copy the value of __malloc_hook to an automatic variable in case + __malloc_hook is modified in another thread between its + NULL-check and the use. + + Note: Strictly speaking, this is not a right solution. We should + use mutexes to access non-read-only variables that are shared + among multiple threads. We just leave it for compatibility with + glibc malloc (i.e., assignments to __malloc_hook) for now. */ + hook = __malloc_hook; + return (hook != NULL ? *hook : _malloc_internal) (size); +} + +#ifndef _LIBC + +/* On some ANSI C systems, some libc functions call _malloc, _free + and _realloc. Make them use the GNU functions. */ + +extern void *_malloc (size_t); +extern void _free (void *); +extern void *_realloc (void *, size_t); + +void * +_malloc (size_t size) +{ + return malloc (size); +} + +void +_free (void *ptr) +{ + free (ptr); +} + +void * +_realloc (void *ptr, size_t size) +{ + return realloc (ptr, size); +} + +#endif +/* Free a block of memory allocated by `malloc'. + Copyright 1990, 1991, 1992, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public +License along with this library. If not, see . + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + + +/* Debugging hook for free. */ +void (*__free_hook) (void *__ptr); + +/* List of blocks allocated by aligned_alloc. */ +struct alignlist *_aligned_blocks = NULL; + +/* Return memory to the heap. + Like `_free_internal' but don't lock mutex. */ +void +_free_internal_nolock (void *ptr) +{ + int type; + size_t block, blocks; + register size_t i; + struct list *prev, *next; + void *curbrk; + const size_t lesscore_threshold + /* Threshold of free space at which we will return some to the system. */ + = FINAL_FREE_BLOCKS + 2 * __malloc_extra_blocks; + + register struct alignlist *l; + + if (ptr == NULL) + return; + + PROTECT_MALLOC_STATE (0); + + LOCK_ALIGNED_BLOCKS (); + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == ptr) + { + l->aligned = NULL; /* Mark the slot in the list as free. */ + ptr = l->exact; + break; + } + UNLOCK_ALIGNED_BLOCKS (); + + block = BLOCK (ptr); + + type = _heapinfo[block].busy.type; + switch (type) + { + case 0: + /* Get as many statistics as early as we can. */ + --_chunks_used; + _bytes_used -= _heapinfo[block].busy.info.size * BLOCKSIZE; + _bytes_free += _heapinfo[block].busy.info.size * BLOCKSIZE; + + /* Find the free cluster previous to this one in the free list. + Start searching at the last block referenced; this may benefit + programs with locality of allocation. */ + i = _heapindex; + if (i > block) + while (i > block) + i = _heapinfo[i].free.prev; + else + { + do + i = _heapinfo[i].free.next; + while (i > 0 && i < block); + i = _heapinfo[i].free.prev; + } + + /* Determine how to link this block into the free list. */ + if (block == i + _heapinfo[i].free.size) + { + /* Coalesce this block with its predecessor. */ + _heapinfo[i].free.size += _heapinfo[block].busy.info.size; + block = i; + } + else + { + /* Really link this block back into the free list. */ + _heapinfo[block].free.size = _heapinfo[block].busy.info.size; + _heapinfo[block].free.next = _heapinfo[i].free.next; + _heapinfo[block].free.prev = i; + _heapinfo[i].free.next = block; + _heapinfo[_heapinfo[block].free.next].free.prev = block; + ++_chunks_free; + } + + /* Now that the block is linked in, see if we can coalesce it + with its successor (by deleting its successor from the list + and adding in its size). */ + if (block + _heapinfo[block].free.size == _heapinfo[block].free.next) + { + _heapinfo[block].free.size + += _heapinfo[_heapinfo[block].free.next].free.size; + _heapinfo[block].free.next + = _heapinfo[_heapinfo[block].free.next].free.next; + _heapinfo[_heapinfo[block].free.next].free.prev = block; + --_chunks_free; + } + + /* How many trailing free blocks are there now? */ + blocks = _heapinfo[block].free.size; + + /* Where is the current end of accessible core? */ + curbrk = (*__morecore) (0); + + if (_heaplimit != 0 && curbrk == ADDRESS (_heaplimit)) + { + /* The end of the malloc heap is at the end of accessible core. + It's possible that moving _heapinfo will allow us to + return some space to the system. */ + + size_t info_block = BLOCK (_heapinfo); + size_t info_blocks = _heapinfo[info_block].busy.info.size; + size_t prev_block = _heapinfo[block].free.prev; + size_t prev_blocks = _heapinfo[prev_block].free.size; + size_t next_block = _heapinfo[block].free.next; + size_t next_blocks = _heapinfo[next_block].free.size; + + if (/* Win if this block being freed is last in core, the info table + is just before it, the previous free block is just before the + info table, and the two free blocks together form a useful + amount to return to the system. */ + (block + blocks == _heaplimit && + info_block + info_blocks == block && + prev_block != 0 && prev_block + prev_blocks == info_block && + blocks + prev_blocks >= lesscore_threshold) || + /* Nope, not the case. We can also win if this block being + freed is just before the info table, and the table extends + to the end of core or is followed only by a free block, + and the total free space is worth returning to the system. */ + (block + blocks == info_block && + ((info_block + info_blocks == _heaplimit && + blocks >= lesscore_threshold) || + (info_block + info_blocks == next_block && + next_block + next_blocks == _heaplimit && + blocks + next_blocks >= lesscore_threshold))) + ) + { + malloc_info *newinfo; + size_t oldlimit = _heaplimit; + + /* Free the old info table, clearing _heaplimit to avoid + recursion into this code. We don't want to return the + table's blocks to the system before we have copied them to + the new location. */ + _heaplimit = 0; + _free_internal_nolock (_heapinfo); + _heaplimit = oldlimit; + + /* Tell malloc to search from the beginning of the heap for + free blocks, so it doesn't reuse the ones just freed. */ + _heapindex = 0; + + /* Allocate new space for the info table and move its data. */ + newinfo = _malloc_internal_nolock (info_blocks * BLOCKSIZE); + PROTECT_MALLOC_STATE (0); + memmove (newinfo, _heapinfo, info_blocks * BLOCKSIZE); + _heapinfo = newinfo; + + /* We should now have coalesced the free block with the + blocks freed from the old info table. Examine the entire + trailing free block to decide below whether to return some + to the system. */ + block = _heapinfo[0].free.prev; + blocks = _heapinfo[block].free.size; + } + + /* Now see if we can return stuff to the system. */ + if (block + blocks == _heaplimit && blocks >= lesscore_threshold) + { + register size_t bytes = blocks * BLOCKSIZE; + _heaplimit -= blocks; + (*__morecore) (-bytes); + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapinfo[block].free.next; + _heapinfo[_heapinfo[block].free.next].free.prev + = _heapinfo[block].free.prev; + block = _heapinfo[block].free.prev; + --_chunks_free; + _bytes_free -= bytes; + } + } + + /* Set the next search to begin at this block. */ + _heapindex = block; + break; + + default: + /* Do some of the statistics. */ + --_chunks_used; + _bytes_used -= 1 << type; + ++_chunks_free; + _bytes_free += 1 << type; + + /* Get the address of the first free fragment in this block. */ + prev = (struct list *) ((char *) ADDRESS (block) + + (_heapinfo[block].busy.info.frag.first << type)); + + if (_heapinfo[block].busy.info.frag.nfree == (BLOCKSIZE >> type) - 1) + { + /* If all fragments of this block are free, remove them + from the fragment list and free the whole block. */ + next = prev; + for (i = 1; i < (size_t) (BLOCKSIZE >> type); ++i) + next = next->next; + prev->prev->next = next; + if (next != NULL) + next->prev = prev->prev; + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = 1; + + /* Keep the statistics accurate. */ + ++_chunks_used; + _bytes_used += BLOCKSIZE; + _chunks_free -= BLOCKSIZE >> type; + _bytes_free -= BLOCKSIZE; + +#if defined (GC_MALLOC_CHECK) || defined (USE_PTHREAD) + _free_internal_nolock (ADDRESS (block)); +#else + free (ADDRESS (block)); +#endif + } + else if (_heapinfo[block].busy.info.frag.nfree != 0) + { + /* If some fragments of this block are free, link this + fragment into the fragment list after the first free + fragment of this block. */ + next = ptr; + next->next = prev->next; + next->prev = prev; + prev->next = next; + if (next->next != NULL) + next->next->prev = next; + ++_heapinfo[block].busy.info.frag.nfree; + } + else + { + /* No fragments of this block are free, so link this + fragment into the fragment list and announce that + it is the first free fragment of this block. */ + prev = ptr; + _heapinfo[block].busy.info.frag.nfree = 1; + _heapinfo[block].busy.info.frag.first = + (uintptr_t) ptr % BLOCKSIZE >> type; + prev->next = _fraghead[type].next; + prev->prev = &_fraghead[type]; + prev->prev->next = prev; + if (prev->next != NULL) + prev->next->prev = prev; + } + break; + } + + PROTECT_MALLOC_STATE (1); +} + +/* Return memory to the heap. + Like `free' but don't call a __free_hook if there is one. */ +void +_free_internal (void *ptr) +{ + LOCK (); + _free_internal_nolock (ptr); + UNLOCK (); +} + +/* Return memory to the heap. */ + +void +free (void *ptr) +{ + void (*hook) (void *) = __free_hook; + + if (hook != NULL) + (*hook) (ptr); + else + _free_internal (ptr); +} + +/* Define the `cfree' alias for `free'. */ +#ifdef weak_alias +weak_alias (free, cfree) +#else +void +cfree (void *ptr) +{ + free (ptr); +} +#endif +/* Change the size of a block allocated by `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public +License along with this library. If not, see . + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef min +#define min(a, b) ((a) < (b) ? (a) : (b)) +#endif + +/* Debugging hook for realloc. */ +void *(*__realloc_hook) (void *ptr, size_t size); + +/* Resize the given region to the new size, returning a pointer + to the (possibly moved) region. This is optimized for speed; + some benchmarks seem to indicate that greater compactness is + achieved by unconditionally allocating and copying to a + new region. This module has incestuous knowledge of the + internals of both free and malloc. */ +void * +_realloc_internal_nolock (void *ptr, size_t size) +{ + void *result; + int type; + size_t block, blocks, oldlimit; + + if (size == 0) + { + _free_internal_nolock (ptr); + return _malloc_internal_nolock (0); + } + else if (ptr == NULL) + return _malloc_internal_nolock (size); + + block = BLOCK (ptr); + + PROTECT_MALLOC_STATE (0); + + type = _heapinfo[block].busy.type; + switch (type) + { + case 0: + /* Maybe reallocate a large block to a small fragment. */ + if (size <= BLOCKSIZE / 2) + { + result = _malloc_internal_nolock (size); + if (result != NULL) + { + memcpy (result, ptr, size); + _free_internal_nolock (ptr); + goto out; + } + } + + /* The new size is a large allocation as well; + see if we can hold it in place. */ + blocks = BLOCKIFY (size); + if (blocks < _heapinfo[block].busy.info.size) + { + /* The new size is smaller; return + excess memory to the free list. */ + _heapinfo[block + blocks].busy.type = 0; + _heapinfo[block + blocks].busy.info.size + = _heapinfo[block].busy.info.size - blocks; + _heapinfo[block].busy.info.size = blocks; + /* We have just created a new chunk by splitting a chunk in two. + Now we will free this chunk; increment the statistics counter + so it doesn't become wrong when _free_internal decrements it. */ + ++_chunks_used; + _free_internal_nolock (ADDRESS (block + blocks)); + result = ptr; + } + else if (blocks == _heapinfo[block].busy.info.size) + /* No size change necessary. */ + result = ptr; + else + { + /* Won't fit, so allocate a new region that will. + Free the old region first in case there is sufficient + adjacent free space to grow without moving. */ + blocks = _heapinfo[block].busy.info.size; + /* Prevent free from actually returning memory to the system. */ + oldlimit = _heaplimit; + _heaplimit = 0; + _free_internal_nolock (ptr); + result = _malloc_internal_nolock (size); + PROTECT_MALLOC_STATE (0); + if (_heaplimit == 0) + _heaplimit = oldlimit; + if (result == NULL) + { + /* Now we're really in trouble. We have to unfree + the thing we just freed. Unfortunately it might + have been coalesced with its neighbors. */ + if (_heapindex == block) + (void) _malloc_internal_nolock (blocks * BLOCKSIZE); + else + { + void *previous + = _malloc_internal_nolock ((block - _heapindex) * BLOCKSIZE); + (void) _malloc_internal_nolock (blocks * BLOCKSIZE); + _free_internal_nolock (previous); + } + goto out; + } + if (ptr != result) + memmove (result, ptr, blocks * BLOCKSIZE); + } + break; + + default: + /* Old size is a fragment; type is logarithm + to base two of the fragment size. */ + if (size > (size_t) (1 << (type - 1)) && + size <= (size_t) (1 << type)) + /* The new size is the same kind of fragment. */ + result = ptr; + else + { + /* The new size is different; allocate a new space, + and copy the lesser of the new size and the old. */ + result = _malloc_internal_nolock (size); + if (result == NULL) + goto out; + memcpy (result, ptr, min (size, (size_t) 1 << type)); + _free_internal_nolock (ptr); + } + break; + } + + PROTECT_MALLOC_STATE (1); + out: + return result; +} + +void * +_realloc_internal (void *ptr, size_t size) +{ + void *result; + + LOCK (); + result = _realloc_internal_nolock (ptr, size); + UNLOCK (); + + return result; +} + +void * +realloc (void *ptr, size_t size) +{ + void *(*hook) (void *, size_t); + + if (!__malloc_initialized && !__malloc_initialize ()) + return NULL; + + hook = __realloc_hook; + return (hook != NULL ? *hook : _realloc_internal) (ptr, size); +} +/* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public +License along with this library. If not, see . + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +/* Allocate an array of NMEMB elements each SIZE bytes long. + The entire array is initialized to zeros. */ +void * +calloc (size_t nmemb, size_t size) +{ + void *result; + size_t bytes = nmemb * size; + + if (size != 0 && bytes / size != nmemb) + { + errno = ENOMEM; + return NULL; + } + + result = malloc (bytes); + if (result) + return memset (result, 0, bytes); + return result; +} +/* Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +The GNU C Library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with the GNU C Library. If not, see . */ + +/* uClibc defines __GNU_LIBRARY__, but it is not completely + compatible. */ +#if !defined (__GNU_LIBRARY__) || defined (__UCLIBC__) +#define __sbrk sbrk +#else /* __GNU_LIBRARY__ && ! defined (__UCLIBC__) */ +/* It is best not to declare this and cast its result on foreign operating + systems with potentially hostile include files. */ + +extern void *__sbrk (ptrdiff_t increment); +#endif /* __GNU_LIBRARY__ && ! defined (__UCLIBC__) */ + +/* Allocate INCREMENT more bytes of data space, + and return the start of data space, or NULL on errors. + If INCREMENT is negative, shrink data space. */ +void * +__default_morecore (ptrdiff_t increment) +{ + void *result; +#if defined (CYGWIN) + if (!DUMPED) + { + return bss_sbrk (increment); + } +#endif + result = (void *) __sbrk (increment); + if (result == (void *) -1) + return NULL; + return result; +} +/* Copyright (C) 1991, 92, 93, 94, 95, 96 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public +License along with this library. If not, see . */ + +void *(*__memalign_hook) (size_t size, size_t alignment); + +void * +aligned_alloc (size_t alignment, size_t size) +{ + void *result; + size_t adj, lastadj; + void *(*hook) (size_t, size_t) = __memalign_hook; + + if (hook) + return (*hook) (alignment, size); + + /* Allocate a block with enough extra space to pad the block with up to + (ALIGNMENT - 1) bytes if necessary. */ + if (- size < alignment) + { + errno = ENOMEM; + return NULL; + } + result = malloc (size + alignment - 1); + if (result == NULL) + return NULL; + + /* Figure out how much we will need to pad this particular block + to achieve the required alignment. */ + adj = alignment - (uintptr_t) result % alignment; + if (adj == alignment) + adj = 0; + + if (adj != alignment - 1) + { + do + { + /* Reallocate the block with only as much excess as it + needs. */ + free (result); + result = malloc (size + adj); + if (result == NULL) /* Impossible unless interrupted. */ + return NULL; + + lastadj = adj; + adj = alignment - (uintptr_t) result % alignment; + if (adj == alignment) + adj = 0; + /* It's conceivable we might have been so unlucky as to get + a different block with weaker alignment. If so, this + block is too short to contain SIZE after alignment + correction. So we must try again and get another block, + slightly larger. */ + } while (adj > lastadj); + } + + if (adj != 0) + { + /* Record this block in the list of aligned blocks, so that `free' + can identify the pointer it is passed, which will be in the middle + of an allocated block. */ + + struct alignlist *l; + LOCK_ALIGNED_BLOCKS (); + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == NULL) + /* This slot is free. Use it. */ + break; + if (l == NULL) + { + l = malloc (sizeof *l); + if (l != NULL) + { + l->next = _aligned_blocks; + _aligned_blocks = l; + } + } + if (l != NULL) + { + l->exact = result; + result = l->aligned = (char *) result + adj; + } + UNLOCK_ALIGNED_BLOCKS (); + if (l == NULL) + { + free (result); + result = NULL; + } + } + + return result; +} + +/* An obsolete alias for aligned_alloc, for any old libraries that use + this alias. */ + +void * +memalign (size_t alignment, size_t size) +{ + return aligned_alloc (alignment, size); +} + +/* If HYBRID_MALLOC is defined, we may want to use the system + posix_memalign below. */ +#ifndef HYBRID_MALLOC +int +posix_memalign (void **memptr, size_t alignment, size_t size) +{ + void *mem; + + if (alignment == 0 + || alignment % sizeof (void *) != 0 + || (alignment & (alignment - 1)) != 0) + return EINVAL; + + mem = aligned_alloc (alignment, size); + if (mem == NULL) + return ENOMEM; + + *memptr = mem; + + return 0; +} +#endif + +/* Allocate memory on a page boundary. + Copyright (C) 1991, 92, 93, 94, 96 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public +License along with this library. If not, see . + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +/* Allocate SIZE bytes on a page boundary. */ +extern void *valloc (size_t); + +#if defined _SC_PAGESIZE || !defined HAVE_GETPAGESIZE +# include "getpagesize.h" +#elif !defined getpagesize +extern int getpagesize (void); +#endif + +static size_t pagesize; + +void * +valloc (size_t size) +{ + if (pagesize == 0) + pagesize = getpagesize (); + + return aligned_alloc (pagesize, size); +} + +#ifdef HYBRID_MALLOC +#undef malloc +#undef realloc +#undef calloc +#undef aligned_alloc +#undef free + +/* Declare system malloc and friends. */ +extern void *malloc (size_t size); +extern void *realloc (void *ptr, size_t size); +extern void *calloc (size_t nmemb, size_t size); +extern void free (void *ptr); +#ifdef HAVE_ALIGNED_ALLOC +extern void *aligned_alloc (size_t alignment, size_t size); +#elif defined HAVE_POSIX_MEMALIGN +extern int posix_memalign (void **memptr, size_t alignment, size_t size); +#endif + +/* See the comments near the beginning of this file for explanations + of the following functions. */ + +void * +hybrid_malloc (size_t size) +{ + if (DUMPED) + return malloc (size); + return gmalloc (size); +} + +void * +hybrid_calloc (size_t nmemb, size_t size) +{ + if (DUMPED) + return calloc (nmemb, size); + return gcalloc (nmemb, size); +} + +void +hybrid_free (void *ptr) +{ + if (!DUMPED) + gfree (ptr); + else if (!ALLOCATED_BEFORE_DUMPING (ptr)) + free (ptr); + /* Otherwise the dumped emacs is trying to free something allocated + before dumping; do nothing. */ + return; +} + +#if defined HAVE_ALIGNED_ALLOC || defined HAVE_POSIX_MEMALIGN +void * +hybrid_aligned_alloc (size_t alignment, size_t size) +{ + if (!DUMPED) + return galigned_alloc (alignment, size); + /* The following is copied from alloc.c */ +#ifdef HAVE_ALIGNED_ALLOC + return aligned_alloc (alignment, size); +#else /* HAVE_POSIX_MEMALIGN */ + void *p; + return posix_memalign (&p, alignment, size) == 0 ? p : 0; +#endif +} +#endif + +void * +hybrid_realloc (void *ptr, size_t size) +{ + void *result; + int type; + size_t block, oldsize; + + if (!DUMPED) + return grealloc (ptr, size); + if (!ALLOCATED_BEFORE_DUMPING (ptr)) + return realloc (ptr, size); + + /* The dumped emacs is trying to realloc storage allocated before + dumping. We just malloc new space and copy the data. */ + if (size == 0 || ptr == NULL) + return malloc (size); + block = ((char *) ptr - _heapbase) / BLOCKSIZE + 1; + type = _heapinfo[block].busy.type; + oldsize = + type == 0 ? _heapinfo[block].busy.info.size * BLOCKSIZE + : (size_t) 1 << type; + result = malloc (size); + if (result) + return memcpy (result, ptr, min (oldsize, size)); + return result; +} + +#ifdef HYBRID_GET_CURRENT_DIR_NAME +/* Defined in sysdep.c. */ +char *gget_current_dir_name (void); + +char * +hybrid_get_current_dir_name (void) +{ + if (DUMPED) + return get_current_dir_name (); + return gget_current_dir_name (); +} +#endif + +#endif /* HYBRID_MALLOC */ + +#ifdef GC_MCHECK + +/* Standard debugging hooks for `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public +License along with this library. If not, see . + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#include + +/* Old hook values. */ +static void (*old_free_hook) (void *ptr); +static void *(*old_malloc_hook) (size_t size); +static void *(*old_realloc_hook) (void *ptr, size_t size); + +/* Function to call when something awful happens. */ +static void (*abortfunc) (enum mcheck_status); + +/* Arbitrary magical numbers. */ +#define MAGICWORD (SIZE_MAX / 11 ^ SIZE_MAX / 13 << 3) +#define MAGICFREE (SIZE_MAX / 17 ^ SIZE_MAX / 19 << 4) +#define MAGICBYTE ((char) 0xd7) +#define MALLOCFLOOD ((char) 0x93) +#define FREEFLOOD ((char) 0x95) + +struct hdr + { + size_t size; /* Exact size requested by user. */ + size_t magic; /* Magic number to check header integrity. */ + }; + +static enum mcheck_status +checkhdr (const struct hdr *hdr) +{ + enum mcheck_status status; + switch (hdr->magic) + { + default: + status = MCHECK_HEAD; + break; + case MAGICFREE: + status = MCHECK_FREE; + break; + case MAGICWORD: + if (((char *) &hdr[1])[hdr->size] != MAGICBYTE) + status = MCHECK_TAIL; + else + status = MCHECK_OK; + break; + } + if (status != MCHECK_OK) + (*abortfunc) (status); + return status; +} + +static void +freehook (void *ptr) +{ + struct hdr *hdr; + + if (ptr) + { + struct alignlist *l; + + /* If the block was allocated by aligned_alloc, its real pointer + to free is recorded in _aligned_blocks; find that. */ + PROTECT_MALLOC_STATE (0); + LOCK_ALIGNED_BLOCKS (); + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == ptr) + { + l->aligned = NULL; /* Mark the slot in the list as free. */ + ptr = l->exact; + break; + } + UNLOCK_ALIGNED_BLOCKS (); + PROTECT_MALLOC_STATE (1); + + hdr = ((struct hdr *) ptr) - 1; + checkhdr (hdr); + hdr->magic = MAGICFREE; + memset (ptr, FREEFLOOD, hdr->size); + } + else + hdr = NULL; + + __free_hook = old_free_hook; + free (hdr); + __free_hook = freehook; +} + +static void * +mallochook (size_t size) +{ + struct hdr *hdr; + + __malloc_hook = old_malloc_hook; + hdr = malloc (sizeof *hdr + size + 1); + __malloc_hook = mallochook; + if (hdr == NULL) + return NULL; + + hdr->size = size; + hdr->magic = MAGICWORD; + ((char *) &hdr[1])[size] = MAGICBYTE; + return memset (hdr + 1, MALLOCFLOOD, size); +} + +static void * +reallochook (void *ptr, size_t size) +{ + struct hdr *hdr = NULL; + size_t osize = 0; + + if (ptr) + { + hdr = ((struct hdr *) ptr) - 1; + osize = hdr->size; + + checkhdr (hdr); + if (size < osize) + memset ((char *) ptr + size, FREEFLOOD, osize - size); + } + + __free_hook = old_free_hook; + __malloc_hook = old_malloc_hook; + __realloc_hook = old_realloc_hook; + hdr = realloc (hdr, sizeof *hdr + size + 1); + __free_hook = freehook; + __malloc_hook = mallochook; + __realloc_hook = reallochook; + if (hdr == NULL) + return NULL; + + hdr->size = size; + hdr->magic = MAGICWORD; + ((char *) &hdr[1])[size] = MAGICBYTE; + if (size > osize) + memset ((char *) (hdr + 1) + osize, MALLOCFLOOD, size - osize); + return hdr + 1; +} + +static void +mabort (enum mcheck_status status) +{ + const char *msg; + switch (status) + { + case MCHECK_OK: + msg = "memory is consistent, library is buggy"; + break; + case MCHECK_HEAD: + msg = "memory clobbered before allocated block"; + break; + case MCHECK_TAIL: + msg = "memory clobbered past end of allocated block"; + break; + case MCHECK_FREE: + msg = "block freed twice"; + break; + default: + msg = "bogus mcheck_status, library is buggy"; + break; + } +#ifdef __GNU_LIBRARY__ + __libc_fatal (msg); +#else + fprintf (stderr, "mcheck: %s\n", msg); + fflush (stderr); +# ifdef emacs + emacs_abort (); +# else + abort (); +# endif +#endif +} + +static int mcheck_used = 0; + +int +mcheck (void (*func) (enum mcheck_status)) +{ + abortfunc = (func != NULL) ? func : &mabort; + + /* These hooks may not be safely inserted if malloc is already in use. */ + if (!__malloc_initialized && !mcheck_used) + { + old_free_hook = __free_hook; + __free_hook = freehook; + old_malloc_hook = __malloc_hook; + __malloc_hook = mallochook; + old_realloc_hook = __realloc_hook; + __realloc_hook = reallochook; + mcheck_used = 1; + } + + return mcheck_used ? 0 : -1; +} + +enum mcheck_status +mprobe (void *ptr) +{ + return mcheck_used ? checkhdr (ptr) : MCHECK_DISABLED; +} + +#endif /* GC_MCHECK */ diff --cc test/manual/etags/c-src/emacs/src/keyboard.c index 77f7fb97898,00000000000..077b147c76e mode 100644,000000..100644 --- a/test/manual/etags/c-src/emacs/src/keyboard.c +++ b/test/manual/etags/c-src/emacs/src/keyboard.c @@@ -1,11960 -1,0 +1,11960 @@@ +/* Keyboard and mouse input; editor command loop. + - Copyright (C) 1985-1989, 1993-1997, 1999-2015 Free Software Foundation, ++Copyright (C) 1985-1989, 1993-1997, 1999-2016 Free Software Foundation, +Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "sysstdio.h" +#include + +#include "lisp.h" +#include "termchar.h" +#include "termopts.h" +#include "frame.h" +#include "termhooks.h" +#include "macros.h" +#include "keyboard.h" +#include "window.h" +#include "commands.h" +#include "character.h" +#include "buffer.h" +#include "disptab.h" +#include "dispextern.h" +#include "syntax.h" +#include "intervals.h" +#include "keymap.h" +#include "blockinput.h" +#include "puresize.h" +#include "systime.h" +#include "atimer.h" +#include "process.h" +#include + +#ifdef HAVE_PTHREAD +#include +#endif +#ifdef MSDOS +#include "msdos.h" +#include +#else /* not MSDOS */ +#include +#endif /* not MSDOS */ + +#if defined USABLE_FIONREAD && defined USG5_4 +# include +#endif + +#include "syssignal.h" + +#include +#include +#include + +#ifdef HAVE_WINDOW_SYSTEM +#include TERM_HEADER +#endif /* HAVE_WINDOW_SYSTEM */ + +/* Variables for blockinput.h: */ + +/* Positive if interrupt input is blocked right now. */ +volatile int interrupt_input_blocked; + +/* True means an input interrupt or alarm signal has arrived. + The QUIT macro checks this. */ +volatile bool pending_signals; + +#define KBD_BUFFER_SIZE 4096 + +KBOARD *initial_kboard; +KBOARD *current_kboard; +static KBOARD *all_kboards; + +/* True in the single-kboard state, false in the any-kboard state. */ +static bool single_kboard; + +#define NUM_RECENT_KEYS (300) + +/* Index for storing next element into recent_keys. */ +static int recent_keys_index; + +/* Total number of elements stored into recent_keys. */ +static int total_keys; + +/* This vector holds the last NUM_RECENT_KEYS keystrokes. */ +static Lisp_Object recent_keys; + +/* Vector holding the key sequence that invoked the current command. + It is reused for each command, and it may be longer than the current + sequence; this_command_key_count indicates how many elements + actually mean something. + It's easier to staticpro a single Lisp_Object than an array. */ +Lisp_Object this_command_keys; +ptrdiff_t this_command_key_count; + +/* True after calling Freset_this_command_lengths. + Usually it is false. */ +static bool this_command_key_count_reset; + +/* This vector is used as a buffer to record the events that were actually read + by read_key_sequence. */ +static Lisp_Object raw_keybuf; +static int raw_keybuf_count; + +#define GROW_RAW_KEYBUF \ + if (raw_keybuf_count == ASIZE (raw_keybuf)) \ + raw_keybuf = larger_vector (raw_keybuf, 1, -1) + +/* Number of elements of this_command_keys + that precede this key sequence. */ +static ptrdiff_t this_single_command_key_start; + +/* Record values of this_command_key_count and echo_length () + before this command was read. */ +static ptrdiff_t before_command_key_count; +static ptrdiff_t before_command_echo_length; + +#ifdef HAVE_STACK_OVERFLOW_HANDLING + +/* For longjmp to recover from C stack overflow. */ +sigjmp_buf return_to_command_loop; + +/* Message displayed by Vtop_level when recovering from C stack overflow. */ +static Lisp_Object recover_top_level_message; + +#endif /* HAVE_STACK_OVERFLOW_HANDLING */ + +/* Message normally displayed by Vtop_level. */ +static Lisp_Object regular_top_level_message; + +/* For longjmp to where kbd input is being done. */ + +static sys_jmp_buf getcjmp; + +/* True while doing kbd input. */ +bool waiting_for_input; + +/* True while displaying for echoing. Delays C-g throwing. */ + +static bool echoing; + +/* Non-null means we can start echoing at the next input pause even + though there is something in the echo area. */ + +static struct kboard *ok_to_echo_at_next_pause; + +/* The kboard last echoing, or null for none. Reset to 0 in + cancel_echoing. If non-null, and a current echo area message + exists, and echo_message_buffer is eq to the current message + buffer, we know that the message comes from echo_kboard. */ + +struct kboard *echo_kboard; + +/* The buffer used for echoing. Set in echo_now, reset in + cancel_echoing. */ + +Lisp_Object echo_message_buffer; + +/* True means C-g should cause immediate error-signal. */ +bool immediate_quit; + +/* Character that causes a quit. Normally C-g. + + If we are running on an ordinary terminal, this must be an ordinary + ASCII char, since we want to make it our interrupt character. + + If we are not running on an ordinary terminal, it still needs to be + an ordinary ASCII char. This character needs to be recognized in + the input interrupt handler. At this point, the keystroke is + represented as a struct input_event, while the desired quit + character is specified as a lispy event. The mapping from struct + input_events to lispy events cannot run in an interrupt handler, + and the reverse mapping is difficult for anything but ASCII + keystrokes. + + FOR THESE ELABORATE AND UNSATISFYING REASONS, quit_char must be an + ASCII character. */ +int quit_char; + +/* Current depth in recursive edits. */ +EMACS_INT command_loop_level; + +/* If not Qnil, this is a switch-frame event which we decided to put + off until the end of a key sequence. This should be read as the + next command input, after any unread_command_events. + + read_key_sequence uses this to delay switch-frame events until the + end of the key sequence; Fread_char uses it to put off switch-frame + events until a non-ASCII event is acceptable as input. */ +Lisp_Object unread_switch_frame; + +/* Last size recorded for a current buffer which is not a minibuffer. */ +static ptrdiff_t last_non_minibuf_size; + +/* Total number of times read_char has returned, modulo UINTMAX_MAX + 1. */ +uintmax_t num_input_events; + +/* Value of num_nonmacro_input_events as of last auto save. */ + +static EMACS_INT last_auto_save; + +/* The value of point when the last command was started. */ +static ptrdiff_t last_point_position; + +/* The frame in which the last input event occurred, or Qmacro if the + last event came from a macro. We use this to determine when to + generate switch-frame events. This may be cleared by functions + like Fselect_frame, to make sure that a switch-frame event is + generated by the next character. + + FIXME: This is modified by a signal handler so it should be volatile. + It's exported to Lisp, though, so it can't simply be marked + 'volatile' here. */ +Lisp_Object internal_last_event_frame; + +/* `read_key_sequence' stores here the command definition of the + key sequence that it reads. */ +static Lisp_Object read_key_sequence_cmd; +static Lisp_Object read_key_sequence_remapped; + +/* File in which we write all commands we read. */ +static FILE *dribble; + +/* True if input is available. */ +bool input_pending; + +/* True if more input was available last time we read an event. + + Since redisplay can take a significant amount of time and is not + indispensable to perform the user's commands, when input arrives + "too fast", Emacs skips redisplay. More specifically, if the next + command has already been input when we finish the previous command, + we skip the intermediate redisplay. + + This is useful to try and make sure Emacs keeps up with fast input + rates, such as auto-repeating keys. But in some cases, this proves + too conservative: we may end up disabling redisplay for the whole + duration of a key repetition, even though we could afford to + redisplay every once in a while. + + So we "sample" the input_pending flag before running a command and + use *that* value after running the command to decide whether to + skip redisplay or not. This way, we only skip redisplay if we + really can't keep up with the repeat rate. + + This only makes a difference if the next input arrives while running the + command, which is very unlikely if the command is executed quickly. + IOW this tends to avoid skipping redisplay after a long running command + (which is a case where skipping redisplay is not very useful since the + redisplay time is small compared to the time it took to run the command). + + A typical use case is when scrolling. Scrolling time can be split into: + - Time to do jit-lock on the newly displayed portion of buffer. + - Time to run the actual scroll command. + - Time to perform the redisplay. + Jit-lock can happen either during the command or during the redisplay. + In the most painful cases, the jit-lock time is the one that dominates. + Also jit-lock can be tweaked (via jit-lock-defer) to delay its job, at the + cost of temporary inaccuracy in display and scrolling. + So without input_was_pending, what typically happens is the following: + - when the command starts, there's no pending input (yet). + - the scroll command triggers jit-lock. + - during the long jit-lock time the next input arrives. + - at the end of the command, we check input_pending and hence decide to + skip redisplay. + - we read the next input and start over. + End result: all the hard work of jit-locking is "wasted" since redisplay + doesn't actually happens (at least not before the input rate slows down). + With input_was_pending redisplay is still skipped if Emacs can't keep up + with the input rate, but if it can keep up just enough that there's no + input_pending when we begin the command, then redisplay is not skipped + which results in better feedback to the user. */ +static bool input_was_pending; + +/* Circular buffer for pre-read keyboard input. */ + +static struct input_event kbd_buffer[KBD_BUFFER_SIZE]; + +/* Pointer to next available character in kbd_buffer. + If kbd_fetch_ptr == kbd_store_ptr, the buffer is empty. + This may be kbd_buffer + KBD_BUFFER_SIZE, meaning that the + next available char is in kbd_buffer[0]. */ +static struct input_event *kbd_fetch_ptr; + +/* Pointer to next place to store character in kbd_buffer. This + may be kbd_buffer + KBD_BUFFER_SIZE, meaning that the next + character should go in kbd_buffer[0]. */ +static struct input_event * volatile kbd_store_ptr; + +/* The above pair of variables forms a "queue empty" flag. When we + enqueue a non-hook event, we increment kbd_store_ptr. When we + dequeue a non-hook event, we increment kbd_fetch_ptr. We say that + there is input available if the two pointers are not equal. + + Why not just have a flag set and cleared by the enqueuing and + dequeuing functions? Such a flag could be screwed up by interrupts + at inopportune times. */ + +static void recursive_edit_unwind (Lisp_Object buffer); +static Lisp_Object command_loop (void); + +static void echo_now (void); +static ptrdiff_t echo_length (void); + +/* Incremented whenever a timer is run. */ +unsigned timers_run; + +/* Address (if not 0) of struct timespec to zero out if a SIGIO interrupt + happens. */ +struct timespec *input_available_clear_time; + +/* True means use SIGIO interrupts; false means use CBREAK mode. + Default is true if INTERRUPT_INPUT is defined. */ +bool interrupt_input; + +/* Nonzero while interrupts are temporarily deferred during redisplay. */ +bool interrupts_deferred; + +/* The time when Emacs started being idle. */ + +static struct timespec timer_idleness_start_time; + +/* After Emacs stops being idle, this saves the last value + of timer_idleness_start_time from when it was idle. */ + +static struct timespec timer_last_idleness_start_time; + + +/* Global variable declarations. */ + +/* Flags for readable_events. */ +#define READABLE_EVENTS_DO_TIMERS_NOW (1 << 0) +#define READABLE_EVENTS_FILTER_EVENTS (1 << 1) +#define READABLE_EVENTS_IGNORE_SQUEEZABLES (1 << 2) + +/* Function for init_keyboard to call with no args (if nonzero). */ +static void (*keyboard_init_hook) (void); + +static bool get_input_pending (int); +static bool readable_events (int); +static Lisp_Object read_char_x_menu_prompt (Lisp_Object, + Lisp_Object, bool *); +static Lisp_Object read_char_minibuf_menu_prompt (int, Lisp_Object); +static Lisp_Object make_lispy_event (struct input_event *); +static Lisp_Object make_lispy_movement (struct frame *, Lisp_Object, + enum scroll_bar_part, + Lisp_Object, Lisp_Object, + Time); +static Lisp_Object modify_event_symbol (ptrdiff_t, int, Lisp_Object, + Lisp_Object, const char *const *, + Lisp_Object *, ptrdiff_t); +static Lisp_Object make_lispy_switch_frame (Lisp_Object); +static Lisp_Object make_lispy_focus_in (Lisp_Object); +#ifdef HAVE_WINDOW_SYSTEM +static Lisp_Object make_lispy_focus_out (Lisp_Object); +#endif /* HAVE_WINDOW_SYSTEM */ +static bool help_char_p (Lisp_Object); +static void save_getcjmp (sys_jmp_buf); +static void restore_getcjmp (sys_jmp_buf); +static Lisp_Object apply_modifiers (int, Lisp_Object); +static void clear_event (struct input_event *); +static void restore_kboard_configuration (int); +#ifdef USABLE_SIGIO +static void deliver_input_available_signal (int signo); +#endif +static void handle_interrupt (bool); +static _Noreturn void quit_throw_to_read_char (bool); +static void process_special_events (void); +static void timer_start_idle (void); +static void timer_stop_idle (void); +static void timer_resume_idle (void); +static void deliver_user_signal (int); +static char *find_user_signal_name (int); +static void store_user_signal_events (void); + +/* These setters are used only in this file, so they can be private. */ +static void +kset_echo_string (struct kboard *kb, Lisp_Object val) +{ + kb->echo_string_ = val; +} +static void +kset_kbd_queue (struct kboard *kb, Lisp_Object val) +{ + kb->kbd_queue_ = val; +} +static void +kset_keyboard_translate_table (struct kboard *kb, Lisp_Object val) +{ + kb->Vkeyboard_translate_table_ = val; +} +static void +kset_last_prefix_arg (struct kboard *kb, Lisp_Object val) +{ + kb->Vlast_prefix_arg_ = val; +} +static void +kset_last_repeatable_command (struct kboard *kb, Lisp_Object val) +{ + kb->Vlast_repeatable_command_ = val; +} +static void +kset_local_function_key_map (struct kboard *kb, Lisp_Object val) +{ + kb->Vlocal_function_key_map_ = val; +} +static void +kset_overriding_terminal_local_map (struct kboard *kb, Lisp_Object val) +{ + kb->Voverriding_terminal_local_map_ = val; +} +static void +kset_real_last_command (struct kboard *kb, Lisp_Object val) +{ + kb->Vreal_last_command_ = val; +} +static void +kset_system_key_syms (struct kboard *kb, Lisp_Object val) +{ + kb->system_key_syms_ = val; +} + + +/* Add C to the echo string, without echoing it immediately. C can be + a character, which is pretty-printed, or a symbol, whose name is + printed. */ + +static void +echo_add_key (Lisp_Object c) +{ + char initbuf[KEY_DESCRIPTION_SIZE + 100]; + ptrdiff_t size = sizeof initbuf; + char *buffer = initbuf; + char *ptr = buffer; + Lisp_Object echo_string; + USE_SAFE_ALLOCA; + + echo_string = KVAR (current_kboard, echo_string); + + /* If someone has passed us a composite event, use its head symbol. */ + c = EVENT_HEAD (c); + + if (INTEGERP (c)) + ptr = push_key_description (XINT (c), ptr); + else if (SYMBOLP (c)) + { + Lisp_Object name = SYMBOL_NAME (c); + ptrdiff_t nbytes = SBYTES (name); + + if (size - (ptr - buffer) < nbytes) + { + ptrdiff_t offset = ptr - buffer; + size = max (2 * size, size + nbytes); + buffer = SAFE_ALLOCA (size); + ptr = buffer + offset; + } + + ptr += copy_text (SDATA (name), (unsigned char *) ptr, nbytes, + STRING_MULTIBYTE (name), 1); + } + + if ((NILP (echo_string) || SCHARS (echo_string) == 0) + && help_char_p (c)) + { + static const char text[] = " (Type ? for further options)"; + int len = sizeof text - 1; + + if (size - (ptr - buffer) < len) + { + ptrdiff_t offset = ptr - buffer; + size += len; + buffer = SAFE_ALLOCA (size); + ptr = buffer + offset; + } + + memcpy (ptr, text, len); + ptr += len; + } + + /* Replace a dash from echo_dash with a space, otherwise add a space + at the end as a separator between keys. */ + AUTO_STRING (space, " "); + if (STRINGP (echo_string) && SCHARS (echo_string) > 1) + { + Lisp_Object last_char, prev_char, idx; + + idx = make_number (SCHARS (echo_string) - 2); + prev_char = Faref (echo_string, idx); + + idx = make_number (SCHARS (echo_string) - 1); + last_char = Faref (echo_string, idx); + + /* We test PREV_CHAR to make sure this isn't the echoing of a + minus-sign. */ + if (XINT (last_char) == '-' && XINT (prev_char) != ' ') + Faset (echo_string, idx, make_number (' ')); + else + echo_string = concat2 (echo_string, space); + } + else if (STRINGP (echo_string) && SCHARS (echo_string) > 0) + echo_string = concat2 (echo_string, space); + + kset_echo_string + (current_kboard, + concat2 (echo_string, make_string (buffer, ptr - buffer))); + SAFE_FREE (); +} + +/* Add C to the echo string, if echoing is going on. C can be a + character or a symbol. */ + +static void +echo_char (Lisp_Object c) +{ + if (current_kboard->immediate_echo) + { + echo_add_key (c); + echo_now (); + } +} + +/* Temporarily add a dash to the end of the echo string if it's not + empty, so that it serves as a mini-prompt for the very next + character. */ + +static void +echo_dash (void) +{ + /* Do nothing if not echoing at all. */ + if (NILP (KVAR (current_kboard, echo_string))) + return; + + if (this_command_key_count == 0) + return; + + if (!current_kboard->immediate_echo + && SCHARS (KVAR (current_kboard, echo_string)) == 0) + return; + + /* Do nothing if we just printed a prompt. */ + if (current_kboard->echo_after_prompt + == SCHARS (KVAR (current_kboard, echo_string))) + return; + + /* Do nothing if we have already put a dash at the end. */ + if (SCHARS (KVAR (current_kboard, echo_string)) > 1) + { + Lisp_Object last_char, prev_char, idx; + + idx = make_number (SCHARS (KVAR (current_kboard, echo_string)) - 2); + prev_char = Faref (KVAR (current_kboard, echo_string), idx); + + idx = make_number (SCHARS (KVAR (current_kboard, echo_string)) - 1); + last_char = Faref (KVAR (current_kboard, echo_string), idx); + + if (XINT (last_char) == '-' && XINT (prev_char) != ' ') + return; + } + + /* Put a dash at the end of the buffer temporarily, + but make it go away when the next character is added. */ + AUTO_STRING (dash, "-"); + kset_echo_string (current_kboard, + concat2 (KVAR (current_kboard, echo_string), dash)); + echo_now (); +} + +/* Display the current echo string, and begin echoing if not already + doing so. */ + +static void +echo_now (void) +{ + if (!current_kboard->immediate_echo) + { + ptrdiff_t i; + current_kboard->immediate_echo = 1; + + for (i = 0; i < this_command_key_count; i++) + { + Lisp_Object c; + + /* Set before_command_echo_length to the value that would + have been saved before the start of this subcommand in + command_loop_1, if we had already been echoing then. */ + if (i == this_single_command_key_start) + before_command_echo_length = echo_length (); + + c = AREF (this_command_keys, i); + if (! (EVENT_HAS_PARAMETERS (c) + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qmouse_movement))) + echo_char (c); + } + + /* Set before_command_echo_length to the value that would + have been saved before the start of this subcommand in + command_loop_1, if we had already been echoing then. */ + if (this_command_key_count == this_single_command_key_start) + before_command_echo_length = echo_length (); + + /* Put a dash at the end to invite the user to type more. */ + echo_dash (); + } + + echoing = 1; + /* FIXME: Use call (Qmessage) so it can be advised (e.g. emacspeak). */ + message3_nolog (KVAR (current_kboard, echo_string)); + echoing = 0; + + /* Record in what buffer we echoed, and from which kboard. */ + echo_message_buffer = echo_area_buffer[0]; + echo_kboard = current_kboard; + + if (waiting_for_input && !NILP (Vquit_flag)) + quit_throw_to_read_char (0); +} + +/* Turn off echoing, for the start of a new command. */ + +void +cancel_echoing (void) +{ + current_kboard->immediate_echo = 0; + current_kboard->echo_after_prompt = -1; + kset_echo_string (current_kboard, Qnil); + ok_to_echo_at_next_pause = NULL; + echo_kboard = NULL; + echo_message_buffer = Qnil; +} + +/* Return the length of the current echo string. */ + +static ptrdiff_t +echo_length (void) +{ + return (STRINGP (KVAR (current_kboard, echo_string)) + ? SCHARS (KVAR (current_kboard, echo_string)) + : 0); +} + +/* Truncate the current echo message to its first LEN chars. + This and echo_char get used by read_key_sequence when the user + switches frames while entering a key sequence. */ + +static void +echo_truncate (ptrdiff_t nchars) +{ + if (STRINGP (KVAR (current_kboard, echo_string))) + kset_echo_string (current_kboard, + Fsubstring (KVAR (current_kboard, echo_string), + make_number (0), make_number (nchars))); + truncate_echo_area (nchars); +} + + +/* Functions for manipulating this_command_keys. */ +static void +add_command_key (Lisp_Object key) +{ +#if 0 /* Not needed after we made Freset_this_command_lengths + do the job immediately. */ + /* If reset-this-command-length was called recently, obey it now. + See the doc string of that function for an explanation of why. */ + if (before_command_restore_flag) + { + this_command_key_count = before_command_key_count_1; + if (this_command_key_count < this_single_command_key_start) + this_single_command_key_start = this_command_key_count; + echo_truncate (before_command_echo_length_1); + before_command_restore_flag = 0; + } +#endif + + if (this_command_key_count >= ASIZE (this_command_keys)) + this_command_keys = larger_vector (this_command_keys, 1, -1); + + ASET (this_command_keys, this_command_key_count, key); + ++this_command_key_count; +} + + +Lisp_Object +recursive_edit_1 (void) +{ + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object val; + + if (command_loop_level > 0) + { + specbind (Qstandard_output, Qt); + specbind (Qstandard_input, Qt); + } + +#ifdef HAVE_WINDOW_SYSTEM + /* The command loop has started an hourglass timer, so we have to + cancel it here, otherwise it will fire because the recursive edit + can take some time. Do not check for display_hourglass_p here, + because it could already be nil. */ + cancel_hourglass (); +#endif + + /* This function may have been called from a debugger called from + within redisplay, for instance by Edebugging a function called + from fontification-functions. We want to allow redisplay in + the debugging session. + + The recursive edit is left with a `(throw exit ...)'. The `exit' + tag is not caught anywhere in redisplay, i.e. when we leave the + recursive edit, the original redisplay leading to the recursive + edit will be unwound. The outcome should therefore be safe. */ + specbind (Qinhibit_redisplay, Qnil); + redisplaying_p = 0; + + val = command_loop (); + if (EQ (val, Qt)) + Fsignal (Qquit, Qnil); + /* Handle throw from read_minibuf when using minibuffer + while it's active but we're in another window. */ + if (STRINGP (val)) + xsignal1 (Qerror, val); + + return unbind_to (count, Qnil); +} + +/* When an auto-save happens, record the "time", and don't do again soon. */ + +void +record_auto_save (void) +{ + last_auto_save = num_nonmacro_input_events; +} + +/* Make an auto save happen as soon as possible at command level. */ + +#ifdef SIGDANGER +void +force_auto_save_soon (void) +{ + last_auto_save = - auto_save_interval - 1; + + record_asynch_buffer_change (); +} +#endif + +DEFUN ("recursive-edit", Frecursive_edit, Srecursive_edit, 0, 0, "", + doc: /* Invoke the editor command loop recursively. +To get out of the recursive edit, a command can throw to `exit' -- for +instance `(throw 'exit nil)'. +If you throw a value other than t, `recursive-edit' returns normally +to the function that called it. Throwing a t value causes +`recursive-edit' to quit, so that control returns to the command loop +one level up. + +This function is called by the editor initialization to begin editing. */) + (void) +{ + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object buffer; + + /* If we enter while input is blocked, don't lock up here. + This may happen through the debugger during redisplay. */ + if (input_blocked_p ()) + return Qnil; + + if (command_loop_level >= 0 + && current_buffer != XBUFFER (XWINDOW (selected_window)->contents)) + buffer = Fcurrent_buffer (); + else + buffer = Qnil; + + /* Don't do anything interesting between the increment and the + record_unwind_protect! Otherwise, we could get distracted and + never decrement the counter again. */ + command_loop_level++; + update_mode_lines = 17; + record_unwind_protect (recursive_edit_unwind, buffer); + + /* If we leave recursive_edit_1 below with a `throw' for instance, + like it is done in the splash screen display, we have to + make sure that we restore single_kboard as command_loop_1 + would have done if it were left normally. */ + if (command_loop_level > 0) + temporarily_switch_to_single_kboard (SELECTED_FRAME ()); + + recursive_edit_1 (); + return unbind_to (count, Qnil); +} + +void +recursive_edit_unwind (Lisp_Object buffer) +{ + if (BUFFERP (buffer)) + Fset_buffer (buffer); + + command_loop_level--; + update_mode_lines = 18; +} + + +#if 0 /* These two functions are now replaced with + temporarily_switch_to_single_kboard. */ +static void +any_kboard_state () +{ +#if 0 /* Theory: if there's anything in Vunread_command_events, + it will right away be read by read_key_sequence, + and then if we do switch KBOARDS, it will go into the side + queue then. So we don't need to do anything special here -- rms. */ + if (CONSP (Vunread_command_events)) + { + current_kboard->kbd_queue + = nconc2 (Vunread_command_events, current_kboard->kbd_queue); + current_kboard->kbd_queue_has_data = 1; + } + Vunread_command_events = Qnil; +#endif + single_kboard = 0; +} + +/* Switch to the single-kboard state, making current_kboard + the only KBOARD from which further input is accepted. */ + +void +single_kboard_state () +{ + single_kboard = 1; +} +#endif + +/* If we're in single_kboard state for kboard KBOARD, + get out of it. */ + +void +not_single_kboard_state (KBOARD *kboard) +{ + if (kboard == current_kboard) + single_kboard = 0; +} + +/* Maintain a stack of kboards, so other parts of Emacs + can switch temporarily to the kboard of a given frame + and then revert to the previous status. */ + +struct kboard_stack +{ + KBOARD *kboard; + struct kboard_stack *next; +}; + +static struct kboard_stack *kboard_stack; + +void +push_kboard (struct kboard *k) +{ + struct kboard_stack *p = xmalloc (sizeof *p); + + p->next = kboard_stack; + p->kboard = current_kboard; + kboard_stack = p; + + current_kboard = k; +} + +void +pop_kboard (void) +{ + struct terminal *t; + struct kboard_stack *p = kboard_stack; + bool found = 0; + for (t = terminal_list; t; t = t->next_terminal) + { + if (t->kboard == p->kboard) + { + current_kboard = p->kboard; + found = 1; + break; + } + } + if (!found) + { + /* The terminal we remembered has been deleted. */ + current_kboard = FRAME_KBOARD (SELECTED_FRAME ()); + single_kboard = 0; + } + kboard_stack = p->next; + xfree (p); +} + +/* Switch to single_kboard mode, making current_kboard the only KBOARD + from which further input is accepted. If F is non-nil, set its + KBOARD as the current keyboard. + + This function uses record_unwind_protect_int to return to the previous + state later. + + If Emacs is already in single_kboard mode, and F's keyboard is + locked, then this function will throw an error. */ + +void +temporarily_switch_to_single_kboard (struct frame *f) +{ + bool was_locked = single_kboard; + if (was_locked) + { + if (f != NULL && FRAME_KBOARD (f) != current_kboard) + /* We can not switch keyboards while in single_kboard mode. + In rare cases, Lisp code may call `recursive-edit' (or + `read-minibuffer' or `y-or-n-p') after it switched to a + locked frame. For example, this is likely to happen + when server.el connects to a new terminal while Emacs is in + single_kboard mode. It is best to throw an error instead + of presenting the user with a frozen screen. */ + error ("Terminal %d is locked, cannot read from it", + FRAME_TERMINAL (f)->id); + else + /* This call is unnecessary, but helps + `restore_kboard_configuration' discover if somebody changed + `current_kboard' behind our back. */ + push_kboard (current_kboard); + } + else if (f != NULL) + current_kboard = FRAME_KBOARD (f); + single_kboard = 1; + record_unwind_protect_int (restore_kboard_configuration, was_locked); +} + +#if 0 /* This function is not needed anymore. */ +void +record_single_kboard_state () +{ + if (single_kboard) + push_kboard (current_kboard); + record_unwind_protect_int (restore_kboard_configuration, single_kboard); +} +#endif + +static void +restore_kboard_configuration (int was_locked) +{ + single_kboard = was_locked; + if (was_locked) + { + struct kboard *prev = current_kboard; + pop_kboard (); + /* The pop should not change the kboard. */ + if (single_kboard && current_kboard != prev) + emacs_abort (); + } +} + + +/* Handle errors that are not handled at inner levels + by printing an error message and returning to the editor command loop. */ + +static Lisp_Object +cmd_error (Lisp_Object data) +{ + Lisp_Object old_level, old_length; + char macroerror[sizeof "After..kbd macro iterations: " + + INT_STRLEN_BOUND (EMACS_INT)]; + +#ifdef HAVE_WINDOW_SYSTEM + if (display_hourglass_p) + cancel_hourglass (); +#endif + + if (!NILP (executing_kbd_macro)) + { + if (executing_kbd_macro_iterations == 1) + sprintf (macroerror, "After 1 kbd macro iteration: "); + else + sprintf (macroerror, "After %"pI"d kbd macro iterations: ", + executing_kbd_macro_iterations); + } + else + *macroerror = 0; + + Vstandard_output = Qt; + Vstandard_input = Qt; + Vexecuting_kbd_macro = Qnil; + executing_kbd_macro = Qnil; + kset_prefix_arg (current_kboard, Qnil); + kset_last_prefix_arg (current_kboard, Qnil); + cancel_echoing (); + + /* Avoid unquittable loop if data contains a circular list. */ + old_level = Vprint_level; + old_length = Vprint_length; + XSETFASTINT (Vprint_level, 10); + XSETFASTINT (Vprint_length, 10); + cmd_error_internal (data, macroerror); + Vprint_level = old_level; + Vprint_length = old_length; + + Vquit_flag = Qnil; + Vinhibit_quit = Qnil; + + return make_number (0); +} + +/* Take actions on handling an error. DATA is the data that describes + the error. + + CONTEXT is a C-string containing ASCII characters only which + describes the context in which the error happened. If we need to + generalize CONTEXT to allow multibyte characters, make it a Lisp + string. */ + +void +cmd_error_internal (Lisp_Object data, const char *context) +{ + /* The immediate context is not interesting for Quits, + since they are asynchronous. */ + if (EQ (XCAR (data), Qquit)) + Vsignaling_function = Qnil; + + Vquit_flag = Qnil; + Vinhibit_quit = Qt; + + /* Use user's specified output function if any. */ + if (!NILP (Vcommand_error_function)) + call3 (Vcommand_error_function, data, + context ? build_string (context) : empty_unibyte_string, + Vsignaling_function); + + Vsignaling_function = Qnil; +} + +DEFUN ("command-error-default-function", Fcommand_error_default_function, + Scommand_error_default_function, 3, 3, 0, + doc: /* Produce default output for unhandled error message. +Default value of `command-error-function'. */) + (Lisp_Object data, Lisp_Object context, Lisp_Object signal) +{ + struct frame *sf = SELECTED_FRAME (); + + CHECK_STRING (context); + + /* If the window system or terminal frame hasn't been initialized + yet, or we're not interactive, write the message to stderr and exit. */ + if (!sf->glyphs_initialized_p + /* The initial frame is a special non-displaying frame. It + will be current in daemon mode when there are no frames + to display, and in non-daemon mode before the real frame + has finished initializing. If an error is thrown in the + latter case while creating the frame, then the frame + will never be displayed, so the safest thing to do is + write to stderr and quit. In daemon mode, there are + many other potential errors that do not prevent frames + from being created, so continuing as normal is better in + that case. */ + || (!IS_DAEMON && FRAME_INITIAL_P (sf)) + || noninteractive) + { + print_error_message (data, Qexternal_debugging_output, + SSDATA (context), signal); + Fterpri (Qexternal_debugging_output, Qnil); + Fkill_emacs (make_number (-1)); + } + else + { + clear_message (1, 0); + Fdiscard_input (); + message_log_maybe_newline (); + bitch_at_user (); + + print_error_message (data, Qt, SSDATA (context), signal); + } + return Qnil; +} + +static Lisp_Object command_loop_2 (Lisp_Object); +static Lisp_Object top_level_1 (Lisp_Object); + +/* Entry to editor-command-loop. + This level has the catches for exiting/returning to editor command loop. + It returns nil to exit recursive edit, t to abort it. */ + +Lisp_Object +command_loop (void) +{ +#ifdef HAVE_STACK_OVERFLOW_HANDLING + /* At least on GNU/Linux, saving signal mask is important here. */ + if (sigsetjmp (return_to_command_loop, 1) != 0) + { + /* Comes here from handle_sigsegv, see sysdep.c. */ + init_eval (); + Vinternal__top_level_message = recover_top_level_message; + } + else + Vinternal__top_level_message = regular_top_level_message; +#endif /* HAVE_STACK_OVERFLOW_HANDLING */ + if (command_loop_level > 0 || minibuf_level > 0) + { + Lisp_Object val; + val = internal_catch (Qexit, command_loop_2, Qnil); + executing_kbd_macro = Qnil; + return val; + } + else + while (1) + { + internal_catch (Qtop_level, top_level_1, Qnil); + internal_catch (Qtop_level, command_loop_2, Qnil); + executing_kbd_macro = Qnil; + + /* End of file in -batch run causes exit here. */ + if (noninteractive) + Fkill_emacs (Qt); + } +} + +/* Here we catch errors in execution of commands within the + editing loop, and reenter the editing loop. + When there is an error, cmd_error runs and returns a non-nil + value to us. A value of nil means that command_loop_1 itself + returned due to end of file (or end of kbd macro). */ + +static Lisp_Object +command_loop_2 (Lisp_Object ignore) +{ + register Lisp_Object val; + + do + val = internal_condition_case (command_loop_1, Qerror, cmd_error); + while (!NILP (val)); + + return Qnil; +} + +static Lisp_Object +top_level_2 (void) +{ + return Feval (Vtop_level, Qnil); +} + +static Lisp_Object +top_level_1 (Lisp_Object ignore) +{ + /* On entry to the outer level, run the startup file. */ + if (!NILP (Vtop_level)) + internal_condition_case (top_level_2, Qerror, cmd_error); + else if (!NILP (Vpurify_flag)) + message1 ("Bare impure Emacs (standard Lisp code not loaded)"); + else + message1 ("Bare Emacs (standard Lisp code not loaded)"); + return Qnil; +} + +DEFUN ("top-level", Ftop_level, Stop_level, 0, 0, "", + doc: /* Exit all recursive editing levels. +This also exits all active minibuffers. */ + attributes: noreturn) + (void) +{ +#ifdef HAVE_WINDOW_SYSTEM + if (display_hourglass_p) + cancel_hourglass (); +#endif + + /* Unblock input if we enter with input blocked. This may happen if + redisplay traps e.g. during tool-bar update with input blocked. */ + totally_unblock_input (); + + Fthrow (Qtop_level, Qnil); +} + +static _Noreturn void +user_error (const char *msg) +{ + xsignal1 (Quser_error, build_string (msg)); +} + +/* _Noreturn will be added to prototype by make-docfile. */ +DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0, 0, "", + doc: /* Exit from the innermost recursive edit or minibuffer. */ + attributes: noreturn) + (void) +{ + if (command_loop_level > 0 || minibuf_level > 0) + Fthrow (Qexit, Qnil); + + user_error ("No recursive edit is in progress"); +} + +/* _Noreturn will be added to prototype by make-docfile. */ +DEFUN ("abort-recursive-edit", Fabort_recursive_edit, Sabort_recursive_edit, 0, 0, "", + doc: /* Abort the command that requested this recursive edit or minibuffer input. */ + attributes: noreturn) + (void) +{ + if (command_loop_level > 0 || minibuf_level > 0) + Fthrow (Qexit, Qt); + + user_error ("No recursive edit is in progress"); +} + +/* Restore mouse tracking enablement. See Ftrack_mouse for the only use + of this function. */ + +static void +tracking_off (Lisp_Object old_value) +{ + do_mouse_tracking = old_value; + if (NILP (old_value)) + { + /* Redisplay may have been preempted because there was input + available, and it assumes it will be called again after the + input has been processed. If the only input available was + the sort that we have just disabled, then we need to call + redisplay. */ + if (!readable_events (READABLE_EVENTS_DO_TIMERS_NOW)) + { + redisplay_preserve_echo_area (6); + get_input_pending (READABLE_EVENTS_DO_TIMERS_NOW); + } + } +} + +DEFUN ("internal--track-mouse", Ftrack_mouse, Strack_mouse, 1, 1, 0, + doc: /* Call BODYFUN with mouse movement events enabled. */) + (Lisp_Object bodyfun) +{ + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object val; + + record_unwind_protect (tracking_off, do_mouse_tracking); + + do_mouse_tracking = Qt; + + val = call0 (bodyfun); + return unbind_to (count, val); +} + +/* If mouse has moved on some frame, return one of those frames. + + Return 0 otherwise. + + If ignore_mouse_drag_p is non-zero, ignore (implicit) mouse movement + after resizing the tool-bar window. */ + +bool ignore_mouse_drag_p; + +static struct frame * +some_mouse_moved (void) +{ + Lisp_Object tail, frame; + + if (ignore_mouse_drag_p) + { + /* ignore_mouse_drag_p = 0; */ + return 0; + } + + FOR_EACH_FRAME (tail, frame) + { + if (XFRAME (frame)->mouse_moved) + return XFRAME (frame); + } + + return 0; +} + + +/* This is the actual command reading loop, + sans error-handling encapsulation. */ + +static int read_key_sequence (Lisp_Object *, int, Lisp_Object, + bool, bool, bool, bool); +static void adjust_point_for_property (ptrdiff_t, bool); + +/* The last boundary auto-added to buffer-undo-list. */ +Lisp_Object last_undo_boundary; + +/* FIXME: This is wrong rather than test window-system, we should call + a new set-selection, which will then dispatch to x-set-selection, or + tty-set-selection, or w32-set-selection, ... */ + +Lisp_Object +command_loop_1 (void) +{ + Lisp_Object cmd; + Lisp_Object keybuf[30]; + int i; + EMACS_INT prev_modiff = 0; + struct buffer *prev_buffer = NULL; + bool already_adjusted = 0; + + kset_prefix_arg (current_kboard, Qnil); + kset_last_prefix_arg (current_kboard, Qnil); + Vdeactivate_mark = Qnil; + waiting_for_input = 0; + cancel_echoing (); + + this_command_key_count = 0; + this_command_key_count_reset = 0; + this_single_command_key_start = 0; + + if (NILP (Vmemory_full)) + { + /* Make sure this hook runs after commands that get errors and + throw to top level. */ + /* Note that the value cell will never directly contain nil + if the symbol is a local variable. */ + if (!NILP (Vpost_command_hook) && !NILP (Vrun_hooks)) + safe_run_hooks (Qpost_command_hook); + + /* If displaying a message, resize the echo area window to fit + that message's size exactly. */ + if (!NILP (echo_area_buffer[0])) + resize_echo_area_exactly (); + + /* If there are warnings waiting, process them. */ + if (!NILP (Vdelayed_warnings_list)) + safe_run_hooks (Qdelayed_warnings_hook); + + if (!NILP (Vdeferred_action_list)) + safe_run_hooks (Qdeferred_action_function); + } + + /* Do this after running Vpost_command_hook, for consistency. */ + kset_last_command (current_kboard, Vthis_command); + kset_real_last_command (current_kboard, Vreal_this_command); + if (!CONSP (last_command_event)) + kset_last_repeatable_command (current_kboard, Vreal_this_command); + + while (1) + { + if (! FRAME_LIVE_P (XFRAME (selected_frame))) + Fkill_emacs (Qnil); + + /* Make sure the current window's buffer is selected. */ + set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents)); + + /* Display any malloc warning that just came out. Use while because + displaying one warning can cause another. */ + + while (pending_malloc_warning) + display_malloc_warning (); + + Vdeactivate_mark = Qnil; + + /* Don't ignore mouse movements for more than a single command + loop. (This flag is set in xdisp.c whenever the tool bar is + resized, because the resize moves text up or down, and would + generate false mouse drag events if we don't ignore them.) */ + ignore_mouse_drag_p = 0; + + /* If minibuffer on and echo area in use, + wait a short time and redraw minibuffer. */ + + if (minibuf_level + && !NILP (echo_area_buffer[0]) + && EQ (minibuf_window, echo_area_window) + && NUMBERP (Vminibuffer_message_timeout)) + { + /* Bind inhibit-quit to t so that C-g gets read in + rather than quitting back to the minibuffer. */ + ptrdiff_t count = SPECPDL_INDEX (); + specbind (Qinhibit_quit, Qt); + + sit_for (Vminibuffer_message_timeout, 0, 2); + + /* Clear the echo area. */ + message1 (0); + safe_run_hooks (Qecho_area_clear_hook); + + unbind_to (count, Qnil); + + /* If a C-g came in before, treat it as input now. */ + if (!NILP (Vquit_flag)) + { + Vquit_flag = Qnil; + Vunread_command_events = list1 (make_number (quit_char)); + } + } + + /* If it has changed current-menubar from previous value, + really recompute the menubar from the value. */ + if (! NILP (Vlucid_menu_bar_dirty_flag) + && !NILP (Ffboundp (Qrecompute_lucid_menubar))) + call0 (Qrecompute_lucid_menubar); + + before_command_key_count = this_command_key_count; + before_command_echo_length = echo_length (); + + Vthis_command = Qnil; + Vreal_this_command = Qnil; + Vthis_original_command = Qnil; + Vthis_command_keys_shift_translated = Qnil; + + /* Read next key sequence; i gets its length. */ + i = read_key_sequence (keybuf, ARRAYELTS (keybuf), + Qnil, 0, 1, 1, 0); + + /* A filter may have run while we were reading the input. */ + if (! FRAME_LIVE_P (XFRAME (selected_frame))) + Fkill_emacs (Qnil); + set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents)); + + ++num_input_keys; + + /* Now we have read a key sequence of length I, + or else I is 0 and we found end of file. */ + + if (i == 0) /* End of file -- happens only in */ + return Qnil; /* a kbd macro, at the end. */ + /* -1 means read_key_sequence got a menu that was rejected. + Just loop around and read another command. */ + if (i == -1) + { + cancel_echoing (); + this_command_key_count = 0; + this_command_key_count_reset = 0; + this_single_command_key_start = 0; + goto finalize; + } + + last_command_event = keybuf[i - 1]; + + /* If the previous command tried to force a specific window-start, + forget about that, in case this command moves point far away + from that position. But also throw away beg_unchanged and + end_unchanged information in that case, so that redisplay will + update the whole window properly. */ + if (XWINDOW (selected_window)->force_start) + { + struct buffer *b; + XWINDOW (selected_window)->force_start = 0; + b = XBUFFER (XWINDOW (selected_window)->contents); + BUF_BEG_UNCHANGED (b) = BUF_END_UNCHANGED (b) = 0; + } + + cmd = read_key_sequence_cmd; + if (!NILP (Vexecuting_kbd_macro)) + { + if (!NILP (Vquit_flag)) + { + Vexecuting_kbd_macro = Qt; + QUIT; /* Make some noise. */ + /* Will return since macro now empty. */ + } + } + + /* Do redisplay processing after this command except in special + cases identified below. */ + prev_buffer = current_buffer; + prev_modiff = MODIFF; + last_point_position = PT; + + /* By default, we adjust point to a boundary of a region that + has such a property that should be treated intangible + (e.g. composition, display). But, some commands will set + this variable differently. */ + Vdisable_point_adjustment = Qnil; + + /* Process filters and timers may have messed with deactivate-mark. + reset it before we execute the command. */ + Vdeactivate_mark = Qnil; + + /* Remap command through active keymaps. */ + Vthis_original_command = cmd; + if (!NILP (read_key_sequence_remapped)) + cmd = read_key_sequence_remapped; + + /* Execute the command. */ + + { + total_keys += total_keys < NUM_RECENT_KEYS; + ASET (recent_keys, recent_keys_index, + Fcons (Qnil, cmd)); + if (++recent_keys_index >= NUM_RECENT_KEYS) + recent_keys_index = 0; + } + Vthis_command = cmd; + Vreal_this_command = cmd; + safe_run_hooks (Qpre_command_hook); + + already_adjusted = 0; + + if (NILP (Vthis_command)) + /* nil means key is undefined. */ + call0 (Qundefined); + else + { + /* Here for a command that isn't executed directly. */ + +#ifdef HAVE_WINDOW_SYSTEM + ptrdiff_t scount = SPECPDL_INDEX (); + + if (display_hourglass_p + && NILP (Vexecuting_kbd_macro)) + { + record_unwind_protect_void (cancel_hourglass); + start_hourglass (); + } +#endif + + if (NILP (KVAR (current_kboard, Vprefix_arg))) /* FIXME: Why? --Stef */ + { + Lisp_Object undo = BVAR (current_buffer, undo_list); + Fundo_boundary (); + last_undo_boundary + = (EQ (undo, BVAR (current_buffer, undo_list)) + ? Qnil : BVAR (current_buffer, undo_list)); + } + call1 (Qcommand_execute, Vthis_command); + +#ifdef HAVE_WINDOW_SYSTEM + /* Do not check display_hourglass_p here, because + `command-execute' could change it, but we should cancel + hourglass cursor anyway. + But don't cancel the hourglass within a macro + just because a command in the macro finishes. */ + if (NILP (Vexecuting_kbd_macro)) + unbind_to (scount, Qnil); +#endif + } + kset_last_prefix_arg (current_kboard, Vcurrent_prefix_arg); + + safe_run_hooks (Qpost_command_hook); + + /* If displaying a message, resize the echo area window to fit + that message's size exactly. */ + if (!NILP (echo_area_buffer[0])) + resize_echo_area_exactly (); + + /* If there are warnings waiting, process them. */ + if (!NILP (Vdelayed_warnings_list)) + safe_run_hooks (Qdelayed_warnings_hook); + + safe_run_hooks (Qdeferred_action_function); + + /* If there is a prefix argument, + 1) We don't want Vlast_command to be ``universal-argument'' + (that would be dumb), so don't set Vlast_command, + 2) we want to leave echoing on so that the prefix will be + echoed as part of this key sequence, so don't call + cancel_echoing, and + 3) we want to leave this_command_key_count non-zero, so that + read_char will realize that it is re-reading a character, and + not echo it a second time. + + If the command didn't actually create a prefix arg, + but is merely a frame event that is transparent to prefix args, + then the above doesn't apply. */ + if (NILP (KVAR (current_kboard, Vprefix_arg)) + || CONSP (last_command_event)) + { + kset_last_command (current_kboard, Vthis_command); + kset_real_last_command (current_kboard, Vreal_this_command); + if (!CONSP (last_command_event)) + kset_last_repeatable_command (current_kboard, Vreal_this_command); + cancel_echoing (); + this_command_key_count = 0; + this_command_key_count_reset = 0; + this_single_command_key_start = 0; + } + + if (!NILP (BVAR (current_buffer, mark_active)) + && !NILP (Vrun_hooks)) + { + /* In Emacs 22, setting transient-mark-mode to `only' was a + way of turning it on for just one command. This usage is + obsolete, but support it anyway. */ + if (EQ (Vtransient_mark_mode, Qidentity)) + Vtransient_mark_mode = Qnil; + else if (EQ (Vtransient_mark_mode, Qonly)) + Vtransient_mark_mode = Qidentity; + + if (!NILP (Vdeactivate_mark)) + /* If `select-active-regions' is non-nil, this call to + `deactivate-mark' also sets the PRIMARY selection. */ + call0 (Qdeactivate_mark); + else + { + /* Even if not deactivating the mark, set PRIMARY if + `select-active-regions' is non-nil. */ + if (!NILP (Fwindow_system (Qnil)) + /* Even if mark_active is non-nil, the actual buffer + marker may not have been set yet (Bug#7044). */ + && XMARKER (BVAR (current_buffer, mark))->buffer + && (EQ (Vselect_active_regions, Qonly) + ? EQ (CAR_SAFE (Vtransient_mark_mode), Qonly) + : (!NILP (Vselect_active_regions) + && !NILP (Vtransient_mark_mode))) + && NILP (Fmemq (Vthis_command, + Vselection_inhibit_update_commands))) + { + Lisp_Object txt + = call1 (Fsymbol_value (Qregion_extract_function), Qnil); + if (XINT (Flength (txt)) > 0) + /* Don't set empty selections. */ + call2 (Qgui_set_selection, QPRIMARY, txt); + } + + if (current_buffer != prev_buffer || MODIFF != prev_modiff) + run_hook (intern ("activate-mark-hook")); + } + + Vsaved_region_selection = Qnil; + } + + finalize: + + if (current_buffer == prev_buffer + && last_point_position != PT + && NILP (Vdisable_point_adjustment) + && NILP (Vglobal_disable_point_adjustment)) + { + if (last_point_position > BEGV + && last_point_position < ZV + && (composition_adjust_point (last_point_position, + last_point_position) + != last_point_position)) + /* The last point was temporarily set within a grapheme + cluster to prevent automatic composition. To recover + the automatic composition, we must update the + display. */ + windows_or_buffers_changed = 21; + if (!already_adjusted) + adjust_point_for_property (last_point_position, + MODIFF != prev_modiff); + } + + /* Install chars successfully executed in kbd macro. */ + + if (!NILP (KVAR (current_kboard, defining_kbd_macro)) + && NILP (KVAR (current_kboard, Vprefix_arg))) + finalize_kbd_macro_chars (); + } +} + +Lisp_Object +read_menu_command (void) +{ + Lisp_Object keybuf[30]; + ptrdiff_t count = SPECPDL_INDEX (); + int i; + + /* We don't want to echo the keystrokes while navigating the + menus. */ + specbind (Qecho_keystrokes, make_number (0)); + + i = read_key_sequence (keybuf, ARRAYELTS (keybuf), + Qnil, 0, 1, 1, 1); + + unbind_to (count, Qnil); + + if (! FRAME_LIVE_P (XFRAME (selected_frame))) + Fkill_emacs (Qnil); + if (i == 0 || i == -1) + return Qt; + + return read_key_sequence_cmd; +} + +/* Adjust point to a boundary of a region that has such a property + that should be treated intangible. For the moment, we check + `composition', `display' and `invisible' properties. + LAST_PT is the last position of point. */ + +static void +adjust_point_for_property (ptrdiff_t last_pt, bool modified) +{ + ptrdiff_t beg, end; + Lisp_Object val, overlay, tmp; + /* When called after buffer modification, we should temporarily + suppress the point adjustment for automatic composition so that a + user can keep inserting another character at point or keep + deleting characters around point. */ + bool check_composition = ! modified, check_display = 1, check_invisible = 1; + ptrdiff_t orig_pt = PT; + + /* FIXME: cycling is probably not necessary because these properties + can't be usefully combined anyway. */ + while (check_composition || check_display || check_invisible) + { + /* FIXME: check `intangible'. */ + if (check_composition + && PT > BEGV && PT < ZV + && (beg = composition_adjust_point (last_pt, PT)) != PT) + { + SET_PT (beg); + check_display = check_invisible = 1; + } + check_composition = 0; + if (check_display + && PT > BEGV && PT < ZV + && !NILP (val = get_char_property_and_overlay + (make_number (PT), Qdisplay, Qnil, &overlay)) + && display_prop_intangible_p (val, overlay, PT, PT_BYTE) + && (!OVERLAYP (overlay) + ? get_property_and_range (PT, Qdisplay, &val, &beg, &end, Qnil) + : (beg = OVERLAY_POSITION (OVERLAY_START (overlay)), + end = OVERLAY_POSITION (OVERLAY_END (overlay)))) + && (beg < PT /* && end > PT <- It's always the case. */ + || (beg <= PT && STRINGP (val) && SCHARS (val) == 0))) + { + eassert (end > PT); + SET_PT (PT < last_pt + ? (STRINGP (val) && SCHARS (val) == 0 + ? max (beg - 1, BEGV) + : beg) + : end); + check_composition = check_invisible = 1; + } + check_display = 0; + if (check_invisible && PT > BEGV && PT < ZV) + { + int inv; + bool ellipsis = 0; + beg = end = PT; + + /* Find boundaries `beg' and `end' of the invisible area, if any. */ + while (end < ZV +#if 0 + /* FIXME: We should stop if we find a spot between + two runs of `invisible' where inserted text would + be visible. This is important when we have two + invisible boundaries that enclose an area: if the + area is empty, we need this test in order to make + it possible to place point in the middle rather + than skip both boundaries. However, this code + also stops anywhere in a non-sticky text-property, + which breaks (e.g.) Org mode. */ + && (val = Fget_pos_property (make_number (end), + Qinvisible, Qnil), + TEXT_PROP_MEANS_INVISIBLE (val)) +#endif + && !NILP (val = get_char_property_and_overlay + (make_number (end), Qinvisible, Qnil, &overlay)) + && (inv = TEXT_PROP_MEANS_INVISIBLE (val))) + { + ellipsis = ellipsis || inv > 1 + || (OVERLAYP (overlay) + && (!NILP (Foverlay_get (overlay, Qafter_string)) + || !NILP (Foverlay_get (overlay, Qbefore_string)))); + tmp = Fnext_single_char_property_change + (make_number (end), Qinvisible, Qnil, Qnil); + end = NATNUMP (tmp) ? XFASTINT (tmp) : ZV; + } + while (beg > BEGV +#if 0 + && (val = Fget_pos_property (make_number (beg), + Qinvisible, Qnil), + TEXT_PROP_MEANS_INVISIBLE (val)) +#endif + && !NILP (val = get_char_property_and_overlay + (make_number (beg - 1), Qinvisible, Qnil, &overlay)) + && (inv = TEXT_PROP_MEANS_INVISIBLE (val))) + { + ellipsis = ellipsis || inv > 1 + || (OVERLAYP (overlay) + && (!NILP (Foverlay_get (overlay, Qafter_string)) + || !NILP (Foverlay_get (overlay, Qbefore_string)))); + tmp = Fprevious_single_char_property_change + (make_number (beg), Qinvisible, Qnil, Qnil); + beg = NATNUMP (tmp) ? XFASTINT (tmp) : BEGV; + } + + /* Move away from the inside area. */ + if (beg < PT && end > PT) + { + SET_PT ((orig_pt == PT && (last_pt < beg || last_pt > end)) + /* We haven't moved yet (so we don't need to fear + infinite-looping) and we were outside the range + before (so either end of the range still corresponds + to a move in the right direction): pretend we moved + less than we actually did, so that we still have + more freedom below in choosing which end of the range + to go to. */ + ? (orig_pt = -1, PT < last_pt ? end : beg) + /* We either have moved already or the last point + was already in the range: we don't get to choose + which end of the range we have to go to. */ + : (PT < last_pt ? beg : end)); + check_composition = check_display = 1; + } +#if 0 /* This assertion isn't correct, because SET_PT may end up setting + the point to something other than its argument, due to + point-motion hooks, intangibility, etc. */ + eassert (PT == beg || PT == end); +#endif + + /* Pretend the area doesn't exist if the buffer is not + modified. */ + if (!modified && !ellipsis && beg < end) + { + if (last_pt == beg && PT == end && end < ZV) + (check_composition = check_display = 1, SET_PT (end + 1)); + else if (last_pt == end && PT == beg && beg > BEGV) + (check_composition = check_display = 1, SET_PT (beg - 1)); + else if (PT == ((PT < last_pt) ? beg : end)) + /* We've already moved as far as we can. Trying to go + to the other end would mean moving backwards and thus + could lead to an infinite loop. */ + ; + else if (val = Fget_pos_property (make_number (PT), + Qinvisible, Qnil), + TEXT_PROP_MEANS_INVISIBLE (val) + && (val = (Fget_pos_property + (make_number (PT == beg ? end : beg), + Qinvisible, Qnil)), + !TEXT_PROP_MEANS_INVISIBLE (val))) + (check_composition = check_display = 1, + SET_PT (PT == beg ? end : beg)); + } + } + check_invisible = 0; + } +} + +/* Subroutine for safe_run_hooks: run the hook, which is ARGS[1]. */ + +static Lisp_Object +safe_run_hooks_1 (ptrdiff_t nargs, Lisp_Object *args) +{ + eassert (nargs == 2); + return call0 (args[1]); +} + +/* Subroutine for safe_run_hooks: handle an error by clearing out the function + from the hook. */ + +static Lisp_Object +safe_run_hooks_error (Lisp_Object error, ptrdiff_t nargs, Lisp_Object *args) +{ + eassert (nargs == 2); + AUTO_STRING (format, "Error in %s (%S): %S"); + Lisp_Object hook = args[0]; + Lisp_Object fun = args[1]; + CALLN (Fmessage, format, hook, fun, error); + + if (SYMBOLP (hook)) + { + Lisp_Object val; + bool found = 0; + Lisp_Object newval = Qnil; + for (val = find_symbol_value (hook); CONSP (val); val = XCDR (val)) + if (EQ (fun, XCAR (val))) + found = 1; + else + newval = Fcons (XCAR (val), newval); + if (found) + return Fset (hook, Fnreverse (newval)); + /* Not found in the local part of the hook. Let's look at the global + part. */ + newval = Qnil; + for (val = (NILP (Fdefault_boundp (hook)) ? Qnil + : Fdefault_value (hook)); + CONSP (val); val = XCDR (val)) + if (EQ (fun, XCAR (val))) + found = 1; + else + newval = Fcons (XCAR (val), newval); + if (found) + return Fset_default (hook, Fnreverse (newval)); + } + return Qnil; +} + +static Lisp_Object +safe_run_hook_funcall (ptrdiff_t nargs, Lisp_Object *args) +{ + eassert (nargs == 2); + /* Yes, run_hook_with_args works with args in the other order. */ + internal_condition_case_n (safe_run_hooks_1, + 2, ((Lisp_Object []) {args[1], args[0]}), + Qt, safe_run_hooks_error); + return Qnil; +} + +/* If we get an error while running the hook, cause the hook variable + to be nil. Also inhibit quits, so that C-g won't cause the hook + to mysteriously evaporate. */ + +void +safe_run_hooks (Lisp_Object hook) +{ + struct gcpro gcpro1; + ptrdiff_t count = SPECPDL_INDEX (); + + GCPRO1 (hook); + specbind (Qinhibit_quit, Qt); + run_hook_with_args (2, ((Lisp_Object []) {hook, hook}), safe_run_hook_funcall); + unbind_to (count, Qnil); + UNGCPRO; +} + + +/* Nonzero means polling for input is temporarily suppressed. */ + +int poll_suppress_count; + + +#ifdef POLL_FOR_INPUT + +/* Asynchronous timer for polling. */ + +static struct atimer *poll_timer; + +/* Poll for input, so that we catch a C-g if it comes in. */ +void +poll_for_input_1 (void) +{ + if (! input_blocked_p () + && !waiting_for_input) + gobble_input (); +} + +/* Timer callback function for poll_timer. TIMER is equal to + poll_timer. */ + +static void +poll_for_input (struct atimer *timer) +{ + if (poll_suppress_count == 0) + pending_signals = 1; +} + +#endif /* POLL_FOR_INPUT */ + +/* Begin signals to poll for input, if they are appropriate. + This function is called unconditionally from various places. */ + +void +start_polling (void) +{ +#ifdef POLL_FOR_INPUT + /* XXX This condition was (read_socket_hook && !interrupt_input), + but read_socket_hook is not global anymore. Let's pretend that + it's always set. */ + if (!interrupt_input) + { + /* Turn alarm handling on unconditionally. It might have + been turned off in process.c. */ + turn_on_atimers (1); + + /* If poll timer doesn't exist, or we need one with + a different interval, start a new one. */ + if (poll_timer == NULL + || poll_timer->interval.tv_sec != polling_period) + { + time_t period = max (1, min (polling_period, TYPE_MAXIMUM (time_t))); + struct timespec interval = make_timespec (period, 0); + + if (poll_timer) + cancel_atimer (poll_timer); + + poll_timer = start_atimer (ATIMER_CONTINUOUS, interval, + poll_for_input, NULL); + } + + /* Let the timer's callback function poll for input + if this becomes zero. */ + --poll_suppress_count; + } +#endif +} + +/* True if we are using polling to handle input asynchronously. */ + +bool +input_polling_used (void) +{ +#ifdef POLL_FOR_INPUT + /* XXX This condition was (read_socket_hook && !interrupt_input), + but read_socket_hook is not global anymore. Let's pretend that + it's always set. */ + return !interrupt_input; +#else + return 0; +#endif +} + +/* Turn off polling. */ + +void +stop_polling (void) +{ +#ifdef POLL_FOR_INPUT + /* XXX This condition was (read_socket_hook && !interrupt_input), + but read_socket_hook is not global anymore. Let's pretend that + it's always set. */ + if (!interrupt_input) + ++poll_suppress_count; +#endif +} + +/* Set the value of poll_suppress_count to COUNT + and start or stop polling accordingly. */ + +void +set_poll_suppress_count (int count) +{ +#ifdef POLL_FOR_INPUT + if (count == 0 && poll_suppress_count != 0) + { + poll_suppress_count = 1; + start_polling (); + } + else if (count != 0 && poll_suppress_count == 0) + { + stop_polling (); + } + poll_suppress_count = count; +#endif +} + +/* Bind polling_period to a value at least N. + But don't decrease it. */ + +void +bind_polling_period (int n) +{ +#ifdef POLL_FOR_INPUT + EMACS_INT new = polling_period; + + if (n > new) + new = n; + + stop_other_atimers (poll_timer); + stop_polling (); + specbind (Qpolling_period, make_number (new)); + /* Start a new alarm with the new period. */ + start_polling (); +#endif +} + +/* Apply the control modifier to CHARACTER. */ + +int +make_ctrl_char (int c) +{ + /* Save the upper bits here. */ + int upper = c & ~0177; + + if (! ASCII_CHAR_P (c)) + return c |= ctrl_modifier; + + c &= 0177; + + /* Everything in the columns containing the upper-case letters + denotes a control character. */ + if (c >= 0100 && c < 0140) + { + int oc = c; + c &= ~0140; + /* Set the shift modifier for a control char + made from a shifted letter. But only for letters! */ + if (oc >= 'A' && oc <= 'Z') + c |= shift_modifier; + } + + /* The lower-case letters denote control characters too. */ + else if (c >= 'a' && c <= 'z') + c &= ~0140; + + /* Include the bits for control and shift + only if the basic ASCII code can't indicate them. */ + else if (c >= ' ') + c |= ctrl_modifier; + + /* Replace the high bits. */ + c |= (upper & ~ctrl_modifier); + + return c; +} + +/* Display the help-echo property of the character after the mouse pointer. + Either show it in the echo area, or call show-help-function to display + it by other means (maybe in a tooltip). + + If HELP is nil, that means clear the previous help echo. + + If HELP is a string, display that string. If HELP is a function, + call it with OBJECT and POS as arguments; the function should + return a help string or nil for none. For all other types of HELP, + evaluate it to obtain a string. + + WINDOW is the window in which the help was generated, if any. + It is nil if not in a window. + + If OBJECT is a buffer, POS is the position in the buffer where the + `help-echo' text property was found. + + If OBJECT is an overlay, that overlay has a `help-echo' property, + and POS is the position in the overlay's buffer under the mouse. + + If OBJECT is a string (an overlay string or a string displayed with + the `display' property). POS is the position in that string under + the mouse. + + Note: this function may only be called with HELP nil or a string + from X code running asynchronously. */ + +void +show_help_echo (Lisp_Object help, Lisp_Object window, Lisp_Object object, + Lisp_Object pos) +{ + if (!NILP (help) && !STRINGP (help)) + { + if (FUNCTIONP (help)) + help = safe_call (4, help, window, object, pos); + else + help = safe_eval (help); + + if (!STRINGP (help)) + return; + } + + if (!noninteractive && STRINGP (help)) + { + /* The mouse-fixup-help-message Lisp function can call + mouse_position_hook, which resets the mouse_moved flags. + This causes trouble if we are trying to read a mouse motion + event (i.e., if we are inside a `track-mouse' form), so we + restore the mouse_moved flag. */ + struct frame *f = NILP (do_mouse_tracking) ? NULL : some_mouse_moved (); + help = call1 (Qmouse_fixup_help_message, help); + if (f) + f->mouse_moved = 1; + } + + if (STRINGP (help) || NILP (help)) + { + if (!NILP (Vshow_help_function)) + call1 (Vshow_help_function, help); + help_echo_showing_p = STRINGP (help); + } +} + + + +/* Input of single characters from keyboard. */ + +static Lisp_Object kbd_buffer_get_event (KBOARD **kbp, bool *used_mouse_menu, + struct timespec *end_time); +static void record_char (Lisp_Object c); + +static Lisp_Object help_form_saved_window_configs; +static void +read_char_help_form_unwind (void) +{ + Lisp_Object window_config = XCAR (help_form_saved_window_configs); + help_form_saved_window_configs = XCDR (help_form_saved_window_configs); + if (!NILP (window_config)) + Fset_window_configuration (window_config); +} + +#define STOP_POLLING \ +do { if (! polling_stopped_here) stop_polling (); \ + polling_stopped_here = 1; } while (0) + +#define RESUME_POLLING \ +do { if (polling_stopped_here) start_polling (); \ + polling_stopped_here = 0; } while (0) + +static Lisp_Object +read_event_from_main_queue (struct timespec *end_time, + sys_jmp_buf local_getcjmp, + bool *used_mouse_menu) +{ + Lisp_Object c = Qnil; + sys_jmp_buf save_jump; + KBOARD *kb IF_LINT (= NULL); + + start: + + /* Read from the main queue, and if that gives us something we can't use yet, + we put it on the appropriate side queue and try again. */ + + if (end_time && timespec_cmp (*end_time, current_timespec ()) <= 0) + return c; + + /* Actually read a character, waiting if necessary. */ + save_getcjmp (save_jump); + restore_getcjmp (local_getcjmp); + if (!end_time) + timer_start_idle (); + c = kbd_buffer_get_event (&kb, used_mouse_menu, end_time); + restore_getcjmp (save_jump); + + if (! NILP (c) && (kb != current_kboard)) + { + Lisp_Object last = KVAR (kb, kbd_queue); + if (CONSP (last)) + { + while (CONSP (XCDR (last))) + last = XCDR (last); + if (!NILP (XCDR (last))) + emacs_abort (); + } + if (!CONSP (last)) + kset_kbd_queue (kb, list1 (c)); + else + XSETCDR (last, list1 (c)); + kb->kbd_queue_has_data = 1; + c = Qnil; + if (single_kboard) + goto start; + current_kboard = kb; + /* This is going to exit from read_char + so we had better get rid of this frame's stuff. */ + return make_number (-2); + } + + /* Terminate Emacs in batch mode if at eof. */ + if (noninteractive && INTEGERP (c) && XINT (c) < 0) + Fkill_emacs (make_number (1)); + + if (INTEGERP (c)) + { + /* Add in any extra modifiers, where appropriate. */ + if ((extra_keyboard_modifiers & CHAR_CTL) + || ((extra_keyboard_modifiers & 0177) < ' ' + && (extra_keyboard_modifiers & 0177) != 0)) + XSETINT (c, make_ctrl_char (XINT (c))); + + /* Transfer any other modifier bits directly from + extra_keyboard_modifiers to c. Ignore the actual character code + in the low 16 bits of extra_keyboard_modifiers. */ + XSETINT (c, XINT (c) | (extra_keyboard_modifiers & ~0xff7f & ~CHAR_CTL)); + } + + return c; +} + + + +/* Like `read_event_from_main_queue' but applies keyboard-coding-system + to tty input. */ +static Lisp_Object +read_decoded_event_from_main_queue (struct timespec *end_time, + sys_jmp_buf local_getcjmp, + Lisp_Object prev_event, + bool *used_mouse_menu) +{ +#define MAX_ENCODED_BYTES 16 +#ifndef WINDOWSNT + Lisp_Object events[MAX_ENCODED_BYTES]; + int n = 0; +#endif + while (true) + { + Lisp_Object nextevt + = read_event_from_main_queue (end_time, local_getcjmp, + used_mouse_menu); +#ifdef WINDOWSNT + /* w32_console already returns decoded events. It either reads + Unicode characters from the Windows keyboard input, or + converts characters encoded in the current codepage into + Unicode. See w32inevt.c:key_event, near its end. */ + return nextevt; +#else + struct frame *frame = XFRAME (selected_frame); + struct terminal *terminal = frame->terminal; + if (!((FRAME_TERMCAP_P (frame) || FRAME_MSDOS_P (frame)) + /* Don't apply decoding if we're just reading a raw event + (e.g. reading bytes sent by the xterm to specify the position + of a mouse click). */ + && (!EQ (prev_event, Qt)) + && (TERMINAL_KEYBOARD_CODING (terminal)->common_flags + & CODING_REQUIRE_DECODING_MASK))) + return nextevt; /* No decoding needed. */ + else + { + int meta_key = terminal->display_info.tty->meta_key; + eassert (n < MAX_ENCODED_BYTES); + events[n++] = nextevt; + if (NATNUMP (nextevt) + && XINT (nextevt) < (meta_key == 1 ? 0x80 : 0x100)) + { /* An encoded byte sequence, let's try to decode it. */ + struct coding_system *coding + = TERMINAL_KEYBOARD_CODING (terminal); + + if (raw_text_coding_system_p (coding)) + { + int i; + if (meta_key != 2) + for (i = 0; i < n; i++) + events[i] = make_number (XINT (events[i]) & ~0x80); + } + else + { + unsigned char src[MAX_ENCODED_BYTES]; + unsigned char dest[MAX_ENCODED_BYTES * MAX_MULTIBYTE_LENGTH]; + int i; + for (i = 0; i < n; i++) + src[i] = XINT (events[i]); + if (meta_key != 2) + for (i = 0; i < n; i++) + src[i] &= ~0x80; + coding->destination = dest; + coding->dst_bytes = sizeof dest; + decode_coding_c_string (coding, src, n, Qnil); + eassert (coding->produced_char <= n); + if (coding->produced_char == 0) + { /* The encoded sequence is incomplete. */ + if (n < MAX_ENCODED_BYTES) /* Avoid buffer overflow. */ + continue; /* Read on! */ + } + else + { + const unsigned char *p = coding->destination; + eassert (coding->carryover_bytes == 0); + n = 0; + while (n < coding->produced_char) + events[n++] = make_number (STRING_CHAR_ADVANCE (p)); + } + } + } + /* Now `events' should hold decoded events. + Normally, n should be equal to 1, but better not rely on it. + We can only return one event here, so return the first we + had and keep the others (if any) for later. */ + while (n > 1) + Vunread_command_events + = Fcons (events[--n], Vunread_command_events); + return events[0]; + } +#endif + } +} + +static bool +echo_keystrokes_p (void) +{ + return (FLOATP (Vecho_keystrokes) ? XFLOAT_DATA (Vecho_keystrokes) > 0.0 + : INTEGERP (Vecho_keystrokes) ? XINT (Vecho_keystrokes) > 0 : false); +} + +/* Read a character from the keyboard; call the redisplay if needed. */ +/* commandflag 0 means do not autosave, but do redisplay. + -1 means do not redisplay, but do autosave. + -2 means do neither. + 1 means do both. + + The argument MAP is a keymap for menu prompting. + + PREV_EVENT is the previous input event, or nil if we are reading + the first event of a key sequence (or not reading a key sequence). + If PREV_EVENT is t, that is a "magic" value that says + not to run input methods, but in other respects to act as if + not reading a key sequence. + + If USED_MOUSE_MENU is non-null, then set *USED_MOUSE_MENU to true + if we used a mouse menu to read the input, or false otherwise. If + USED_MOUSE_MENU is null, don't dereference it. + + Value is -2 when we find input on another keyboard. A second call + to read_char will read it. + + If END_TIME is non-null, it is a pointer to a struct timespec + specifying the maximum time to wait until. If no input arrives by + that time, stop waiting and return nil. + + Value is t if we showed a menu and the user rejected it. */ + +Lisp_Object +read_char (int commandflag, Lisp_Object map, + Lisp_Object prev_event, + bool *used_mouse_menu, struct timespec *end_time) +{ + Lisp_Object c; + ptrdiff_t jmpcount; + sys_jmp_buf local_getcjmp; + sys_jmp_buf save_jump; + Lisp_Object tem, save; + volatile Lisp_Object previous_echo_area_message; + volatile Lisp_Object also_record; + volatile bool reread; + struct gcpro gcpro1, gcpro2; + bool volatile polling_stopped_here = 0; + struct kboard *orig_kboard = current_kboard; + + also_record = Qnil; + +#if 0 /* This was commented out as part of fixing echo for C-u left. */ + before_command_key_count = this_command_key_count; + before_command_echo_length = echo_length (); +#endif + c = Qnil; + previous_echo_area_message = Qnil; + + GCPRO2 (c, previous_echo_area_message); + + retry: + + if (CONSP (Vunread_post_input_method_events)) + { + c = XCAR (Vunread_post_input_method_events); + Vunread_post_input_method_events + = XCDR (Vunread_post_input_method_events); + + /* Undo what read_char_x_menu_prompt did when it unread + additional keys returned by Fx_popup_menu. */ + if (CONSP (c) + && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c))) + && NILP (XCDR (c))) + c = XCAR (c); + + reread = true; + goto reread_first; + } + else + reread = false; + + + if (CONSP (Vunread_command_events)) + { + bool was_disabled = 0; + + c = XCAR (Vunread_command_events); + Vunread_command_events = XCDR (Vunread_command_events); + + /* Undo what sit-for did when it unread additional keys + inside universal-argument. */ + + if (CONSP (c) && EQ (XCAR (c), Qt)) + c = XCDR (c); + else + reread = true; + + /* Undo what read_char_x_menu_prompt did when it unread + additional keys returned by Fx_popup_menu. */ + if (CONSP (c) + && EQ (XCDR (c), Qdisabled) + && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c)))) + { + was_disabled = 1; + c = XCAR (c); + } + + /* If the queued event is something that used the mouse, + set used_mouse_menu accordingly. */ + if (used_mouse_menu + /* Also check was_disabled so last-nonmenu-event won't return + a bad value when submenus are involved. (Bug#447) */ + && (EQ (c, Qtool_bar) || EQ (c, Qmenu_bar) || was_disabled)) + *used_mouse_menu = 1; + + goto reread_for_input_method; + } + + if (CONSP (Vunread_input_method_events)) + { + c = XCAR (Vunread_input_method_events); + Vunread_input_method_events = XCDR (Vunread_input_method_events); + + /* Undo what read_char_x_menu_prompt did when it unread + additional keys returned by Fx_popup_menu. */ + if (CONSP (c) + && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c))) + && NILP (XCDR (c))) + c = XCAR (c); + reread = true; + goto reread_for_input_method; + } + + this_command_key_count_reset = 0; + + if (!NILP (Vexecuting_kbd_macro)) + { + /* We set this to Qmacro; since that's not a frame, nobody will + try to switch frames on us, and the selected window will + remain unchanged. + + Since this event came from a macro, it would be misleading to + leave internal_last_event_frame set to wherever the last + real event came from. Normally, a switch-frame event selects + internal_last_event_frame after each command is read, but + events read from a macro should never cause a new frame to be + selected. */ + Vlast_event_frame = internal_last_event_frame = Qmacro; + + /* Exit the macro if we are at the end. + Also, some things replace the macro with t + to force an early exit. */ + if (EQ (Vexecuting_kbd_macro, Qt) + || executing_kbd_macro_index >= XFASTINT (Flength (Vexecuting_kbd_macro))) + { + XSETINT (c, -1); + goto exit; + } + + c = Faref (Vexecuting_kbd_macro, make_number (executing_kbd_macro_index)); + if (STRINGP (Vexecuting_kbd_macro) + && (XFASTINT (c) & 0x80) && (XFASTINT (c) <= 0xff)) + XSETFASTINT (c, CHAR_META | (XFASTINT (c) & ~0x80)); + + executing_kbd_macro_index++; + + goto from_macro; + } + + if (!NILP (unread_switch_frame)) + { + c = unread_switch_frame; + unread_switch_frame = Qnil; + + /* This event should make it into this_command_keys, and get echoed + again, so we do not set `reread'. */ + goto reread_first; + } + + /* If redisplay was requested. */ + if (commandflag >= 0) + { + bool echo_current = EQ (echo_message_buffer, echo_area_buffer[0]); + + /* If there is pending input, process any events which are not + user-visible, such as X selection_request events. */ + if (input_pending + || detect_input_pending_run_timers (0)) + swallow_events (false); /* May clear input_pending. */ + + /* Redisplay if no pending input. */ + while (!(input_pending + && (input_was_pending || !redisplay_dont_pause))) + { + input_was_pending = input_pending; + if (help_echo_showing_p && !EQ (selected_window, minibuf_window)) + redisplay_preserve_echo_area (5); + else + redisplay (); + + if (!input_pending) + /* Normal case: no input arrived during redisplay. */ + break; + + /* Input arrived and pre-empted redisplay. + Process any events which are not user-visible. */ + swallow_events (false); + /* If that cleared input_pending, try again to redisplay. */ + } + + /* Prevent the redisplay we just did + from messing up echoing of the input after the prompt. */ + if (commandflag == 0 && echo_current) + echo_message_buffer = echo_area_buffer[0]; + + } + + /* Message turns off echoing unless more keystrokes turn it on again. + + The code in 20.x for the condition was + + 1. echo_area_glyphs && *echo_area_glyphs + 2. && echo_area_glyphs != current_kboard->echobuf + 3. && ok_to_echo_at_next_pause != echo_area_glyphs + + (1) means there's a current message displayed + + (2) means it's not the message from echoing from the current + kboard. + + (3) There's only one place in 20.x where ok_to_echo_at_next_pause + is set to a non-null value. This is done in read_char and it is + set to echo_area_glyphs after a call to echo_char. That means + ok_to_echo_at_next_pause is either null or + current_kboard->echobuf with the appropriate current_kboard at + that time. + + So, condition (3) means in clear text ok_to_echo_at_next_pause + must be either null, or the current message isn't from echoing at + all, or it's from echoing from a different kboard than the + current one. */ + + if (/* There currently is something in the echo area. */ + !NILP (echo_area_buffer[0]) + && (/* It's an echo from a different kboard. */ + echo_kboard != current_kboard + /* Or we explicitly allow overwriting whatever there is. */ + || ok_to_echo_at_next_pause == NULL)) + cancel_echoing (); + else + echo_dash (); + + /* Try reading a character via menu prompting in the minibuf. + Try this before the sit-for, because the sit-for + would do the wrong thing if we are supposed to do + menu prompting. If EVENT_HAS_PARAMETERS then we are reading + after a mouse event so don't try a minibuf menu. */ + c = Qnil; + if (KEYMAPP (map) && INTERACTIVE + && !NILP (prev_event) && ! EVENT_HAS_PARAMETERS (prev_event) + /* Don't bring up a menu if we already have another event. */ + && NILP (Vunread_command_events) + && !detect_input_pending_run_timers (0)) + { + c = read_char_minibuf_menu_prompt (commandflag, map); + + if (INTEGERP (c) && XINT (c) == -2) + return c; /* wrong_kboard_jmpbuf */ + + if (! NILP (c)) + goto exit; + } + + /* Make a longjmp point for quits to use, but don't alter getcjmp just yet. + We will do that below, temporarily for short sections of code, + when appropriate. local_getcjmp must be in effect + around any call to sit_for or kbd_buffer_get_event; + it *must not* be in effect when we call redisplay. */ + + jmpcount = SPECPDL_INDEX (); + if (sys_setjmp (local_getcjmp)) + { + /* Handle quits while reading the keyboard. */ + /* We must have saved the outer value of getcjmp here, + so restore it now. */ + restore_getcjmp (save_jump); + pthread_sigmask (SIG_SETMASK, &empty_mask, 0); + unbind_to (jmpcount, Qnil); + XSETINT (c, quit_char); + internal_last_event_frame = selected_frame; + Vlast_event_frame = internal_last_event_frame; + /* If we report the quit char as an event, + don't do so more than once. */ + if (!NILP (Vinhibit_quit)) + Vquit_flag = Qnil; + + { + KBOARD *kb = FRAME_KBOARD (XFRAME (selected_frame)); + if (kb != current_kboard) + { + Lisp_Object last = KVAR (kb, kbd_queue); + /* We shouldn't get here if we were in single-kboard mode! */ + if (single_kboard) + emacs_abort (); + if (CONSP (last)) + { + while (CONSP (XCDR (last))) + last = XCDR (last); + if (!NILP (XCDR (last))) + emacs_abort (); + } + if (!CONSP (last)) + kset_kbd_queue (kb, list1 (c)); + else + XSETCDR (last, list1 (c)); + kb->kbd_queue_has_data = 1; + current_kboard = kb; + /* This is going to exit from read_char + so we had better get rid of this frame's stuff. */ + UNGCPRO; + return make_number (-2); /* wrong_kboard_jmpbuf */ + } + } + goto non_reread; + } + + /* Start idle timers if no time limit is supplied. We don't do it + if a time limit is supplied to avoid an infinite recursion in the + situation where an idle timer calls `sit-for'. */ + + if (!end_time) + timer_start_idle (); + + /* If in middle of key sequence and minibuffer not active, + start echoing if enough time elapses. */ + + if (minibuf_level == 0 + && !end_time + && !current_kboard->immediate_echo + && this_command_key_count > 0 + && ! noninteractive + && echo_keystrokes_p () + && (/* No message. */ + NILP (echo_area_buffer[0]) + /* Or empty message. */ + || (BUF_BEG (XBUFFER (echo_area_buffer[0])) + == BUF_Z (XBUFFER (echo_area_buffer[0]))) + /* Or already echoing from same kboard. */ + || (echo_kboard && ok_to_echo_at_next_pause == echo_kboard) + /* Or not echoing before and echoing allowed. */ + || (!echo_kboard && ok_to_echo_at_next_pause))) + { + /* After a mouse event, start echoing right away. + This is because we are probably about to display a menu, + and we don't want to delay before doing so. */ + if (EVENT_HAS_PARAMETERS (prev_event)) + echo_now (); + else + { + Lisp_Object tem0; + + save_getcjmp (save_jump); + restore_getcjmp (local_getcjmp); + tem0 = sit_for (Vecho_keystrokes, 1, 1); + restore_getcjmp (save_jump); + if (EQ (tem0, Qt) + && ! CONSP (Vunread_command_events)) + echo_now (); + } + } + + /* Maybe auto save due to number of keystrokes. */ + + if (commandflag != 0 && commandflag != -2 + && auto_save_interval > 0 + && num_nonmacro_input_events - last_auto_save > max (auto_save_interval, 20) + && !detect_input_pending_run_timers (0)) + { + Fdo_auto_save (Qnil, Qnil); + /* Hooks can actually change some buffers in auto save. */ + redisplay (); + } + + /* Try reading using an X menu. + This is never confused with reading using the minibuf + because the recursive call of read_char in read_char_minibuf_menu_prompt + does not pass on any keymaps. */ + + if (KEYMAPP (map) && INTERACTIVE + && !NILP (prev_event) + && EVENT_HAS_PARAMETERS (prev_event) + && !EQ (XCAR (prev_event), Qmenu_bar) + && !EQ (XCAR (prev_event), Qtool_bar) + /* Don't bring up a menu if we already have another event. */ + && NILP (Vunread_command_events)) + { + c = read_char_x_menu_prompt (map, prev_event, used_mouse_menu); + + /* Now that we have read an event, Emacs is not idle. */ + if (!end_time) + timer_stop_idle (); + + goto exit; + } + + /* Maybe autosave and/or garbage collect due to idleness. */ + + if (INTERACTIVE && NILP (c)) + { + int delay_level; + ptrdiff_t buffer_size; + + /* Slow down auto saves logarithmically in size of current buffer, + and garbage collect while we're at it. */ + if (! MINI_WINDOW_P (XWINDOW (selected_window))) + last_non_minibuf_size = Z - BEG; + buffer_size = (last_non_minibuf_size >> 8) + 1; + delay_level = 0; + while (buffer_size > 64) + delay_level++, buffer_size -= buffer_size >> 2; + if (delay_level < 4) delay_level = 4; + /* delay_level is 4 for files under around 50k, 7 at 100k, + 9 at 200k, 11 at 300k, and 12 at 500k. It is 15 at 1 meg. */ + + /* Auto save if enough time goes by without input. */ + if (commandflag != 0 && commandflag != -2 + && num_nonmacro_input_events > last_auto_save + && INTEGERP (Vauto_save_timeout) + && XINT (Vauto_save_timeout) > 0) + { + Lisp_Object tem0; + EMACS_INT timeout = XFASTINT (Vauto_save_timeout); + + timeout = min (timeout, MOST_POSITIVE_FIXNUM / delay_level * 4); + timeout = delay_level * timeout / 4; + save_getcjmp (save_jump); + restore_getcjmp (local_getcjmp); + tem0 = sit_for (make_number (timeout), 1, 1); + restore_getcjmp (save_jump); + + if (EQ (tem0, Qt) + && ! CONSP (Vunread_command_events)) + { + Fdo_auto_save (Qnil, Qnil); + redisplay (); + } + } + + /* If there is still no input available, ask for GC. */ + if (!detect_input_pending_run_timers (0)) + maybe_gc (); + } + + /* Notify the caller if an autosave hook, or a timer, sentinel or + filter in the sit_for calls above have changed the current + kboard. This could happen if they use the minibuffer or start a + recursive edit, like the fancy splash screen in server.el's + filter. If this longjmp wasn't here, read_key_sequence would + interpret the next key sequence using the wrong translation + tables and function keymaps. */ + if (NILP (c) && current_kboard != orig_kboard) + { + UNGCPRO; + return make_number (-2); /* wrong_kboard_jmpbuf */ + } + + /* If this has become non-nil here, it has been set by a timer + or sentinel or filter. */ + if (CONSP (Vunread_command_events)) + { + c = XCAR (Vunread_command_events); + Vunread_command_events = XCDR (Vunread_command_events); + + if (CONSP (c) && EQ (XCAR (c), Qt)) + c = XCDR (c); + else + reread = true; + } + + /* Read something from current KBOARD's side queue, if possible. */ + + if (NILP (c)) + { + if (current_kboard->kbd_queue_has_data) + { + if (!CONSP (KVAR (current_kboard, kbd_queue))) + emacs_abort (); + c = XCAR (KVAR (current_kboard, kbd_queue)); + kset_kbd_queue (current_kboard, + XCDR (KVAR (current_kboard, kbd_queue))); + if (NILP (KVAR (current_kboard, kbd_queue))) + current_kboard->kbd_queue_has_data = 0; + input_pending = readable_events (0); + if (EVENT_HAS_PARAMETERS (c) + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qswitch_frame)) + internal_last_event_frame = XCAR (XCDR (c)); + Vlast_event_frame = internal_last_event_frame; + } + } + + /* If current_kboard's side queue is empty check the other kboards. + If one of them has data that we have not yet seen here, + switch to it and process the data waiting for it. + + Note: if the events queued up for another kboard + have already been seen here, and therefore are not a complete command, + the kbd_queue_has_data field is 0, so we skip that kboard here. + That's to avoid an infinite loop switching between kboards here. */ + if (NILP (c) && !single_kboard) + { + KBOARD *kb; + for (kb = all_kboards; kb; kb = kb->next_kboard) + if (kb->kbd_queue_has_data) + { + current_kboard = kb; + /* This is going to exit from read_char + so we had better get rid of this frame's stuff. */ + UNGCPRO; + return make_number (-2); /* wrong_kboard_jmpbuf */ + } + } + + wrong_kboard: + + STOP_POLLING; + + if (NILP (c)) + { + c = read_decoded_event_from_main_queue (end_time, local_getcjmp, + prev_event, used_mouse_menu); + if (NILP (c) && end_time + && timespec_cmp (*end_time, current_timespec ()) <= 0) + { + goto exit; + } + + if (EQ (c, make_number (-2))) + { + /* This is going to exit from read_char + so we had better get rid of this frame's stuff. */ + UNGCPRO; + return c; + } + } + + non_reread: + + if (!end_time) + timer_stop_idle (); + RESUME_POLLING; + + if (NILP (c)) + { + if (commandflag >= 0 + && !input_pending && !detect_input_pending_run_timers (0)) + redisplay (); + + goto wrong_kboard; + } + + /* Buffer switch events are only for internal wakeups + so don't show them to the user. + Also, don't record a key if we already did. */ + if (BUFFERP (c)) + goto exit; + + /* Process special events within read_char + and loop around to read another event. */ + save = Vquit_flag; + Vquit_flag = Qnil; + tem = access_keymap (get_keymap (Vspecial_event_map, 0, 1), c, 0, 0, 1); + Vquit_flag = save; + + if (!NILP (tem)) + { + struct buffer *prev_buffer = current_buffer; + last_input_event = c; + call4 (Qcommand_execute, tem, Qnil, Fvector (1, &last_input_event), Qt); + + if (CONSP (c) && EQ (XCAR (c), Qselect_window) && !end_time) + /* We stopped being idle for this event; undo that. This + prevents automatic window selection (under + mouse_autoselect_window from acting as a real input event, for + example banishing the mouse under mouse-avoidance-mode. */ + timer_resume_idle (); + + if (current_buffer != prev_buffer) + { + /* The command may have changed the keymaps. Pretend there + is input in another keyboard and return. This will + recalculate keymaps. */ + c = make_number (-2); + goto exit; + } + else + goto retry; + } + + /* Handle things that only apply to characters. */ + if (INTEGERP (c)) + { + /* If kbd_buffer_get_event gave us an EOF, return that. */ + if (XINT (c) == -1) + goto exit; + + if ((STRINGP (KVAR (current_kboard, Vkeyboard_translate_table)) + && UNSIGNED_CMP (XFASTINT (c), <, + SCHARS (KVAR (current_kboard, + Vkeyboard_translate_table)))) + || (VECTORP (KVAR (current_kboard, Vkeyboard_translate_table)) + && UNSIGNED_CMP (XFASTINT (c), <, + ASIZE (KVAR (current_kboard, + Vkeyboard_translate_table)))) + || (CHAR_TABLE_P (KVAR (current_kboard, Vkeyboard_translate_table)) + && CHARACTERP (c))) + { + Lisp_Object d; + d = Faref (KVAR (current_kboard, Vkeyboard_translate_table), c); + /* nil in keyboard-translate-table means no translation. */ + if (!NILP (d)) + c = d; + } + } + + /* If this event is a mouse click in the menu bar, + return just menu-bar for now. Modify the mouse click event + so we won't do this twice, then queue it up. */ + if (EVENT_HAS_PARAMETERS (c) + && CONSP (XCDR (c)) + && CONSP (EVENT_START (c)) + && CONSP (XCDR (EVENT_START (c)))) + { + Lisp_Object posn; + + posn = POSN_POSN (EVENT_START (c)); + /* Handle menu-bar events: + insert the dummy prefix event `menu-bar'. */ + if (EQ (posn, Qmenu_bar) || EQ (posn, Qtool_bar)) + { + /* Change menu-bar to (menu-bar) as the event "position". */ + POSN_SET_POSN (EVENT_START (c), list1 (posn)); + + also_record = c; + Vunread_command_events = Fcons (c, Vunread_command_events); + c = posn; + } + } + + /* Store these characters into recent_keys, the dribble file if any, + and the keyboard macro being defined, if any. */ + record_char (c); + if (! NILP (also_record)) + record_char (also_record); + + /* Wipe the echo area. + But first, if we are about to use an input method, + save the echo area contents for it to refer to. */ + if (INTEGERP (c) + && ! NILP (Vinput_method_function) + && ' ' <= XINT (c) && XINT (c) < 256 && XINT (c) != 127) + { + previous_echo_area_message = Fcurrent_message (); + Vinput_method_previous_message = previous_echo_area_message; + } + + /* Now wipe the echo area, except for help events which do their + own stuff with the echo area. */ + if (!CONSP (c) + || (!(EQ (Qhelp_echo, XCAR (c))) + && !(EQ (Qswitch_frame, XCAR (c))) + /* Don't wipe echo area for select window events: These might + get delayed via `mouse-autoselect-window' (Bug#11304). */ + && !(EQ (Qselect_window, XCAR (c))))) + { + if (!NILP (echo_area_buffer[0])) + { + safe_run_hooks (Qecho_area_clear_hook); + clear_message (1, 0); + } + } + + reread_for_input_method: + from_macro: + /* Pass this to the input method, if appropriate. */ + if (INTEGERP (c) + && ! NILP (Vinput_method_function) + /* Don't run the input method within a key sequence, + after the first event of the key sequence. */ + && NILP (prev_event) + && ' ' <= XINT (c) && XINT (c) < 256 && XINT (c) != 127) + { + Lisp_Object keys; + ptrdiff_t key_count; + bool key_count_reset; + ptrdiff_t command_key_start; + struct gcpro gcpro1; + ptrdiff_t count = SPECPDL_INDEX (); + + /* Save the echo status. */ + bool saved_immediate_echo = current_kboard->immediate_echo; + struct kboard *saved_ok_to_echo = ok_to_echo_at_next_pause; + Lisp_Object saved_echo_string = KVAR (current_kboard, echo_string); + ptrdiff_t saved_echo_after_prompt = current_kboard->echo_after_prompt; + +#if 0 + if (before_command_restore_flag) + { + this_command_key_count = before_command_key_count_1; + if (this_command_key_count < this_single_command_key_start) + this_single_command_key_start = this_command_key_count; + echo_truncate (before_command_echo_length_1); + before_command_restore_flag = 0; + } +#endif + + /* Save the this_command_keys status. */ + key_count = this_command_key_count; + key_count_reset = this_command_key_count_reset; + command_key_start = this_single_command_key_start; + + if (key_count > 0) + keys = Fcopy_sequence (this_command_keys); + else + keys = Qnil; + GCPRO1 (keys); + + /* Clear out this_command_keys. */ + this_command_key_count = 0; + this_command_key_count_reset = 0; + this_single_command_key_start = 0; + + /* Now wipe the echo area. */ + if (!NILP (echo_area_buffer[0])) + safe_run_hooks (Qecho_area_clear_hook); + clear_message (1, 0); + echo_truncate (0); + + /* If we are not reading a key sequence, + never use the echo area. */ + if (!KEYMAPP (map)) + { + specbind (Qinput_method_use_echo_area, Qt); + } + + /* Call the input method. */ + tem = call1 (Vinput_method_function, c); + + tem = unbind_to (count, tem); + + /* Restore the saved echoing state + and this_command_keys state. */ + this_command_key_count = key_count; + this_command_key_count_reset = key_count_reset; + this_single_command_key_start = command_key_start; + if (key_count > 0) + this_command_keys = keys; + + cancel_echoing (); + ok_to_echo_at_next_pause = saved_ok_to_echo; + /* Do not restore the echo area string when the user is + introducing a prefix argument. Otherwise we end with + repetitions of the partially introduced prefix + argument. (bug#19875) */ + if (NILP (intern ("prefix-arg"))) + { + kset_echo_string (current_kboard, saved_echo_string); + } + current_kboard->echo_after_prompt = saved_echo_after_prompt; + if (saved_immediate_echo) + echo_now (); + + UNGCPRO; + + /* The input method can return no events. */ + if (! CONSP (tem)) + { + /* Bring back the previous message, if any. */ + if (! NILP (previous_echo_area_message)) + message_with_string ("%s", previous_echo_area_message, 0); + goto retry; + } + /* It returned one event or more. */ + c = XCAR (tem); + Vunread_post_input_method_events + = nconc2 (XCDR (tem), Vunread_post_input_method_events); + } + + reread_first: + + /* Display help if not echoing. */ + if (CONSP (c) && EQ (XCAR (c), Qhelp_echo)) + { + /* (help-echo FRAME HELP WINDOW OBJECT POS). */ + Lisp_Object help, object, position, window, htem; + + htem = Fcdr (XCDR (c)); + help = Fcar (htem); + htem = Fcdr (htem); + window = Fcar (htem); + htem = Fcdr (htem); + object = Fcar (htem); + htem = Fcdr (htem); + position = Fcar (htem); + + show_help_echo (help, window, object, position); + + /* We stopped being idle for this event; undo that. */ + if (!end_time) + timer_resume_idle (); + goto retry; + } + + if ((! reread || this_command_key_count == 0 + || this_command_key_count_reset) + && !end_time) + { + + /* Don't echo mouse motion events. */ + if (echo_keystrokes_p () + && ! (EVENT_HAS_PARAMETERS (c) + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qmouse_movement))) + { + echo_char (c); + if (! NILP (also_record)) + echo_char (also_record); + /* Once we reread a character, echoing can happen + the next time we pause to read a new one. */ + ok_to_echo_at_next_pause = current_kboard; + } + + /* Record this character as part of the current key. */ + add_command_key (c); + if (! NILP (also_record)) + add_command_key (also_record); + } + + last_input_event = c; + num_input_events++; + + /* Process the help character specially if enabled. */ + if (!NILP (Vhelp_form) && help_char_p (c)) + { + ptrdiff_t count = SPECPDL_INDEX (); + + help_form_saved_window_configs + = Fcons (Fcurrent_window_configuration (Qnil), + help_form_saved_window_configs); + record_unwind_protect_void (read_char_help_form_unwind); + call0 (Qhelp_form_show); + + cancel_echoing (); + do + { + c = read_char (0, Qnil, Qnil, 0, NULL); + if (EVENT_HAS_PARAMETERS (c) + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qmouse_click)) + XSETCAR (help_form_saved_window_configs, Qnil); + } + while (BUFFERP (c)); + /* Remove the help from the frame. */ + unbind_to (count, Qnil); + + redisplay (); + if (EQ (c, make_number (040))) + { + cancel_echoing (); + do + c = read_char (0, Qnil, Qnil, 0, NULL); + while (BUFFERP (c)); + } + } + + exit: + RESUME_POLLING; + input_was_pending = input_pending; + RETURN_UNGCPRO (c); +} + +/* Record a key that came from a mouse menu. + Record it for echoing, for this-command-keys, and so on. */ + +static void +record_menu_key (Lisp_Object c) +{ + /* Wipe the echo area. */ + clear_message (1, 0); + + record_char (c); + +#if 0 + before_command_key_count = this_command_key_count; + before_command_echo_length = echo_length (); +#endif + + /* Don't echo mouse motion events. */ + if (echo_keystrokes_p ()) + { + echo_char (c); + + /* Once we reread a character, echoing can happen + the next time we pause to read a new one. */ + ok_to_echo_at_next_pause = 0; + } + + /* Record this character as part of the current key. */ + add_command_key (c); + + /* Re-reading in the middle of a command. */ + last_input_event = c; + num_input_events++; +} + +/* Return true if should recognize C as "the help character". */ + +static bool +help_char_p (Lisp_Object c) +{ + Lisp_Object tail; + + if (EQ (c, Vhelp_char)) + return 1; + for (tail = Vhelp_event_list; CONSP (tail); tail = XCDR (tail)) + if (EQ (c, XCAR (tail))) + return 1; + return 0; +} + +/* Record the input event C in various ways. */ + +static void +record_char (Lisp_Object c) +{ + int recorded = 0; + + if (CONSP (c) && (EQ (XCAR (c), Qhelp_echo) || EQ (XCAR (c), Qmouse_movement))) + { + /* To avoid filling recent_keys with help-echo and mouse-movement + events, we filter out repeated help-echo events, only store the + first and last in a series of mouse-movement events, and don't + store repeated help-echo events which are only separated by + mouse-movement events. */ + + Lisp_Object ev1, ev2, ev3; + int ix1, ix2, ix3; + + if ((ix1 = recent_keys_index - 1) < 0) + ix1 = NUM_RECENT_KEYS - 1; + ev1 = AREF (recent_keys, ix1); + + if ((ix2 = ix1 - 1) < 0) + ix2 = NUM_RECENT_KEYS - 1; + ev2 = AREF (recent_keys, ix2); + + if ((ix3 = ix2 - 1) < 0) + ix3 = NUM_RECENT_KEYS - 1; + ev3 = AREF (recent_keys, ix3); + + if (EQ (XCAR (c), Qhelp_echo)) + { + /* Don't record `help-echo' in recent_keys unless it shows some help + message, and a different help than the previously recorded + event. */ + Lisp_Object help, last_help; + + help = Fcar_safe (Fcdr_safe (XCDR (c))); + if (!STRINGP (help)) + recorded = 1; + else if (CONSP (ev1) && EQ (XCAR (ev1), Qhelp_echo) + && (last_help = Fcar_safe (Fcdr_safe (XCDR (ev1))), EQ (last_help, help))) + recorded = 1; + else if (CONSP (ev1) && EQ (XCAR (ev1), Qmouse_movement) + && CONSP (ev2) && EQ (XCAR (ev2), Qhelp_echo) + && (last_help = Fcar_safe (Fcdr_safe (XCDR (ev2))), EQ (last_help, help))) + recorded = -1; + else if (CONSP (ev1) && EQ (XCAR (ev1), Qmouse_movement) + && CONSP (ev2) && EQ (XCAR (ev2), Qmouse_movement) + && CONSP (ev3) && EQ (XCAR (ev3), Qhelp_echo) + && (last_help = Fcar_safe (Fcdr_safe (XCDR (ev3))), EQ (last_help, help))) + recorded = -2; + } + else if (EQ (XCAR (c), Qmouse_movement)) + { + /* Only record one pair of `mouse-movement' on a window in recent_keys. + So additional mouse movement events replace the last element. */ + Lisp_Object last_window, window; + + window = Fcar_safe (Fcar_safe (XCDR (c))); + if (CONSP (ev1) && EQ (XCAR (ev1), Qmouse_movement) + && (last_window = Fcar_safe (Fcar_safe (XCDR (ev1))), EQ (last_window, window)) + && CONSP (ev2) && EQ (XCAR (ev2), Qmouse_movement) + && (last_window = Fcar_safe (Fcar_safe (XCDR (ev2))), EQ (last_window, window))) + { + ASET (recent_keys, ix1, c); + recorded = 1; + } + } + } + else + store_kbd_macro_char (c); + + if (!recorded) + { + total_keys += total_keys < NUM_RECENT_KEYS; + ASET (recent_keys, recent_keys_index, c); + if (++recent_keys_index >= NUM_RECENT_KEYS) + recent_keys_index = 0; + } + else if (recorded < 0) + { + /* We need to remove one or two events from recent_keys. + To do this, we simply put nil at those events and move the + recent_keys_index backwards over those events. Usually, + users will never see those nil events, as they will be + overwritten by the command keys entered to see recent_keys + (e.g. C-h l). */ + + while (recorded++ < 0 && total_keys > 0) + { + if (total_keys < NUM_RECENT_KEYS) + total_keys--; + if (--recent_keys_index < 0) + recent_keys_index = NUM_RECENT_KEYS - 1; + ASET (recent_keys, recent_keys_index, Qnil); + } + } + + num_nonmacro_input_events++; + + /* Write c to the dribble file. If c is a lispy event, write + the event's symbol to the dribble file, in . Bleaugh. + If you, dear reader, have a better idea, you've got the source. :-) */ + if (dribble) + { + block_input (); + if (INTEGERP (c)) + { + if (XUINT (c) < 0x100) + putc (XUINT (c), dribble); + else + fprintf (dribble, " 0x%"pI"x", XUINT (c)); + } + else + { + Lisp_Object dribblee; + + /* If it's a structured event, take the event header. */ + dribblee = EVENT_HEAD (c); + + if (SYMBOLP (dribblee)) + { + putc ('<', dribble); + fwrite (SDATA (SYMBOL_NAME (dribblee)), sizeof (char), + SBYTES (SYMBOL_NAME (dribblee)), + dribble); + putc ('>', dribble); + } + } + + fflush (dribble); + unblock_input (); + } +} + +/* Copy out or in the info on where C-g should throw to. + This is used when running Lisp code from within get_char, + in case get_char is called recursively. + See read_process_output. */ + +static void +save_getcjmp (sys_jmp_buf temp) +{ + memcpy (temp, getcjmp, sizeof getcjmp); +} + +static void +restore_getcjmp (sys_jmp_buf temp) +{ + memcpy (getcjmp, temp, sizeof getcjmp); +} + +/* Low level keyboard/mouse input. + kbd_buffer_store_event places events in kbd_buffer, and + kbd_buffer_get_event retrieves them. */ + +/* Return true if there are any events in the queue that read-char + would return. If this returns false, a read-char would block. */ +static bool +readable_events (int flags) +{ + if (flags & READABLE_EVENTS_DO_TIMERS_NOW) + timer_check (); + + /* If the buffer contains only FOCUS_IN_EVENT events, and + READABLE_EVENTS_FILTER_EVENTS is set, report it as empty. */ + if (kbd_fetch_ptr != kbd_store_ptr) + { + if (flags & (READABLE_EVENTS_FILTER_EVENTS +#ifdef USE_TOOLKIT_SCROLL_BARS + | READABLE_EVENTS_IGNORE_SQUEEZABLES +#endif + )) + { + struct input_event *event; + + event = ((kbd_fetch_ptr < kbd_buffer + KBD_BUFFER_SIZE) + ? kbd_fetch_ptr + : kbd_buffer); + + do + { + if (!( +#ifdef USE_TOOLKIT_SCROLL_BARS + (flags & READABLE_EVENTS_FILTER_EVENTS) && +#endif + event->kind == FOCUS_IN_EVENT) +#ifdef USE_TOOLKIT_SCROLL_BARS + && !((flags & READABLE_EVENTS_IGNORE_SQUEEZABLES) + && (event->kind == SCROLL_BAR_CLICK_EVENT + || event->kind == HORIZONTAL_SCROLL_BAR_CLICK_EVENT) + && event->part == scroll_bar_handle + && event->modifiers == 0) +#endif + && !((flags & READABLE_EVENTS_FILTER_EVENTS) + && event->kind == BUFFER_SWITCH_EVENT)) + return 1; + event++; + if (event == kbd_buffer + KBD_BUFFER_SIZE) + event = kbd_buffer; + } + while (event != kbd_store_ptr); + } + else + return 1; + } + + if (!(flags & READABLE_EVENTS_IGNORE_SQUEEZABLES) + && !NILP (do_mouse_tracking) && some_mouse_moved ()) + return 1; + if (single_kboard) + { + if (current_kboard->kbd_queue_has_data) + return 1; + } + else + { + KBOARD *kb; + for (kb = all_kboards; kb; kb = kb->next_kboard) + if (kb->kbd_queue_has_data) + return 1; + } + return 0; +} + +/* Set this for debugging, to have a way to get out */ +int stop_character EXTERNALLY_VISIBLE; + +static KBOARD * +event_to_kboard (struct input_event *event) +{ + /* Not applicable for these special events. */ + if (event->kind == SELECTION_REQUEST_EVENT + || event->kind == SELECTION_CLEAR_EVENT) + return NULL; + else + { + Lisp_Object obj = event->frame_or_window; + /* There are some events that set this field to nil or string. */ + if (WINDOWP (obj)) + obj = WINDOW_FRAME (XWINDOW (obj)); + /* Also ignore dead frames here. */ + return ((FRAMEP (obj) && FRAME_LIVE_P (XFRAME (obj))) + ? FRAME_KBOARD (XFRAME (obj)) : NULL); + } +} + +#ifdef subprocesses +/* Return the number of slots occupied in kbd_buffer. */ + +static int +kbd_buffer_nr_stored (void) +{ + return kbd_fetch_ptr == kbd_store_ptr + ? 0 + : (kbd_fetch_ptr < kbd_store_ptr + ? kbd_store_ptr - kbd_fetch_ptr + : ((kbd_buffer + KBD_BUFFER_SIZE) - kbd_fetch_ptr + + (kbd_store_ptr - kbd_buffer))); +} +#endif /* Store an event obtained at interrupt level into kbd_buffer, fifo */ + +void +kbd_buffer_store_event (register struct input_event *event) +{ + kbd_buffer_store_event_hold (event, 0); +} + +/* Store EVENT obtained at interrupt level into kbd_buffer, fifo. + + If HOLD_QUIT is 0, just stuff EVENT into the fifo. + Else, if HOLD_QUIT.kind != NO_EVENT, discard EVENT. + Else, if EVENT is a quit event, store the quit event + in HOLD_QUIT, and return (thus ignoring further events). + + This is used to postpone the processing of the quit event until all + subsequent input events have been parsed (and discarded). */ + +void +kbd_buffer_store_event_hold (register struct input_event *event, + struct input_event *hold_quit) +{ + if (event->kind == NO_EVENT) + emacs_abort (); + + if (hold_quit && hold_quit->kind != NO_EVENT) + return; + + if (event->kind == ASCII_KEYSTROKE_EVENT) + { + register int c = event->code & 0377; + + if (event->modifiers & ctrl_modifier) + c = make_ctrl_char (c); + + c |= (event->modifiers + & (meta_modifier | alt_modifier + | hyper_modifier | super_modifier)); + + if (c == quit_char) + { + KBOARD *kb = FRAME_KBOARD (XFRAME (event->frame_or_window)); + struct input_event *sp; + + if (single_kboard && kb != current_kboard) + { + kset_kbd_queue + (kb, list2 (make_lispy_switch_frame (event->frame_or_window), + make_number (c))); + kb->kbd_queue_has_data = 1; + for (sp = kbd_fetch_ptr; sp != kbd_store_ptr; sp++) + { + if (sp == kbd_buffer + KBD_BUFFER_SIZE) + sp = kbd_buffer; + + if (event_to_kboard (sp) == kb) + { + sp->kind = NO_EVENT; + sp->frame_or_window = Qnil; + sp->arg = Qnil; + } + } + return; + } + + if (hold_quit) + { + *hold_quit = *event; + return; + } + + /* If this results in a quit_char being returned to Emacs as + input, set Vlast_event_frame properly. If this doesn't + get returned to Emacs as an event, the next event read + will set Vlast_event_frame again, so this is safe to do. */ + { + Lisp_Object focus; + + focus = FRAME_FOCUS_FRAME (XFRAME (event->frame_or_window)); + if (NILP (focus)) + focus = event->frame_or_window; + internal_last_event_frame = focus; + Vlast_event_frame = focus; + } + + handle_interrupt (0); + return; + } + + if (c && c == stop_character) + { + sys_suspend (); + return; + } + } + /* Don't insert two BUFFER_SWITCH_EVENT's in a row. + Just ignore the second one. */ + else if (event->kind == BUFFER_SWITCH_EVENT + && kbd_fetch_ptr != kbd_store_ptr + && ((kbd_store_ptr == kbd_buffer + ? kbd_buffer + KBD_BUFFER_SIZE - 1 + : kbd_store_ptr - 1)->kind) == BUFFER_SWITCH_EVENT) + return; + + if (kbd_store_ptr - kbd_buffer == KBD_BUFFER_SIZE) + kbd_store_ptr = kbd_buffer; + + /* Don't let the very last slot in the buffer become full, + since that would make the two pointers equal, + and that is indistinguishable from an empty buffer. + Discard the event if it would fill the last slot. */ + if (kbd_fetch_ptr - 1 != kbd_store_ptr) + { + *kbd_store_ptr = *event; + ++kbd_store_ptr; +#ifdef subprocesses + if (kbd_buffer_nr_stored () > KBD_BUFFER_SIZE / 2 + && ! kbd_on_hold_p ()) + { + /* Don't read keyboard input until we have processed kbd_buffer. + This happens when pasting text longer than KBD_BUFFER_SIZE/2. */ + hold_keyboard_input (); + if (!noninteractive) + ignore_sigio (); + stop_polling (); + } +#endif /* subprocesses */ + } + + /* If we're inside while-no-input, and this event qualifies + as input, set quit-flag to cause an interrupt. */ + if (!NILP (Vthrow_on_input) + && event->kind != FOCUS_IN_EVENT + && event->kind != FOCUS_OUT_EVENT + && event->kind != HELP_EVENT + && event->kind != ICONIFY_EVENT + && event->kind != DEICONIFY_EVENT) + { + Vquit_flag = Vthrow_on_input; + /* If we're inside a function that wants immediate quits, + do it now. */ + if (immediate_quit && NILP (Vinhibit_quit)) + { + immediate_quit = 0; + QUIT; + } + } +} + + +/* Put an input event back in the head of the event queue. */ + +void +kbd_buffer_unget_event (register struct input_event *event) +{ + if (kbd_fetch_ptr == kbd_buffer) + kbd_fetch_ptr = kbd_buffer + KBD_BUFFER_SIZE; + + /* Don't let the very last slot in the buffer become full, */ + if (kbd_fetch_ptr - 1 != kbd_store_ptr) + { + --kbd_fetch_ptr; + *kbd_fetch_ptr = *event; + } +} + +/* Limit help event positions to this range, to avoid overflow problems. */ +#define INPUT_EVENT_POS_MAX \ + ((ptrdiff_t) min (PTRDIFF_MAX, min (TYPE_MAXIMUM (Time) / 2, \ + MOST_POSITIVE_FIXNUM))) +#define INPUT_EVENT_POS_MIN (-1 - INPUT_EVENT_POS_MAX) + +/* Return a Time that encodes position POS. POS must be in range. */ + +static Time +position_to_Time (ptrdiff_t pos) +{ + eassert (INPUT_EVENT_POS_MIN <= pos && pos <= INPUT_EVENT_POS_MAX); + return pos; +} + +/* Return the position that ENCODED_POS encodes. + Avoid signed integer overflow. */ + +static ptrdiff_t +Time_to_position (Time encoded_pos) +{ + if (encoded_pos <= INPUT_EVENT_POS_MAX) + return encoded_pos; + Time encoded_pos_min = INPUT_EVENT_POS_MIN; + eassert (encoded_pos_min <= encoded_pos); + ptrdiff_t notpos = -1 - encoded_pos; + return -1 - notpos; +} + +/* Generate a HELP_EVENT input_event and store it in the keyboard + buffer. + + HELP is the help form. + + FRAME and WINDOW are the frame and window where the help is + generated. OBJECT is the Lisp object where the help was found (a + buffer, a string, an overlay, or nil if neither from a string nor + from a buffer). POS is the position within OBJECT where the help + was found. */ + +void +gen_help_event (Lisp_Object help, Lisp_Object frame, Lisp_Object window, + Lisp_Object object, ptrdiff_t pos) +{ + struct input_event event; + + event.kind = HELP_EVENT; + event.frame_or_window = frame; + event.arg = object; + event.x = WINDOWP (window) ? window : frame; + event.y = help; + event.timestamp = position_to_Time (pos); + kbd_buffer_store_event (&event); +} + + +/* Store HELP_EVENTs for HELP on FRAME in the input queue. */ + +void +kbd_buffer_store_help_event (Lisp_Object frame, Lisp_Object help) +{ + struct input_event event; + + event.kind = HELP_EVENT; + event.frame_or_window = frame; + event.arg = Qnil; + event.x = Qnil; + event.y = help; + event.timestamp = 0; + kbd_buffer_store_event (&event); +} + + +/* Discard any mouse events in the event buffer by setting them to + NO_EVENT. */ +void +discard_mouse_events (void) +{ + struct input_event *sp; + for (sp = kbd_fetch_ptr; sp != kbd_store_ptr; sp++) + { + if (sp == kbd_buffer + KBD_BUFFER_SIZE) + sp = kbd_buffer; + + if (sp->kind == MOUSE_CLICK_EVENT + || sp->kind == WHEEL_EVENT + || sp->kind == HORIZ_WHEEL_EVENT +#ifdef HAVE_GPM + || sp->kind == GPM_CLICK_EVENT +#endif + || sp->kind == SCROLL_BAR_CLICK_EVENT + || sp->kind == HORIZONTAL_SCROLL_BAR_CLICK_EVENT) + { + sp->kind = NO_EVENT; + } + } +} + + +/* Return true if there are any real events waiting in the event + buffer, not counting `NO_EVENT's. + + Discard NO_EVENT events at the front of the input queue, possibly + leaving the input queue empty if there are no real input events. */ + +bool +kbd_buffer_events_waiting (void) +{ + struct input_event *sp; + + for (sp = kbd_fetch_ptr; + sp != kbd_store_ptr && sp->kind == NO_EVENT; + ++sp) + { + if (sp == kbd_buffer + KBD_BUFFER_SIZE) + sp = kbd_buffer; + } + + kbd_fetch_ptr = sp; + return sp != kbd_store_ptr && sp->kind != NO_EVENT; +} + + +/* Clear input event EVENT. */ + +static void +clear_event (struct input_event *event) +{ + event->kind = NO_EVENT; +} + + +/* Read one event from the event buffer, waiting if necessary. + The value is a Lisp object representing the event. + The value is nil for an event that should be ignored, + or that was handled here. + We always read and discard one event. */ + +static Lisp_Object +kbd_buffer_get_event (KBOARD **kbp, + bool *used_mouse_menu, + struct timespec *end_time) +{ + Lisp_Object obj; + +#ifdef subprocesses + if (kbd_on_hold_p () && kbd_buffer_nr_stored () < KBD_BUFFER_SIZE / 4) + { + /* Start reading input again because we have processed enough to + be able to accept new events again. */ + unhold_keyboard_input (); + start_polling (); + } +#endif /* subprocesses */ + +#if !defined HAVE_DBUS && !defined USE_FILE_NOTIFY + if (noninteractive + /* In case we are running as a daemon, only do this before + detaching from the terminal. */ + || (IS_DAEMON && DAEMON_RUNNING)) + { + int c = getchar (); + XSETINT (obj, c); + *kbp = current_kboard; + return obj; + } +#endif /* !defined HAVE_DBUS && !defined USE_FILE_NOTIFY */ + + /* Wait until there is input available. */ + for (;;) + { + /* Break loop if there's an unread command event. Needed in + moused window autoselection which uses a timer to insert such + events. */ + if (CONSP (Vunread_command_events)) + break; + + if (kbd_fetch_ptr != kbd_store_ptr) + break; + if (!NILP (do_mouse_tracking) && some_mouse_moved ()) + break; + + /* If the quit flag is set, then read_char will return + quit_char, so that counts as "available input." */ + if (!NILP (Vquit_flag)) + quit_throw_to_read_char (0); + + /* One way or another, wait until input is available; then, if + interrupt handlers have not read it, read it now. */ + +#ifdef USABLE_SIGIO + gobble_input (); +#endif + if (kbd_fetch_ptr != kbd_store_ptr) + break; + if (!NILP (do_mouse_tracking) && some_mouse_moved ()) + break; + if (end_time) + { + struct timespec now = current_timespec (); + if (timespec_cmp (*end_time, now) <= 0) + return Qnil; /* Finished waiting. */ + else + { + struct timespec duration = timespec_sub (*end_time, now); + wait_reading_process_output (min (duration.tv_sec, + WAIT_READING_MAX), + duration.tv_nsec, + -1, 1, Qnil, NULL, 0); + } + } + else + { + bool do_display = true; + + if (FRAME_TERMCAP_P (SELECTED_FRAME ())) + { + struct tty_display_info *tty = CURTTY (); + + /* When this TTY is displaying a menu, we must prevent + any redisplay, because we modify the frame's glyph + matrix behind the back of the display engine. */ + if (tty->showing_menu) + do_display = false; + } + + wait_reading_process_output (0, 0, -1, do_display, Qnil, NULL, 0); + } + + if (!interrupt_input && kbd_fetch_ptr == kbd_store_ptr) + gobble_input (); + } + + if (CONSP (Vunread_command_events)) + { + Lisp_Object first; + first = XCAR (Vunread_command_events); + Vunread_command_events = XCDR (Vunread_command_events); + *kbp = current_kboard; + return first; + } + + /* At this point, we know that there is a readable event available + somewhere. If the event queue is empty, then there must be a + mouse movement enabled and available. */ + if (kbd_fetch_ptr != kbd_store_ptr) + { + struct input_event *event; + + event = ((kbd_fetch_ptr < kbd_buffer + KBD_BUFFER_SIZE) + ? kbd_fetch_ptr + : kbd_buffer); + + *kbp = event_to_kboard (event); + if (*kbp == 0) + *kbp = current_kboard; /* Better than returning null ptr? */ + + obj = Qnil; + + /* These two kinds of events get special handling + and don't actually appear to the command loop. + We return nil for them. */ + if (event->kind == SELECTION_REQUEST_EVENT + || event->kind == SELECTION_CLEAR_EVENT) + { +#ifdef HAVE_X11 + struct input_event copy; + + /* Remove it from the buffer before processing it, + since otherwise swallow_events will see it + and process it again. */ + copy = *event; + kbd_fetch_ptr = event + 1; + input_pending = readable_events (0); + x_handle_selection_event (©); +#else + /* We're getting selection request events, but we don't have + a window system. */ + emacs_abort (); +#endif + } + +#if defined (HAVE_NS) + else if (event->kind == NS_TEXT_EVENT) + { + if (event->code == KEY_NS_PUT_WORKING_TEXT) + obj = list1 (intern ("ns-put-working-text")); + else + obj = list1 (intern ("ns-unput-working-text")); + kbd_fetch_ptr = event + 1; + if (used_mouse_menu) + *used_mouse_menu = 1; + } +#endif + +#if defined (HAVE_X11) || defined (HAVE_NTGUI) \ + || defined (HAVE_NS) + else if (event->kind == DELETE_WINDOW_EVENT) + { + /* Make an event (delete-frame (FRAME)). */ + obj = list2 (Qdelete_frame, list1 (event->frame_or_window)); + kbd_fetch_ptr = event + 1; + } +#endif +#if defined (HAVE_X11) || defined (HAVE_NTGUI) \ + || defined (HAVE_NS) + else if (event->kind == ICONIFY_EVENT) + { + /* Make an event (iconify-frame (FRAME)). */ + obj = list2 (Qiconify_frame, list1 (event->frame_or_window)); + kbd_fetch_ptr = event + 1; + } + else if (event->kind == DEICONIFY_EVENT) + { + /* Make an event (make-frame-visible (FRAME)). */ + obj = list2 (Qmake_frame_visible, list1 (event->frame_or_window)); + kbd_fetch_ptr = event + 1; + } +#endif + else if (event->kind == BUFFER_SWITCH_EVENT) + { + /* The value doesn't matter here; only the type is tested. */ + XSETBUFFER (obj, current_buffer); + kbd_fetch_ptr = event + 1; + } +#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \ + || defined (HAVE_NS) || defined (USE_GTK) + else if (event->kind == MENU_BAR_ACTIVATE_EVENT) + { + kbd_fetch_ptr = event + 1; + input_pending = readable_events (0); + if (FRAME_LIVE_P (XFRAME (event->frame_or_window))) + x_activate_menubar (XFRAME (event->frame_or_window)); + } +#endif +#ifdef HAVE_NTGUI + else if (event->kind == LANGUAGE_CHANGE_EVENT) + { + /* Make an event (language-change FRAME CODEPAGE LANGUAGE-ID). */ + obj = list4 (Qlanguage_change, + event->frame_or_window, + make_number (event->code), + make_number (event->modifiers)); + kbd_fetch_ptr = event + 1; + } +#endif +#ifdef USE_FILE_NOTIFY + else if (event->kind == FILE_NOTIFY_EVENT) + { +#ifdef HAVE_W32NOTIFY + /* Make an event (file-notify (DESCRIPTOR ACTION FILE) CALLBACK). */ + obj = list3 (Qfile_notify, event->arg, event->frame_or_window); +#else + obj = make_lispy_event (event); +#endif + kbd_fetch_ptr = event + 1; + } +#endif /* USE_FILE_NOTIFY */ + else if (event->kind == SAVE_SESSION_EVENT) + { + obj = list2 (Qsave_session, event->arg); + kbd_fetch_ptr = event + 1; + } + /* Just discard these, by returning nil. + With MULTI_KBOARD, these events are used as placeholders + when we need to randomly delete events from the queue. + (They shouldn't otherwise be found in the buffer, + but on some machines it appears they do show up + even without MULTI_KBOARD.) */ + /* On Windows NT/9X, NO_EVENT is used to delete extraneous + mouse events during a popup-menu call. */ + else if (event->kind == NO_EVENT) + kbd_fetch_ptr = event + 1; + else if (event->kind == HELP_EVENT) + { + Lisp_Object object, position, help, frame, window; + + frame = event->frame_or_window; + object = event->arg; + position = make_number (Time_to_position (event->timestamp)); + window = event->x; + help = event->y; + clear_event (event); + + kbd_fetch_ptr = event + 1; + if (!WINDOWP (window)) + window = Qnil; + obj = Fcons (Qhelp_echo, + list5 (frame, help, window, object, position)); + } + else if (event->kind == FOCUS_IN_EVENT) + { + /* Notification of a FocusIn event. The frame receiving the + focus is in event->frame_or_window. Generate a + switch-frame event if necessary. */ + Lisp_Object frame, focus; + + frame = event->frame_or_window; + focus = FRAME_FOCUS_FRAME (XFRAME (frame)); + if (FRAMEP (focus)) + frame = focus; + + if ( +#ifdef HAVE_X11 + ! NILP (event->arg) + && +#endif + !EQ (frame, internal_last_event_frame) + && !EQ (frame, selected_frame)) + obj = make_lispy_switch_frame (frame); + else + obj = make_lispy_focus_in (frame); + + internal_last_event_frame = frame; + kbd_fetch_ptr = event + 1; + } + else if (event->kind == FOCUS_OUT_EVENT) + { +#ifdef HAVE_WINDOW_SYSTEM + + Display_Info *di; + Lisp_Object frame = event->frame_or_window; + bool focused = false; + + for (di = x_display_list; di && ! focused; di = di->next) + focused = di->x_highlight_frame != 0; + + if (!focused) + obj = make_lispy_focus_out (frame); + +#endif /* HAVE_WINDOW_SYSTEM */ + + kbd_fetch_ptr = event + 1; + } +#ifdef HAVE_DBUS + else if (event->kind == DBUS_EVENT) + { + obj = make_lispy_event (event); + kbd_fetch_ptr = event + 1; + } +#endif + else if (event->kind == CONFIG_CHANGED_EVENT) + { + obj = make_lispy_event (event); + kbd_fetch_ptr = event + 1; + } + else + { + /* If this event is on a different frame, return a switch-frame this + time, and leave the event in the queue for next time. */ + Lisp_Object frame; + Lisp_Object focus; + + frame = event->frame_or_window; + if (CONSP (frame)) + frame = XCAR (frame); + else if (WINDOWP (frame)) + frame = WINDOW_FRAME (XWINDOW (frame)); + + focus = FRAME_FOCUS_FRAME (XFRAME (frame)); + if (! NILP (focus)) + frame = focus; + + if (! EQ (frame, internal_last_event_frame) + && !EQ (frame, selected_frame)) + obj = make_lispy_switch_frame (frame); + internal_last_event_frame = frame; + + /* If we didn't decide to make a switch-frame event, go ahead + and build a real event from the queue entry. */ + + if (NILP (obj)) + { + obj = make_lispy_event (event); + +#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \ + || defined (HAVE_NS) || defined (USE_GTK) + /* If this was a menu selection, then set the flag to inhibit + writing to last_nonmenu_event. Don't do this if the event + we're returning is (menu-bar), though; that indicates the + beginning of the menu sequence, and we might as well leave + that as the `event with parameters' for this selection. */ + if (used_mouse_menu + && !EQ (event->frame_or_window, event->arg) + && (event->kind == MENU_BAR_EVENT + || event->kind == TOOL_BAR_EVENT)) + *used_mouse_menu = 1; +#endif +#ifdef HAVE_NS + /* Certain system events are non-key events. */ + if (used_mouse_menu + && event->kind == NS_NONKEY_EVENT) + *used_mouse_menu = 1; +#endif + + /* Wipe out this event, to catch bugs. */ + clear_event (event); + kbd_fetch_ptr = event + 1; + } + } + } + /* Try generating a mouse motion event. */ + else if (!NILP (do_mouse_tracking) && some_mouse_moved ()) + { + struct frame *f = some_mouse_moved (); + Lisp_Object bar_window; + enum scroll_bar_part part; + Lisp_Object x, y; + Time t; + + *kbp = current_kboard; + /* Note that this uses F to determine which terminal to look at. + If there is no valid info, it does not store anything + so x remains nil. */ + x = Qnil; + + /* XXX Can f or mouse_position_hook be NULL here? */ + if (f && FRAME_TERMINAL (f)->mouse_position_hook) + (*FRAME_TERMINAL (f)->mouse_position_hook) (&f, 0, &bar_window, + &part, &x, &y, &t); + + obj = Qnil; + + /* Decide if we should generate a switch-frame event. Don't + generate switch-frame events for motion outside of all Emacs + frames. */ + if (!NILP (x) && f) + { + Lisp_Object frame; + + frame = FRAME_FOCUS_FRAME (f); + if (NILP (frame)) + XSETFRAME (frame, f); + + if (! EQ (frame, internal_last_event_frame) + && !EQ (frame, selected_frame)) + obj = make_lispy_switch_frame (frame); + internal_last_event_frame = frame; + } + + /* If we didn't decide to make a switch-frame event, go ahead and + return a mouse-motion event. */ + if (!NILP (x) && NILP (obj)) + obj = make_lispy_movement (f, bar_window, part, x, y, t); + } + else + /* We were promised by the above while loop that there was + something for us to read! */ + emacs_abort (); + + input_pending = readable_events (0); + + Vlast_event_frame = internal_last_event_frame; + + return (obj); +} + +/* Process any non-user-visible events (currently X selection events), + without reading any user-visible events. */ + +static void +process_special_events (void) +{ + struct input_event *event; + + for (event = kbd_fetch_ptr; event != kbd_store_ptr; ++event) + { + if (event == kbd_buffer + KBD_BUFFER_SIZE) + { + event = kbd_buffer; + if (event == kbd_store_ptr) + break; + } + + /* If we find a stored X selection request, handle it now. */ + if (event->kind == SELECTION_REQUEST_EVENT + || event->kind == SELECTION_CLEAR_EVENT) + { +#ifdef HAVE_X11 + + /* Remove the event from the fifo buffer before processing; + otherwise swallow_events called recursively could see it + and process it again. To do this, we move the events + between kbd_fetch_ptr and EVENT one slot to the right, + cyclically. */ + + struct input_event copy = *event; + struct input_event *beg + = (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE) + ? kbd_buffer : kbd_fetch_ptr; + + if (event > beg) + memmove (beg + 1, beg, (event - beg) * sizeof (struct input_event)); + else if (event < beg) + { + if (event > kbd_buffer) + memmove (kbd_buffer + 1, kbd_buffer, + (event - kbd_buffer) * sizeof (struct input_event)); + *kbd_buffer = *(kbd_buffer + KBD_BUFFER_SIZE - 1); + if (beg < kbd_buffer + KBD_BUFFER_SIZE - 1) + memmove (beg + 1, beg, + (kbd_buffer + KBD_BUFFER_SIZE - 1 - beg) + * sizeof (struct input_event)); + } + + if (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE) + kbd_fetch_ptr = kbd_buffer + 1; + else + kbd_fetch_ptr++; + + input_pending = readable_events (0); + x_handle_selection_event (©); +#else + /* We're getting selection request events, but we don't have + a window system. */ + emacs_abort (); +#endif + } + } +} + +/* Process any events that are not user-visible, run timer events that + are ripe, and return, without reading any user-visible events. */ + +void +swallow_events (bool do_display) +{ + unsigned old_timers_run; + + process_special_events (); + + old_timers_run = timers_run; + get_input_pending (READABLE_EVENTS_DO_TIMERS_NOW); + + if (!input_pending && timers_run != old_timers_run && do_display) + redisplay_preserve_echo_area (7); +} + +/* Record the start of when Emacs is idle, + for the sake of running idle-time timers. */ + +static void +timer_start_idle (void) +{ + /* If we are already in the idle state, do nothing. */ + if (timespec_valid_p (timer_idleness_start_time)) + return; + + timer_idleness_start_time = current_timespec (); + timer_last_idleness_start_time = timer_idleness_start_time; + + /* Mark all idle-time timers as once again candidates for running. */ + call0 (intern ("internal-timer-start-idle")); +} + +/* Record that Emacs is no longer idle, so stop running idle-time timers. */ + +static void +timer_stop_idle (void) +{ + timer_idleness_start_time = invalid_timespec (); +} + +/* Resume idle timer from last idle start time. */ + +static void +timer_resume_idle (void) +{ + if (timespec_valid_p (timer_idleness_start_time)) + return; + + timer_idleness_start_time = timer_last_idleness_start_time; +} + +/* This is only for debugging. */ +struct input_event last_timer_event EXTERNALLY_VISIBLE; + +/* List of elisp functions to call, delayed because they were generated in + a context where Elisp could not be safely run (e.g. redisplay, signal, + ...). Each element has the form (FUN . ARGS). */ +Lisp_Object pending_funcalls; + +/* Return true if TIMER is a valid timer, placing its value into *RESULT. */ +static bool +decode_timer (Lisp_Object timer, struct timespec *result) +{ + Lisp_Object *vec; + + if (! (VECTORP (timer) && ASIZE (timer) == 9)) + return 0; + vec = XVECTOR (timer)->contents; + if (! NILP (vec[0])) + return 0; + if (! INTEGERP (vec[2])) + return false; + + struct lisp_time t; + if (decode_time_components (vec[1], vec[2], vec[3], vec[8], &t, 0) <= 0) + return false; + *result = lisp_to_timespec (t); + return timespec_valid_p (*result); +} + + +/* Check whether a timer has fired. To prevent larger problems we simply + disregard elements that are not proper timers. Do not make a circular + timer list for the time being. + + Returns the time to wait until the next timer fires. If a + timer is triggering now, return zero. + If no timer is active, return -1. + + If a timer is ripe, we run it, with quitting turned off. + In that case we return 0 to indicate that a new timer_check_2 call + should be done. */ + +static struct timespec +timer_check_2 (Lisp_Object timers, Lisp_Object idle_timers) +{ + struct timespec nexttime; + struct timespec now; + struct timespec idleness_now; + Lisp_Object chosen_timer; + struct gcpro gcpro1; + + nexttime = invalid_timespec (); + + chosen_timer = Qnil; + GCPRO1 (chosen_timer); + + /* First run the code that was delayed. */ + while (CONSP (pending_funcalls)) + { + Lisp_Object funcall = XCAR (pending_funcalls); + pending_funcalls = XCDR (pending_funcalls); + safe_call2 (Qapply, XCAR (funcall), XCDR (funcall)); + } + + if (CONSP (timers) || CONSP (idle_timers)) + { + now = current_timespec (); + idleness_now = (timespec_valid_p (timer_idleness_start_time) + ? timespec_sub (now, timer_idleness_start_time) + : make_timespec (0, 0)); + } + + while (CONSP (timers) || CONSP (idle_timers)) + { + Lisp_Object timer = Qnil, idle_timer = Qnil; + struct timespec timer_time, idle_timer_time; + struct timespec difference; + struct timespec timer_difference = invalid_timespec (); + struct timespec idle_timer_difference = invalid_timespec (); + bool ripe, timer_ripe = 0, idle_timer_ripe = 0; + + /* Set TIMER and TIMER_DIFFERENCE + based on the next ordinary timer. + TIMER_DIFFERENCE is the distance in time from NOW to when + this timer becomes ripe. + Skip past invalid timers and timers already handled. */ + if (CONSP (timers)) + { + timer = XCAR (timers); + if (! decode_timer (timer, &timer_time)) + { + timers = XCDR (timers); + continue; + } + + timer_ripe = timespec_cmp (timer_time, now) <= 0; + timer_difference = (timer_ripe + ? timespec_sub (now, timer_time) + : timespec_sub (timer_time, now)); + } + + /* Likewise for IDLE_TIMER and IDLE_TIMER_DIFFERENCE + based on the next idle timer. */ + if (CONSP (idle_timers)) + { + idle_timer = XCAR (idle_timers); + if (! decode_timer (idle_timer, &idle_timer_time)) + { + idle_timers = XCDR (idle_timers); + continue; + } + + idle_timer_ripe = timespec_cmp (idle_timer_time, idleness_now) <= 0; + idle_timer_difference + = (idle_timer_ripe + ? timespec_sub (idleness_now, idle_timer_time) + : timespec_sub (idle_timer_time, idleness_now)); + } + + /* Decide which timer is the next timer, + and set CHOSEN_TIMER, DIFFERENCE, and RIPE accordingly. + Also step down the list where we found that timer. */ + + if (timespec_valid_p (timer_difference) + && (! timespec_valid_p (idle_timer_difference) + || idle_timer_ripe < timer_ripe + || (idle_timer_ripe == timer_ripe + && ((timer_ripe + ? timespec_cmp (idle_timer_difference, + timer_difference) + : timespec_cmp (timer_difference, + idle_timer_difference)) + < 0)))) + { + chosen_timer = timer; + timers = XCDR (timers); + difference = timer_difference; + ripe = timer_ripe; + } + else + { + chosen_timer = idle_timer; + idle_timers = XCDR (idle_timers); + difference = idle_timer_difference; + ripe = idle_timer_ripe; + } + + /* If timer is ripe, run it if it hasn't been run. */ + if (ripe) + { + if (NILP (AREF (chosen_timer, 0))) + { + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object old_deactivate_mark = Vdeactivate_mark; + + /* Mark the timer as triggered to prevent problems if the lisp + code fails to reschedule it right. */ + ASET (chosen_timer, 0, Qt); + + specbind (Qinhibit_quit, Qt); + + call1 (Qtimer_event_handler, chosen_timer); + Vdeactivate_mark = old_deactivate_mark; + timers_run++; + unbind_to (count, Qnil); + + /* Since we have handled the event, + we don't need to tell the caller to wake up and do it. */ + /* But the caller must still wait for the next timer, so + return 0 to indicate that. */ + } + + nexttime = make_timespec (0, 0); + break; + } + else + /* When we encounter a timer that is still waiting, + return the amount of time to wait before it is ripe. */ + { + UNGCPRO; + return difference; + } + } + + /* No timers are pending in the future. */ + /* Return 0 if we generated an event, and -1 if not. */ + UNGCPRO; + return nexttime; +} + + +/* Check whether a timer has fired. To prevent larger problems we simply + disregard elements that are not proper timers. Do not make a circular + timer list for the time being. + + Returns the time to wait until the next timer fires. + If no timer is active, return an invalid value. + + As long as any timer is ripe, we run it. */ + +struct timespec +timer_check (void) +{ + struct timespec nexttime; + Lisp_Object timers, idle_timers; + struct gcpro gcpro1, gcpro2; + + Lisp_Object tem = Vinhibit_quit; + Vinhibit_quit = Qt; + + /* We use copies of the timers' lists to allow a timer to add itself + again, without locking up Emacs if the newly added timer is + already ripe when added. */ + + /* Always consider the ordinary timers. */ + timers = Fcopy_sequence (Vtimer_list); + /* Consider the idle timers only if Emacs is idle. */ + if (timespec_valid_p (timer_idleness_start_time)) + idle_timers = Fcopy_sequence (Vtimer_idle_list); + else + idle_timers = Qnil; + + Vinhibit_quit = tem; + + GCPRO2 (timers, idle_timers); + + do + { + nexttime = timer_check_2 (timers, idle_timers); + } + while (nexttime.tv_sec == 0 && nexttime.tv_nsec == 0); + + UNGCPRO; + return nexttime; +} + +DEFUN ("current-idle-time", Fcurrent_idle_time, Scurrent_idle_time, 0, 0, 0, + doc: /* Return the current length of Emacs idleness, or nil. +The value when Emacs is idle is a list of four integers (HIGH LOW USEC PSEC) +in the same style as (current-time). + +The value when Emacs is not idle is nil. + +PSEC is a multiple of the system clock resolution. */) + (void) +{ + if (timespec_valid_p (timer_idleness_start_time)) + return make_lisp_time (timespec_sub (current_timespec (), + timer_idleness_start_time)); + + return Qnil; +} + +/* Caches for modify_event_symbol. */ +static Lisp_Object accent_key_syms; +static Lisp_Object func_key_syms; +static Lisp_Object mouse_syms; +static Lisp_Object wheel_syms; +static Lisp_Object drag_n_drop_syms; + +/* This is a list of keysym codes for special "accent" characters. + It parallels lispy_accent_keys. */ + +static const int lispy_accent_codes[] = +{ +#ifdef XK_dead_circumflex + XK_dead_circumflex, +#else + 0, +#endif +#ifdef XK_dead_grave + XK_dead_grave, +#else + 0, +#endif +#ifdef XK_dead_tilde + XK_dead_tilde, +#else + 0, +#endif +#ifdef XK_dead_diaeresis + XK_dead_diaeresis, +#else + 0, +#endif +#ifdef XK_dead_macron + XK_dead_macron, +#else + 0, +#endif +#ifdef XK_dead_degree + XK_dead_degree, +#else + 0, +#endif +#ifdef XK_dead_acute + XK_dead_acute, +#else + 0, +#endif +#ifdef XK_dead_cedilla + XK_dead_cedilla, +#else + 0, +#endif +#ifdef XK_dead_breve + XK_dead_breve, +#else + 0, +#endif +#ifdef XK_dead_ogonek + XK_dead_ogonek, +#else + 0, +#endif +#ifdef XK_dead_caron + XK_dead_caron, +#else + 0, +#endif +#ifdef XK_dead_doubleacute + XK_dead_doubleacute, +#else + 0, +#endif +#ifdef XK_dead_abovedot + XK_dead_abovedot, +#else + 0, +#endif +#ifdef XK_dead_abovering + XK_dead_abovering, +#else + 0, +#endif +#ifdef XK_dead_iota + XK_dead_iota, +#else + 0, +#endif +#ifdef XK_dead_belowdot + XK_dead_belowdot, +#else + 0, +#endif +#ifdef XK_dead_voiced_sound + XK_dead_voiced_sound, +#else + 0, +#endif +#ifdef XK_dead_semivoiced_sound + XK_dead_semivoiced_sound, +#else + 0, +#endif +#ifdef XK_dead_hook + XK_dead_hook, +#else + 0, +#endif +#ifdef XK_dead_horn + XK_dead_horn, +#else + 0, +#endif +}; + +/* This is a list of Lisp names for special "accent" characters. + It parallels lispy_accent_codes. */ + +static const char *const lispy_accent_keys[] = +{ + "dead-circumflex", + "dead-grave", + "dead-tilde", + "dead-diaeresis", + "dead-macron", + "dead-degree", + "dead-acute", + "dead-cedilla", + "dead-breve", + "dead-ogonek", + "dead-caron", + "dead-doubleacute", + "dead-abovedot", + "dead-abovering", + "dead-iota", + "dead-belowdot", + "dead-voiced-sound", + "dead-semivoiced-sound", + "dead-hook", + "dead-horn", +}; + +#ifdef HAVE_NTGUI +#define FUNCTION_KEY_OFFSET 0x0 + +const char *const lispy_function_keys[] = + { + 0, /* 0 */ + + 0, /* VK_LBUTTON 0x01 */ + 0, /* VK_RBUTTON 0x02 */ + "cancel", /* VK_CANCEL 0x03 */ + 0, /* VK_MBUTTON 0x04 */ + + 0, 0, 0, /* 0x05 .. 0x07 */ + + "backspace", /* VK_BACK 0x08 */ + "tab", /* VK_TAB 0x09 */ + + 0, 0, /* 0x0A .. 0x0B */ + + "clear", /* VK_CLEAR 0x0C */ + "return", /* VK_RETURN 0x0D */ + + 0, 0, /* 0x0E .. 0x0F */ + + 0, /* VK_SHIFT 0x10 */ + 0, /* VK_CONTROL 0x11 */ + 0, /* VK_MENU 0x12 */ + "pause", /* VK_PAUSE 0x13 */ + "capslock", /* VK_CAPITAL 0x14 */ + "kana", /* VK_KANA/VK_HANGUL 0x15 */ + 0, /* 0x16 */ + "junja", /* VK_JUNJA 0x17 */ + "final", /* VK_FINAL 0x18 */ + "kanji", /* VK_KANJI/VK_HANJA 0x19 */ + 0, /* 0x1A */ + "escape", /* VK_ESCAPE 0x1B */ + "convert", /* VK_CONVERT 0x1C */ + "non-convert", /* VK_NONCONVERT 0x1D */ + "accept", /* VK_ACCEPT 0x1E */ + "mode-change", /* VK_MODECHANGE 0x1F */ + 0, /* VK_SPACE 0x20 */ + "prior", /* VK_PRIOR 0x21 */ + "next", /* VK_NEXT 0x22 */ + "end", /* VK_END 0x23 */ + "home", /* VK_HOME 0x24 */ + "left", /* VK_LEFT 0x25 */ + "up", /* VK_UP 0x26 */ + "right", /* VK_RIGHT 0x27 */ + "down", /* VK_DOWN 0x28 */ + "select", /* VK_SELECT 0x29 */ + "print", /* VK_PRINT 0x2A */ + "execute", /* VK_EXECUTE 0x2B */ + "snapshot", /* VK_SNAPSHOT 0x2C */ + "insert", /* VK_INSERT 0x2D */ + "delete", /* VK_DELETE 0x2E */ + "help", /* VK_HELP 0x2F */ + + /* VK_0 thru VK_9 are the same as ASCII '0' thru '9' (0x30 - 0x39) */ + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, 0, 0, 0, 0, 0, 0, /* 0x3A .. 0x40 */ + + /* VK_A thru VK_Z are the same as ASCII 'A' thru 'Z' (0x41 - 0x5A) */ + + 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + + "lwindow", /* VK_LWIN 0x5B */ + "rwindow", /* VK_RWIN 0x5C */ + "apps", /* VK_APPS 0x5D */ + 0, /* 0x5E */ + "sleep", + "kp-0", /* VK_NUMPAD0 0x60 */ + "kp-1", /* VK_NUMPAD1 0x61 */ + "kp-2", /* VK_NUMPAD2 0x62 */ + "kp-3", /* VK_NUMPAD3 0x63 */ + "kp-4", /* VK_NUMPAD4 0x64 */ + "kp-5", /* VK_NUMPAD5 0x65 */ + "kp-6", /* VK_NUMPAD6 0x66 */ + "kp-7", /* VK_NUMPAD7 0x67 */ + "kp-8", /* VK_NUMPAD8 0x68 */ + "kp-9", /* VK_NUMPAD9 0x69 */ + "kp-multiply", /* VK_MULTIPLY 0x6A */ + "kp-add", /* VK_ADD 0x6B */ + "kp-separator", /* VK_SEPARATOR 0x6C */ + "kp-subtract", /* VK_SUBTRACT 0x6D */ + "kp-decimal", /* VK_DECIMAL 0x6E */ + "kp-divide", /* VK_DIVIDE 0x6F */ + "f1", /* VK_F1 0x70 */ + "f2", /* VK_F2 0x71 */ + "f3", /* VK_F3 0x72 */ + "f4", /* VK_F4 0x73 */ + "f5", /* VK_F5 0x74 */ + "f6", /* VK_F6 0x75 */ + "f7", /* VK_F7 0x76 */ + "f8", /* VK_F8 0x77 */ + "f9", /* VK_F9 0x78 */ + "f10", /* VK_F10 0x79 */ + "f11", /* VK_F11 0x7A */ + "f12", /* VK_F12 0x7B */ + "f13", /* VK_F13 0x7C */ + "f14", /* VK_F14 0x7D */ + "f15", /* VK_F15 0x7E */ + "f16", /* VK_F16 0x7F */ + "f17", /* VK_F17 0x80 */ + "f18", /* VK_F18 0x81 */ + "f19", /* VK_F19 0x82 */ + "f20", /* VK_F20 0x83 */ + "f21", /* VK_F21 0x84 */ + "f22", /* VK_F22 0x85 */ + "f23", /* VK_F23 0x86 */ + "f24", /* VK_F24 0x87 */ + + 0, 0, 0, 0, /* 0x88 .. 0x8B */ + 0, 0, 0, 0, /* 0x8C .. 0x8F */ + + "kp-numlock", /* VK_NUMLOCK 0x90 */ + "scroll", /* VK_SCROLL 0x91 */ + /* Not sure where the following block comes from. + Windows headers have NEC and Fujitsu specific keys in + this block, but nothing generic. */ + "kp-space", /* VK_NUMPAD_CLEAR 0x92 */ + "kp-enter", /* VK_NUMPAD_ENTER 0x93 */ + "kp-prior", /* VK_NUMPAD_PRIOR 0x94 */ + "kp-next", /* VK_NUMPAD_NEXT 0x95 */ + "kp-end", /* VK_NUMPAD_END 0x96 */ + "kp-home", /* VK_NUMPAD_HOME 0x97 */ + "kp-left", /* VK_NUMPAD_LEFT 0x98 */ + "kp-up", /* VK_NUMPAD_UP 0x99 */ + "kp-right", /* VK_NUMPAD_RIGHT 0x9A */ + "kp-down", /* VK_NUMPAD_DOWN 0x9B */ + "kp-insert", /* VK_NUMPAD_INSERT 0x9C */ + "kp-delete", /* VK_NUMPAD_DELETE 0x9D */ + + 0, 0, /* 0x9E .. 0x9F */ + + /* + * VK_L* & VK_R* - left and right Alt, Ctrl and Shift virtual keys. + * Used only as parameters to GetAsyncKeyState and GetKeyState. + * No other API or message will distinguish left and right keys this way. + * 0xA0 .. 0xA5 + */ + 0, 0, 0, 0, 0, 0, + + /* Multimedia keys. These are handled as WM_APPCOMMAND, which allows us + to enable them selectively, and gives access to a few more functions. + See lispy_multimedia_keys below. */ + 0, 0, 0, 0, 0, 0, 0, /* 0xA6 .. 0xAC Browser */ + 0, 0, 0, /* 0xAD .. 0xAF Volume */ + 0, 0, 0, 0, /* 0xB0 .. 0xB3 Media */ + 0, 0, 0, 0, /* 0xB4 .. 0xB7 Apps */ + + /* 0xB8 .. 0xC0 "OEM" keys - all seem to be punctuation. */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, + + /* 0xC1 - 0xDA unallocated, 0xDB-0xDF more OEM keys */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, /* 0xE0 */ + "ax", /* VK_OEM_AX 0xE1 */ + 0, /* VK_OEM_102 0xE2 */ + "ico-help", /* VK_ICO_HELP 0xE3 */ + "ico-00", /* VK_ICO_00 0xE4 */ + 0, /* VK_PROCESSKEY 0xE5 - used by IME */ + "ico-clear", /* VK_ICO_CLEAR 0xE6 */ + 0, /* VK_PACKET 0xE7 - used to pass Unicode chars */ + 0, /* 0xE8 */ + "reset", /* VK_OEM_RESET 0xE9 */ + "jump", /* VK_OEM_JUMP 0xEA */ + "oem-pa1", /* VK_OEM_PA1 0xEB */ + "oem-pa2", /* VK_OEM_PA2 0xEC */ + "oem-pa3", /* VK_OEM_PA3 0xED */ + "wsctrl", /* VK_OEM_WSCTRL 0xEE */ + "cusel", /* VK_OEM_CUSEL 0xEF */ + "oem-attn", /* VK_OEM_ATTN 0xF0 */ + "finish", /* VK_OEM_FINISH 0xF1 */ + "copy", /* VK_OEM_COPY 0xF2 */ + "auto", /* VK_OEM_AUTO 0xF3 */ + "enlw", /* VK_OEM_ENLW 0xF4 */ + "backtab", /* VK_OEM_BACKTAB 0xF5 */ + "attn", /* VK_ATTN 0xF6 */ + "crsel", /* VK_CRSEL 0xF7 */ + "exsel", /* VK_EXSEL 0xF8 */ + "ereof", /* VK_EREOF 0xF9 */ + "play", /* VK_PLAY 0xFA */ + "zoom", /* VK_ZOOM 0xFB */ + "noname", /* VK_NONAME 0xFC */ + "pa1", /* VK_PA1 0xFD */ + "oem_clear", /* VK_OEM_CLEAR 0xFE */ + 0 /* 0xFF */ + }; + +/* Some of these duplicate the "Media keys" on newer keyboards, + but they are delivered to the application in a different way. */ +static const char *const lispy_multimedia_keys[] = + { + 0, + "browser-back", + "browser-forward", + "browser-refresh", + "browser-stop", + "browser-search", + "browser-favorites", + "browser-home", + "volume-mute", + "volume-down", + "volume-up", + "media-next", + "media-previous", + "media-stop", + "media-play-pause", + "mail", + "media-select", + "app-1", + "app-2", + "bass-down", + "bass-boost", + "bass-up", + "treble-down", + "treble-up", + "mic-volume-mute", + "mic-volume-down", + "mic-volume-up", + "help", + "find", + "new", + "open", + "close", + "save", + "print", + "undo", + "redo", + "copy", + "cut", + "paste", + "mail-reply", + "mail-forward", + "mail-send", + "spell-check", + "toggle-dictate-command", + "mic-toggle", + "correction-list", + "media-play", + "media-pause", + "media-record", + "media-fast-forward", + "media-rewind", + "media-channel-up", + "media-channel-down" + }; + +#else /* not HAVE_NTGUI */ + +/* This should be dealt with in XTread_socket now, and that doesn't + depend on the client system having the Kana syms defined. See also + the XK_kana_A case below. */ +#if 0 +#ifdef XK_kana_A +static const char *const lispy_kana_keys[] = + { + /* X Keysym value */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x400 .. 0x40f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x410 .. 0x41f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x420 .. 0x42f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x430 .. 0x43f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x440 .. 0x44f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x450 .. 0x45f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x460 .. 0x46f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,"overline",0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x480 .. 0x48f */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x490 .. 0x49f */ + 0, "kana-fullstop", "kana-openingbracket", "kana-closingbracket", + "kana-comma", "kana-conjunctive", "kana-WO", "kana-a", + "kana-i", "kana-u", "kana-e", "kana-o", + "kana-ya", "kana-yu", "kana-yo", "kana-tsu", + "prolongedsound", "kana-A", "kana-I", "kana-U", + "kana-E", "kana-O", "kana-KA", "kana-KI", + "kana-KU", "kana-KE", "kana-KO", "kana-SA", + "kana-SHI", "kana-SU", "kana-SE", "kana-SO", + "kana-TA", "kana-CHI", "kana-TSU", "kana-TE", + "kana-TO", "kana-NA", "kana-NI", "kana-NU", + "kana-NE", "kana-NO", "kana-HA", "kana-HI", + "kana-FU", "kana-HE", "kana-HO", "kana-MA", + "kana-MI", "kana-MU", "kana-ME", "kana-MO", + "kana-YA", "kana-YU", "kana-YO", "kana-RA", + "kana-RI", "kana-RU", "kana-RE", "kana-RO", + "kana-WA", "kana-N", "voicedsound", "semivoicedsound", + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x4e0 .. 0x4ef */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x4f0 .. 0x4ff */ + }; +#endif /* XK_kana_A */ +#endif /* 0 */ + +#define FUNCTION_KEY_OFFSET 0xff00 + +/* You'll notice that this table is arranged to be conveniently + indexed by X Windows keysym values. */ +static const char *const lispy_function_keys[] = + { + /* X Keysym value */ + + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xff00...0f */ + "backspace", "tab", "linefeed", "clear", + 0, "return", 0, 0, + 0, 0, 0, "pause", /* 0xff10...1f */ + 0, 0, 0, 0, 0, 0, 0, "escape", + 0, 0, 0, 0, + 0, "kanji", "muhenkan", "henkan", /* 0xff20...2f */ + "romaji", "hiragana", "katakana", "hiragana-katakana", + "zenkaku", "hankaku", "zenkaku-hankaku", "touroku", + "massyo", "kana-lock", "kana-shift", "eisu-shift", + "eisu-toggle", /* 0xff30...3f */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0xff40...4f */ + + "home", "left", "up", "right", /* 0xff50 */ /* IsCursorKey */ + "down", "prior", "next", "end", + "begin", 0, 0, 0, 0, 0, 0, 0, + "select", /* 0xff60 */ /* IsMiscFunctionKey */ + "print", + "execute", + "insert", + 0, /* 0xff64 */ + "undo", + "redo", + "menu", + "find", + "cancel", + "help", + "break", /* 0xff6b */ + + 0, 0, 0, 0, + 0, 0, 0, 0, "backtab", 0, 0, 0, /* 0xff70... */ + 0, 0, 0, 0, 0, 0, 0, "kp-numlock", /* 0xff78... */ + "kp-space", /* 0xff80 */ /* IsKeypadKey */ + 0, 0, 0, 0, 0, 0, 0, 0, + "kp-tab", /* 0xff89 */ + 0, 0, 0, + "kp-enter", /* 0xff8d */ + 0, 0, 0, + "kp-f1", /* 0xff91 */ + "kp-f2", + "kp-f3", + "kp-f4", + "kp-home", /* 0xff95 */ + "kp-left", + "kp-up", + "kp-right", + "kp-down", + "kp-prior", /* kp-page-up */ + "kp-next", /* kp-page-down */ + "kp-end", + "kp-begin", + "kp-insert", + "kp-delete", + 0, /* 0xffa0 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, + "kp-multiply", /* 0xffaa */ + "kp-add", + "kp-separator", + "kp-subtract", + "kp-decimal", + "kp-divide", /* 0xffaf */ + "kp-0", /* 0xffb0 */ + "kp-1", "kp-2", "kp-3", "kp-4", "kp-5", "kp-6", "kp-7", "kp-8", "kp-9", + 0, /* 0xffba */ + 0, 0, + "kp-equal", /* 0xffbd */ + "f1", /* 0xffbe */ /* IsFunctionKey */ + "f2", + "f3", "f4", "f5", "f6", "f7", "f8", "f9", "f10", /* 0xffc0 */ + "f11", "f12", "f13", "f14", "f15", "f16", "f17", "f18", + "f19", "f20", "f21", "f22", "f23", "f24", "f25", "f26", /* 0xffd0 */ + "f27", "f28", "f29", "f30", "f31", "f32", "f33", "f34", + "f35", 0, 0, 0, 0, 0, 0, 0, /* 0xffe0 */ + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xfff0 */ + 0, 0, 0, 0, 0, 0, 0, "delete" + }; + +/* ISO 9995 Function and Modifier Keys; the first byte is 0xFE. */ +#define ISO_FUNCTION_KEY_OFFSET 0xfe00 + +static const char *const iso_lispy_function_keys[] = + { + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xfe00 */ + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xfe08 */ + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xfe10 */ + 0, 0, 0, 0, 0, 0, 0, 0, /* 0xfe18 */ + "iso-lefttab", /* 0xfe20 */ + "iso-move-line-up", "iso-move-line-down", + "iso-partial-line-up", "iso-partial-line-down", + "iso-partial-space-left", "iso-partial-space-right", + "iso-set-margin-left", "iso-set-margin-right", /* 0xffe27, 28 */ + "iso-release-margin-left", "iso-release-margin-right", + "iso-release-both-margins", + "iso-fast-cursor-left", "iso-fast-cursor-right", + "iso-fast-cursor-up", "iso-fast-cursor-down", + "iso-continuous-underline", "iso-discontinuous-underline", /* 0xfe30, 31 */ + "iso-emphasize", "iso-center-object", "iso-enter", /* ... 0xfe34 */ + }; + +#endif /* not HAVE_NTGUI */ + +static Lisp_Object Vlispy_mouse_stem; + +static const char *const lispy_wheel_names[] = +{ + "wheel-up", "wheel-down", "wheel-left", "wheel-right" +}; + +/* drag-n-drop events are generated when a set of selected files are + dragged from another application and dropped onto an Emacs window. */ +static const char *const lispy_drag_n_drop_names[] = +{ + "drag-n-drop" +}; + +/* An array of symbol indexes of scroll bar parts, indexed by an enum + scroll_bar_part value. Note that Qnil corresponds to + scroll_bar_nowhere and should not appear in Lisp events. */ +static short const scroll_bar_parts[] = { + SYMBOL_INDEX (Qnil), SYMBOL_INDEX (Qabove_handle), SYMBOL_INDEX (Qhandle), + SYMBOL_INDEX (Qbelow_handle), SYMBOL_INDEX (Qup), SYMBOL_INDEX (Qdown), + SYMBOL_INDEX (Qtop), SYMBOL_INDEX (Qbottom), SYMBOL_INDEX (Qend_scroll), + SYMBOL_INDEX (Qratio), SYMBOL_INDEX (Qbefore_handle), + SYMBOL_INDEX (Qhorizontal_handle), SYMBOL_INDEX (Qafter_handle), + SYMBOL_INDEX (Qleft), SYMBOL_INDEX (Qright), SYMBOL_INDEX (Qleftmost), + SYMBOL_INDEX (Qrightmost), SYMBOL_INDEX (Qend_scroll), SYMBOL_INDEX (Qratio) +}; + +/* A vector, indexed by button number, giving the down-going location + of currently depressed buttons, both scroll bar and non-scroll bar. + + The elements have the form + (BUTTON-NUMBER MODIFIER-MASK . REST) + where REST is the cdr of a position as it would be reported in the event. + + The make_lispy_event function stores positions here to tell the + difference between click and drag events, and to store the starting + location to be included in drag events. */ + +static Lisp_Object button_down_location; + +/* Information about the most recent up-going button event: Which + button, what location, and what time. */ + +static int last_mouse_button; +static int last_mouse_x; +static int last_mouse_y; +static Time button_down_time; + +/* The number of clicks in this multiple-click. */ + +static int double_click_count; + +/* X and Y are frame-relative coordinates for a click or wheel event. + Return a Lisp-style event list. */ + +static Lisp_Object +make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, + Time t) +{ + enum window_part part; + Lisp_Object posn = Qnil; + Lisp_Object extra_info = Qnil; + /* Coordinate pixel positions to return. */ + int xret = 0, yret = 0; + /* The window under frame pixel coordinates (x,y) */ + Lisp_Object window = f + ? window_from_coordinates (f, XINT (x), XINT (y), &part, 0) + : Qnil; + + if (WINDOWP (window)) + { + /* It's a click in window WINDOW at frame coordinates (X,Y) */ + struct window *w = XWINDOW (window); + Lisp_Object string_info = Qnil; + ptrdiff_t textpos = 0; + int col = -1, row = -1; + int dx = -1, dy = -1; + int width = -1, height = -1; + Lisp_Object object = Qnil; + + /* Pixel coordinates relative to the window corner. */ + int wx = XINT (x) - WINDOW_LEFT_EDGE_X (w); + int wy = XINT (y) - WINDOW_TOP_EDGE_Y (w); + + /* For text area clicks, return X, Y relative to the corner of + this text area. Note that dX, dY etc are set below, by + buffer_posn_from_coords. */ + if (part == ON_TEXT) + { + xret = XINT (x) - window_box_left (w, TEXT_AREA); + yret = wy - WINDOW_HEADER_LINE_HEIGHT (w); + } + /* For mode line and header line clicks, return X, Y relative to + the left window edge. Use mode_line_string to look for a + string on the click position. */ + else if (part == ON_MODE_LINE || part == ON_HEADER_LINE) + { + Lisp_Object string; + ptrdiff_t charpos; + + posn = (part == ON_MODE_LINE) ? Qmode_line : Qheader_line; + /* Note that mode_line_string takes COL, ROW as pixels and + converts them to characters. */ + col = wx; + row = wy; + string = mode_line_string (w, part, &col, &row, &charpos, + &object, &dx, &dy, &width, &height); + if (STRINGP (string)) + string_info = Fcons (string, make_number (charpos)); + textpos = -1; + + xret = wx; + yret = wy; + } + /* For fringes and margins, Y is relative to the area's (and the + window's) top edge, while X is meaningless. */ + else if (part == ON_LEFT_MARGIN || part == ON_RIGHT_MARGIN) + { + Lisp_Object string; + ptrdiff_t charpos; + + posn = (part == ON_LEFT_MARGIN) ? Qleft_margin : Qright_margin; + col = wx; + row = wy; + string = marginal_area_string (w, part, &col, &row, &charpos, + &object, &dx, &dy, &width, &height); + if (STRINGP (string)) + string_info = Fcons (string, make_number (charpos)); + xret = wx; + yret = wy - WINDOW_HEADER_LINE_HEIGHT (w); + } + else if (part == ON_LEFT_FRINGE) + { + posn = Qleft_fringe; + col = 0; + xret = wx; + dx = wx + - (WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (w) + ? 0 : window_box_width (w, LEFT_MARGIN_AREA)); + dy = yret = wy - WINDOW_HEADER_LINE_HEIGHT (w); + } + else if (part == ON_RIGHT_FRINGE) + { + posn = Qright_fringe; + col = 0; + xret = wx; + dx = wx + - window_box_width (w, LEFT_MARGIN_AREA) + - window_box_width (w, TEXT_AREA) + - (WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (w) + ? window_box_width (w, RIGHT_MARGIN_AREA) + : 0); + dy = yret = wy - WINDOW_HEADER_LINE_HEIGHT (w); + } + else if (part == ON_VERTICAL_BORDER) + { + posn = Qvertical_line; + width = 1; + dx = 0; + xret = wx; + dy = yret = wy; + } + else if (part == ON_VERTICAL_SCROLL_BAR) + { + posn = Qvertical_scroll_bar; + width = WINDOW_SCROLL_BAR_AREA_WIDTH (w); + dx = xret = wx; + dy = yret = wy; + } + else if (part == ON_HORIZONTAL_SCROLL_BAR) + { + posn = Qhorizontal_scroll_bar; + width = WINDOW_SCROLL_BAR_AREA_HEIGHT (w); + dx = xret = wx; + dy = yret = wy; + } + else if (part == ON_RIGHT_DIVIDER) + { + posn = Qright_divider; + width = WINDOW_RIGHT_DIVIDER_WIDTH (w); + dx = xret = wx; + dy = yret = wy; + } + else if (part == ON_BOTTOM_DIVIDER) + { + posn = Qbottom_divider; + width = WINDOW_BOTTOM_DIVIDER_WIDTH (w); + dx = xret = wx; + dy = yret = wy; + } + + /* For clicks in the text area, fringes, margins, or vertical + scroll bar, call buffer_posn_from_coords to extract TEXTPOS, + the buffer position nearest to the click. */ + if (!textpos) + { + Lisp_Object string2, object2 = Qnil; + struct display_pos p; + int dx2, dy2; + int width2, height2; + /* The pixel X coordinate passed to buffer_posn_from_coords + is the X coordinate relative to the text area for clicks + in text-area, right-margin/fringe and right-side vertical + scroll bar, zero otherwise. */ + int x2 + = (part == ON_TEXT) ? xret + : (part == ON_RIGHT_FRINGE || part == ON_RIGHT_MARGIN + || (part == ON_VERTICAL_SCROLL_BAR + && WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_RIGHT (w))) + ? (XINT (x) - window_box_left (w, TEXT_AREA)) + : 0; + int y2 = wy; + + string2 = buffer_posn_from_coords (w, &x2, &y2, &p, + &object2, &dx2, &dy2, + &width2, &height2); + textpos = CHARPOS (p.pos); + if (col < 0) col = x2; + if (row < 0) row = y2; + if (dx < 0) dx = dx2; + if (dy < 0) dy = dy2; + if (width < 0) width = width2; + if (height < 0) height = height2; + + if (NILP (posn)) + { + posn = make_number (textpos); + if (STRINGP (string2)) + string_info = Fcons (string2, + make_number (CHARPOS (p.string_pos))); + } + if (NILP (object)) + object = object2; + } + +#ifdef HAVE_WINDOW_SYSTEM + if (IMAGEP (object)) + { + Lisp_Object image_map, hotspot; + if ((image_map = Fplist_get (XCDR (object), QCmap), + !NILP (image_map)) + && (hotspot = find_hot_spot (image_map, dx, dy), + CONSP (hotspot)) + && (hotspot = XCDR (hotspot), CONSP (hotspot))) + posn = XCAR (hotspot); + } +#endif + + /* Object info. */ + extra_info + = list3 (object, + Fcons (make_number (dx), make_number (dy)), + Fcons (make_number (width), make_number (height))); + + /* String info. */ + extra_info = Fcons (string_info, + Fcons (textpos < 0 ? Qnil : make_number (textpos), + Fcons (Fcons (make_number (col), + make_number (row)), + extra_info))); + } + else if (f != 0) + { + /* Return mouse pixel coordinates here. */ + XSETFRAME (window, f); + xret = XINT (x); + yret = XINT (y); + } + else + window = Qnil; + + return Fcons (window, + Fcons (posn, + Fcons (Fcons (make_number (xret), + make_number (yret)), + Fcons (make_number (t), + extra_info)))); +} + +/* Return non-zero if F is a GUI frame that uses some toolkit-managed + menu bar. This really means that Emacs draws and manages the menu + bar as part of its normal display, and therefore can compute its + geometry. */ +static bool +toolkit_menubar_in_use (struct frame *f) +{ +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) || defined (HAVE_NTGUI) + return !(!FRAME_WINDOW_P (f)); +#else + return false; +#endif +} + +/* Build the part of Lisp event which represents scroll bar state from + EV. TYPE is one of Qvertical_scroll_bar or Qhorizontal_scroll_bar. */ + +static Lisp_Object +make_scroll_bar_position (struct input_event *ev, Lisp_Object type) +{ + return list5 (ev->frame_or_window, type, Fcons (ev->x, ev->y), + make_number (ev->timestamp), + builtin_lisp_symbol (scroll_bar_parts[ev->part])); +} + +/* Given a struct input_event, build the lisp event which represents + it. If EVENT is 0, build a mouse movement event from the mouse + movement buffer, which should have a movement event in it. + + Note that events must be passed to this function in the order they + are received; this function stores the location of button presses + in order to build drag events when the button is released. */ + +static Lisp_Object +make_lispy_event (struct input_event *event) +{ + int i; + + switch (event->kind) + { + /* A simple keystroke. */ + case ASCII_KEYSTROKE_EVENT: + case MULTIBYTE_CHAR_KEYSTROKE_EVENT: + { + Lisp_Object lispy_c; + EMACS_INT c = event->code; + if (event->kind == ASCII_KEYSTROKE_EVENT) + { + c &= 0377; + eassert (c == event->code); + /* Turn ASCII characters into control characters + when proper. */ + if (event->modifiers & ctrl_modifier) + { + c = make_ctrl_char (c); + event->modifiers &= ~ctrl_modifier; + } + } + + /* Add in the other modifier bits. The shift key was taken care + of by the X code. */ + c |= (event->modifiers + & (meta_modifier | alt_modifier + | hyper_modifier | super_modifier | ctrl_modifier)); + /* Distinguish Shift-SPC from SPC. */ + if ((event->code) == 040 + && event->modifiers & shift_modifier) + c |= shift_modifier; + button_down_time = 0; + XSETFASTINT (lispy_c, c); + return lispy_c; + } + +#ifdef HAVE_NS + /* NS_NONKEY_EVENTs are just like NON_ASCII_KEYSTROKE_EVENTs, + except that they are non-key events (last-nonmenu-event is nil). */ + case NS_NONKEY_EVENT: +#endif + + /* A function key. The symbol may need to have modifier prefixes + tacked onto it. */ + case NON_ASCII_KEYSTROKE_EVENT: + button_down_time = 0; + + for (i = 0; i < ARRAYELTS (lispy_accent_codes); i++) + if (event->code == lispy_accent_codes[i]) + return modify_event_symbol (i, + event->modifiers, + Qfunction_key, Qnil, + lispy_accent_keys, &accent_key_syms, + ARRAYELTS (lispy_accent_keys)); + +#if 0 +#ifdef XK_kana_A + if (event->code >= 0x400 && event->code < 0x500) + return modify_event_symbol (event->code - 0x400, + event->modifiers & ~shift_modifier, + Qfunction_key, Qnil, + lispy_kana_keys, &func_key_syms, + ARRAYELTS (lispy_kana_keys)); +#endif /* XK_kana_A */ +#endif /* 0 */ + +#ifdef ISO_FUNCTION_KEY_OFFSET + if (event->code < FUNCTION_KEY_OFFSET + && event->code >= ISO_FUNCTION_KEY_OFFSET) + return modify_event_symbol (event->code - ISO_FUNCTION_KEY_OFFSET, + event->modifiers, + Qfunction_key, Qnil, + iso_lispy_function_keys, &func_key_syms, + ARRAYELTS (iso_lispy_function_keys)); +#endif + + if ((FUNCTION_KEY_OFFSET <= event->code + && (event->code + < FUNCTION_KEY_OFFSET + ARRAYELTS (lispy_function_keys))) + && lispy_function_keys[event->code - FUNCTION_KEY_OFFSET]) + return modify_event_symbol (event->code - FUNCTION_KEY_OFFSET, + event->modifiers, + Qfunction_key, Qnil, + lispy_function_keys, &func_key_syms, + ARRAYELTS (lispy_function_keys)); + + /* Handle system-specific or unknown keysyms. + We need to use an alist rather than a vector as the cache + since we can't make a vector long enough. */ + if (NILP (KVAR (current_kboard, system_key_syms))) + kset_system_key_syms (current_kboard, Fcons (Qnil, Qnil)); + return modify_event_symbol (event->code, + event->modifiers, + Qfunction_key, + KVAR (current_kboard, Vsystem_key_alist), + 0, &KVAR (current_kboard, system_key_syms), + PTRDIFF_MAX); + +#ifdef HAVE_NTGUI + case MULTIMEDIA_KEY_EVENT: + if (event->code < ARRAYELTS (lispy_multimedia_keys) + && event->code > 0 && lispy_multimedia_keys[event->code]) + { + return modify_event_symbol (event->code, event->modifiers, + Qfunction_key, Qnil, + lispy_multimedia_keys, &func_key_syms, + ARRAYELTS (lispy_multimedia_keys)); + } + return Qnil; +#endif + + /* A mouse click. Figure out where it is, decide whether it's + a press, click or drag, and build the appropriate structure. */ + case MOUSE_CLICK_EVENT: +#ifdef HAVE_GPM + case GPM_CLICK_EVENT: +#endif +#ifndef USE_TOOLKIT_SCROLL_BARS + case SCROLL_BAR_CLICK_EVENT: + case HORIZONTAL_SCROLL_BAR_CLICK_EVENT: +#endif + { + int button = event->code; + bool is_double; + Lisp_Object position; + Lisp_Object *start_pos_ptr; + Lisp_Object start_pos; + + position = Qnil; + + /* Build the position as appropriate for this mouse click. */ + if (event->kind == MOUSE_CLICK_EVENT +#ifdef HAVE_GPM + || event->kind == GPM_CLICK_EVENT +#endif + ) + { + struct frame *f = XFRAME (event->frame_or_window); + int row, column; + + /* Ignore mouse events that were made on frame that + have been deleted. */ + if (! FRAME_LIVE_P (f)) + return Qnil; + + /* EVENT->x and EVENT->y are frame-relative pixel + coordinates at this place. Under old redisplay, COLUMN + and ROW are set to frame relative glyph coordinates + which are then used to determine whether this click is + in a menu (non-toolkit version). */ + if (!toolkit_menubar_in_use (f)) + { + pixel_to_glyph_coords (f, XINT (event->x), XINT (event->y), + &column, &row, NULL, 1); + + /* In the non-toolkit version, clicks on the menu bar + are ordinary button events in the event buffer. + Distinguish them, and invoke the menu. + + (In the toolkit version, the toolkit handles the + menu bar and Emacs doesn't know about it until + after the user makes a selection.) */ + if (row >= 0 && row < FRAME_MENU_BAR_LINES (f) + && (event->modifiers & down_modifier)) + { + Lisp_Object items, item; + + /* Find the menu bar item under `column'. */ + item = Qnil; + items = FRAME_MENU_BAR_ITEMS (f); + for (i = 0; i < ASIZE (items); i += 4) + { + Lisp_Object pos, string; + string = AREF (items, i + 1); + pos = AREF (items, i + 3); + if (NILP (string)) + break; + if (column >= XINT (pos) + && column < XINT (pos) + SCHARS (string)) + { + item = AREF (items, i); + break; + } + } + + /* ELisp manual 2.4b says (x y) are window + relative but code says they are + frame-relative. */ + position = list4 (event->frame_or_window, + Qmenu_bar, + Fcons (event->x, event->y), + make_number (event->timestamp)); + + return list2 (item, position); + } + } + + position = make_lispy_position (f, event->x, event->y, + event->timestamp); + } +#ifndef USE_TOOLKIT_SCROLL_BARS + else + /* It's a scrollbar click. */ + position = make_scroll_bar_position (event, Qvertical_scroll_bar); +#endif /* not USE_TOOLKIT_SCROLL_BARS */ + + if (button >= ASIZE (button_down_location)) + { + ptrdiff_t incr = button - ASIZE (button_down_location) + 1; + button_down_location = larger_vector (button_down_location, + incr, -1); + mouse_syms = larger_vector (mouse_syms, incr, -1); + } + + start_pos_ptr = aref_addr (button_down_location, button); + start_pos = *start_pos_ptr; + *start_pos_ptr = Qnil; + + { + /* On window-system frames, use the value of + double-click-fuzz as is. On other frames, interpret it + as a multiple of 1/8 characters. */ + struct frame *f; + int fuzz; + + if (WINDOWP (event->frame_or_window)) + f = XFRAME (XWINDOW (event->frame_or_window)->frame); + else if (FRAMEP (event->frame_or_window)) + f = XFRAME (event->frame_or_window); + else + emacs_abort (); + + if (FRAME_WINDOW_P (f)) + fuzz = double_click_fuzz; + else + fuzz = double_click_fuzz / 8; + + is_double = (button == last_mouse_button + && (eabs (XINT (event->x) - last_mouse_x) <= fuzz) + && (eabs (XINT (event->y) - last_mouse_y) <= fuzz) + && button_down_time != 0 + && (EQ (Vdouble_click_time, Qt) + || (NATNUMP (Vdouble_click_time) + && (event->timestamp - button_down_time + < XFASTINT (Vdouble_click_time))))); + } + + last_mouse_button = button; + last_mouse_x = XINT (event->x); + last_mouse_y = XINT (event->y); + + /* If this is a button press, squirrel away the location, so + we can decide later whether it was a click or a drag. */ + if (event->modifiers & down_modifier) + { + if (is_double) + { + double_click_count++; + event->modifiers |= ((double_click_count > 2) + ? triple_modifier + : double_modifier); + } + else + double_click_count = 1; + button_down_time = event->timestamp; + *start_pos_ptr = Fcopy_alist (position); + ignore_mouse_drag_p = 0; + } + + /* Now we're releasing a button - check the co-ordinates to + see if this was a click or a drag. */ + else if (event->modifiers & up_modifier) + { + /* If we did not see a down before this up, ignore the up. + Probably this happened because the down event chose a + menu item. It would be an annoyance to treat the + release of the button that chose the menu item as a + separate event. */ + + if (!CONSP (start_pos)) + return Qnil; + + event->modifiers &= ~up_modifier; + + { + Lisp_Object new_down, down; + EMACS_INT xdiff = double_click_fuzz, ydiff = double_click_fuzz; + + /* The third element of every position + should be the (x,y) pair. */ + down = Fcar (Fcdr (Fcdr (start_pos))); + new_down = Fcar (Fcdr (Fcdr (position))); + + if (CONSP (down) + && INTEGERP (XCAR (down)) && INTEGERP (XCDR (down))) + { + xdiff = XINT (XCAR (new_down)) - XINT (XCAR (down)); + ydiff = XINT (XCDR (new_down)) - XINT (XCDR (down)); + } + + if (ignore_mouse_drag_p) + { + event->modifiers |= click_modifier; + ignore_mouse_drag_p = 0; + } + else if (xdiff < double_click_fuzz && xdiff > - double_click_fuzz + && ydiff < double_click_fuzz && ydiff > - double_click_fuzz + /* Maybe the mouse has moved a lot, caused scrolling, and + eventually ended up at the same screen position (but + not buffer position) in which case it is a drag, not + a click. */ + /* FIXME: OTOH if the buffer position has changed + because of a timer or process filter rather than + because of mouse movement, it should be considered as + a click. But mouse-drag-region completely ignores + this case and it hasn't caused any real problem, so + it's probably OK to ignore it as well. */ + && EQ (Fcar (Fcdr (start_pos)), Fcar (Fcdr (position)))) + /* Mouse hasn't moved (much). */ + event->modifiers |= click_modifier; + else + { + button_down_time = 0; + event->modifiers |= drag_modifier; + } + + /* Don't check is_double; treat this as multiple + if the down-event was multiple. */ + if (double_click_count > 1) + event->modifiers |= ((double_click_count > 2) + ? triple_modifier + : double_modifier); + } + } + else + /* Every mouse event should either have the down_modifier or + the up_modifier set. */ + emacs_abort (); + + { + /* Get the symbol we should use for the mouse click. */ + Lisp_Object head; + + head = modify_event_symbol (button, + event->modifiers, + Qmouse_click, Vlispy_mouse_stem, + NULL, + &mouse_syms, + ASIZE (mouse_syms)); + if (event->modifiers & drag_modifier) + return list3 (head, start_pos, position); + else if (event->modifiers & (double_modifier | triple_modifier)) + return list3 (head, position, make_number (double_click_count)); + else + return list2 (head, position); + } + } + + case WHEEL_EVENT: + case HORIZ_WHEEL_EVENT: + { + Lisp_Object position; + Lisp_Object head; + + /* Build the position as appropriate for this mouse click. */ + struct frame *f = XFRAME (event->frame_or_window); + + /* Ignore wheel events that were made on frame that have been + deleted. */ + if (! FRAME_LIVE_P (f)) + return Qnil; + + position = make_lispy_position (f, event->x, event->y, + event->timestamp); + + /* Set double or triple modifiers to indicate the wheel speed. */ + { + /* On window-system frames, use the value of + double-click-fuzz as is. On other frames, interpret it + as a multiple of 1/8 characters. */ + struct frame *fr; + int fuzz; + int symbol_num; + bool is_double; + + if (WINDOWP (event->frame_or_window)) + fr = XFRAME (XWINDOW (event->frame_or_window)->frame); + else if (FRAMEP (event->frame_or_window)) + fr = XFRAME (event->frame_or_window); + else + emacs_abort (); + + fuzz = FRAME_WINDOW_P (fr) + ? double_click_fuzz : double_click_fuzz / 8; + + if (event->modifiers & up_modifier) + { + /* Emit a wheel-up event. */ + event->modifiers &= ~up_modifier; + symbol_num = 0; + } + else if (event->modifiers & down_modifier) + { + /* Emit a wheel-down event. */ + event->modifiers &= ~down_modifier; + symbol_num = 1; + } + else + /* Every wheel event should either have the down_modifier or + the up_modifier set. */ + emacs_abort (); + + if (event->kind == HORIZ_WHEEL_EVENT) + symbol_num += 2; + + is_double = (last_mouse_button == - (1 + symbol_num) + && (eabs (XINT (event->x) - last_mouse_x) <= fuzz) + && (eabs (XINT (event->y) - last_mouse_y) <= fuzz) + && button_down_time != 0 + && (EQ (Vdouble_click_time, Qt) + || (NATNUMP (Vdouble_click_time) + && (event->timestamp - button_down_time + < XFASTINT (Vdouble_click_time))))); + if (is_double) + { + double_click_count++; + event->modifiers |= ((double_click_count > 2) + ? triple_modifier + : double_modifier); + } + else + { + double_click_count = 1; + event->modifiers |= click_modifier; + } + + button_down_time = event->timestamp; + /* Use a negative value to distinguish wheel from mouse button. */ + last_mouse_button = - (1 + symbol_num); + last_mouse_x = XINT (event->x); + last_mouse_y = XINT (event->y); + + /* Get the symbol we should use for the wheel event. */ + head = modify_event_symbol (symbol_num, + event->modifiers, + Qmouse_click, + Qnil, + lispy_wheel_names, + &wheel_syms, + ASIZE (wheel_syms)); + } + + if (event->modifiers & (double_modifier | triple_modifier)) + return list3 (head, position, make_number (double_click_count)); + else + return list2 (head, position); + } + + +#ifdef USE_TOOLKIT_SCROLL_BARS + + /* We don't have down and up events if using toolkit scroll bars, + so make this always a click event. Store in the `part' of + the Lisp event a symbol which maps to the following actions: + + `above_handle' page up + `below_handle' page down + `up' line up + `down' line down + `top' top of buffer + `bottom' bottom of buffer + `handle' thumb has been dragged. + `end-scroll' end of interaction with scroll bar + + The incoming input_event contains in its `part' member an + index of type `enum scroll_bar_part' which we can use as an + index in scroll_bar_parts to get the appropriate symbol. */ + + case SCROLL_BAR_CLICK_EVENT: + { + Lisp_Object position, head; + + position = make_scroll_bar_position (event, Qvertical_scroll_bar); + + /* Always treat scroll bar events as clicks. */ + event->modifiers |= click_modifier; + event->modifiers &= ~up_modifier; + + if (event->code >= ASIZE (mouse_syms)) + mouse_syms = larger_vector (mouse_syms, + event->code - ASIZE (mouse_syms) + 1, + -1); + + /* Get the symbol we should use for the mouse click. */ + head = modify_event_symbol (event->code, + event->modifiers, + Qmouse_click, + Vlispy_mouse_stem, + NULL, &mouse_syms, + ASIZE (mouse_syms)); + return list2 (head, position); + } + + case HORIZONTAL_SCROLL_BAR_CLICK_EVENT: + { + Lisp_Object position, head; + + position = make_scroll_bar_position (event, Qhorizontal_scroll_bar); + + /* Always treat scroll bar events as clicks. */ + event->modifiers |= click_modifier; + event->modifiers &= ~up_modifier; + + if (event->code >= ASIZE (mouse_syms)) + mouse_syms = larger_vector (mouse_syms, + event->code - ASIZE (mouse_syms) + 1, + -1); + + /* Get the symbol we should use for the mouse click. */ + head = modify_event_symbol (event->code, + event->modifiers, + Qmouse_click, + Vlispy_mouse_stem, + NULL, &mouse_syms, + ASIZE (mouse_syms)); + return list2 (head, position); + } + +#endif /* USE_TOOLKIT_SCROLL_BARS */ + + case DRAG_N_DROP_EVENT: + { + struct frame *f; + Lisp_Object head, position; + Lisp_Object files; + + f = XFRAME (event->frame_or_window); + files = event->arg; + + /* Ignore mouse events that were made on frames that + have been deleted. */ + if (! FRAME_LIVE_P (f)) + return Qnil; + + position = make_lispy_position (f, event->x, event->y, + event->timestamp); + + head = modify_event_symbol (0, event->modifiers, + Qdrag_n_drop, Qnil, + lispy_drag_n_drop_names, + &drag_n_drop_syms, 1); + return list3 (head, position, files); + } + +#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \ + || defined (HAVE_NS) || defined (USE_GTK) + case MENU_BAR_EVENT: + if (EQ (event->arg, event->frame_or_window)) + /* This is the prefix key. We translate this to + `(menu_bar)' because the code in keyboard.c for menu + events, which we use, relies on this. */ + return list1 (Qmenu_bar); + return event->arg; +#endif + + case SELECT_WINDOW_EVENT: + /* Make an event (select-window (WINDOW)). */ + return list2 (Qselect_window, list1 (event->frame_or_window)); + + case TOOL_BAR_EVENT: + if (EQ (event->arg, event->frame_or_window)) + /* This is the prefix key. We translate this to + `(tool_bar)' because the code in keyboard.c for tool bar + events, which we use, relies on this. */ + return list1 (Qtool_bar); + else if (SYMBOLP (event->arg)) + return apply_modifiers (event->modifiers, event->arg); + return event->arg; + + case USER_SIGNAL_EVENT: + /* A user signal. */ + { + char *name = find_user_signal_name (event->code); + if (!name) + emacs_abort (); + return intern (name); + } + + case SAVE_SESSION_EVENT: + return Qsave_session; + +#ifdef HAVE_DBUS + case DBUS_EVENT: + { + return Fcons (Qdbus_event, event->arg); + } +#endif /* HAVE_DBUS */ + +#if defined HAVE_GFILENOTIFY || defined HAVE_INOTIFY + case FILE_NOTIFY_EVENT: + { + return Fcons (Qfile_notify, event->arg); + } +#endif /* defined HAVE_GFILENOTIFY || defined HAVE_INOTIFY */ + + case CONFIG_CHANGED_EVENT: + return list3 (Qconfig_changed_event, + event->arg, event->frame_or_window); + + /* The 'kind' field of the event is something we don't recognize. */ + default: + emacs_abort (); + } +} + +static Lisp_Object +make_lispy_movement (struct frame *frame, Lisp_Object bar_window, enum scroll_bar_part part, + Lisp_Object x, Lisp_Object y, Time t) +{ + /* Is it a scroll bar movement? */ + if (frame && ! NILP (bar_window)) + { + Lisp_Object part_sym; + + part_sym = builtin_lisp_symbol (scroll_bar_parts[part]); + return list2 (Qscroll_bar_movement, + list5 (bar_window, + Qvertical_scroll_bar, + Fcons (x, y), + make_number (t), + part_sym)); + } + /* Or is it an ordinary mouse movement? */ + else + { + Lisp_Object position; + position = make_lispy_position (frame, x, y, t); + return list2 (Qmouse_movement, position); + } +} + +/* Construct a switch frame event. */ +static Lisp_Object +make_lispy_switch_frame (Lisp_Object frame) +{ + return list2 (Qswitch_frame, frame); +} + +static Lisp_Object +make_lispy_focus_in (Lisp_Object frame) +{ + return list2 (Qfocus_in, frame); +} + +#ifdef HAVE_WINDOW_SYSTEM + +static Lisp_Object +make_lispy_focus_out (Lisp_Object frame) +{ + return list2 (Qfocus_out, frame); +} + +#endif /* HAVE_WINDOW_SYSTEM */ + +/* Manipulating modifiers. */ + +/* Parse the name of SYMBOL, and return the set of modifiers it contains. + + If MODIFIER_END is non-zero, set *MODIFIER_END to the position in + SYMBOL's name of the end of the modifiers; the string from this + position is the unmodified symbol name. + + This doesn't use any caches. */ + +static int +parse_modifiers_uncached (Lisp_Object symbol, ptrdiff_t *modifier_end) +{ + Lisp_Object name; + ptrdiff_t i; + int modifiers; + + CHECK_SYMBOL (symbol); + + modifiers = 0; + name = SYMBOL_NAME (symbol); + + for (i = 0; i < SBYTES (name) - 1; ) + { + ptrdiff_t this_mod_end = 0; + int this_mod = 0; + + /* See if the name continues with a modifier word. + Check that the word appears, but don't check what follows it. + Set this_mod and this_mod_end to record what we find. */ + + switch (SREF (name, i)) + { +#define SINGLE_LETTER_MOD(BIT) \ + (this_mod_end = i + 1, this_mod = BIT) + + case 'A': + SINGLE_LETTER_MOD (alt_modifier); + break; + + case 'C': + SINGLE_LETTER_MOD (ctrl_modifier); + break; + + case 'H': + SINGLE_LETTER_MOD (hyper_modifier); + break; + + case 'M': + SINGLE_LETTER_MOD (meta_modifier); + break; + + case 'S': + SINGLE_LETTER_MOD (shift_modifier); + break; + + case 's': + SINGLE_LETTER_MOD (super_modifier); + break; + +#undef SINGLE_LETTER_MOD + +#define MULTI_LETTER_MOD(BIT, NAME, LEN) \ + if (i + LEN + 1 <= SBYTES (name) \ + && ! memcmp (SDATA (name) + i, NAME, LEN)) \ + { \ + this_mod_end = i + LEN; \ + this_mod = BIT; \ + } + + case 'd': + MULTI_LETTER_MOD (drag_modifier, "drag", 4); + MULTI_LETTER_MOD (down_modifier, "down", 4); + MULTI_LETTER_MOD (double_modifier, "double", 6); + break; + + case 't': + MULTI_LETTER_MOD (triple_modifier, "triple", 6); + break; +#undef MULTI_LETTER_MOD + + } + + /* If we found no modifier, stop looking for them. */ + if (this_mod_end == 0) + break; + + /* Check there is a dash after the modifier, so that it + really is a modifier. */ + if (this_mod_end >= SBYTES (name) + || SREF (name, this_mod_end) != '-') + break; + + /* This modifier is real; look for another. */ + modifiers |= this_mod; + i = this_mod_end + 1; + } + + /* Should we include the `click' modifier? */ + if (! (modifiers & (down_modifier | drag_modifier + | double_modifier | triple_modifier)) + && i + 7 == SBYTES (name) + && memcmp (SDATA (name) + i, "mouse-", 6) == 0 + && ('0' <= SREF (name, i + 6) && SREF (name, i + 6) <= '9')) + modifiers |= click_modifier; + + if (! (modifiers & (double_modifier | triple_modifier)) + && i + 6 < SBYTES (name) + && memcmp (SDATA (name) + i, "wheel-", 6) == 0) + modifiers |= click_modifier; + + if (modifier_end) + *modifier_end = i; + + return modifiers; +} + +/* Return a symbol whose name is the modifier prefixes for MODIFIERS + prepended to the string BASE[0..BASE_LEN-1]. + This doesn't use any caches. */ +static Lisp_Object +apply_modifiers_uncached (int modifiers, char *base, int base_len, int base_len_byte) +{ + /* Since BASE could contain nulls, we can't use intern here; we have + to use Fintern, which expects a genuine Lisp_String, and keeps a + reference to it. */ + char new_mods[sizeof "A-C-H-M-S-s-down-drag-double-triple-"]; + int mod_len; + + { + char *p = new_mods; + + /* Only the event queue may use the `up' modifier; it should always + be turned into a click or drag event before presented to lisp code. */ + if (modifiers & up_modifier) + emacs_abort (); + + if (modifiers & alt_modifier) { *p++ = 'A'; *p++ = '-'; } + if (modifiers & ctrl_modifier) { *p++ = 'C'; *p++ = '-'; } + if (modifiers & hyper_modifier) { *p++ = 'H'; *p++ = '-'; } + if (modifiers & meta_modifier) { *p++ = 'M'; *p++ = '-'; } + if (modifiers & shift_modifier) { *p++ = 'S'; *p++ = '-'; } + if (modifiers & super_modifier) { *p++ = 's'; *p++ = '-'; } + if (modifiers & double_modifier) p = stpcpy (p, "double-"); + if (modifiers & triple_modifier) p = stpcpy (p, "triple-"); + if (modifiers & down_modifier) p = stpcpy (p, "down-"); + if (modifiers & drag_modifier) p = stpcpy (p, "drag-"); + /* The click modifier is denoted by the absence of other modifiers. */ + + *p = '\0'; + + mod_len = p - new_mods; + } + + { + Lisp_Object new_name; + + new_name = make_uninit_multibyte_string (mod_len + base_len, + mod_len + base_len_byte); + memcpy (SDATA (new_name), new_mods, mod_len); + memcpy (SDATA (new_name) + mod_len, base, base_len_byte); + + return Fintern (new_name, Qnil); + } +} + + +static const char *const modifier_names[] = +{ + "up", "down", "drag", "click", "double", "triple", 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, "alt", "super", "hyper", "shift", "control", "meta" +}; +#define NUM_MOD_NAMES ARRAYELTS (modifier_names) + +static Lisp_Object modifier_symbols; + +/* Return the list of modifier symbols corresponding to the mask MODIFIERS. */ +static Lisp_Object +lispy_modifier_list (int modifiers) +{ + Lisp_Object modifier_list; + int i; + + modifier_list = Qnil; + for (i = 0; (1<= table_size) + return Qnil; + + if (CONSP (*symbol_table)) + value = Fcdr (assq_no_quit (symbol_int, *symbol_table)); + + /* If *symbol_table doesn't seem to be initialized properly, fix that. + *symbol_table should be a lisp vector TABLE_SIZE elements long, + where the Nth element is the symbol for NAME_TABLE[N], or nil if + we've never used that symbol before. */ + else + { + if (! VECTORP (*symbol_table) + || ASIZE (*symbol_table) != table_size) + { + Lisp_Object size; + + XSETFASTINT (size, table_size); + *symbol_table = Fmake_vector (size, Qnil); + } + + value = AREF (*symbol_table, symbol_num); + } + + /* Have we already used this symbol before? */ + if (NILP (value)) + { + /* No; let's create it. */ + if (CONSP (name_alist_or_stem)) + value = Fcdr_safe (Fassq (symbol_int, name_alist_or_stem)); + else if (STRINGP (name_alist_or_stem)) + { + char *buf; + ptrdiff_t len = (SBYTES (name_alist_or_stem) + + sizeof "-" + INT_STRLEN_BOUND (EMACS_INT)); + USE_SAFE_ALLOCA; + buf = SAFE_ALLOCA (len); + esprintf (buf, "%s-%"pI"d", SDATA (name_alist_or_stem), + XINT (symbol_int) + 1); + value = intern (buf); + SAFE_FREE (); + } + else if (name_table != 0 && name_table[symbol_num]) + value = intern (name_table[symbol_num]); + +#ifdef HAVE_WINDOW_SYSTEM + if (NILP (value)) + { + char *name = x_get_keysym_name (symbol_num); + if (name) + value = intern (name); + } +#endif + + if (NILP (value)) + { + char buf[sizeof "key-" + INT_STRLEN_BOUND (EMACS_INT)]; + sprintf (buf, "key-%"pD"d", symbol_num); + value = intern (buf); + } + + if (CONSP (*symbol_table)) + *symbol_table = Fcons (Fcons (symbol_int, value), *symbol_table); + else + ASET (*symbol_table, symbol_num, value); + + /* Fill in the cache entries for this symbol; this also + builds the Qevent_symbol_elements property, which the user + cares about. */ + apply_modifiers (modifiers & click_modifier, value); + Fput (value, Qevent_kind, symbol_kind); + } + + /* Apply modifiers to that symbol. */ + return apply_modifiers (modifiers, value); +} + +/* Convert a list that represents an event type, + such as (ctrl meta backspace), into the usual representation of that + event type as a number or a symbol. */ + +DEFUN ("event-convert-list", Fevent_convert_list, Sevent_convert_list, 1, 1, 0, + doc: /* Convert the event description list EVENT-DESC to an event type. +EVENT-DESC should contain one base event type (a character or symbol) +and zero or more modifier names (control, meta, hyper, super, shift, alt, +drag, down, double or triple). The base must be last. +The return value is an event type (a character or symbol) which +has the same base event type and all the specified modifiers. */) + (Lisp_Object event_desc) +{ + Lisp_Object base; + int modifiers = 0; + Lisp_Object rest; + + base = Qnil; + rest = event_desc; + while (CONSP (rest)) + { + Lisp_Object elt; + int this = 0; + + elt = XCAR (rest); + rest = XCDR (rest); + + /* Given a symbol, see if it is a modifier name. */ + if (SYMBOLP (elt) && CONSP (rest)) + this = parse_solitary_modifier (elt); + + if (this != 0) + modifiers |= this; + else if (!NILP (base)) + error ("Two bases given in one event"); + else + base = elt; + + } + + /* Let the symbol A refer to the character A. */ + if (SYMBOLP (base) && SCHARS (SYMBOL_NAME (base)) == 1) + XSETINT (base, SREF (SYMBOL_NAME (base), 0)); + + if (INTEGERP (base)) + { + /* Turn (shift a) into A. */ + if ((modifiers & shift_modifier) != 0 + && (XINT (base) >= 'a' && XINT (base) <= 'z')) + { + XSETINT (base, XINT (base) - ('a' - 'A')); + modifiers &= ~shift_modifier; + } + + /* Turn (control a) into C-a. */ + if (modifiers & ctrl_modifier) + return make_number ((modifiers & ~ctrl_modifier) + | make_ctrl_char (XINT (base))); + else + return make_number (modifiers | XINT (base)); + } + else if (SYMBOLP (base)) + return apply_modifiers (modifiers, base); + else + error ("Invalid base event"); +} + +/* Try to recognize SYMBOL as a modifier name. + Return the modifier flag bit, or 0 if not recognized. */ + +int +parse_solitary_modifier (Lisp_Object symbol) +{ + Lisp_Object name = SYMBOL_NAME (symbol); + + switch (SREF (name, 0)) + { +#define SINGLE_LETTER_MOD(BIT) \ + if (SBYTES (name) == 1) \ + return BIT; + +#define MULTI_LETTER_MOD(BIT, NAME, LEN) \ + if (LEN == SBYTES (name) \ + && ! memcmp (SDATA (name), NAME, LEN)) \ + return BIT; + + case 'A': + SINGLE_LETTER_MOD (alt_modifier); + break; + + case 'a': + MULTI_LETTER_MOD (alt_modifier, "alt", 3); + break; + + case 'C': + SINGLE_LETTER_MOD (ctrl_modifier); + break; + + case 'c': + MULTI_LETTER_MOD (ctrl_modifier, "ctrl", 4); + MULTI_LETTER_MOD (ctrl_modifier, "control", 7); + break; + + case 'H': + SINGLE_LETTER_MOD (hyper_modifier); + break; + + case 'h': + MULTI_LETTER_MOD (hyper_modifier, "hyper", 5); + break; + + case 'M': + SINGLE_LETTER_MOD (meta_modifier); + break; + + case 'm': + MULTI_LETTER_MOD (meta_modifier, "meta", 4); + break; + + case 'S': + SINGLE_LETTER_MOD (shift_modifier); + break; + + case 's': + MULTI_LETTER_MOD (shift_modifier, "shift", 5); + MULTI_LETTER_MOD (super_modifier, "super", 5); + SINGLE_LETTER_MOD (super_modifier); + break; + + case 'd': + MULTI_LETTER_MOD (drag_modifier, "drag", 4); + MULTI_LETTER_MOD (down_modifier, "down", 4); + MULTI_LETTER_MOD (double_modifier, "double", 6); + break; + + case 't': + MULTI_LETTER_MOD (triple_modifier, "triple", 6); + break; + +#undef SINGLE_LETTER_MOD +#undef MULTI_LETTER_MOD + } + + return 0; +} + +/* Return true if EVENT is a list whose elements are all integers or symbols. + Such a list is not valid as an event, + but it can be a Lucid-style event type list. */ + +bool +lucid_event_type_list_p (Lisp_Object object) +{ + Lisp_Object tail; + + if (! CONSP (object)) + return 0; + + if (EQ (XCAR (object), Qhelp_echo) + || EQ (XCAR (object), Qvertical_line) + || EQ (XCAR (object), Qmode_line) + || EQ (XCAR (object), Qheader_line)) + return 0; + + for (tail = object; CONSP (tail); tail = XCDR (tail)) + { + Lisp_Object elt; + elt = XCAR (tail); + if (! (INTEGERP (elt) || SYMBOLP (elt))) + return 0; + } + + return NILP (tail); +} + +/* Return true if terminal input chars are available. + Also, store the return value into INPUT_PENDING. + + Serves the purpose of ioctl (0, FIONREAD, ...) + but works even if FIONREAD does not exist. + (In fact, this may actually read some input.) + + If READABLE_EVENTS_DO_TIMERS_NOW is set in FLAGS, actually run + timer events that are ripe. + If READABLE_EVENTS_FILTER_EVENTS is set in FLAGS, ignore internal + events (FOCUS_IN_EVENT). + If READABLE_EVENTS_IGNORE_SQUEEZABLES is set in FLAGS, ignore mouse + movements and toolkit scroll bar thumb drags. */ + +static bool +get_input_pending (int flags) +{ + /* First of all, have we already counted some input? */ + input_pending = (!NILP (Vquit_flag) || readable_events (flags)); + + /* If input is being read as it arrives, and we have none, there is none. */ + if (!input_pending && (!interrupt_input || interrupts_deferred)) + { + /* Try to read some input and see how much we get. */ + gobble_input (); + input_pending = (!NILP (Vquit_flag) || readable_events (flags)); + } + + return input_pending; +} + +/* Put a BUFFER_SWITCH_EVENT in the buffer + so that read_key_sequence will notice the new current buffer. */ + +void +record_asynch_buffer_change (void) +{ + /* We don't need a buffer-switch event unless Emacs is waiting for input. + The purpose of the event is to make read_key_sequence look up the + keymaps again. If we aren't in read_key_sequence, we don't need one, + and the event could cause trouble by messing up (input-pending-p). + Note: Fwaiting_for_user_input_p always returns nil when async + subprocesses aren't supported. */ + if (!NILP (Fwaiting_for_user_input_p ())) + { + struct input_event event; + + EVENT_INIT (event); + event.kind = BUFFER_SWITCH_EVENT; + event.frame_or_window = Qnil; + event.arg = Qnil; + + /* Make sure no interrupt happens while storing the event. */ +#ifdef USABLE_SIGIO + if (interrupt_input) + kbd_buffer_store_event (&event); + else +#endif + { + stop_polling (); + kbd_buffer_store_event (&event); + start_polling (); + } + } +} + +/* Read any terminal input already buffered up by the system + into the kbd_buffer, but do not wait. + + Return the number of keyboard chars read, or -1 meaning + this is a bad time to try to read input. */ + +int +gobble_input (void) +{ + int nread = 0; + bool err = 0; + struct terminal *t; + + /* Store pending user signal events, if any. */ + store_user_signal_events (); + + /* Loop through the available terminals, and call their input hooks. */ + t = terminal_list; + while (t) + { + struct terminal *next = t->next_terminal; + + if (t->read_socket_hook) + { + int nr; + struct input_event hold_quit; + + if (input_blocked_p ()) + { + pending_signals = 1; + break; + } + + EVENT_INIT (hold_quit); + hold_quit.kind = NO_EVENT; + + /* No need for FIONREAD or fcntl; just say don't wait. */ + while ((nr = (*t->read_socket_hook) (t, &hold_quit)) > 0) + nread += nr; + + if (nr == -1) /* Not OK to read input now. */ + { + err = 1; + } + else if (nr == -2) /* Non-transient error. */ + { + /* The terminal device terminated; it should be closed. */ + + /* Kill Emacs if this was our last terminal. */ + if (!terminal_list->next_terminal) + /* Formerly simply reported no input, but that + sometimes led to a failure of Emacs to terminate. + SIGHUP seems appropriate if we can't reach the + terminal. */ + /* ??? Is it really right to send the signal just to + this process rather than to the whole process + group? Perhaps on systems with FIONREAD Emacs is + alone in its group. */ + terminate_due_to_signal (SIGHUP, 10); + + /* XXX Is calling delete_terminal safe here? It calls delete_frame. */ + { + Lisp_Object tmp; + XSETTERMINAL (tmp, t); + Fdelete_terminal (tmp, Qnoelisp); + } + } + + /* If there was no error, make sure the pointer + is visible for all frames on this terminal. */ + if (nr >= 0) + { + Lisp_Object tail, frame; + + FOR_EACH_FRAME (tail, frame) + { + struct frame *f = XFRAME (frame); + if (FRAME_TERMINAL (f) == t) + frame_make_pointer_visible (f); + } + } + + if (hold_quit.kind != NO_EVENT) + kbd_buffer_store_event (&hold_quit); + } + + t = next; + } + + if (err && !nread) + nread = -1; + + return nread; +} + +/* This is the tty way of reading available input. + + Note that each terminal device has its own `struct terminal' object, + and so this function is called once for each individual termcap + terminal. The first parameter indicates which terminal to read from. */ + +int +tty_read_avail_input (struct terminal *terminal, + struct input_event *hold_quit) +{ + /* Using KBD_BUFFER_SIZE - 1 here avoids reading more than + the kbd_buffer can really hold. That may prevent loss + of characters on some systems when input is stuffed at us. */ + unsigned char cbuf[KBD_BUFFER_SIZE - 1]; + int n_to_read, i; + struct tty_display_info *tty = terminal->display_info.tty; + int nread = 0; +#ifdef subprocesses + int buffer_free = KBD_BUFFER_SIZE - kbd_buffer_nr_stored () - 1; + + if (kbd_on_hold_p () || buffer_free <= 0) + return 0; +#endif /* subprocesses */ + + if (!terminal->name) /* Don't read from a dead terminal. */ + return 0; + + if (terminal->type != output_termcap + && terminal->type != output_msdos_raw) + emacs_abort (); + + /* XXX I think the following code should be moved to separate hook + functions in system-dependent files. */ +#ifdef WINDOWSNT + /* FIXME: AFAIK, tty_read_avail_input is not used under w32 since the non-GUI + code sets read_socket_hook to w32_console_read_socket instead! */ + return 0; +#else /* not WINDOWSNT */ + if (! tty->term_initted) /* In case we get called during bootstrap. */ + return 0; + + if (! tty->input) + return 0; /* The terminal is suspended. */ + +#ifdef MSDOS + n_to_read = dos_keysns (); + if (n_to_read == 0) + return 0; + + cbuf[0] = dos_keyread (); + nread = 1; + +#else /* not MSDOS */ +#ifdef HAVE_GPM + if (gpm_tty == tty) + { + Gpm_Event event; + struct input_event gpm_hold_quit; + int gpm, fd = gpm_fd; + + EVENT_INIT (gpm_hold_quit); + gpm_hold_quit.kind = NO_EVENT; + + /* gpm==1 if event received. + gpm==0 if the GPM daemon has closed the connection, in which case + Gpm_GetEvent closes gpm_fd and clears it to -1, which is why + we save it in `fd' so close_gpm can remove it from the + select masks. + gpm==-1 if a protocol error or EWOULDBLOCK; the latter is normal. */ + while (gpm = Gpm_GetEvent (&event), gpm == 1) { + nread += handle_one_term_event (tty, &event, &gpm_hold_quit); + } + if (gpm == 0) + /* Presumably the GPM daemon has closed the connection. */ + close_gpm (fd); + if (gpm_hold_quit.kind != NO_EVENT) + kbd_buffer_store_event (&gpm_hold_quit); + if (nread) + return nread; + } +#endif /* HAVE_GPM */ + +/* Determine how many characters we should *try* to read. */ +#ifdef USABLE_FIONREAD + /* Find out how much input is available. */ + if (ioctl (fileno (tty->input), FIONREAD, &n_to_read) < 0) + { + if (! noninteractive) + return -2; /* Close this terminal. */ + else + n_to_read = 0; + } + if (n_to_read == 0) + return 0; + if (n_to_read > sizeof cbuf) + n_to_read = sizeof cbuf; +#elif defined USG || defined CYGWIN + /* Read some input if available, but don't wait. */ + n_to_read = sizeof cbuf; + fcntl (fileno (tty->input), F_SETFL, O_NONBLOCK); +#else +# error "Cannot read without possibly delaying" +#endif + +#ifdef subprocesses + /* Don't read more than we can store. */ + if (n_to_read > buffer_free) + n_to_read = buffer_free; +#endif /* subprocesses */ + + /* Now read; for one reason or another, this will not block. + NREAD is set to the number of chars read. */ + do + { + nread = emacs_read (fileno (tty->input), (char *) cbuf, n_to_read); + /* POSIX infers that processes which are not in the session leader's + process group won't get SIGHUPs at logout time. BSDI adheres to + this part standard and returns -1 from read (0) with errno==EIO + when the control tty is taken away. + Jeffrey Honig says this is generally safe. */ + if (nread == -1 && errno == EIO) + return -2; /* Close this terminal. */ +#if defined (AIX) && defined (_BSD) + /* The kernel sometimes fails to deliver SIGHUP for ptys. + This looks incorrect, but it isn't, because _BSD causes + O_NDELAY to be defined in fcntl.h as O_NONBLOCK, + and that causes a value other than 0 when there is no input. */ + if (nread == 0) + return -2; /* Close this terminal. */ +#endif + } + while ( + /* We used to retry the read if it was interrupted. + But this does the wrong thing when O_NONBLOCK causes + an EAGAIN error. Does anybody know of a situation + where a retry is actually needed? */ +#if 0 + nread < 0 && (errno == EAGAIN || errno == EFAULT +#ifdef EBADSLT + || errno == EBADSLT +#endif + ) +#else + 0 +#endif + ); + +#ifndef USABLE_FIONREAD +#if defined (USG) || defined (CYGWIN) + fcntl (fileno (tty->input), F_SETFL, 0); +#endif /* USG or CYGWIN */ +#endif /* no FIONREAD */ + + if (nread <= 0) + return nread; + +#endif /* not MSDOS */ +#endif /* not WINDOWSNT */ + + for (i = 0; i < nread; i++) + { + struct input_event buf; + EVENT_INIT (buf); + buf.kind = ASCII_KEYSTROKE_EVENT; + buf.modifiers = 0; + if (tty->meta_key == 1 && (cbuf[i] & 0x80)) + buf.modifiers = meta_modifier; + if (tty->meta_key != 2) + cbuf[i] &= ~0x80; + + buf.code = cbuf[i]; + /* Set the frame corresponding to the active tty. Note that the + value of selected_frame is not reliable here, redisplay tends + to temporarily change it. */ + buf.frame_or_window = tty->top_frame; + buf.arg = Qnil; + + kbd_buffer_store_event (&buf); + /* Don't look at input that follows a C-g too closely. + This reduces lossage due to autorepeat on C-g. */ + if (buf.kind == ASCII_KEYSTROKE_EVENT + && buf.code == quit_char) + break; + } + + return nread; +} + +static void +handle_async_input (void) +{ +#ifdef USABLE_SIGIO + while (1) + { + int nread = gobble_input (); + /* -1 means it's not ok to read the input now. + UNBLOCK_INPUT will read it later; now, avoid infinite loop. + 0 means there was no keyboard input available. */ + if (nread <= 0) + break; + } +#endif +} + +void +process_pending_signals (void) +{ + pending_signals = 0; + handle_async_input (); + do_pending_atimers (); +} + +/* Undo any number of BLOCK_INPUT calls down to level LEVEL, + and reinvoke any pending signal if the level is now 0 and + a fatal error is not already in progress. */ + +void +unblock_input_to (int level) +{ + interrupt_input_blocked = level; + if (level == 0) + { + if (pending_signals && !fatal_error_in_progress) + process_pending_signals (); + } + else if (level < 0) + emacs_abort (); +} + +/* End critical section. + + If doing signal-driven input, and a signal came in when input was + blocked, reinvoke the signal handler now to deal with it. + + It will also process queued input, if it was not read before. + When a longer code sequence does not use block/unblock input + at all, the whole input gathered up to the next call to + unblock_input will be processed inside that call. */ + +void +unblock_input (void) +{ + unblock_input_to (interrupt_input_blocked - 1); +} + +/* Undo any number of BLOCK_INPUT calls, + and also reinvoke any pending signal. */ + +void +totally_unblock_input (void) +{ + unblock_input_to (0); +} + +#ifdef USABLE_SIGIO + +void +handle_input_available_signal (int sig) +{ + pending_signals = 1; + + if (input_available_clear_time) + *input_available_clear_time = make_timespec (0, 0); +} + +static void +deliver_input_available_signal (int sig) +{ + deliver_process_signal (sig, handle_input_available_signal); +} +#endif /* USABLE_SIGIO */ + + +/* User signal events. */ + +struct user_signal_info +{ + /* Signal number. */ + int sig; + + /* Name of the signal. */ + char *name; + + /* Number of pending signals. */ + int npending; + + struct user_signal_info *next; +}; + +/* List of user signals. */ +static struct user_signal_info *user_signals = NULL; + +void +add_user_signal (int sig, const char *name) +{ + struct sigaction action; + struct user_signal_info *p; + + for (p = user_signals; p; p = p->next) + if (p->sig == sig) + /* Already added. */ + return; + + p = xmalloc (sizeof *p); + p->sig = sig; + p->name = xstrdup (name); + p->npending = 0; + p->next = user_signals; + user_signals = p; + + emacs_sigaction_init (&action, deliver_user_signal); + sigaction (sig, &action, 0); +} + +static void +handle_user_signal (int sig) +{ + struct user_signal_info *p; + const char *special_event_name = NULL; + + if (SYMBOLP (Vdebug_on_event)) + special_event_name = SSDATA (SYMBOL_NAME (Vdebug_on_event)); + + for (p = user_signals; p; p = p->next) + if (p->sig == sig) + { + if (special_event_name + && strcmp (special_event_name, p->name) == 0) + { + /* Enter the debugger in many ways. */ + debug_on_next_call = 1; + debug_on_quit = 1; + Vquit_flag = Qt; + Vinhibit_quit = Qnil; + + /* Eat the event. */ + break; + } + + p->npending++; +#ifdef USABLE_SIGIO + if (interrupt_input) + handle_input_available_signal (sig); + else +#endif + { + /* Tell wait_reading_process_output that it needs to wake + up and look around. */ + if (input_available_clear_time) + *input_available_clear_time = make_timespec (0, 0); + } + break; + } +} + +static void +deliver_user_signal (int sig) +{ + deliver_process_signal (sig, handle_user_signal); +} + +static char * +find_user_signal_name (int sig) +{ + struct user_signal_info *p; + + for (p = user_signals; p; p = p->next) + if (p->sig == sig) + return p->name; + + return NULL; +} + +static void +store_user_signal_events (void) +{ + struct user_signal_info *p; + struct input_event buf; + bool buf_initialized = 0; + + for (p = user_signals; p; p = p->next) + if (p->npending > 0) + { + if (! buf_initialized) + { + memset (&buf, 0, sizeof buf); + buf.kind = USER_SIGNAL_EVENT; + buf.frame_or_window = selected_frame; + buf_initialized = 1; + } + + do + { + buf.code = p->sig; + kbd_buffer_store_event (&buf); + p->npending--; + } + while (p->npending > 0); + } +} + + +static void menu_bar_item (Lisp_Object, Lisp_Object, Lisp_Object, void *); +static Lisp_Object menu_bar_one_keymap_changed_items; + +/* These variables hold the vector under construction within + menu_bar_items and its subroutines, and the current index + for storing into that vector. */ +static Lisp_Object menu_bar_items_vector; +static int menu_bar_items_index; + + +static const char *separator_names[] = { + "space", + "no-line", + "single-line", + "double-line", + "single-dashed-line", + "double-dashed-line", + "shadow-etched-in", + "shadow-etched-out", + "shadow-etched-in-dash", + "shadow-etched-out-dash", + "shadow-double-etched-in", + "shadow-double-etched-out", + "shadow-double-etched-in-dash", + "shadow-double-etched-out-dash", + 0, +}; + +/* Return true if LABEL specifies a separator. */ + +bool +menu_separator_name_p (const char *label) +{ + if (!label) + return 0; + else if (strlen (label) > 3 + && memcmp (label, "--", 2) == 0 + && label[2] != '-') + { + int i; + label += 2; + for (i = 0; separator_names[i]; ++i) + if (strcmp (label, separator_names[i]) == 0) + return 1; + } + else + { + /* It's a separator if it contains only dashes. */ + while (*label == '-') + ++label; + return (*label == 0); + } + + return 0; +} + + +/* Return a vector of menu items for a menu bar, appropriate + to the current buffer. Each item has three elements in the vector: + KEY STRING MAPLIST. + + OLD is an old vector we can optionally reuse, or nil. */ + +Lisp_Object +menu_bar_items (Lisp_Object old) +{ + /* The number of keymaps we're scanning right now, and the number of + keymaps we have allocated space for. */ + ptrdiff_t nmaps; + + /* maps[0..nmaps-1] are the prefix definitions of KEYBUF[0..t-1] + in the current keymaps, or nil where it is not a prefix. */ + Lisp_Object *maps; + + Lisp_Object mapsbuf[3]; + Lisp_Object def, tail; + + ptrdiff_t mapno; + Lisp_Object oquit; + + USE_SAFE_ALLOCA; + + /* In order to build the menus, we need to call the keymap + accessors. They all call QUIT. But this function is called + during redisplay, during which a quit is fatal. So inhibit + quitting while building the menus. + We do this instead of specbind because (1) errors will clear it anyway + and (2) this avoids risk of specpdl overflow. */ + oquit = Vinhibit_quit; + Vinhibit_quit = Qt; + + if (!NILP (old)) + menu_bar_items_vector = old; + else + menu_bar_items_vector = Fmake_vector (make_number (24), Qnil); + menu_bar_items_index = 0; + + /* Build our list of keymaps. + If we recognize a function key and replace its escape sequence in + keybuf with its symbol, or if the sequence starts with a mouse + click and we need to switch buffers, we jump back here to rebuild + the initial keymaps from the current buffer. */ + { + Lisp_Object *tmaps; + + /* Should overriding-terminal-local-map and overriding-local-map apply? */ + if (!NILP (Voverriding_local_map_menu_flag) + && !NILP (Voverriding_local_map)) + { + /* Yes, use them (if non-nil) as well as the global map. */ + maps = mapsbuf; + nmaps = 0; + if (!NILP (KVAR (current_kboard, Voverriding_terminal_local_map))) + maps[nmaps++] = KVAR (current_kboard, Voverriding_terminal_local_map); + if (!NILP (Voverriding_local_map)) + maps[nmaps++] = Voverriding_local_map; + } + else + { + /* No, so use major and minor mode keymaps and keymap property. + Note that menu-bar bindings in the local-map and keymap + properties may not work reliable, as they are only + recognized when the menu-bar (or mode-line) is updated, + which does not normally happen after every command. */ + Lisp_Object tem; + ptrdiff_t nminor; + nminor = current_minor_maps (NULL, &tmaps); + SAFE_NALLOCA (maps, 1, nminor + 4); + nmaps = 0; + tem = KVAR (current_kboard, Voverriding_terminal_local_map); + if (!NILP (tem) && !NILP (Voverriding_local_map_menu_flag)) + maps[nmaps++] = tem; + if (tem = get_local_map (PT, current_buffer, Qkeymap), !NILP (tem)) + maps[nmaps++] = tem; + memcpy (maps + nmaps, tmaps, nminor * sizeof (maps[0])); + nmaps += nminor; + maps[nmaps++] = get_local_map (PT, current_buffer, Qlocal_map); + } + maps[nmaps++] = current_global_map; + } + + /* Look up in each map the dummy prefix key `menu-bar'. */ + + for (mapno = nmaps - 1; mapno >= 0; mapno--) + if (!NILP (maps[mapno])) + { + def = get_keymap (access_keymap (maps[mapno], Qmenu_bar, 1, 0, 1), + 0, 1); + if (CONSP (def)) + { + menu_bar_one_keymap_changed_items = Qnil; + map_keymap_canonical (def, menu_bar_item, Qnil, NULL); + } + } + + /* Move to the end those items that should be at the end. */ + + for (tail = Vmenu_bar_final_items; CONSP (tail); tail = XCDR (tail)) + { + int i; + int end = menu_bar_items_index; + + for (i = 0; i < end; i += 4) + if (EQ (XCAR (tail), AREF (menu_bar_items_vector, i))) + { + Lisp_Object tem0, tem1, tem2, tem3; + /* Move the item at index I to the end, + shifting all the others forward. */ + tem0 = AREF (menu_bar_items_vector, i + 0); + tem1 = AREF (menu_bar_items_vector, i + 1); + tem2 = AREF (menu_bar_items_vector, i + 2); + tem3 = AREF (menu_bar_items_vector, i + 3); + if (end > i + 4) + memmove (aref_addr (menu_bar_items_vector, i), + aref_addr (menu_bar_items_vector, i + 4), + (end - i - 4) * word_size); + ASET (menu_bar_items_vector, end - 4, tem0); + ASET (menu_bar_items_vector, end - 3, tem1); + ASET (menu_bar_items_vector, end - 2, tem2); + ASET (menu_bar_items_vector, end - 1, tem3); + break; + } + } + + /* Add nil, nil, nil, nil at the end. */ + { + int i = menu_bar_items_index; + if (i + 4 > ASIZE (menu_bar_items_vector)) + menu_bar_items_vector + = larger_vector (menu_bar_items_vector, 4, -1); + /* Add this item. */ + ASET (menu_bar_items_vector, i, Qnil); i++; + ASET (menu_bar_items_vector, i, Qnil); i++; + ASET (menu_bar_items_vector, i, Qnil); i++; + ASET (menu_bar_items_vector, i, Qnil); i++; + menu_bar_items_index = i; + } + + Vinhibit_quit = oquit; + SAFE_FREE (); + return menu_bar_items_vector; +} + +/* Add one item to menu_bar_items_vector, for KEY, ITEM_STRING and DEF. + If there's already an item for KEY, add this DEF to it. */ + +Lisp_Object item_properties; + +static void +menu_bar_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy1, void *dummy2) +{ + struct gcpro gcpro1; + int i; + bool parsed; + Lisp_Object tem; + + if (EQ (item, Qundefined)) + { + /* If a map has an explicit `undefined' as definition, + discard any previously made menu bar item. */ + + for (i = 0; i < menu_bar_items_index; i += 4) + if (EQ (key, AREF (menu_bar_items_vector, i))) + { + if (menu_bar_items_index > i + 4) + memmove (aref_addr (menu_bar_items_vector, i), + aref_addr (menu_bar_items_vector, i + 4), + (menu_bar_items_index - i - 4) * word_size); + menu_bar_items_index -= 4; + } + } + + /* If this keymap has already contributed to this KEY, + don't contribute to it a second time. */ + tem = Fmemq (key, menu_bar_one_keymap_changed_items); + if (!NILP (tem) || NILP (item)) + return; + + menu_bar_one_keymap_changed_items + = Fcons (key, menu_bar_one_keymap_changed_items); + + /* We add to menu_bar_one_keymap_changed_items before doing the + parse_menu_item, so that if it turns out it wasn't a menu item, + it still correctly hides any further menu item. */ + GCPRO1 (key); + parsed = parse_menu_item (item, 1); + UNGCPRO; + if (!parsed) + return; + + item = AREF (item_properties, ITEM_PROPERTY_DEF); + + /* Find any existing item for this KEY. */ + for (i = 0; i < menu_bar_items_index; i += 4) + if (EQ (key, AREF (menu_bar_items_vector, i))) + break; + + /* If we did not find this KEY, add it at the end. */ + if (i == menu_bar_items_index) + { + /* If vector is too small, get a bigger one. */ + if (i + 4 > ASIZE (menu_bar_items_vector)) + menu_bar_items_vector = larger_vector (menu_bar_items_vector, 4, -1); + /* Add this item. */ + ASET (menu_bar_items_vector, i, key); i++; + ASET (menu_bar_items_vector, i, + AREF (item_properties, ITEM_PROPERTY_NAME)); i++; + ASET (menu_bar_items_vector, i, list1 (item)); i++; + ASET (menu_bar_items_vector, i, make_number (0)); i++; + menu_bar_items_index = i; + } + /* We did find an item for this KEY. Add ITEM to its list of maps. */ + else + { + Lisp_Object old; + old = AREF (menu_bar_items_vector, i + 2); + /* If the new and the old items are not both keymaps, + the lookup will only find `item'. */ + item = Fcons (item, KEYMAPP (item) && KEYMAPP (XCAR (old)) ? old : Qnil); + ASET (menu_bar_items_vector, i + 2, item); + } +} + + /* This is used as the handler when calling menu_item_eval_property. */ +static Lisp_Object +menu_item_eval_property_1 (Lisp_Object arg) +{ + /* If we got a quit from within the menu computation, + quit all the way out of it. This takes care of C-] in the debugger. */ + if (CONSP (arg) && EQ (XCAR (arg), Qquit)) + Fsignal (Qquit, Qnil); + + return Qnil; +} + +static Lisp_Object +eval_dyn (Lisp_Object form) +{ + return Feval (form, Qnil); +} + +/* Evaluate an expression and return the result (or nil if something + went wrong). Used to evaluate dynamic parts of menu items. */ +Lisp_Object +menu_item_eval_property (Lisp_Object sexpr) +{ + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object val; + specbind (Qinhibit_redisplay, Qt); + val = internal_condition_case_1 (eval_dyn, sexpr, Qerror, + menu_item_eval_property_1); + return unbind_to (count, val); +} + +/* This function parses a menu item and leaves the result in the + vector item_properties. + ITEM is a key binding, a possible menu item. + INMENUBAR is > 0 when this is considered for an entry in a menu bar + top level. + INMENUBAR is < 0 when this is considered for an entry in a keyboard menu. + parse_menu_item returns true if the item is a menu item and false + otherwise. */ + +bool +parse_menu_item (Lisp_Object item, int inmenubar) +{ + Lisp_Object def, tem, item_string, start; + Lisp_Object filter; + Lisp_Object keyhint; + int i; + + filter = Qnil; + keyhint = Qnil; + + if (!CONSP (item)) + return 0; + + /* Create item_properties vector if necessary. */ + if (NILP (item_properties)) + item_properties + = Fmake_vector (make_number (ITEM_PROPERTY_ENABLE + 1), Qnil); + + /* Initialize optional entries. */ + for (i = ITEM_PROPERTY_DEF; i < ITEM_PROPERTY_ENABLE; i++) + ASET (item_properties, i, Qnil); + ASET (item_properties, ITEM_PROPERTY_ENABLE, Qt); + + /* Save the item here to protect it from GC. */ + ASET (item_properties, ITEM_PROPERTY_ITEM, item); + + item_string = XCAR (item); + + start = item; + item = XCDR (item); + if (STRINGP (item_string)) + { + /* Old format menu item. */ + ASET (item_properties, ITEM_PROPERTY_NAME, item_string); + + /* Maybe help string. */ + if (CONSP (item) && STRINGP (XCAR (item))) + { + ASET (item_properties, ITEM_PROPERTY_HELP, XCAR (item)); + start = item; + item = XCDR (item); + } + + /* Maybe an obsolete key binding cache. */ + if (CONSP (item) && CONSP (XCAR (item)) + && (NILP (XCAR (XCAR (item))) + || VECTORP (XCAR (XCAR (item))))) + item = XCDR (item); + + /* This is the real definition--the function to run. */ + ASET (item_properties, ITEM_PROPERTY_DEF, item); + + /* Get enable property, if any. */ + if (SYMBOLP (item)) + { + tem = Fget (item, Qmenu_enable); + if (!NILP (Venable_disabled_menus_and_buttons)) + ASET (item_properties, ITEM_PROPERTY_ENABLE, Qt); + else if (!NILP (tem)) + ASET (item_properties, ITEM_PROPERTY_ENABLE, tem); + } + } + else if (EQ (item_string, Qmenu_item) && CONSP (item)) + { + /* New format menu item. */ + ASET (item_properties, ITEM_PROPERTY_NAME, XCAR (item)); + start = XCDR (item); + if (CONSP (start)) + { + /* We have a real binding. */ + ASET (item_properties, ITEM_PROPERTY_DEF, XCAR (start)); + + item = XCDR (start); + /* Is there an obsolete cache list with key equivalences. */ + if (CONSP (item) && CONSP (XCAR (item))) + item = XCDR (item); + + /* Parse properties. */ + while (CONSP (item) && CONSP (XCDR (item))) + { + tem = XCAR (item); + item = XCDR (item); + + if (EQ (tem, QCenable)) + { + if (!NILP (Venable_disabled_menus_and_buttons)) + ASET (item_properties, ITEM_PROPERTY_ENABLE, Qt); + else + ASET (item_properties, ITEM_PROPERTY_ENABLE, XCAR (item)); + } + else if (EQ (tem, QCvisible)) + { + /* If got a visible property and that evaluates to nil + then ignore this item. */ + tem = menu_item_eval_property (XCAR (item)); + if (NILP (tem)) + return 0; + } + else if (EQ (tem, QChelp)) + ASET (item_properties, ITEM_PROPERTY_HELP, XCAR (item)); + else if (EQ (tem, QCfilter)) + filter = item; + else if (EQ (tem, QCkey_sequence)) + { + tem = XCAR (item); + if (SYMBOLP (tem) || STRINGP (tem) || VECTORP (tem)) + /* Be GC protected. Set keyhint to item instead of tem. */ + keyhint = item; + } + else if (EQ (tem, QCkeys)) + { + tem = XCAR (item); + if (CONSP (tem) || STRINGP (tem)) + ASET (item_properties, ITEM_PROPERTY_KEYEQ, tem); + } + else if (EQ (tem, QCbutton) && CONSP (XCAR (item))) + { + Lisp_Object type; + tem = XCAR (item); + type = XCAR (tem); + if (EQ (type, QCtoggle) || EQ (type, QCradio)) + { + ASET (item_properties, ITEM_PROPERTY_SELECTED, + XCDR (tem)); + ASET (item_properties, ITEM_PROPERTY_TYPE, type); + } + } + item = XCDR (item); + } + } + else if (inmenubar || !NILP (start)) + return 0; + } + else + return 0; /* not a menu item */ + + /* If item string is not a string, evaluate it to get string. + If we don't get a string, skip this item. */ + item_string = AREF (item_properties, ITEM_PROPERTY_NAME); + if (!(STRINGP (item_string))) + { + item_string = menu_item_eval_property (item_string); + if (!STRINGP (item_string)) + return 0; + ASET (item_properties, ITEM_PROPERTY_NAME, item_string); + } + + /* If got a filter apply it on definition. */ + def = AREF (item_properties, ITEM_PROPERTY_DEF); + if (!NILP (filter)) + { + def = menu_item_eval_property (list2 (XCAR (filter), + list2 (Qquote, def))); + + ASET (item_properties, ITEM_PROPERTY_DEF, def); + } + + /* Enable or disable selection of item. */ + tem = AREF (item_properties, ITEM_PROPERTY_ENABLE); + if (!EQ (tem, Qt)) + { + tem = menu_item_eval_property (tem); + if (inmenubar && NILP (tem)) + return 0; /* Ignore disabled items in menu bar. */ + ASET (item_properties, ITEM_PROPERTY_ENABLE, tem); + } + + /* If we got no definition, this item is just unselectable text which + is OK in a submenu but not in the menubar. */ + if (NILP (def)) + return (!inmenubar); + + /* See if this is a separate pane or a submenu. */ + def = AREF (item_properties, ITEM_PROPERTY_DEF); + tem = get_keymap (def, 0, 1); + /* For a subkeymap, just record its details and exit. */ + if (CONSP (tem)) + { + ASET (item_properties, ITEM_PROPERTY_MAP, tem); + ASET (item_properties, ITEM_PROPERTY_DEF, tem); + return 1; + } + + /* At the top level in the menu bar, do likewise for commands also. + The menu bar does not display equivalent key bindings anyway. + ITEM_PROPERTY_DEF is already set up properly. */ + if (inmenubar > 0) + return 1; + + { /* This is a command. See if there is an equivalent key binding. */ + Lisp_Object keyeq = AREF (item_properties, ITEM_PROPERTY_KEYEQ); + AUTO_STRING (space_space, " "); + + /* The previous code preferred :key-sequence to :keys, so we + preserve this behavior. */ + if (STRINGP (keyeq) && !CONSP (keyhint)) + keyeq = concat2 (space_space, Fsubstitute_command_keys (keyeq)); + else + { + Lisp_Object prefix = keyeq; + Lisp_Object keys = Qnil; + + if (CONSP (prefix)) + { + def = XCAR (prefix); + prefix = XCDR (prefix); + } + else + def = AREF (item_properties, ITEM_PROPERTY_DEF); + + if (CONSP (keyhint) && !NILP (XCAR (keyhint))) + { + keys = XCAR (keyhint); + tem = Fkey_binding (keys, Qnil, Qnil, Qnil); + + /* We have a suggested key. Is it bound to the command? */ + if (NILP (tem) + || (!EQ (tem, def) + /* If the command is an alias for another + (such as lmenu.el set it up), check if the + original command matches the cached command. */ + && !(SYMBOLP (def) + && EQ (tem, XSYMBOL (def)->function)))) + keys = Qnil; + } + + if (NILP (keys)) + keys = Fwhere_is_internal (def, Qnil, Qt, Qnil, Qnil); + + if (!NILP (keys)) + { + tem = Fkey_description (keys, Qnil); + if (CONSP (prefix)) + { + if (STRINGP (XCAR (prefix))) + tem = concat2 (XCAR (prefix), tem); + if (STRINGP (XCDR (prefix))) + tem = concat2 (tem, XCDR (prefix)); + } + keyeq = concat2 (space_space, tem); + } + else + keyeq = Qnil; + } + + /* If we have an equivalent key binding, use that. */ + ASET (item_properties, ITEM_PROPERTY_KEYEQ, keyeq); + } + + /* Include this when menu help is implemented. + tem = XVECTOR (item_properties)->contents[ITEM_PROPERTY_HELP]; + if (!(NILP (tem) || STRINGP (tem))) + { + tem = menu_item_eval_property (tem); + if (!STRINGP (tem)) + tem = Qnil; + XVECTOR (item_properties)->contents[ITEM_PROPERTY_HELP] = tem; + } + */ + + /* Handle radio buttons or toggle boxes. */ + tem = AREF (item_properties, ITEM_PROPERTY_SELECTED); + if (!NILP (tem)) + ASET (item_properties, ITEM_PROPERTY_SELECTED, + menu_item_eval_property (tem)); + + return 1; +} + + + +/*********************************************************************** + Tool-bars + ***********************************************************************/ + +/* A vector holding tool bar items while they are parsed in function + tool_bar_items. Each item occupies TOOL_BAR_ITEM_NSCLOTS elements + in the vector. */ + +static Lisp_Object tool_bar_items_vector; + +/* A vector holding the result of parse_tool_bar_item. Layout is like + the one for a single item in tool_bar_items_vector. */ + +static Lisp_Object tool_bar_item_properties; + +/* Next free index in tool_bar_items_vector. */ + +static int ntool_bar_items; + +/* Function prototypes. */ + +static void init_tool_bar_items (Lisp_Object); +static void process_tool_bar_item (Lisp_Object, Lisp_Object, Lisp_Object, + void *); +static bool parse_tool_bar_item (Lisp_Object, Lisp_Object); +static void append_tool_bar_item (void); + + +/* Return a vector of tool bar items for keymaps currently in effect. + Reuse vector REUSE if non-nil. Return in *NITEMS the number of + tool bar items found. */ + +Lisp_Object +tool_bar_items (Lisp_Object reuse, int *nitems) +{ + Lisp_Object *maps; + Lisp_Object mapsbuf[3]; + ptrdiff_t nmaps, i; + Lisp_Object oquit; + Lisp_Object *tmaps; + USE_SAFE_ALLOCA; + + *nitems = 0; + + /* In order to build the menus, we need to call the keymap + accessors. They all call QUIT. But this function is called + during redisplay, during which a quit is fatal. So inhibit + quitting while building the menus. We do this instead of + specbind because (1) errors will clear it anyway and (2) this + avoids risk of specpdl overflow. */ + oquit = Vinhibit_quit; + Vinhibit_quit = Qt; + + /* Initialize tool_bar_items_vector and protect it from GC. */ + init_tool_bar_items (reuse); + + /* Build list of keymaps in maps. Set nmaps to the number of maps + to process. */ + + /* Should overriding-terminal-local-map and overriding-local-map apply? */ + if (!NILP (Voverriding_local_map_menu_flag) + && !NILP (Voverriding_local_map)) + { + /* Yes, use them (if non-nil) as well as the global map. */ + maps = mapsbuf; + nmaps = 0; + if (!NILP (KVAR (current_kboard, Voverriding_terminal_local_map))) + maps[nmaps++] = KVAR (current_kboard, Voverriding_terminal_local_map); + if (!NILP (Voverriding_local_map)) + maps[nmaps++] = Voverriding_local_map; + } + else + { + /* No, so use major and minor mode keymaps and keymap property. + Note that tool-bar bindings in the local-map and keymap + properties may not work reliable, as they are only + recognized when the tool-bar (or mode-line) is updated, + which does not normally happen after every command. */ + Lisp_Object tem; + ptrdiff_t nminor; + nminor = current_minor_maps (NULL, &tmaps); + SAFE_NALLOCA (maps, 1, nminor + 4); + nmaps = 0; + tem = KVAR (current_kboard, Voverriding_terminal_local_map); + if (!NILP (tem) && !NILP (Voverriding_local_map_menu_flag)) + maps[nmaps++] = tem; + if (tem = get_local_map (PT, current_buffer, Qkeymap), !NILP (tem)) + maps[nmaps++] = tem; + memcpy (maps + nmaps, tmaps, nminor * sizeof (maps[0])); + nmaps += nminor; + maps[nmaps++] = get_local_map (PT, current_buffer, Qlocal_map); + } + + /* Add global keymap at the end. */ + maps[nmaps++] = current_global_map; + + /* Process maps in reverse order and look up in each map the prefix + key `tool-bar'. */ + for (i = nmaps - 1; i >= 0; --i) + if (!NILP (maps[i])) + { + Lisp_Object keymap; + + keymap = get_keymap (access_keymap (maps[i], Qtool_bar, 1, 0, 1), 0, 1); + if (CONSP (keymap)) + map_keymap (keymap, process_tool_bar_item, Qnil, NULL, 1); + } + + Vinhibit_quit = oquit; + *nitems = ntool_bar_items / TOOL_BAR_ITEM_NSLOTS; + SAFE_FREE (); + return tool_bar_items_vector; +} + + +/* Process the definition of KEY which is DEF. */ + +static void +process_tool_bar_item (Lisp_Object key, Lisp_Object def, Lisp_Object data, void *args) +{ + int i; + struct gcpro gcpro1, gcpro2; + + /* Protect KEY and DEF from GC because parse_tool_bar_item may call + eval. */ + GCPRO2 (key, def); + + if (EQ (def, Qundefined)) + { + /* If a map has an explicit `undefined' as definition, + discard any previously made item. */ + for (i = 0; i < ntool_bar_items; i += TOOL_BAR_ITEM_NSLOTS) + { + Lisp_Object *v = XVECTOR (tool_bar_items_vector)->contents + i; + + if (EQ (key, v[TOOL_BAR_ITEM_KEY])) + { + if (ntool_bar_items > i + TOOL_BAR_ITEM_NSLOTS) + memmove (v, v + TOOL_BAR_ITEM_NSLOTS, + ((ntool_bar_items - i - TOOL_BAR_ITEM_NSLOTS) + * word_size)); + ntool_bar_items -= TOOL_BAR_ITEM_NSLOTS; + break; + } + } + } + else if (parse_tool_bar_item (key, def)) + /* Append a new tool bar item to tool_bar_items_vector. Accept + more than one definition for the same key. */ + append_tool_bar_item (); + + UNGCPRO; +} + +/* Access slot with index IDX of vector tool_bar_item_properties. */ +#define PROP(IDX) AREF (tool_bar_item_properties, (IDX)) +static void +set_prop (ptrdiff_t idx, Lisp_Object val) +{ + ASET (tool_bar_item_properties, idx, val); +} + + +/* Parse a tool bar item specification ITEM for key KEY and return the + result in tool_bar_item_properties. Value is false if ITEM is + invalid. + + ITEM is a list `(menu-item CAPTION BINDING PROPS...)'. + + CAPTION is the caption of the item, If it's not a string, it is + evaluated to get a string. + + BINDING is the tool bar item's binding. Tool-bar items with keymaps + as binding are currently ignored. + + The following properties are recognized: + + - `:enable FORM'. + + FORM is evaluated and specifies whether the tool bar item is + enabled or disabled. + + - `:visible FORM' + + FORM is evaluated and specifies whether the tool bar item is visible. + + - `:filter FUNCTION' + + FUNCTION is invoked with one parameter `(quote BINDING)'. Its + result is stored as the new binding. + + - `:button (TYPE SELECTED)' + + TYPE must be one of `:radio' or `:toggle'. SELECTED is evaluated + and specifies whether the button is selected (pressed) or not. + + - `:image IMAGES' + + IMAGES is either a single image specification or a vector of four + image specifications. See enum tool_bar_item_images. + + - `:help HELP-STRING'. + + Gives a help string to display for the tool bar item. + + - `:label LABEL-STRING'. + + A text label to show with the tool bar button if labels are enabled. */ + +static bool +parse_tool_bar_item (Lisp_Object key, Lisp_Object item) +{ + Lisp_Object filter = Qnil; + Lisp_Object caption; + int i; + bool have_label = 0; + + /* Definition looks like `(menu-item CAPTION BINDING PROPS...)'. + Rule out items that aren't lists, don't start with + `menu-item' or whose rest following `tool-bar-item' is not a + list. */ + if (!CONSP (item)) + return 0; + + /* As an exception, allow old-style menu separators. */ + if (STRINGP (XCAR (item))) + item = list1 (XCAR (item)); + else if (!EQ (XCAR (item), Qmenu_item) + || (item = XCDR (item), !CONSP (item))) + return 0; + + /* Create tool_bar_item_properties vector if necessary. Reset it to + defaults. */ + if (VECTORP (tool_bar_item_properties)) + { + for (i = 0; i < TOOL_BAR_ITEM_NSLOTS; ++i) + set_prop (i, Qnil); + } + else + tool_bar_item_properties + = Fmake_vector (make_number (TOOL_BAR_ITEM_NSLOTS), Qnil); + + /* Set defaults. */ + set_prop (TOOL_BAR_ITEM_KEY, key); + set_prop (TOOL_BAR_ITEM_ENABLED_P, Qt); + + /* Get the caption of the item. If the caption is not a string, + evaluate it to get a string. If we don't get a string, skip this + item. */ + caption = XCAR (item); + if (!STRINGP (caption)) + { + caption = menu_item_eval_property (caption); + if (!STRINGP (caption)) + return 0; + } + set_prop (TOOL_BAR_ITEM_CAPTION, caption); + + /* If the rest following the caption is not a list, the menu item is + either a separator, or invalid. */ + item = XCDR (item); + if (!CONSP (item)) + { + if (menu_separator_name_p (SSDATA (caption))) + { + set_prop (TOOL_BAR_ITEM_TYPE, Qt); +#if !defined (USE_GTK) && !defined (HAVE_NS) + /* If we use build_desired_tool_bar_string to render the + tool bar, the separator is rendered as an image. */ + set_prop (TOOL_BAR_ITEM_IMAGES, + (menu_item_eval_property + (Vtool_bar_separator_image_expression))); + set_prop (TOOL_BAR_ITEM_ENABLED_P, Qnil); + set_prop (TOOL_BAR_ITEM_SELECTED_P, Qnil); + set_prop (TOOL_BAR_ITEM_CAPTION, Qnil); +#endif + return 1; + } + return 0; + } + + /* Store the binding. */ + set_prop (TOOL_BAR_ITEM_BINDING, XCAR (item)); + item = XCDR (item); + + /* Ignore cached key binding, if any. */ + if (CONSP (item) && CONSP (XCAR (item))) + item = XCDR (item); + + /* Process the rest of the properties. */ + for (; CONSP (item) && CONSP (XCDR (item)); item = XCDR (XCDR (item))) + { + Lisp_Object ikey, value; + + ikey = XCAR (item); + value = XCAR (XCDR (item)); + + if (EQ (ikey, QCenable)) + { + /* `:enable FORM'. */ + if (!NILP (Venable_disabled_menus_and_buttons)) + set_prop (TOOL_BAR_ITEM_ENABLED_P, Qt); + else + set_prop (TOOL_BAR_ITEM_ENABLED_P, value); + } + else if (EQ (ikey, QCvisible)) + { + /* `:visible FORM'. If got a visible property and that + evaluates to nil then ignore this item. */ + if (NILP (menu_item_eval_property (value))) + return 0; + } + else if (EQ (ikey, QChelp)) + /* `:help HELP-STRING'. */ + set_prop (TOOL_BAR_ITEM_HELP, value); + else if (EQ (ikey, QCvert_only)) + /* `:vert-only t/nil'. */ + set_prop (TOOL_BAR_ITEM_VERT_ONLY, value); + else if (EQ (ikey, QClabel)) + { + const char *bad_label = "!!?GARBLED ITEM?!!"; + /* `:label LABEL-STRING'. */ + set_prop (TOOL_BAR_ITEM_LABEL, + STRINGP (value) ? value : build_string (bad_label)); + have_label = 1; + } + else if (EQ (ikey, QCfilter)) + /* ':filter FORM'. */ + filter = value; + else if (EQ (ikey, QCbutton) && CONSP (value)) + { + /* `:button (TYPE . SELECTED)'. */ + Lisp_Object type, selected; + + type = XCAR (value); + selected = XCDR (value); + if (EQ (type, QCtoggle) || EQ (type, QCradio)) + { + set_prop (TOOL_BAR_ITEM_SELECTED_P, selected); + set_prop (TOOL_BAR_ITEM_TYPE, type); + } + } + else if (EQ (ikey, QCimage) + && (CONSP (value) + || (VECTORP (value) && ASIZE (value) == 4))) + /* Value is either a single image specification or a vector + of 4 such specifications for the different button states. */ + set_prop (TOOL_BAR_ITEM_IMAGES, value); + else if (EQ (ikey, QCrtl)) + /* ':rtl STRING' */ + set_prop (TOOL_BAR_ITEM_RTL_IMAGE, value); + } + + + if (!have_label) + { + /* Try to make one from caption and key. */ + Lisp_Object tkey = PROP (TOOL_BAR_ITEM_KEY); + Lisp_Object tcapt = PROP (TOOL_BAR_ITEM_CAPTION); + const char *label = SYMBOLP (tkey) ? SSDATA (SYMBOL_NAME (tkey)) : ""; + const char *capt = STRINGP (tcapt) ? SSDATA (tcapt) : ""; + ptrdiff_t max_lbl = + 2 * max (0, min (tool_bar_max_label_size, STRING_BYTES_BOUND / 2)); + char *buf = xmalloc (max_lbl + 1); + Lisp_Object new_lbl; + ptrdiff_t caption_len = strlen (capt); + + if (caption_len <= max_lbl && capt[0] != '\0') + { + strcpy (buf, capt); + while (caption_len > 0 && buf[caption_len - 1] == '.') + caption_len--; + buf[caption_len] = '\0'; + label = capt = buf; + } + + if (strlen (label) <= max_lbl && label[0] != '\0') + { + ptrdiff_t j; + if (label != buf) + strcpy (buf, label); + + for (j = 0; buf[j] != '\0'; ++j) + if (buf[j] == '-') + buf[j] = ' '; + label = buf; + } + else + label = ""; + + new_lbl = Fupcase_initials (build_string (label)); + if (SCHARS (new_lbl) <= tool_bar_max_label_size) + set_prop (TOOL_BAR_ITEM_LABEL, new_lbl); + else + set_prop (TOOL_BAR_ITEM_LABEL, empty_unibyte_string); + xfree (buf); + } + + /* If got a filter apply it on binding. */ + if (!NILP (filter)) + set_prop (TOOL_BAR_ITEM_BINDING, + (menu_item_eval_property + (list2 (filter, + list2 (Qquote, + PROP (TOOL_BAR_ITEM_BINDING)))))); + + /* See if the binding is a keymap. Give up if it is. */ + if (CONSP (get_keymap (PROP (TOOL_BAR_ITEM_BINDING), 0, 1))) + return 0; + + /* Enable or disable selection of item. */ + if (!EQ (PROP (TOOL_BAR_ITEM_ENABLED_P), Qt)) + set_prop (TOOL_BAR_ITEM_ENABLED_P, + menu_item_eval_property (PROP (TOOL_BAR_ITEM_ENABLED_P))); + + /* Handle radio buttons or toggle boxes. */ + if (!NILP (PROP (TOOL_BAR_ITEM_SELECTED_P))) + set_prop (TOOL_BAR_ITEM_SELECTED_P, + menu_item_eval_property (PROP (TOOL_BAR_ITEM_SELECTED_P))); + + return 1; + +#undef PROP +} + + +/* Initialize tool_bar_items_vector. REUSE, if non-nil, is a vector + that can be reused. */ + +static void +init_tool_bar_items (Lisp_Object reuse) +{ + if (VECTORP (reuse)) + tool_bar_items_vector = reuse; + else + tool_bar_items_vector = Fmake_vector (make_number (64), Qnil); + ntool_bar_items = 0; +} + + +/* Append parsed tool bar item properties from + tool_bar_item_properties */ + +static void +append_tool_bar_item (void) +{ + ptrdiff_t incr + = (ntool_bar_items + - (ASIZE (tool_bar_items_vector) - TOOL_BAR_ITEM_NSLOTS)); + + /* Enlarge tool_bar_items_vector if necessary. */ + if (incr > 0) + tool_bar_items_vector = larger_vector (tool_bar_items_vector, incr, -1); + + /* Append entries from tool_bar_item_properties to the end of + tool_bar_items_vector. */ + vcopy (tool_bar_items_vector, ntool_bar_items, + XVECTOR (tool_bar_item_properties)->contents, TOOL_BAR_ITEM_NSLOTS); + ntool_bar_items += TOOL_BAR_ITEM_NSLOTS; +} + + + + + +/* Read a character using menus based on the keymap MAP. + Return nil if there are no menus in the maps. + Return t if we displayed a menu but the user rejected it. + + PREV_EVENT is the previous input event, or nil if we are reading + the first event of a key sequence. + + If USED_MOUSE_MENU is non-null, set *USED_MOUSE_MENU to true + if we used a mouse menu to read the input, or false otherwise. If + USED_MOUSE_MENU is null, don't dereference it. + + The prompting is done based on the prompt-string of the map + and the strings associated with various map elements. + + This can be done with X menus or with menus put in the minibuf. + These are done in different ways, depending on how the input will be read. + Menus using X are done after auto-saving in read-char, getting the input + event from Fx_popup_menu; menus using the minibuf use read_char recursively + and do auto-saving in the inner call of read_char. */ + +static Lisp_Object +read_char_x_menu_prompt (Lisp_Object map, + Lisp_Object prev_event, bool *used_mouse_menu) +{ + if (used_mouse_menu) + *used_mouse_menu = 0; + + /* Use local over global Menu maps. */ + + if (! menu_prompting) + return Qnil; + + /* If we got to this point via a mouse click, + use a real menu for mouse selection. */ + if (EVENT_HAS_PARAMETERS (prev_event) + && !EQ (XCAR (prev_event), Qmenu_bar) + && !EQ (XCAR (prev_event), Qtool_bar)) + { + /* Display the menu and get the selection. */ + Lisp_Object value; + + value = Fx_popup_menu (prev_event, get_keymap (map, 0, 1)); + if (CONSP (value)) + { + Lisp_Object tem; + + record_menu_key (XCAR (value)); + + /* If we got multiple events, unread all but + the first. + There is no way to prevent those unread events + from showing up later in last_nonmenu_event. + So turn symbol and integer events into lists, + to indicate that they came from a mouse menu, + so that when present in last_nonmenu_event + they won't confuse things. */ + for (tem = XCDR (value); CONSP (tem); tem = XCDR (tem)) + { + record_menu_key (XCAR (tem)); + if (SYMBOLP (XCAR (tem)) + || INTEGERP (XCAR (tem))) + XSETCAR (tem, Fcons (XCAR (tem), Qdisabled)); + } + + /* If we got more than one event, put all but the first + onto this list to be read later. + Return just the first event now. */ + Vunread_command_events + = nconc2 (XCDR (value), Vunread_command_events); + value = XCAR (value); + } + else if (NILP (value)) + value = Qt; + if (used_mouse_menu) + *used_mouse_menu = 1; + return value; + } + return Qnil ; +} + +static Lisp_Object +read_char_minibuf_menu_prompt (int commandflag, + Lisp_Object map) +{ + Lisp_Object name; + ptrdiff_t nlength; + /* FIXME: Use the minibuffer's frame width. */ + ptrdiff_t width = FRAME_COLS (SELECTED_FRAME ()) - 4; + ptrdiff_t idx = -1; + bool nobindings = 1; + Lisp_Object rest, vector; + Lisp_Object prompt_strings = Qnil; + + vector = Qnil; + + if (! menu_prompting) + return Qnil; + + map = get_keymap (map, 0, 1); + name = Fkeymap_prompt (map); + + /* If we don't have any menus, just read a character normally. */ + if (!STRINGP (name)) + return Qnil; + +#define PUSH_C_STR(str, listvar) \ + listvar = Fcons (build_unibyte_string (str), listvar) + + /* Prompt string always starts with map's prompt, and a space. */ + prompt_strings = Fcons (name, prompt_strings); + PUSH_C_STR (": ", prompt_strings); + nlength = SCHARS (name) + 2; + + rest = map; + + /* Present the documented bindings, a line at a time. */ + while (1) + { + bool notfirst = 0; + Lisp_Object menu_strings = prompt_strings; + ptrdiff_t i = nlength; + Lisp_Object obj; + Lisp_Object orig_defn_macro; + + /* Loop over elements of map. */ + while (i < width) + { + Lisp_Object elt; + + /* FIXME: Use map_keymap to handle new keymap formats. */ + + /* At end of map, wrap around if just starting, + or end this line if already have something on it. */ + if (NILP (rest)) + { + if (notfirst || nobindings) + break; + else + rest = map; + } + + /* Look at the next element of the map. */ + if (idx >= 0) + elt = AREF (vector, idx); + else + elt = Fcar_safe (rest); + + if (idx < 0 && VECTORP (elt)) + { + /* If we found a dense table in the keymap, + advanced past it, but start scanning its contents. */ + rest = Fcdr_safe (rest); + vector = elt; + idx = 0; + } + else + { + /* An ordinary element. */ + Lisp_Object event, tem; + + if (idx < 0) + { + event = Fcar_safe (elt); /* alist */ + elt = Fcdr_safe (elt); + } + else + { + XSETINT (event, idx); /* vector */ + } + + /* Ignore the element if it has no prompt string. */ + if (INTEGERP (event) && parse_menu_item (elt, -1)) + { + /* True if the char to type matches the string. */ + bool char_matches; + Lisp_Object upcased_event, downcased_event; + Lisp_Object desc = Qnil; + Lisp_Object s + = AREF (item_properties, ITEM_PROPERTY_NAME); + + upcased_event = Fupcase (event); + downcased_event = Fdowncase (event); + char_matches = (XINT (upcased_event) == SREF (s, 0) + || XINT (downcased_event) == SREF (s, 0)); + if (! char_matches) + desc = Fsingle_key_description (event, Qnil); + +#if 0 /* It is redundant to list the equivalent key bindings because + the prefix is what the user has already typed. */ + tem + = XVECTOR (item_properties)->contents[ITEM_PROPERTY_KEYEQ]; + if (!NILP (tem)) + /* Insert equivalent keybinding. */ + s = concat2 (s, tem); +#endif + tem + = AREF (item_properties, ITEM_PROPERTY_TYPE); + if (EQ (tem, QCradio) || EQ (tem, QCtoggle)) + { + /* Insert button prefix. */ + Lisp_Object selected + = AREF (item_properties, ITEM_PROPERTY_SELECTED); + AUTO_STRING (radio_yes, "(*) "); + AUTO_STRING (radio_no , "( ) "); + AUTO_STRING (check_yes, "[X] "); + AUTO_STRING (check_no , "[ ] "); + if (EQ (tem, QCradio)) + tem = NILP (selected) ? radio_yes : radio_no; + else + tem = NILP (selected) ? check_yes : check_no; + s = concat2 (tem, s); + } + + + /* If we have room for the prompt string, add it to this line. + If this is the first on the line, always add it. */ + if ((SCHARS (s) + i + 2 + + (char_matches ? 0 : SCHARS (desc) + 3)) + < width + || !notfirst) + { + ptrdiff_t thiswidth; + + /* Punctuate between strings. */ + if (notfirst) + { + PUSH_C_STR (", ", menu_strings); + i += 2; + } + notfirst = 1; + nobindings = 0; + + /* If the char to type doesn't match the string's + first char, explicitly show what char to type. */ + if (! char_matches) + { + /* Add as much of string as fits. */ + thiswidth = min (SCHARS (desc), width - i); + menu_strings + = Fcons (Fsubstring (desc, make_number (0), + make_number (thiswidth)), + menu_strings); + i += thiswidth; + PUSH_C_STR (" = ", menu_strings); + i += 3; + } + + /* Add as much of string as fits. */ + thiswidth = min (SCHARS (s), width - i); + menu_strings + = Fcons (Fsubstring (s, make_number (0), + make_number (thiswidth)), + menu_strings); + i += thiswidth; + } + else + { + /* If this element does not fit, end the line now, + and save the element for the next line. */ + PUSH_C_STR ("...", menu_strings); + break; + } + } + + /* Move past this element. */ + if (idx >= 0 && idx + 1 >= ASIZE (vector)) + /* Handle reaching end of dense table. */ + idx = -1; + if (idx >= 0) + idx++; + else + rest = Fcdr_safe (rest); + } + } + + /* Prompt with that and read response. */ + message3_nolog (apply1 (intern ("concat"), Fnreverse (menu_strings))); + + /* Make believe it's not a keyboard macro in case the help char + is pressed. Help characters are not recorded because menu prompting + is not used on replay. */ + orig_defn_macro = KVAR (current_kboard, defining_kbd_macro); + kset_defining_kbd_macro (current_kboard, Qnil); + do + obj = read_char (commandflag, Qnil, Qt, 0, NULL); + while (BUFFERP (obj)); + kset_defining_kbd_macro (current_kboard, orig_defn_macro); + + if (!INTEGERP (obj) || XINT (obj) == -2 + || (! EQ (obj, menu_prompt_more_char) + && (!INTEGERP (menu_prompt_more_char) + || ! EQ (obj, make_number (Ctl (XINT (menu_prompt_more_char))))))) + { + if (!NILP (KVAR (current_kboard, defining_kbd_macro))) + store_kbd_macro_char (obj); + return obj; + } + /* Help char - go round again. */ + } +} + +/* Reading key sequences. */ + +static Lisp_Object +follow_key (Lisp_Object keymap, Lisp_Object key) +{ + return access_keymap (get_keymap (keymap, 0, 1), + key, 1, 0, 1); +} + +static Lisp_Object +active_maps (Lisp_Object first_event) +{ + Lisp_Object position + = CONSP (first_event) ? CAR_SAFE (XCDR (first_event)) : Qnil; + return Fcons (Qkeymap, Fcurrent_active_maps (Qt, position)); +} + +/* Structure used to keep track of partial application of key remapping + such as Vfunction_key_map and Vkey_translation_map. */ +typedef struct keyremap +{ + /* This is the map originally specified for this use. */ + Lisp_Object parent; + /* This is a submap reached by looking up, in PARENT, + the events from START to END. */ + Lisp_Object map; + /* Positions [START, END) in the key sequence buffer + are the key that we have scanned so far. + Those events are the ones that we will replace + if PARENT maps them into a key sequence. */ + int start, end; +} keyremap; + +/* Lookup KEY in MAP. + MAP is a keymap mapping keys to key vectors or functions. + If the mapping is a function and DO_FUNCALL is true, + the function is called with PROMPT as parameter and its return + value is used as the return value of this function (after checking + that it is indeed a vector). */ + +static Lisp_Object +access_keymap_keyremap (Lisp_Object map, Lisp_Object key, Lisp_Object prompt, + bool do_funcall) +{ + Lisp_Object next; + + next = access_keymap (map, key, 1, 0, 1); + + /* Handle a symbol whose function definition is a keymap + or an array. */ + if (SYMBOLP (next) && !NILP (Ffboundp (next)) + && (ARRAYP (XSYMBOL (next)->function) + || KEYMAPP (XSYMBOL (next)->function))) + next = Fautoload_do_load (XSYMBOL (next)->function, next, Qnil); + + /* If the keymap gives a function, not an + array, then call the function with one arg and use + its value instead. */ + if (do_funcall && FUNCTIONP (next)) + { + Lisp_Object tem; + tem = next; + + next = call1 (next, prompt); + /* If the function returned something invalid, + barf--don't ignore it. + (To ignore it safely, we would need to gcpro a bunch of + other variables.) */ + if (! (NILP (next) || VECTORP (next) || STRINGP (next))) + error ("Function %s returns invalid key sequence", + SSDATA (SYMBOL_NAME (tem))); + } + return next; +} + +/* Do one step of the key remapping used for function-key-map and + key-translation-map: + KEYBUF is the buffer holding the input events. + BUFSIZE is its maximum size. + FKEY is a pointer to the keyremap structure to use. + INPUT is the index of the last element in KEYBUF. + DOIT if true says that the remapping can actually take place. + DIFF is used to return the number of keys added/removed by the remapping. + PARENT is the root of the keymap. + PROMPT is the prompt to use if the remapping happens through a function. + Return true if the remapping actually took place. */ + +static bool +keyremap_step (Lisp_Object *keybuf, int bufsize, volatile keyremap *fkey, + int input, bool doit, int *diff, Lisp_Object prompt) +{ + Lisp_Object next, key; + + key = keybuf[fkey->end++]; + + if (KEYMAPP (fkey->parent)) + next = access_keymap_keyremap (fkey->map, key, prompt, doit); + else + next = Qnil; + + /* If keybuf[fkey->start..fkey->end] is bound in the + map and we're in a position to do the key remapping, replace it with + the binding and restart with fkey->start at the end. */ + if ((VECTORP (next) || STRINGP (next)) && doit) + { + int len = XFASTINT (Flength (next)); + int i; + + *diff = len - (fkey->end - fkey->start); + + if (bufsize - input <= *diff) + error ("Key sequence too long"); + + /* Shift the keys that follow fkey->end. */ + if (*diff < 0) + for (i = fkey->end; i < input; i++) + keybuf[i + *diff] = keybuf[i]; + else if (*diff > 0) + for (i = input - 1; i >= fkey->end; i--) + keybuf[i + *diff] = keybuf[i]; + /* Overwrite the old keys with the new ones. */ + for (i = 0; i < len; i++) + keybuf[fkey->start + i] + = Faref (next, make_number (i)); + + fkey->start = fkey->end += *diff; + fkey->map = fkey->parent; + + return 1; + } + + fkey->map = get_keymap (next, 0, 1); + + /* If we no longer have a bound suffix, try a new position for + fkey->start. */ + if (!CONSP (fkey->map)) + { + fkey->end = ++fkey->start; + fkey->map = fkey->parent; + } + return 0; +} + +static bool +test_undefined (Lisp_Object binding) +{ + return (NILP (binding) + || EQ (binding, Qundefined) + || (SYMBOLP (binding) + && EQ (Fcommand_remapping (binding, Qnil, Qnil), Qundefined))); +} + +/* Read a sequence of keys that ends with a non prefix character, + storing it in KEYBUF, a buffer of size BUFSIZE. + Prompt with PROMPT. + Return the length of the key sequence stored. + Return -1 if the user rejected a command menu. + + Echo starting immediately unless `prompt' is 0. + + If PREVENT_REDISPLAY is non-zero, avoid redisplay by calling + read_char with a suitable COMMANDFLAG argument. + + Where a key sequence ends depends on the currently active keymaps. + These include any minor mode keymaps active in the current buffer, + the current buffer's local map, and the global map. + + If a key sequence has no other bindings, we check Vfunction_key_map + to see if some trailing subsequence might be the beginning of a + function key's sequence. If so, we try to read the whole function + key, and substitute its symbolic name into the key sequence. + + We ignore unbound `down-' mouse clicks. We turn unbound `drag-' and + `double-' events into similar click events, if that would make them + bound. We try to turn `triple-' events first into `double-' events, + then into clicks. + + If we get a mouse click in a mode line, vertical divider, or other + non-text area, we treat the click as if it were prefixed by the + symbol denoting that area - `mode-line', `vertical-line', or + whatever. + + If the sequence starts with a mouse click, we read the key sequence + with respect to the buffer clicked on, not the current buffer. + + If the user switches frames in the midst of a key sequence, we put + off the switch-frame event until later; the next call to + read_char will return it. + + If FIX_CURRENT_BUFFER, we restore current_buffer + from the selected window's buffer. */ + +static int +read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, + bool dont_downcase_last, bool can_return_switch_frame, + bool fix_current_buffer, bool prevent_redisplay) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + /* How many keys there are in the current key sequence. */ + int t; + + /* The length of the echo buffer when we started reading, and + the length of this_command_keys when we started reading. */ + ptrdiff_t echo_start IF_LINT (= 0); + ptrdiff_t keys_start; + + Lisp_Object current_binding = Qnil; + Lisp_Object first_event = Qnil; + + /* Index of the first key that has no binding. + It is useless to try fkey.start larger than that. */ + int first_unbound; + + /* If t < mock_input, then KEYBUF[t] should be read as the next + input key. + + We use this to recover after recognizing a function key. Once we + realize that a suffix of the current key sequence is actually a + function key's escape sequence, we replace the suffix with the + function key's binding from Vfunction_key_map. Now keybuf + contains a new and different key sequence, so the echo area, + this_command_keys, and the submaps and defs arrays are wrong. In + this situation, we set mock_input to t, set t to 0, and jump to + restart_sequence; the loop will read keys from keybuf up until + mock_input, thus rebuilding the state; and then it will resume + reading characters from the keyboard. */ + int mock_input = 0; + + /* If the sequence is unbound in submaps[], then + keybuf[fkey.start..fkey.end-1] is a prefix in Vfunction_key_map, + and fkey.map is its binding. + + These might be > t, indicating that all function key scanning + should hold off until t reaches them. We do this when we've just + recognized a function key, to avoid searching for the function + key's again in Vfunction_key_map. */ + keyremap fkey; + + /* Likewise, for key_translation_map and input-decode-map. */ + keyremap keytran, indec; + + /* True if we are trying to map a key by changing an upper-case + letter to lower case, or a shifted function key to an unshifted + one. */ + bool shift_translated = 0; + + /* If we receive a `switch-frame' or `select-window' event in the middle of + a key sequence, we put it off for later. + While we're reading, we keep the event here. */ + Lisp_Object delayed_switch_frame; + + Lisp_Object original_uppercase IF_LINT (= Qnil); + int original_uppercase_position = -1; + + /* Gets around Microsoft compiler limitations. */ + bool dummyflag = 0; + + struct buffer *starting_buffer; + + /* List of events for which a fake prefix key has been generated. */ + Lisp_Object fake_prefixed_keys = Qnil; + + struct gcpro gcpro1; + + GCPRO1 (fake_prefixed_keys); + raw_keybuf_count = 0; + + last_nonmenu_event = Qnil; + + delayed_switch_frame = Qnil; + + if (INTERACTIVE) + { + if (!NILP (prompt)) + { + /* Install the string PROMPT as the beginning of the string + of echoing, so that it serves as a prompt for the next + character. */ + kset_echo_string (current_kboard, prompt); + current_kboard->echo_after_prompt = SCHARS (prompt); + echo_now (); + } + else if (cursor_in_echo_area + && echo_keystrokes_p ()) + /* This doesn't put in a dash if the echo buffer is empty, so + you don't always see a dash hanging out in the minibuffer. */ + echo_dash (); + } + + /* Record the initial state of the echo area and this_command_keys; + we will need to restore them if we replay a key sequence. */ + if (INTERACTIVE) + echo_start = echo_length (); + keys_start = this_command_key_count; + this_single_command_key_start = keys_start; + + /* We jump here when we need to reinitialize fkey and keytran; this + happens if we switch keyboards between rescans. */ + replay_entire_sequence: + + indec.map = indec.parent = KVAR (current_kboard, Vinput_decode_map); + fkey.map = fkey.parent = KVAR (current_kboard, Vlocal_function_key_map); + keytran.map = keytran.parent = Vkey_translation_map; + indec.start = indec.end = 0; + fkey.start = fkey.end = 0; + keytran.start = keytran.end = 0; + + /* We jump here when the key sequence has been thoroughly changed, and + we need to rescan it starting from the beginning. When we jump here, + keybuf[0..mock_input] holds the sequence we should reread. */ + replay_sequence: + + starting_buffer = current_buffer; + first_unbound = bufsize + 1; + + /* Build our list of keymaps. + If we recognize a function key and replace its escape sequence in + keybuf with its symbol, or if the sequence starts with a mouse + click and we need to switch buffers, we jump back here to rebuild + the initial keymaps from the current buffer. */ + current_binding = active_maps (first_event); + + /* Start from the beginning in keybuf. */ + t = 0; + + /* These are no-ops the first time through, but if we restart, they + revert the echo area and this_command_keys to their original state. */ + this_command_key_count = keys_start; + if (INTERACTIVE && t < mock_input) + echo_truncate (echo_start); + + /* If the best binding for the current key sequence is a keymap, or + we may be looking at a function key's escape sequence, keep on + reading. */ + while (!NILP (current_binding) + /* Keep reading as long as there's a prefix binding. */ + ? KEYMAPP (current_binding) + /* Don't return in the middle of a possible function key sequence, + if the only bindings we found were via case conversion. + Thus, if ESC O a has a function-key-map translation + and ESC o has a binding, don't return after ESC O, + so that we can translate ESC O plus the next character. */ + : (/* indec.start < t || fkey.start < t || */ keytran.start < t)) + { + Lisp_Object key; + bool used_mouse_menu = 0; + + /* Where the last real key started. If we need to throw away a + key that has expanded into more than one element of keybuf + (say, a mouse click on the mode line which is being treated + as [mode-line (mouse-...)], then we backtrack to this point + of keybuf. */ + int last_real_key_start; + + /* These variables are analogous to echo_start and keys_start; + while those allow us to restart the entire key sequence, + echo_local_start and keys_local_start allow us to throw away + just one key. */ + ptrdiff_t echo_local_start IF_LINT (= 0); + int keys_local_start; + Lisp_Object new_binding; + + eassert (indec.end == t || (indec.end > t && indec.end <= mock_input)); + eassert (indec.start <= indec.end); + eassert (fkey.start <= fkey.end); + eassert (keytran.start <= keytran.end); + /* key-translation-map is applied *after* function-key-map + which is itself applied *after* input-decode-map. */ + eassert (fkey.end <= indec.start); + eassert (keytran.end <= fkey.start); + + if (/* first_unbound < indec.start && first_unbound < fkey.start && */ + first_unbound < keytran.start) + { /* The prefix upto first_unbound has no binding and has + no translation left to do either, so we know it's unbound. + If we don't stop now, we risk staying here indefinitely + (if the user keeps entering fkey or keytran prefixes + like C-c ESC ESC ESC ESC ...) */ + int i; + for (i = first_unbound + 1; i < t; i++) + keybuf[i - first_unbound - 1] = keybuf[i]; + mock_input = t - first_unbound - 1; + indec.end = indec.start -= first_unbound + 1; + indec.map = indec.parent; + fkey.end = fkey.start -= first_unbound + 1; + fkey.map = fkey.parent; + keytran.end = keytran.start -= first_unbound + 1; + keytran.map = keytran.parent; + goto replay_sequence; + } + + if (t >= bufsize) + error ("Key sequence too long"); + + if (INTERACTIVE) + echo_local_start = echo_length (); + keys_local_start = this_command_key_count; + + replay_key: + /* These are no-ops, unless we throw away a keystroke below and + jumped back up to replay_key; in that case, these restore the + variables to their original state, allowing us to replay the + loop. */ + if (INTERACTIVE && t < mock_input) + echo_truncate (echo_local_start); + this_command_key_count = keys_local_start; + + /* By default, assume each event is "real". */ + last_real_key_start = t; + + /* Does mock_input indicate that we are re-reading a key sequence? */ + if (t < mock_input) + { + key = keybuf[t]; + add_command_key (key); + if (echo_keystrokes_p () + && current_kboard->immediate_echo) + { + echo_add_key (key); + echo_dash (); + } + } + + /* If not, we should actually read a character. */ + else + { + { + KBOARD *interrupted_kboard = current_kboard; + struct frame *interrupted_frame = SELECTED_FRAME (); + /* Calling read_char with COMMANDFLAG = -2 avoids + redisplay in read_char and its subroutines. */ + key = read_char (prevent_redisplay ? -2 : NILP (prompt), + current_binding, last_nonmenu_event, + &used_mouse_menu, NULL); + if ((INTEGERP (key) && XINT (key) == -2) /* wrong_kboard_jmpbuf */ + /* When switching to a new tty (with a new keyboard), + read_char returns the new buffer, rather than -2 + (Bug#5095). This is because `terminal-init-xterm' + calls read-char, which eats the wrong_kboard_jmpbuf + return. Any better way to fix this? -- cyd */ + || (interrupted_kboard != current_kboard)) + { + bool found = 0; + struct kboard *k; + + for (k = all_kboards; k; k = k->next_kboard) + if (k == interrupted_kboard) + found = 1; + + if (!found) + { + /* Don't touch interrupted_kboard when it's been + deleted. */ + delayed_switch_frame = Qnil; + goto replay_entire_sequence; + } + + if (!NILP (delayed_switch_frame)) + { + kset_kbd_queue + (interrupted_kboard, + Fcons (delayed_switch_frame, + KVAR (interrupted_kboard, kbd_queue))); + delayed_switch_frame = Qnil; + } + + while (t > 0) + kset_kbd_queue + (interrupted_kboard, + Fcons (keybuf[--t], KVAR (interrupted_kboard, kbd_queue))); + + /* If the side queue is non-empty, ensure it begins with a + switch-frame, so we'll replay it in the right context. */ + if (CONSP (KVAR (interrupted_kboard, kbd_queue)) + && (key = XCAR (KVAR (interrupted_kboard, kbd_queue)), + !(EVENT_HAS_PARAMETERS (key) + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (key)), + Qswitch_frame)))) + { + Lisp_Object frame; + XSETFRAME (frame, interrupted_frame); + kset_kbd_queue + (interrupted_kboard, + Fcons (make_lispy_switch_frame (frame), + KVAR (interrupted_kboard, kbd_queue))); + } + mock_input = 0; + goto replay_entire_sequence; + } + } + + /* read_char returns t when it shows a menu and the user rejects it. + Just return -1. */ + if (EQ (key, Qt)) + { + unbind_to (count, Qnil); + UNGCPRO; + return -1; + } + + /* read_char returns -1 at the end of a macro. + Emacs 18 handles this by returning immediately with a + zero, so that's what we'll do. */ + if (INTEGERP (key) && XINT (key) == -1) + { + t = 0; + /* The Microsoft C compiler can't handle the goto that + would go here. */ + dummyflag = 1; + break; + } + + /* If the current buffer has been changed from under us, the + keymap may have changed, so replay the sequence. */ + if (BUFFERP (key)) + { + timer_resume_idle (); + + mock_input = t; + /* Reset the current buffer from the selected window + in case something changed the former and not the latter. + This is to be more consistent with the behavior + of the command_loop_1. */ + if (fix_current_buffer) + { + if (! FRAME_LIVE_P (XFRAME (selected_frame))) + Fkill_emacs (Qnil); + if (XBUFFER (XWINDOW (selected_window)->contents) + != current_buffer) + Fset_buffer (XWINDOW (selected_window)->contents); + } + + goto replay_sequence; + } + + /* If we have a quit that was typed in another frame, and + quit_throw_to_read_char switched buffers, + replay to get the right keymap. */ + if (INTEGERP (key) + && XINT (key) == quit_char + && current_buffer != starting_buffer) + { + GROW_RAW_KEYBUF; + ASET (raw_keybuf, raw_keybuf_count, key); + raw_keybuf_count++; + keybuf[t++] = key; + mock_input = t; + Vquit_flag = Qnil; + goto replay_sequence; + } + + Vquit_flag = Qnil; + + if (EVENT_HAS_PARAMETERS (key) + /* Either a `switch-frame' or a `select-window' event. */ + && EQ (EVENT_HEAD_KIND (EVENT_HEAD (key)), Qswitch_frame)) + { + /* If we're at the beginning of a key sequence, and the caller + says it's okay, go ahead and return this event. If we're + in the midst of a key sequence, delay it until the end. */ + if (t > 0 || !can_return_switch_frame) + { + delayed_switch_frame = key; + goto replay_key; + } + } + + if (NILP (first_event)) + { + first_event = key; + /* Even if first_event does not specify a particular + window/position, it's important to recompute the maps here + since a long time might have passed since we entered + read_key_sequence, and a timer (or process-filter or + special-event-map, ...) might have switched the current buffer + or the selected window from under us in the mean time. */ + if (fix_current_buffer + && (XBUFFER (XWINDOW (selected_window)->contents) + != current_buffer)) + Fset_buffer (XWINDOW (selected_window)->contents); + current_binding = active_maps (first_event); + } + + GROW_RAW_KEYBUF; + ASET (raw_keybuf, raw_keybuf_count, key); + raw_keybuf_count++; + } + + /* Clicks in non-text areas get prefixed by the symbol + in their CHAR-ADDRESS field. For example, a click on + the mode line is prefixed by the symbol `mode-line'. + + Furthermore, key sequences beginning with mouse clicks + are read using the keymaps of the buffer clicked on, not + the current buffer. So we may have to switch the buffer + here. + + When we turn one event into two events, we must make sure + that neither of the two looks like the original--so that, + if we replay the events, they won't be expanded again. + If not for this, such reexpansion could happen either here + or when user programs play with this-command-keys. */ + if (EVENT_HAS_PARAMETERS (key)) + { + Lisp_Object kind = EVENT_HEAD_KIND (EVENT_HEAD (key)); + if (EQ (kind, Qmouse_click)) + { + Lisp_Object window = POSN_WINDOW (EVENT_START (key)); + Lisp_Object posn = POSN_POSN (EVENT_START (key)); + + if (CONSP (posn) + || (!NILP (fake_prefixed_keys) + && !NILP (Fmemq (key, fake_prefixed_keys)))) + { + /* We're looking a second time at an event for which + we generated a fake prefix key. Set + last_real_key_start appropriately. */ + if (t > 0) + last_real_key_start = t - 1; + } + + if (last_real_key_start == 0) + { + /* Key sequences beginning with mouse clicks are + read using the keymaps in the buffer clicked on, + not the current buffer. If we're at the + beginning of a key sequence, switch buffers. */ + if (WINDOWP (window) + && BUFFERP (XWINDOW (window)->contents) + && XBUFFER (XWINDOW (window)->contents) != current_buffer) + { + ASET (raw_keybuf, raw_keybuf_count, key); + raw_keybuf_count++; + keybuf[t] = key; + mock_input = t + 1; + + /* Arrange to go back to the original buffer once we're + done reading the key sequence. Note that we can't + use save_excursion_{save,restore} here, because they + save point as well as the current buffer; we don't + want to save point, because redisplay may change it, + to accommodate a Fset_window_start or something. We + don't want to do this at the top of the function, + because we may get input from a subprocess which + wants to change the selected window and stuff (say, + emacsclient). */ + record_unwind_current_buffer (); + + if (! FRAME_LIVE_P (XFRAME (selected_frame))) + Fkill_emacs (Qnil); + set_buffer_internal (XBUFFER (XWINDOW (window)->contents)); + goto replay_sequence; + } + } + + /* Expand mode-line and scroll-bar events into two events: + use posn as a fake prefix key. */ + if (SYMBOLP (posn) + && (NILP (fake_prefixed_keys) + || NILP (Fmemq (key, fake_prefixed_keys)))) + { + if (bufsize - t <= 1) + error ("Key sequence too long"); + + keybuf[t] = posn; + keybuf[t + 1] = key; + mock_input = t + 2; + + /* Record that a fake prefix key has been generated + for KEY. Don't modify the event; this would + prevent proper action when the event is pushed + back into unread-command-events. */ + fake_prefixed_keys = Fcons (key, fake_prefixed_keys); + goto replay_key; + } + } + else if (CONSP (XCDR (key)) + && CONSP (EVENT_START (key)) + && CONSP (XCDR (EVENT_START (key)))) + { + Lisp_Object posn; + + posn = POSN_POSN (EVENT_START (key)); + /* Handle menu-bar events: + insert the dummy prefix event `menu-bar'. */ + if (EQ (posn, Qmenu_bar) || EQ (posn, Qtool_bar)) + { + if (bufsize - t <= 1) + error ("Key sequence too long"); + keybuf[t] = posn; + keybuf[t + 1] = key; + + /* Zap the position in key, so we know that we've + expanded it, and don't try to do so again. */ + POSN_SET_POSN (EVENT_START (key), list1 (posn)); + + mock_input = t + 2; + goto replay_sequence; + } + else if (CONSP (posn)) + { + /* We're looking at the second event of a + sequence which we expanded before. Set + last_real_key_start appropriately. */ + if (last_real_key_start == t && t > 0) + last_real_key_start = t - 1; + } + } + } + + /* We have finally decided that KEY is something we might want + to look up. */ + new_binding = follow_key (current_binding, key); + + /* If KEY wasn't bound, we'll try some fallbacks. */ + if (!NILP (new_binding)) + /* This is needed for the following scenario: + event 0: a down-event that gets dropped by calling replay_key. + event 1: some normal prefix like C-h. + After event 0, first_unbound is 0, after event 1 indec.start, + fkey.start, and keytran.start are all 1, so when we see that + C-h is bound, we need to update first_unbound. */ + first_unbound = max (t + 1, first_unbound); + else + { + Lisp_Object head; + + /* Remember the position to put an upper bound on indec.start. */ + first_unbound = min (t, first_unbound); + + head = EVENT_HEAD (key); + + if (SYMBOLP (head)) + { + Lisp_Object breakdown; + int modifiers; + + breakdown = parse_modifiers (head); + modifiers = XINT (XCAR (XCDR (breakdown))); + /* Attempt to reduce an unbound mouse event to a simpler + event that is bound: + Drags reduce to clicks. + Double-clicks reduce to clicks. + Triple-clicks reduce to double-clicks, then to clicks. + Down-clicks are eliminated. + Double-downs reduce to downs, then are eliminated. + Triple-downs reduce to double-downs, then to downs, + then are eliminated. */ + if (modifiers & (down_modifier | drag_modifier + | double_modifier | triple_modifier)) + { + while (modifiers & (down_modifier | drag_modifier + | double_modifier | triple_modifier)) + { + Lisp_Object new_head, new_click; + if (modifiers & triple_modifier) + modifiers ^= (double_modifier | triple_modifier); + else if (modifiers & double_modifier) + modifiers &= ~double_modifier; + else if (modifiers & drag_modifier) + modifiers &= ~drag_modifier; + else + { + /* Dispose of this `down' event by simply jumping + back to replay_key, to get another event. + + Note that if this event came from mock input, + then just jumping back to replay_key will just + hand it to us again. So we have to wipe out any + mock input. + + We could delete keybuf[t] and shift everything + after that to the left by one spot, but we'd also + have to fix up any variable that points into + keybuf, and shifting isn't really necessary + anyway. + + Adding prefixes for non-textual mouse clicks + creates two characters of mock input, and both + must be thrown away. If we're only looking at + the prefix now, we can just jump back to + replay_key. On the other hand, if we've already + processed the prefix, and now the actual click + itself is giving us trouble, then we've lost the + state of the keymaps we want to backtrack to, and + we need to replay the whole sequence to rebuild + it. + + Beyond that, only function key expansion could + create more than two keys, but that should never + generate mouse events, so it's okay to zero + mock_input in that case too. + + FIXME: The above paragraph seems just plain + wrong, if you consider things like + xterm-mouse-mode. -stef + + Isn't this just the most wonderful code ever? */ + + /* If mock_input > t + 1, the above simplification + will actually end up dropping keys on the floor. + This is probably OK for now, but even + if mock_input <= t + 1, we need to adjust indec, + fkey, and keytran. + Typical case [header-line down-mouse-N]: + mock_input = 2, t = 1, fkey.end = 1, + last_real_key_start = 0. */ + if (indec.end > last_real_key_start) + { + indec.end = indec.start + = min (last_real_key_start, indec.start); + indec.map = indec.parent; + if (fkey.end > last_real_key_start) + { + fkey.end = fkey.start + = min (last_real_key_start, fkey.start); + fkey.map = fkey.parent; + if (keytran.end > last_real_key_start) + { + keytran.end = keytran.start + = min (last_real_key_start, keytran.start); + keytran.map = keytran.parent; + } + } + } + if (t == last_real_key_start) + { + mock_input = 0; + goto replay_key; + } + else + { + mock_input = last_real_key_start; + goto replay_sequence; + } + } + + new_head + = apply_modifiers (modifiers, XCAR (breakdown)); + new_click = list2 (new_head, EVENT_START (key)); + + /* Look for a binding for this new key. */ + new_binding = follow_key (current_binding, new_click); + + /* If that click is bound, go for it. */ + if (!NILP (new_binding)) + { + current_binding = new_binding; + key = new_click; + break; + } + /* Otherwise, we'll leave key set to the drag event. */ + } + } + } + } + current_binding = new_binding; + + keybuf[t++] = key; + /* Normally, last_nonmenu_event gets the previous key we read. + But when a mouse popup menu is being used, + we don't update last_nonmenu_event; it continues to hold the mouse + event that preceded the first level of menu. */ + if (!used_mouse_menu) + last_nonmenu_event = key; + + /* Record what part of this_command_keys is the current key sequence. */ + this_single_command_key_start = this_command_key_count - t; + /* When 'input-method-function' called above causes events to be + put on 'unread-post-input-method-events', and as result + 'reread' is set to 'true', the value of 't' can become larger + than 'this_command_key_count', because 'add_command_key' is + not called to update 'this_command_key_count'. If this + happens, 'this_single_command_key_start' will become negative + above, and any call to 'this-single-command-keys' will return + a garbled vector. See bug #20223 for one such situation. + Here we force 'this_single_command_key_start' to never become + negative, to avoid that. */ + if (this_single_command_key_start < 0) + this_single_command_key_start = 0; + + /* Look for this sequence in input-decode-map. + Scan from indec.end until we find a bound suffix. */ + while (indec.end < t) + { + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + bool done; + int diff; + + GCPRO4 (indec.map, fkey.map, keytran.map, delayed_switch_frame); + done = keyremap_step (keybuf, bufsize, &indec, max (t, mock_input), + 1, &diff, prompt); + UNGCPRO; + if (done) + { + mock_input = diff + max (t, mock_input); + goto replay_sequence; + } + } + + if (!KEYMAPP (current_binding) + && !test_undefined (current_binding) + && indec.start >= t) + /* There is a binding and it's not a prefix. + (and it doesn't have any input-decode-map translation pending). + There is thus no function-key in this sequence. + Moving fkey.start is important in this case to allow keytran.start + to go over the sequence before we return (since we keep the + invariant that keytran.end <= fkey.start). */ + { + if (fkey.start < t) + (fkey.start = fkey.end = t, fkey.map = fkey.parent); + } + else + /* If the sequence is unbound, see if we can hang a function key + off the end of it. */ + /* Continue scan from fkey.end until we find a bound suffix. */ + while (fkey.end < indec.start) + { + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + bool done; + int diff; + + GCPRO4 (indec.map, fkey.map, keytran.map, delayed_switch_frame); + done = keyremap_step (keybuf, bufsize, &fkey, + max (t, mock_input), + /* If there's a binding (i.e. + first_binding >= nmaps) we don't want + to apply this function-key-mapping. */ + fkey.end + 1 == t + && (test_undefined (current_binding)), + &diff, prompt); + UNGCPRO; + if (done) + { + mock_input = diff + max (t, mock_input); + /* Adjust the input-decode-map counters. */ + indec.end += diff; + indec.start += diff; + + goto replay_sequence; + } + } + + /* Look for this sequence in key-translation-map. + Scan from keytran.end until we find a bound suffix. */ + while (keytran.end < fkey.start) + { + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + bool done; + int diff; + + GCPRO4 (indec.map, fkey.map, keytran.map, delayed_switch_frame); + done = keyremap_step (keybuf, bufsize, &keytran, max (t, mock_input), + 1, &diff, prompt); + UNGCPRO; + if (done) + { + mock_input = diff + max (t, mock_input); + /* Adjust the function-key-map and input-decode-map counters. */ + indec.end += diff; + indec.start += diff; + fkey.end += diff; + fkey.start += diff; + + goto replay_sequence; + } + } + + /* If KEY is not defined in any of the keymaps, + and cannot be part of a function key or translation, + and is an upper case letter + use the corresponding lower-case letter instead. */ + if (NILP (current_binding) + && /* indec.start >= t && fkey.start >= t && */ keytran.start >= t + && INTEGERP (key) + && ((CHARACTERP (make_number (XINT (key) & ~CHAR_MODIFIER_MASK)) + && uppercasep (XINT (key) & ~CHAR_MODIFIER_MASK)) + || (XINT (key) & shift_modifier))) + { + Lisp_Object new_key; + + original_uppercase = key; + original_uppercase_position = t - 1; + + if (XINT (key) & shift_modifier) + XSETINT (new_key, XINT (key) & ~shift_modifier); + else + XSETINT (new_key, (downcase (XINT (key) & ~CHAR_MODIFIER_MASK) + | (XINT (key) & CHAR_MODIFIER_MASK))); + + /* We have to do this unconditionally, regardless of whether + the lower-case char is defined in the keymaps, because they + might get translated through function-key-map. */ + keybuf[t - 1] = new_key; + mock_input = max (t, mock_input); + shift_translated = 1; + + goto replay_sequence; + } + + if (NILP (current_binding) + && help_char_p (EVENT_HEAD (key)) && t > 1) + { + read_key_sequence_cmd = Vprefix_help_command; + /* The Microsoft C compiler can't handle the goto that + would go here. */ + dummyflag = 1; + break; + } + + /* If KEY is not defined in any of the keymaps, + and cannot be part of a function key or translation, + and is a shifted function key, + use the corresponding unshifted function key instead. */ + if (NILP (current_binding) + && /* indec.start >= t && fkey.start >= t && */ keytran.start >= t) + { + Lisp_Object breakdown = parse_modifiers (key); + int modifiers + = CONSP (breakdown) ? (XINT (XCAR (XCDR (breakdown)))) : 0; + + if (modifiers & shift_modifier + /* Treat uppercase keys as shifted. */ + || (INTEGERP (key) + && (KEY_TO_CHAR (key) + < XCHAR_TABLE (BVAR (current_buffer, downcase_table))->header.size) + && uppercasep (KEY_TO_CHAR (key)))) + { + Lisp_Object new_key + = (modifiers & shift_modifier + ? apply_modifiers (modifiers & ~shift_modifier, + XCAR (breakdown)) + : make_number (downcase (KEY_TO_CHAR (key)) | modifiers)); + + original_uppercase = key; + original_uppercase_position = t - 1; + + /* We have to do this unconditionally, regardless of whether + the lower-case char is defined in the keymaps, because they + might get translated through function-key-map. */ + keybuf[t - 1] = new_key; + mock_input = max (t, mock_input); + /* Reset fkey (and consequently keytran) to apply + function-key-map on the result, so that S-backspace is + correctly mapped to DEL (via backspace). OTOH, + input-decode-map doesn't need to go through it again. */ + fkey.start = fkey.end = 0; + keytran.start = keytran.end = 0; + shift_translated = 1; + + goto replay_sequence; + } + } + } + if (!dummyflag) + read_key_sequence_cmd = current_binding; + read_key_sequence_remapped + /* Remap command through active keymaps. + Do the remapping here, before the unbind_to so it uses the keymaps + of the appropriate buffer. */ + = SYMBOLP (read_key_sequence_cmd) + ? Fcommand_remapping (read_key_sequence_cmd, Qnil, Qnil) + : Qnil; + + unread_switch_frame = delayed_switch_frame; + unbind_to (count, Qnil); + + /* Don't downcase the last character if the caller says don't. + Don't downcase it if the result is undefined, either. */ + if ((dont_downcase_last || NILP (current_binding)) + && t > 0 + && t - 1 == original_uppercase_position) + { + keybuf[t - 1] = original_uppercase; + shift_translated = 0; + } + + if (shift_translated) + Vthis_command_keys_shift_translated = Qt; + + /* Occasionally we fabricate events, perhaps by expanding something + according to function-key-map, or by adding a prefix symbol to a + mouse click in the scroll bar or modeline. In this cases, return + the entire generated key sequence, even if we hit an unbound + prefix or a definition before the end. This means that you will + be able to push back the event properly, and also means that + read-key-sequence will always return a logical unit. + + Better ideas? */ + for (; t < mock_input; t++) + { + if (echo_keystrokes_p ()) + echo_char (keybuf[t]); + add_command_key (keybuf[t]); + } + + UNGCPRO; + return t; +} + +static Lisp_Object +read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo, + Lisp_Object dont_downcase_last, + Lisp_Object can_return_switch_frame, + Lisp_Object cmd_loop, bool allow_string) +{ + Lisp_Object keybuf[30]; + register int i; + struct gcpro gcpro1; + ptrdiff_t count = SPECPDL_INDEX (); + + if (!NILP (prompt)) + CHECK_STRING (prompt); + QUIT; + + specbind (Qinput_method_exit_on_first_char, + (NILP (cmd_loop) ? Qt : Qnil)); + specbind (Qinput_method_use_echo_area, + (NILP (cmd_loop) ? Qt : Qnil)); + + memset (keybuf, 0, sizeof keybuf); + GCPRO1 (keybuf[0]); + gcpro1.nvars = ARRAYELTS (keybuf); + + if (NILP (continue_echo)) + { + this_command_key_count = 0; + this_command_key_count_reset = 0; + this_single_command_key_start = 0; + } + +#ifdef HAVE_WINDOW_SYSTEM + if (display_hourglass_p) + cancel_hourglass (); +#endif + + i = read_key_sequence (keybuf, ARRAYELTS (keybuf), + prompt, ! NILP (dont_downcase_last), + ! NILP (can_return_switch_frame), 0, 0); + +#if 0 /* The following is fine for code reading a key sequence and + then proceeding with a lengthy computation, but it's not good + for code reading keys in a loop, like an input method. */ +#ifdef HAVE_WINDOW_SYSTEM + if (display_hourglass_p) + start_hourglass (); +#endif +#endif + + if (i == -1) + { + Vquit_flag = Qt; + QUIT; + } + UNGCPRO; + return unbind_to (count, + ((allow_string ? make_event_array : Fvector) + (i, keybuf))); +} + +DEFUN ("read-key-sequence", Fread_key_sequence, Sread_key_sequence, 1, 5, 0, + doc: /* Read a sequence of keystrokes and return as a string or vector. +The sequence is sufficient to specify a non-prefix command in the +current local and global maps. + +First arg PROMPT is a prompt string. If nil, do not prompt specially. +Second (optional) arg CONTINUE-ECHO, if non-nil, means this key echos +as a continuation of the previous key. + +The third (optional) arg DONT-DOWNCASE-LAST, if non-nil, means do not +convert the last event to lower case. (Normally any upper case event +is converted to lower case if the original event is undefined and the lower +case equivalent is defined.) A non-nil value is appropriate for reading +a key sequence to be defined. + +A C-g typed while in this function is treated like any other character, +and `quit-flag' is not set. + +If the key sequence starts with a mouse click, then the sequence is read +using the keymaps of the buffer of the window clicked in, not the buffer +of the selected window as normal. + +`read-key-sequence' drops unbound button-down events, since you normally +only care about the click or drag events which follow them. If a drag +or multi-click event is unbound, but the corresponding click event would +be bound, `read-key-sequence' turns the event into a click event at the +drag's starting position. This means that you don't have to distinguish +between click and drag, double, or triple events unless you want to. + +`read-key-sequence' prefixes mouse events on mode lines, the vertical +lines separating windows, and scroll bars with imaginary keys +`mode-line', `vertical-line', and `vertical-scroll-bar'. + +Optional fourth argument CAN-RETURN-SWITCH-FRAME non-nil means that this +function will process a switch-frame event if the user switches frames +before typing anything. If the user switches frames in the middle of a +key sequence, or at the start of the sequence but CAN-RETURN-SWITCH-FRAME +is nil, then the event will be put off until after the current key sequence. + +`read-key-sequence' checks `function-key-map' for function key +sequences, where they wouldn't conflict with ordinary bindings. See +`function-key-map' for more details. + +The optional fifth argument CMD-LOOP, if non-nil, means +that this key sequence is being read by something that will +read commands one after another. It should be nil if the caller +will read just one key sequence. */) + (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object dont_downcase_last, Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop) +{ + return read_key_sequence_vs (prompt, continue_echo, dont_downcase_last, + can_return_switch_frame, cmd_loop, true); +} + +DEFUN ("read-key-sequence-vector", Fread_key_sequence_vector, + Sread_key_sequence_vector, 1, 5, 0, + doc: /* Like `read-key-sequence' but always return a vector. */) + (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object dont_downcase_last, Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop) +{ + return read_key_sequence_vs (prompt, continue_echo, dont_downcase_last, + can_return_switch_frame, cmd_loop, false); +} + +/* Return true if input events are pending. */ + +bool +detect_input_pending (void) +{ + return input_pending || get_input_pending (0); +} + +/* Return true if input events other than mouse movements are + pending. */ + +bool +detect_input_pending_ignore_squeezables (void) +{ + return input_pending || get_input_pending (READABLE_EVENTS_IGNORE_SQUEEZABLES); +} + +/* Return true if input events are pending, and run any pending timers. */ + +bool +detect_input_pending_run_timers (bool do_display) +{ + unsigned old_timers_run = timers_run; + + if (!input_pending) + get_input_pending (READABLE_EVENTS_DO_TIMERS_NOW); + + if (old_timers_run != timers_run && do_display) + redisplay_preserve_echo_area (8); + + return input_pending; +} + +/* This is called in some cases before a possible quit. + It cases the next call to detect_input_pending to recompute input_pending. + So calling this function unnecessarily can't do any harm. */ + +void +clear_input_pending (void) +{ + input_pending = 0; +} + +/* Return true if there are pending requeued events. + This isn't used yet. The hope is to make wait_reading_process_output + call it, and return if it runs Lisp code that unreads something. + The problem is, kbd_buffer_get_event needs to be fixed to know what + to do in that case. It isn't trivial. */ + +bool +requeued_events_pending_p (void) +{ + return (!NILP (Vunread_command_events)); +} + +DEFUN ("input-pending-p", Finput_pending_p, Sinput_pending_p, 0, 1, 0, + doc: /* Return t if command input is currently available with no wait. +Actually, the value is nil only if we can be sure that no input is available; +if there is a doubt, the value is t. + +If CHECK-TIMERS is non-nil, timers that are ready to run will do so. */) + (Lisp_Object check_timers) +{ + if (!NILP (Vunread_command_events) + || !NILP (Vunread_post_input_method_events) + || !NILP (Vunread_input_method_events)) + return (Qt); + + /* Process non-user-visible events (Bug#10195). */ + process_special_events (); + + return (get_input_pending ((NILP (check_timers) + ? 0 : READABLE_EVENTS_DO_TIMERS_NOW) + | READABLE_EVENTS_FILTER_EVENTS) + ? Qt : Qnil); +} + +DEFUN ("recent-keys", Frecent_keys, Srecent_keys, 0, 1, 0, + doc: /* Return vector of last few events, not counting those from keyboard macros. +If INCLUDE-CMDS is non-nil, include the commands that were run, +represented as events of the form (nil . COMMAND). */) + (Lisp_Object include_cmds) +{ + bool cmds = !NILP (include_cmds); + + if (!total_keys + || (cmds && total_keys < NUM_RECENT_KEYS)) + return Fvector (total_keys, + XVECTOR (recent_keys)->contents); + else + { + Lisp_Object es = Qnil; + int i = (total_keys < NUM_RECENT_KEYS + ? 0 : recent_keys_index); + eassert (recent_keys_index < NUM_RECENT_KEYS); + do + { + Lisp_Object e = AREF (recent_keys, i); + if (cmds || !CONSP (e) || !NILP (XCAR (e))) + es = Fcons (e, es); + if (++i >= NUM_RECENT_KEYS) + i = 0; + } while (i != recent_keys_index); + es = Fnreverse (es); + return Fvconcat (1, &es); + } +} + +DEFUN ("this-command-keys", Fthis_command_keys, Sthis_command_keys, 0, 0, 0, + doc: /* Return the key sequence that invoked this command. +However, if the command has called `read-key-sequence', it returns +the last key sequence that has been read. +The value is a string or a vector. + +See also `this-command-keys-vector'. */) + (void) +{ + return make_event_array (this_command_key_count, + XVECTOR (this_command_keys)->contents); +} + +DEFUN ("this-command-keys-vector", Fthis_command_keys_vector, Sthis_command_keys_vector, 0, 0, 0, + doc: /* Return the key sequence that invoked this command, as a vector. +However, if the command has called `read-key-sequence', it returns +the last key sequence that has been read. + +See also `this-command-keys'. */) + (void) +{ + return Fvector (this_command_key_count, + XVECTOR (this_command_keys)->contents); +} + +DEFUN ("this-single-command-keys", Fthis_single_command_keys, + Sthis_single_command_keys, 0, 0, 0, + doc: /* Return the key sequence that invoked this command. +More generally, it returns the last key sequence read, either by +the command loop or by `read-key-sequence'. +Unlike `this-command-keys', this function's value +does not include prefix arguments. +The value is always a vector. */) + (void) +{ + return Fvector (this_command_key_count + - this_single_command_key_start, + (XVECTOR (this_command_keys)->contents + + this_single_command_key_start)); +} + +DEFUN ("this-single-command-raw-keys", Fthis_single_command_raw_keys, + Sthis_single_command_raw_keys, 0, 0, 0, + doc: /* Return the raw events that were read for this command. +More generally, it returns the last key sequence read, either by +the command loop or by `read-key-sequence'. +Unlike `this-single-command-keys', this function's value +shows the events before all translations (except for input methods). +The value is always a vector. */) + (void) +{ + return Fvector (raw_keybuf_count, XVECTOR (raw_keybuf)->contents); +} + +DEFUN ("reset-this-command-lengths", Freset_this_command_lengths, + Sreset_this_command_lengths, 0, 0, 0, + doc: /* Make the unread events replace the last command and echo. +Used in `universal-argument-other-key'. + +`universal-argument-other-key' rereads the event just typed. +It then gets translated through `function-key-map'. +The translated event has to replace the real events, +both in the value of (this-command-keys) and in echoing. +To achieve this, `universal-argument-other-key' calls +`reset-this-command-lengths', which discards the record of reading +these events the first time. */) + (void) +{ + this_command_key_count = before_command_key_count; + if (this_command_key_count < this_single_command_key_start) + this_single_command_key_start = this_command_key_count; + + echo_truncate (before_command_echo_length); + + /* Cause whatever we put into unread-command-events + to echo as if it were being freshly read from the keyboard. */ + this_command_key_count_reset = 1; + + return Qnil; +} + +DEFUN ("clear-this-command-keys", Fclear_this_command_keys, + Sclear_this_command_keys, 0, 1, 0, + doc: /* Clear out the vector that `this-command-keys' returns. +Also clear the record of the last 100 events, unless optional arg +KEEP-RECORD is non-nil. */) + (Lisp_Object keep_record) +{ + int i; + + this_command_key_count = 0; + this_command_key_count_reset = 0; + + if (NILP (keep_record)) + { + for (i = 0; i < ASIZE (recent_keys); ++i) + ASET (recent_keys, i, Qnil); + total_keys = 0; + recent_keys_index = 0; + } + return Qnil; +} + +DEFUN ("recursion-depth", Frecursion_depth, Srecursion_depth, 0, 0, 0, + doc: /* Return the current depth in recursive edits. */) + (void) +{ + Lisp_Object temp; + /* Wrap around reliably on integer overflow. */ + EMACS_INT sum = (command_loop_level & INTMASK) + (minibuf_level & INTMASK); + XSETINT (temp, sum); + return temp; +} + +DEFUN ("open-dribble-file", Fopen_dribble_file, Sopen_dribble_file, 1, 1, + "FOpen dribble file: ", + doc: /* Start writing all keyboard characters to a dribble file called FILE. +If FILE is nil, close any open dribble file. +The file will be closed when Emacs exits. + +Be aware that this records ALL characters you type! +This may include sensitive information such as passwords. */) + (Lisp_Object file) +{ + if (dribble) + { + block_input (); + fclose (dribble); + unblock_input (); + dribble = 0; + } + if (!NILP (file)) + { + int fd; + Lisp_Object encfile; + + file = Fexpand_file_name (file, Qnil); + encfile = ENCODE_FILE (file); + fd = emacs_open (SSDATA (encfile), O_WRONLY | O_CREAT | O_EXCL, 0600); + if (fd < 0 && errno == EEXIST && unlink (SSDATA (encfile)) == 0) + fd = emacs_open (SSDATA (encfile), O_WRONLY | O_CREAT | O_EXCL, 0600); + dribble = fd < 0 ? 0 : fdopen (fd, "w"); + if (dribble == 0) + report_file_error ("Opening dribble", file); + } + return Qnil; +} + +DEFUN ("discard-input", Fdiscard_input, Sdiscard_input, 0, 0, 0, + doc: /* Discard the contents of the terminal input buffer. +Also end any kbd macro being defined. */) + (void) +{ + if (!NILP (KVAR (current_kboard, defining_kbd_macro))) + { + /* Discard the last command from the macro. */ + Fcancel_kbd_macro_events (); + end_kbd_macro (); + } + + Vunread_command_events = Qnil; + + discard_tty_input (); + + kbd_fetch_ptr = kbd_store_ptr; + input_pending = 0; + + return Qnil; +} + +DEFUN ("suspend-emacs", Fsuspend_emacs, Ssuspend_emacs, 0, 1, "", + doc: /* Stop Emacs and return to superior process. You can resume later. +If `cannot-suspend' is non-nil, or if the system doesn't support job +control, run a subshell instead. + +If optional arg STUFFSTRING is non-nil, its characters are stuffed +to be read as terminal input by Emacs's parent, after suspension. + +Before suspending, run the normal hook `suspend-hook'. +After resumption run the normal hook `suspend-resume-hook'. + +Some operating systems cannot stop the Emacs process and resume it later. +On such systems, Emacs starts a subshell instead of suspending. */) + (Lisp_Object stuffstring) +{ + ptrdiff_t count = SPECPDL_INDEX (); + int old_height, old_width; + int width, height; + struct gcpro gcpro1; + + if (tty_list && tty_list->next) + error ("There are other tty frames open; close them before suspending Emacs"); + + if (!NILP (stuffstring)) + CHECK_STRING (stuffstring); + + run_hook (intern ("suspend-hook")); + + GCPRO1 (stuffstring); + get_tty_size (fileno (CURTTY ()->input), &old_width, &old_height); + reset_all_sys_modes (); + /* sys_suspend can get an error if it tries to fork a subshell + and the system resources aren't available for that. */ + record_unwind_protect_void (init_all_sys_modes); + stuff_buffered_input (stuffstring); + if (cannot_suspend) + sys_subshell (); + else + sys_suspend (); + unbind_to (count, Qnil); + + /* Check if terminal/window size has changed. + Note that this is not useful when we are running directly + with a window system; but suspend should be disabled in that case. */ + get_tty_size (fileno (CURTTY ()->input), &width, &height); + if (width != old_width || height != old_height) + change_frame_size (SELECTED_FRAME (), width, + height - FRAME_MENU_BAR_LINES (SELECTED_FRAME ()), + 0, 0, 0, 0); + + run_hook (intern ("suspend-resume-hook")); + + UNGCPRO; + return Qnil; +} + +/* If STUFFSTRING is a string, stuff its contents as pending terminal input. + Then in any case stuff anything Emacs has read ahead and not used. */ + +void +stuff_buffered_input (Lisp_Object stuffstring) +{ +#ifdef SIGTSTP /* stuff_char is defined if SIGTSTP. */ + register unsigned char *p; + + if (STRINGP (stuffstring)) + { + register ptrdiff_t count; + + p = SDATA (stuffstring); + count = SBYTES (stuffstring); + while (count-- > 0) + stuff_char (*p++); + stuff_char ('\n'); + } + + /* Anything we have read ahead, put back for the shell to read. */ + /* ?? What should this do when we have multiple keyboards?? + Should we ignore anything that was typed in at the "wrong" kboard? + + rms: we should stuff everything back into the kboard + it came from. */ + for (; kbd_fetch_ptr != kbd_store_ptr; kbd_fetch_ptr++) + { + + if (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE) + kbd_fetch_ptr = kbd_buffer; + if (kbd_fetch_ptr->kind == ASCII_KEYSTROKE_EVENT) + stuff_char (kbd_fetch_ptr->code); + + clear_event (kbd_fetch_ptr); + } + + input_pending = 0; +#endif /* SIGTSTP */ +} + +void +set_waiting_for_input (struct timespec *time_to_clear) +{ + input_available_clear_time = time_to_clear; + + /* Tell handle_interrupt to throw back to read_char, */ + waiting_for_input = 1; + + /* If handle_interrupt was called before and buffered a C-g, + make it run again now, to avoid timing error. */ + if (!NILP (Vquit_flag)) + quit_throw_to_read_char (0); +} + +void +clear_waiting_for_input (void) +{ + /* Tell handle_interrupt not to throw back to read_char, */ + waiting_for_input = 0; + input_available_clear_time = 0; +} + +/* The SIGINT handler. + + If we have a frame on the controlling tty, we assume that the + SIGINT was generated by C-g, so we call handle_interrupt. + Otherwise, tell QUIT to kill Emacs. */ + +static void +handle_interrupt_signal (int sig) +{ + /* See if we have an active terminal on our controlling tty. */ + struct terminal *terminal = get_named_terminal ("/dev/tty"); + if (!terminal) + { + /* If there are no frames there, let's pretend that we are a + well-behaving UN*X program and quit. We must not call Lisp + in a signal handler, so tell QUIT to exit when it is + safe. */ + Vquit_flag = Qkill_emacs; + } + else + { + /* Otherwise, the SIGINT was probably generated by C-g. */ + + /* Set internal_last_event_frame to the top frame of the + controlling tty, if we have a frame there. We disable the + interrupt key on secondary ttys, so the SIGINT must have come + from the controlling tty. */ + internal_last_event_frame = terminal->display_info.tty->top_frame; + + handle_interrupt (1); + } +} + +static void +deliver_interrupt_signal (int sig) +{ + deliver_process_signal (sig, handle_interrupt_signal); +} + + +/* If Emacs is stuck because `inhibit-quit' is true, then keep track + of the number of times C-g has been requested. If C-g is pressed + enough times, then quit anyway. See bug#6585. */ +static int volatile force_quit_count; + +/* This routine is called at interrupt level in response to C-g. + + It is called from the SIGINT handler or kbd_buffer_store_event. + + If `waiting_for_input' is non zero, then unless `echoing' is + nonzero, immediately throw back to read_char. + + Otherwise it sets the Lisp variable quit-flag not-nil. This causes + eval to throw, when it gets a chance. If quit-flag is already + non-nil, it stops the job right away. */ + +static void +handle_interrupt (bool in_signal_handler) +{ + char c; + + cancel_echoing (); + + /* XXX This code needs to be revised for multi-tty support. */ + if (!NILP (Vquit_flag) && get_named_terminal ("/dev/tty")) + { + if (! in_signal_handler) + { + /* If SIGINT isn't blocked, don't let us be interrupted by + a SIGINT. It might be harmful due to non-reentrancy + in I/O functions. */ + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGINT); + pthread_sigmask (SIG_BLOCK, &blocked, 0); + } + + fflush (stdout); + reset_all_sys_modes (); + +#ifdef SIGTSTP +/* + * On systems which can suspend the current process and return to the original + * shell, this command causes the user to end up back at the shell. + * The "Auto-save" and "Abort" questions are not asked until + * the user elects to return to emacs, at which point he can save the current + * job and either dump core or continue. + */ + sys_suspend (); +#else + /* Perhaps should really fork an inferior shell? + But that would not provide any way to get back + to the original shell, ever. */ + printf ("No support for stopping a process on this operating system;\n"); + printf ("you can continue or abort.\n"); +#endif /* not SIGTSTP */ +#ifdef MSDOS + /* We must remain inside the screen area when the internal terminal + is used. Note that [Enter] is not echoed by dos. */ + cursor_to (SELECTED_FRAME (), 0, 0); +#endif + /* It doesn't work to autosave while GC is in progress; + the code used for auto-saving doesn't cope with the mark bit. */ + if (!gc_in_progress) + { + printf ("Auto-save? (y or n) "); + fflush (stdout); + if (((c = getchar ()) & ~040) == 'Y') + { + Fdo_auto_save (Qt, Qnil); +#ifdef MSDOS + printf ("\r\nAuto-save done"); +#else /* not MSDOS */ + printf ("Auto-save done\n"); +#endif /* not MSDOS */ + } + while (c != '\n') c = getchar (); + } + else + { + /* During GC, it must be safe to reenable quitting again. */ + Vinhibit_quit = Qnil; +#ifdef MSDOS + printf ("\r\n"); +#endif /* not MSDOS */ + printf ("Garbage collection in progress; cannot auto-save now\r\n"); + printf ("but will instead do a real quit after garbage collection ends\r\n"); + fflush (stdout); + } + +#ifdef MSDOS + printf ("\r\nAbort? (y or n) "); +#else /* not MSDOS */ + printf ("Abort (and dump core)? (y or n) "); +#endif /* not MSDOS */ + fflush (stdout); + if (((c = getchar ()) & ~040) == 'Y') + emacs_abort (); + while (c != '\n') c = getchar (); +#ifdef MSDOS + printf ("\r\nContinuing...\r\n"); +#else /* not MSDOS */ + printf ("Continuing...\n"); +#endif /* not MSDOS */ + fflush (stdout); + init_all_sys_modes (); + } + else + { + /* If executing a function that wants to be interrupted out of + and the user has not deferred quitting by binding `inhibit-quit' + then quit right away. */ + if (immediate_quit && NILP (Vinhibit_quit)) + { + struct gl_state_s saved; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + + immediate_quit = 0; + pthread_sigmask (SIG_SETMASK, &empty_mask, 0); + saved = gl_state; + GCPRO4 (saved.object, saved.global_code, + saved.current_syntax_table, saved.old_prop); + Fsignal (Qquit, Qnil); + gl_state = saved; + UNGCPRO; + } + else + { /* Else request quit when it's safe. */ + int count = NILP (Vquit_flag) ? 1 : force_quit_count + 1; + force_quit_count = count; + if (count == 3) + { + immediate_quit = 1; + Vinhibit_quit = Qnil; + } + Vquit_flag = Qt; + } + } + + pthread_sigmask (SIG_SETMASK, &empty_mask, 0); + +/* TODO: The longjmp in this call throws the NS event loop integration off, + and it seems to do fine without this. Probably some attention + needs to be paid to the setting of waiting_for_input in + wait_reading_process_output() under HAVE_NS because of the call + to ns_select there (needed because otherwise events aren't picked up + outside of polling since we don't get SIGIO like X and we don't have a + separate event loop thread like W32. */ +#ifndef HAVE_NS + if (waiting_for_input && !echoing) + quit_throw_to_read_char (in_signal_handler); +#endif +} + +/* Handle a C-g by making read_char return C-g. */ + +static void +quit_throw_to_read_char (bool from_signal) +{ + /* When not called from a signal handler it is safe to call + Lisp. */ + if (!from_signal && EQ (Vquit_flag, Qkill_emacs)) + Fkill_emacs (Qnil); + + /* Prevent another signal from doing this before we finish. */ + clear_waiting_for_input (); + input_pending = 0; + + Vunread_command_events = Qnil; + + if (FRAMEP (internal_last_event_frame) + && !EQ (internal_last_event_frame, selected_frame)) + do_switch_frame (make_lispy_switch_frame (internal_last_event_frame), + 0, 0, Qnil); + + sys_longjmp (getcjmp, 1); +} + +DEFUN ("set-input-interrupt-mode", Fset_input_interrupt_mode, + Sset_input_interrupt_mode, 1, 1, 0, + doc: /* Set interrupt mode of reading keyboard input. +If INTERRUPT is non-nil, Emacs will use input interrupts; +otherwise Emacs uses CBREAK mode. + +See also `current-input-mode'. */) + (Lisp_Object interrupt) +{ + bool new_interrupt_input; +#ifdef USABLE_SIGIO +#ifdef HAVE_X_WINDOWS + if (x_display_list != NULL) + { + /* When using X, don't give the user a real choice, + because we haven't implemented the mechanisms to support it. */ + new_interrupt_input = 1; + } + else +#endif /* HAVE_X_WINDOWS */ + new_interrupt_input = !NILP (interrupt); +#else /* not USABLE_SIGIO */ + new_interrupt_input = 0; +#endif /* not USABLE_SIGIO */ + + if (new_interrupt_input != interrupt_input) + { +#ifdef POLL_FOR_INPUT + stop_polling (); +#endif +#ifndef DOS_NT + /* this causes startup screen to be restored and messes with the mouse */ + reset_all_sys_modes (); + interrupt_input = new_interrupt_input; + init_all_sys_modes (); +#else + interrupt_input = new_interrupt_input; +#endif + +#ifdef POLL_FOR_INPUT + poll_suppress_count = 1; + start_polling (); +#endif + } + return Qnil; +} + +DEFUN ("set-output-flow-control", Fset_output_flow_control, Sset_output_flow_control, 1, 2, 0, + doc: /* Enable or disable ^S/^Q flow control for output to TERMINAL. +If FLOW is non-nil, flow control is enabled and you cannot use C-s or +C-q in key sequences. + +This setting only has an effect on tty terminals and only when +Emacs reads input in CBREAK mode; see `set-input-interrupt-mode'. + +See also `current-input-mode'. */) + (Lisp_Object flow, Lisp_Object terminal) +{ + struct terminal *t = decode_tty_terminal (terminal); + struct tty_display_info *tty; + + if (!t) + return Qnil; + tty = t->display_info.tty; + + if (tty->flow_control != !NILP (flow)) + { +#ifndef DOS_NT + /* This causes startup screen to be restored and messes with the mouse. */ + reset_sys_modes (tty); +#endif + + tty->flow_control = !NILP (flow); + +#ifndef DOS_NT + init_sys_modes (tty); +#endif + } + return Qnil; +} + +DEFUN ("set-input-meta-mode", Fset_input_meta_mode, Sset_input_meta_mode, 1, 2, 0, + doc: /* Enable or disable 8-bit input on TERMINAL. +If META is t, Emacs will accept 8-bit input, and interpret the 8th +bit as the Meta modifier. + +If META is nil, Emacs will ignore the top bit, on the assumption it is +parity. + +Otherwise, Emacs will accept and pass through 8-bit input without +specially interpreting the top bit. + +This setting only has an effect on tty terminal devices. + +Optional parameter TERMINAL specifies the tty terminal device to use. +It may be a terminal object, a frame, or nil for the terminal used by +the currently selected frame. + +See also `current-input-mode'. */) + (Lisp_Object meta, Lisp_Object terminal) +{ + struct terminal *t = decode_tty_terminal (terminal); + struct tty_display_info *tty; + int new_meta; + + if (!t) + return Qnil; + tty = t->display_info.tty; + + if (NILP (meta)) + new_meta = 0; + else if (EQ (meta, Qt)) + new_meta = 1; + else + new_meta = 2; + + if (tty->meta_key != new_meta) + { +#ifndef DOS_NT + /* this causes startup screen to be restored and messes with the mouse */ + reset_sys_modes (tty); +#endif + + tty->meta_key = new_meta; + +#ifndef DOS_NT + init_sys_modes (tty); +#endif + } + return Qnil; +} + +DEFUN ("set-quit-char", Fset_quit_char, Sset_quit_char, 1, 1, 0, + doc: /* Specify character used for quitting. +QUIT must be an ASCII character. + +This function only has an effect on the controlling tty of the Emacs +process. + +See also `current-input-mode'. */) + (Lisp_Object quit) +{ + struct terminal *t = get_named_terminal ("/dev/tty"); + struct tty_display_info *tty; + + if (!t) + return Qnil; + tty = t->display_info.tty; + + if (NILP (quit) || !INTEGERP (quit) || XINT (quit) < 0 || XINT (quit) > 0400) + error ("QUIT must be an ASCII character"); + +#ifndef DOS_NT + /* this causes startup screen to be restored and messes with the mouse */ + reset_sys_modes (tty); +#endif + + /* Don't let this value be out of range. */ + quit_char = XINT (quit) & (tty->meta_key == 0 ? 0177 : 0377); + +#ifndef DOS_NT + init_sys_modes (tty); +#endif + + return Qnil; +} + +DEFUN ("set-input-mode", Fset_input_mode, Sset_input_mode, 3, 4, 0, + doc: /* Set mode of reading keyboard input. +First arg INTERRUPT non-nil means use input interrupts; + nil means use CBREAK mode. +Second arg FLOW non-nil means use ^S/^Q flow control for output to terminal + (no effect except in CBREAK mode). +Third arg META t means accept 8-bit input (for a Meta key). + META nil means ignore the top bit, on the assumption it is parity. + Otherwise, accept 8-bit input and don't use the top bit for Meta. +Optional fourth arg QUIT if non-nil specifies character to use for quitting. +See also `current-input-mode'. */) + (Lisp_Object interrupt, Lisp_Object flow, Lisp_Object meta, Lisp_Object quit) +{ + Fset_input_interrupt_mode (interrupt); + Fset_output_flow_control (flow, Qnil); + Fset_input_meta_mode (meta, Qnil); + if (!NILP (quit)) + Fset_quit_char (quit); + return Qnil; +} + +DEFUN ("current-input-mode", Fcurrent_input_mode, Scurrent_input_mode, 0, 0, 0, + doc: /* Return information about the way Emacs currently reads keyboard input. +The value is a list of the form (INTERRUPT FLOW META QUIT), where + INTERRUPT is non-nil if Emacs is using interrupt-driven input; if + nil, Emacs is using CBREAK mode. + FLOW is non-nil if Emacs uses ^S/^Q flow control for output to the + terminal; this does not apply if Emacs uses interrupt-driven input. + META is t if accepting 8-bit input with 8th bit as Meta flag. + META nil means ignoring the top bit, on the assumption it is parity. + META is neither t nor nil if accepting 8-bit input and using + all 8 bits as the character code. + QUIT is the character Emacs currently uses to quit. +The elements of this list correspond to the arguments of +`set-input-mode'. */) + (void) +{ + struct frame *sf = XFRAME (selected_frame); + + Lisp_Object interrupt = interrupt_input ? Qt : Qnil; + Lisp_Object flow, meta; + if (FRAME_TERMCAP_P (sf) || FRAME_MSDOS_P (sf)) + { + flow = FRAME_TTY (sf)->flow_control ? Qt : Qnil; + meta = (FRAME_TTY (sf)->meta_key == 2 + ? make_number (0) + : (CURTTY ()->meta_key == 1 ? Qt : Qnil)); + } + else + { + flow = Qnil; + meta = Qt; + } + Lisp_Object quit = make_number (quit_char); + + return list4 (interrupt, flow, meta, quit); +} + +DEFUN ("posn-at-x-y", Fposn_at_x_y, Sposn_at_x_y, 2, 4, 0, + doc: /* Return position information for pixel coordinates X and Y. +By default, X and Y are relative to text area of the selected window. +Optional third arg FRAME-OR-WINDOW non-nil specifies frame or window. +If optional fourth arg WHOLE is non-nil, X is relative to the left +edge of the window. + +The return value is similar to a mouse click position: + (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW) + IMAGE (DX . DY) (WIDTH . HEIGHT)) +The `posn-' functions access elements of such lists. */) + (Lisp_Object x, Lisp_Object y, Lisp_Object frame_or_window, Lisp_Object whole) +{ + CHECK_NATNUM (x); + CHECK_NATNUM (y); + + if (NILP (frame_or_window)) + frame_or_window = selected_window; + + if (WINDOWP (frame_or_window)) + { + struct window *w = decode_live_window (frame_or_window); + + XSETINT (x, (XINT (x) + + WINDOW_LEFT_EDGE_X (w) + + (NILP (whole) + ? window_box_left_offset (w, TEXT_AREA) + : 0))); + XSETINT (y, WINDOW_TO_FRAME_PIXEL_Y (w, XINT (y))); + frame_or_window = w->frame; + } + + CHECK_LIVE_FRAME (frame_or_window); + + return make_lispy_position (XFRAME (frame_or_window), x, y, 0); +} + +DEFUN ("posn-at-point", Fposn_at_point, Sposn_at_point, 0, 2, 0, + doc: /* Return position information for buffer POS in WINDOW. +POS defaults to point in WINDOW; WINDOW defaults to the selected window. + +Return nil if position is not visible in window. Otherwise, +the return value is similar to that returned by `event-start' for +a mouse click at the upper left corner of the glyph corresponding +to the given buffer position: + (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW) + IMAGE (DX . DY) (WIDTH . HEIGHT)) +The `posn-' functions access elements of such lists. */) + (Lisp_Object pos, Lisp_Object window) +{ + Lisp_Object tem; + + if (NILP (window)) + window = selected_window; + + tem = Fpos_visible_in_window_p (pos, window, Qt); + if (!NILP (tem)) + { + Lisp_Object x = XCAR (tem); + Lisp_Object y = XCAR (XCDR (tem)); + + /* Point invisible due to hscrolling? */ + if (XINT (x) < 0) + return Qnil; + tem = Fposn_at_x_y (x, y, window, Qnil); + } + + return tem; +} + +/* Set up a new kboard object with reasonable initial values. + TYPE is a window system for which this keyboard is used. */ + +static void +init_kboard (KBOARD *kb, Lisp_Object type) +{ + kset_overriding_terminal_local_map (kb, Qnil); + kset_last_command (kb, Qnil); + kset_real_last_command (kb, Qnil); + kset_keyboard_translate_table (kb, Qnil); + kset_last_repeatable_command (kb, Qnil); + kset_prefix_arg (kb, Qnil); + kset_last_prefix_arg (kb, Qnil); + kset_kbd_queue (kb, Qnil); + kb->kbd_queue_has_data = 0; + kb->immediate_echo = 0; + kset_echo_string (kb, Qnil); + kb->echo_after_prompt = -1; + kb->kbd_macro_buffer = 0; + kb->kbd_macro_bufsize = 0; + kset_defining_kbd_macro (kb, Qnil); + kset_last_kbd_macro (kb, Qnil); + kb->reference_count = 0; + kset_system_key_alist (kb, Qnil); + kset_system_key_syms (kb, Qnil); + kset_window_system (kb, type); + kset_input_decode_map (kb, Fmake_sparse_keymap (Qnil)); + kset_local_function_key_map (kb, Fmake_sparse_keymap (Qnil)); + Fset_keymap_parent (KVAR (kb, Vlocal_function_key_map), Vfunction_key_map); + kset_default_minibuffer_frame (kb, Qnil); +} + +/* Allocate and basically initialize keyboard + object to use with window system TYPE. */ + +KBOARD * +allocate_kboard (Lisp_Object type) +{ + KBOARD *kb = xmalloc (sizeof *kb); + + init_kboard (kb, type); + kb->next_kboard = all_kboards; + all_kboards = kb; + return kb; +} + +/* + * Destroy the contents of a kboard object, but not the object itself. + * We use this just before deleting it, or if we're going to initialize + * it a second time. + */ +static void +wipe_kboard (KBOARD *kb) +{ + xfree (kb->kbd_macro_buffer); +} + +/* Free KB and memory referenced from it. */ + +void +delete_kboard (KBOARD *kb) +{ + KBOARD **kbp; + + for (kbp = &all_kboards; *kbp != kb; kbp = &(*kbp)->next_kboard) + if (*kbp == NULL) + emacs_abort (); + *kbp = kb->next_kboard; + + /* Prevent a dangling reference to KB. */ + if (kb == current_kboard + && FRAMEP (selected_frame) + && FRAME_LIVE_P (XFRAME (selected_frame))) + { + current_kboard = FRAME_KBOARD (XFRAME (selected_frame)); + single_kboard = 0; + if (current_kboard == kb) + emacs_abort (); + } + + wipe_kboard (kb); + xfree (kb); +} + +void +init_keyboard (void) +{ + /* This is correct before outermost invocation of the editor loop. */ + command_loop_level = -1; + immediate_quit = 0; + quit_char = Ctl ('g'); + Vunread_command_events = Qnil; + timer_idleness_start_time = invalid_timespec (); + total_keys = 0; + recent_keys_index = 0; + kbd_fetch_ptr = kbd_buffer; + kbd_store_ptr = kbd_buffer; + do_mouse_tracking = Qnil; + input_pending = 0; + interrupt_input_blocked = 0; + pending_signals = 0; + + /* This means that command_loop_1 won't try to select anything the first + time through. */ + internal_last_event_frame = Qnil; + Vlast_event_frame = internal_last_event_frame; + + current_kboard = initial_kboard; + /* Re-initialize the keyboard again. */ + wipe_kboard (current_kboard); + /* A value of nil for Vwindow_system normally means a tty, but we also use + it for the initial terminal since there is no window system there. */ + init_kboard (current_kboard, Qnil); + + if (!noninteractive) + { + /* Before multi-tty support, these handlers used to be installed + only if the current session was a tty session. Now an Emacs + session may have multiple display types, so we always handle + SIGINT. There is special code in handle_interrupt_signal to exit + Emacs on SIGINT when there are no termcap frames on the + controlling terminal. */ + struct sigaction action; + emacs_sigaction_init (&action, deliver_interrupt_signal); + sigaction (SIGINT, &action, 0); +#ifndef DOS_NT + /* For systems with SysV TERMIO, C-g is set up for both SIGINT and + SIGQUIT and we can't tell which one it will give us. */ + sigaction (SIGQUIT, &action, 0); +#endif /* not DOS_NT */ + } +#ifdef USABLE_SIGIO + if (!noninteractive) + { + struct sigaction action; + emacs_sigaction_init (&action, deliver_input_available_signal); + sigaction (SIGIO, &action, 0); + } +#endif + +/* Use interrupt input by default, if it works and noninterrupt input + has deficiencies. */ + +#ifdef INTERRUPT_INPUT + interrupt_input = 1; +#else + interrupt_input = 0; +#endif + + pthread_sigmask (SIG_SETMASK, &empty_mask, 0); + dribble = 0; + + if (keyboard_init_hook) + (*keyboard_init_hook) (); + +#ifdef POLL_FOR_INPUT + poll_timer = NULL; + poll_suppress_count = 1; + start_polling (); +#endif +} + +/* This type's only use is in syms_of_keyboard, to put properties on the + event header symbols. */ +struct event_head +{ + short var; + short kind; +}; + +static const struct event_head head_table[] = { + {SYMBOL_INDEX (Qmouse_movement), SYMBOL_INDEX (Qmouse_movement)}, + {SYMBOL_INDEX (Qscroll_bar_movement), SYMBOL_INDEX (Qmouse_movement)}, + + /* Some of the event heads. */ + {SYMBOL_INDEX (Qswitch_frame), SYMBOL_INDEX (Qswitch_frame)}, + + {SYMBOL_INDEX (Qfocus_in), SYMBOL_INDEX (Qfocus_in)}, + {SYMBOL_INDEX (Qfocus_out), SYMBOL_INDEX (Qfocus_out)}, + {SYMBOL_INDEX (Qdelete_frame), SYMBOL_INDEX (Qdelete_frame)}, + {SYMBOL_INDEX (Qiconify_frame), SYMBOL_INDEX (Qiconify_frame)}, + {SYMBOL_INDEX (Qmake_frame_visible), SYMBOL_INDEX (Qmake_frame_visible)}, + /* `select-window' should be handled just like `switch-frame' + in read_key_sequence. */ + {SYMBOL_INDEX (Qselect_window), SYMBOL_INDEX (Qswitch_frame)} +}; + +void +syms_of_keyboard (void) +{ + pending_funcalls = Qnil; + staticpro (&pending_funcalls); + + Vlispy_mouse_stem = build_pure_c_string ("mouse"); + staticpro (&Vlispy_mouse_stem); + + regular_top_level_message = build_pure_c_string ("Back to top level"); +#ifdef HAVE_STACK_OVERFLOW_HANDLING + recover_top_level_message + = build_pure_c_string ("Re-entering top level after C stack overflow"); +#endif + DEFVAR_LISP ("internal--top-level-message", Vinternal__top_level_message, + doc: /* Message displayed by `normal-top-level'. */); + Vinternal__top_level_message = regular_top_level_message; + + /* Tool-bars. */ + DEFSYM (QCimage, ":image"); + DEFSYM (Qhelp_echo, "help-echo"); + DEFSYM (QCrtl, ":rtl"); + + staticpro (&item_properties); + item_properties = Qnil; + + staticpro (&tool_bar_item_properties); + tool_bar_item_properties = Qnil; + staticpro (&tool_bar_items_vector); + tool_bar_items_vector = Qnil; + + DEFSYM (Qtimer_event_handler, "timer-event-handler"); + DEFSYM (Qdisabled_command_function, "disabled-command-function"); + DEFSYM (Qself_insert_command, "self-insert-command"); + DEFSYM (Qforward_char, "forward-char"); + DEFSYM (Qbackward_char, "backward-char"); + + /* Non-nil disable property on a command means do not execute it; + call disabled-command-function's value instead. */ + DEFSYM (Qdisabled, "disabled"); + + DEFSYM (Qundefined, "undefined"); + + /* Hooks to run before and after each command. */ + DEFSYM (Qpre_command_hook, "pre-command-hook"); + DEFSYM (Qpost_command_hook, "post-command-hook"); + + DEFSYM (Qdeferred_action_function, "deferred-action-function"); + DEFSYM (Qdelayed_warnings_hook, "delayed-warnings-hook"); + DEFSYM (Qfunction_key, "function-key"); + + /* The values of Qevent_kind properties. */ + DEFSYM (Qmouse_click, "mouse-click"); + + DEFSYM (Qdrag_n_drop, "drag-n-drop"); + DEFSYM (Qsave_session, "save-session"); + DEFSYM (Qconfig_changed_event, "config-changed-event"); + + /* Menu and tool bar item parts. */ + DEFSYM (Qmenu_enable, "menu-enable"); + +#ifdef HAVE_NTGUI + DEFSYM (Qlanguage_change, "language-change"); +#endif + +#ifdef HAVE_DBUS + DEFSYM (Qdbus_event, "dbus-event"); +#endif + +#ifdef USE_FILE_NOTIFY + DEFSYM (Qfile_notify, "file-notify"); +#endif /* USE_FILE_NOTIFY */ + + /* Menu and tool bar item parts. */ + DEFSYM (QCenable, ":enable"); + DEFSYM (QCvisible, ":visible"); + DEFSYM (QChelp, ":help"); + DEFSYM (QCfilter, ":filter"); + DEFSYM (QCbutton, ":button"); + DEFSYM (QCkeys, ":keys"); + DEFSYM (QCkey_sequence, ":key-sequence"); + + /* Non-nil disable property on a command means + do not execute it; call disabled-command-function's value instead. */ + DEFSYM (QCtoggle, ":toggle"); + DEFSYM (QCradio, ":radio"); + DEFSYM (QClabel, ":label"); + DEFSYM (QCvert_only, ":vert-only"); + + /* Symbols to use for parts of windows. */ + DEFSYM (Qvertical_line, "vertical-line"); + DEFSYM (Qright_divider, "right-divider"); + DEFSYM (Qbottom_divider, "bottom-divider"); + + DEFSYM (Qmouse_fixup_help_message, "mouse-fixup-help-message"); + + DEFSYM (Qabove_handle, "above-handle"); + DEFSYM (Qhandle, "handle"); + DEFSYM (Qbelow_handle, "below-handle"); + DEFSYM (Qup, "up"); + DEFSYM (Qdown, "down"); + DEFSYM (Qtop, "top"); + DEFSYM (Qbottom, "bottom"); + DEFSYM (Qend_scroll, "end-scroll"); + DEFSYM (Qratio, "ratio"); + DEFSYM (Qbefore_handle, "before-handle"); + DEFSYM (Qhorizontal_handle, "horizontal-handle"); + DEFSYM (Qafter_handle, "after-handle"); + DEFSYM (Qleft, "left"); + DEFSYM (Qright, "right"); + DEFSYM (Qleftmost, "leftmost"); + DEFSYM (Qrightmost, "rightmost"); + + /* Properties of event headers. */ + DEFSYM (Qevent_kind, "event-kind"); + DEFSYM (Qevent_symbol_elements, "event-symbol-elements"); + + /* An event header symbol HEAD may have a property named + Qevent_symbol_element_mask, which is of the form (BASE MODIFIERS); + BASE is the base, unmodified version of HEAD, and MODIFIERS is the + mask of modifiers applied to it. If present, this is used to help + speed up parse_modifiers. */ + DEFSYM (Qevent_symbol_element_mask, "event-symbol-element-mask"); + + /* An unmodified event header BASE may have a property named + Qmodifier_cache, which is an alist mapping modifier masks onto + modified versions of BASE. If present, this helps speed up + apply_modifiers. */ + DEFSYM (Qmodifier_cache, "modifier-cache"); + + DEFSYM (Qrecompute_lucid_menubar, "recompute-lucid-menubar"); + DEFSYM (Qactivate_menubar_hook, "activate-menubar-hook"); + + DEFSYM (Qpolling_period, "polling-period"); + + DEFSYM (Qgui_set_selection, "gui-set-selection"); + + /* The primary selection. */ + DEFSYM (QPRIMARY, "PRIMARY"); + + DEFSYM (Qhandle_switch_frame, "handle-switch-frame"); + DEFSYM (Qhandle_select_window, "handle-select-window"); + + DEFSYM (Qinput_method_function, "input-method-function"); + DEFSYM (Qinput_method_exit_on_first_char, "input-method-exit-on-first-char"); + DEFSYM (Qinput_method_use_echo_area, "input-method-use-echo-area"); + + DEFSYM (Qhelp_form_show, "help-form-show"); + + DEFSYM (Qecho_keystrokes, "echo-keystrokes"); + + Fset (Qinput_method_exit_on_first_char, Qnil); + Fset (Qinput_method_use_echo_area, Qnil); + + /* Symbols to head events. */ + DEFSYM (Qmouse_movement, "mouse-movement"); + DEFSYM (Qscroll_bar_movement, "scroll-bar-movement"); + DEFSYM (Qswitch_frame, "switch-frame"); + DEFSYM (Qfocus_in, "focus-in"); + DEFSYM (Qfocus_out, "focus-out"); + DEFSYM (Qdelete_frame, "delete-frame"); + DEFSYM (Qiconify_frame, "iconify-frame"); + DEFSYM (Qmake_frame_visible, "make-frame-visible"); + DEFSYM (Qselect_window, "select-window"); + { + int i; + + for (i = 0; i < ARRAYELTS (head_table); i++) + { + const struct event_head *p = &head_table[i]; + Lisp_Object var = builtin_lisp_symbol (p->var); + Lisp_Object kind = builtin_lisp_symbol (p->kind); + Fput (var, Qevent_kind, kind); + Fput (var, Qevent_symbol_elements, list1 (var)); + } + } + + button_down_location = Fmake_vector (make_number (5), Qnil); + staticpro (&button_down_location); + mouse_syms = Fmake_vector (make_number (5), Qnil); + staticpro (&mouse_syms); + wheel_syms = Fmake_vector (make_number (ARRAYELTS (lispy_wheel_names)), + Qnil); + staticpro (&wheel_syms); + + { + int i; + int len = ARRAYELTS (modifier_names); + + modifier_symbols = Fmake_vector (make_number (len), Qnil); + for (i = 0; i < len; i++) + if (modifier_names[i]) + ASET (modifier_symbols, i, intern_c_string (modifier_names[i])); + staticpro (&modifier_symbols); + } + + recent_keys = Fmake_vector (make_number (NUM_RECENT_KEYS), Qnil); + staticpro (&recent_keys); + + this_command_keys = Fmake_vector (make_number (40), Qnil); + staticpro (&this_command_keys); + + raw_keybuf = Fmake_vector (make_number (30), Qnil); + staticpro (&raw_keybuf); + + DEFSYM (Qcommand_execute, "command-execute"); + + accent_key_syms = Qnil; + staticpro (&accent_key_syms); + + func_key_syms = Qnil; + staticpro (&func_key_syms); + + drag_n_drop_syms = Qnil; + staticpro (&drag_n_drop_syms); + + unread_switch_frame = Qnil; + staticpro (&unread_switch_frame); + + internal_last_event_frame = Qnil; + staticpro (&internal_last_event_frame); + + read_key_sequence_cmd = Qnil; + staticpro (&read_key_sequence_cmd); + read_key_sequence_remapped = Qnil; + staticpro (&read_key_sequence_remapped); + + menu_bar_one_keymap_changed_items = Qnil; + staticpro (&menu_bar_one_keymap_changed_items); + + menu_bar_items_vector = Qnil; + staticpro (&menu_bar_items_vector); + + help_form_saved_window_configs = Qnil; + staticpro (&help_form_saved_window_configs); + + defsubr (&Scurrent_idle_time); + defsubr (&Sevent_symbol_parse_modifiers); + defsubr (&Sevent_convert_list); + defsubr (&Sread_key_sequence); + defsubr (&Sread_key_sequence_vector); + defsubr (&Srecursive_edit); + defsubr (&Strack_mouse); + defsubr (&Sinput_pending_p); + defsubr (&Srecent_keys); + defsubr (&Sthis_command_keys); + defsubr (&Sthis_command_keys_vector); + defsubr (&Sthis_single_command_keys); + defsubr (&Sthis_single_command_raw_keys); + defsubr (&Sreset_this_command_lengths); + defsubr (&Sclear_this_command_keys); + defsubr (&Ssuspend_emacs); + defsubr (&Sabort_recursive_edit); + defsubr (&Sexit_recursive_edit); + defsubr (&Srecursion_depth); + defsubr (&Scommand_error_default_function); + defsubr (&Stop_level); + defsubr (&Sdiscard_input); + defsubr (&Sopen_dribble_file); + defsubr (&Sset_input_interrupt_mode); + defsubr (&Sset_output_flow_control); + defsubr (&Sset_input_meta_mode); + defsubr (&Sset_quit_char); + defsubr (&Sset_input_mode); + defsubr (&Scurrent_input_mode); + defsubr (&Sposn_at_point); + defsubr (&Sposn_at_x_y); + + DEFVAR_LISP ("last-command-event", last_command_event, + doc: /* Last input event that was part of a command. */); + + DEFVAR_LISP ("last-nonmenu-event", last_nonmenu_event, + doc: /* Last input event in a command, except for mouse menu events. +Mouse menus give back keys that don't look like mouse events; +this variable holds the actual mouse event that led to the menu, +so that you can determine whether the command was run by mouse or not. */); + + DEFVAR_LISP ("last-input-event", last_input_event, + doc: /* Last input event. */); + + DEFVAR_LISP ("unread-command-events", Vunread_command_events, + doc: /* List of events to be read as the command input. +These events are processed first, before actual keyboard input. +Events read from this list are not normally added to `this-command-keys', +as they will already have been added once as they were read for the first time. +An element of the form (t . EVENT) forces EVENT to be added to that list. */); + Vunread_command_events = Qnil; + + DEFVAR_LISP ("unread-post-input-method-events", Vunread_post_input_method_events, + doc: /* List of events to be processed as input by input methods. +These events are processed before `unread-command-events' +and actual keyboard input, but are not given to `input-method-function'. */); + Vunread_post_input_method_events = Qnil; + + DEFVAR_LISP ("unread-input-method-events", Vunread_input_method_events, + doc: /* List of events to be processed as input by input methods. +These events are processed after `unread-command-events', but +before actual keyboard input. +If there's an active input method, the events are given to +`input-method-function'. */); + Vunread_input_method_events = Qnil; + + DEFVAR_LISP ("meta-prefix-char", meta_prefix_char, + doc: /* Meta-prefix character code. +Meta-foo as command input turns into this character followed by foo. */); + XSETINT (meta_prefix_char, 033); + + DEFVAR_KBOARD ("last-command", Vlast_command, + doc: /* The last command executed. +Normally a symbol with a function definition, but can be whatever was found +in the keymap, or whatever the variable `this-command' was set to by that +command. + +The value `mode-exit' is special; it means that the previous command +read an event that told it to exit, and it did so and unread that event. +In other words, the present command is the event that made the previous +command exit. + +The value `kill-region' is special; it means that the previous command +was a kill command. + +`last-command' has a separate binding for each terminal device. +See Info node `(elisp)Multiple Terminals'. */); + + DEFVAR_KBOARD ("real-last-command", Vreal_last_command, + doc: /* Same as `last-command', but never altered by Lisp code. +Taken from the previous value of `real-this-command'. */); + + DEFVAR_KBOARD ("last-repeatable-command", Vlast_repeatable_command, + doc: /* Last command that may be repeated. +The last command executed that was not bound to an input event. +This is the command `repeat' will try to repeat. +Taken from a previous value of `real-this-command'. */); + + DEFVAR_LISP ("this-command", Vthis_command, + doc: /* The command now being executed. +The command can set this variable; whatever is put here +will be in `last-command' during the following command. */); + Vthis_command = Qnil; + + DEFVAR_LISP ("real-this-command", Vreal_this_command, + doc: /* This is like `this-command', except that commands should never modify it. */); + Vreal_this_command = Qnil; + + DEFVAR_LISP ("this-command-keys-shift-translated", + Vthis_command_keys_shift_translated, + doc: /* Non-nil if the key sequence activating this command was shift-translated. +Shift-translation occurs when there is no binding for the key sequence +as entered, but a binding was found by changing an upper-case letter +to lower-case, or a shifted function key to an unshifted one. */); + Vthis_command_keys_shift_translated = Qnil; + + DEFVAR_LISP ("this-original-command", Vthis_original_command, + doc: /* The command bound to the current key sequence before remapping. +It equals `this-command' if the original command was not remapped through +any of the active keymaps. Otherwise, the value of `this-command' is the +result of looking up the original command in the active keymaps. */); + Vthis_original_command = Qnil; + + DEFVAR_INT ("auto-save-interval", auto_save_interval, + doc: /* Number of input events between auto-saves. +Zero means disable autosaving due to number of characters typed. */); + auto_save_interval = 300; + + DEFVAR_LISP ("auto-save-timeout", Vauto_save_timeout, + doc: /* Number of seconds idle time before auto-save. +Zero or nil means disable auto-saving due to idleness. +After auto-saving due to this many seconds of idle time, +Emacs also does a garbage collection if that seems to be warranted. */); + XSETFASTINT (Vauto_save_timeout, 30); + + DEFVAR_LISP ("echo-keystrokes", Vecho_keystrokes, + doc: /* Nonzero means echo unfinished commands after this many seconds of pause. +The value may be integer or floating point. +If the value is zero, don't echo at all. */); + Vecho_keystrokes = make_number (1); + + DEFVAR_INT ("polling-period", polling_period, + doc: /* Interval between polling for input during Lisp execution. +The reason for polling is to make C-g work to stop a running program. +Polling is needed only when using X windows and SIGIO does not work. +Polling is automatically disabled in all other cases. */); + polling_period = 2; + + DEFVAR_LISP ("double-click-time", Vdouble_click_time, + doc: /* Maximum time between mouse clicks to make a double-click. +Measured in milliseconds. The value nil means disable double-click +recognition; t means double-clicks have no time limit and are detected +by position only. */); + Vdouble_click_time = make_number (500); + + DEFVAR_INT ("double-click-fuzz", double_click_fuzz, + doc: /* Maximum mouse movement between clicks to make a double-click. +On window-system frames, value is the number of pixels the mouse may have +moved horizontally or vertically between two clicks to make a double-click. +On non window-system frames, value is interpreted in units of 1/8 characters +instead of pixels. + +This variable is also the threshold for motion of the mouse +to count as a drag. */); + double_click_fuzz = 3; + + DEFVAR_INT ("num-input-keys", num_input_keys, + doc: /* Number of complete key sequences read as input so far. +This includes key sequences read from keyboard macros. +The number is effectively the number of interactive command invocations. */); + num_input_keys = 0; + + DEFVAR_INT ("num-nonmacro-input-events", num_nonmacro_input_events, + doc: /* Number of input events read from the keyboard so far. +This does not include events generated by keyboard macros. */); + num_nonmacro_input_events = 0; + + DEFVAR_LISP ("last-event-frame", Vlast_event_frame, + doc: /* The frame in which the most recently read event occurred. +If the last event came from a keyboard macro, this is set to `macro'. */); + Vlast_event_frame = Qnil; + + /* This variable is set up in sysdep.c. */ + DEFVAR_LISP ("tty-erase-char", Vtty_erase_char, + doc: /* The ERASE character as set by the user with stty. */); + + DEFVAR_LISP ("help-char", Vhelp_char, + doc: /* Character to recognize as meaning Help. +When it is read, do `(eval help-form)', and display result if it's a string. +If the value of `help-form' is nil, this char can be read normally. */); + XSETINT (Vhelp_char, Ctl ('H')); + + DEFVAR_LISP ("help-event-list", Vhelp_event_list, + doc: /* List of input events to recognize as meaning Help. +These work just like the value of `help-char' (see that). */); + Vhelp_event_list = Qnil; + + DEFVAR_LISP ("help-form", Vhelp_form, + doc: /* Form to execute when character `help-char' is read. +If the form returns a string, that string is displayed. +If `help-form' is nil, the help char is not recognized. */); + Vhelp_form = Qnil; + + DEFVAR_LISP ("prefix-help-command", Vprefix_help_command, + doc: /* Command to run when `help-char' character follows a prefix key. +This command is used only when there is no actual binding +for that character after that prefix key. */); + Vprefix_help_command = Qnil; + + DEFVAR_LISP ("top-level", Vtop_level, + doc: /* Form to evaluate when Emacs starts up. +Useful to set before you dump a modified Emacs. */); + Vtop_level = Qnil; + XSYMBOL (Qtop_level)->declared_special = false; + + DEFVAR_KBOARD ("keyboard-translate-table", Vkeyboard_translate_table, + doc: /* Translate table for local keyboard input, or nil. +If non-nil, the value should be a char-table. Each character read +from the keyboard is looked up in this char-table. If the value found +there is non-nil, then it is used instead of the actual input character. + +The value can also be a string or vector, but this is considered obsolete. +If it is a string or vector of length N, character codes N and up are left +untranslated. In a vector, an element which is nil means "no translation". + +This is applied to the characters supplied to input methods, not their +output. See also `translation-table-for-input'. + +This variable has a separate binding for each terminal. +See Info node `(elisp)Multiple Terminals'. */); + + DEFVAR_BOOL ("cannot-suspend", cannot_suspend, + doc: /* Non-nil means to always spawn a subshell instead of suspending. +\(Even if the operating system has support for stopping a process.\) */); + cannot_suspend = 0; + + DEFVAR_BOOL ("menu-prompting", menu_prompting, + doc: /* Non-nil means prompt with menus when appropriate. +This is done when reading from a keymap that has a prompt string, +for elements that have prompt strings. +The menu is displayed on the screen +if X menus were enabled at configuration +time and the previous event was a mouse click prefix key. +Otherwise, menu prompting uses the echo area. */); + menu_prompting = 1; + + DEFVAR_LISP ("menu-prompt-more-char", menu_prompt_more_char, + doc: /* Character to see next line of menu prompt. +Type this character while in a menu prompt to rotate around the lines of it. */); + XSETINT (menu_prompt_more_char, ' '); + + DEFVAR_INT ("extra-keyboard-modifiers", extra_keyboard_modifiers, + doc: /* A mask of additional modifier keys to use with every keyboard character. +Emacs applies the modifiers of the character stored here to each keyboard +character it reads. For example, after evaluating the expression + (setq extra-keyboard-modifiers ?\\C-x) +all input characters will have the control modifier applied to them. + +Note that the character ?\\C-@, equivalent to the integer zero, does +not count as a control character; rather, it counts as a character +with no modifiers; thus, setting `extra-keyboard-modifiers' to zero +cancels any modification. */); + extra_keyboard_modifiers = 0; + + DEFSYM (Qdeactivate_mark, "deactivate-mark"); + DEFVAR_LISP ("deactivate-mark", Vdeactivate_mark, + doc: /* If an editing command sets this to t, deactivate the mark afterward. +The command loop sets this to nil before each command, +and tests the value when the command returns. +Buffer modification stores t in this variable. */); + Vdeactivate_mark = Qnil; + Fmake_variable_buffer_local (Qdeactivate_mark); + + DEFVAR_LISP ("pre-command-hook", Vpre_command_hook, + doc: /* Normal hook run before each command is executed. +If an unhandled error happens in running this hook, +the function in which the error occurred is unconditionally removed, since +otherwise the error might happen repeatedly and make Emacs nonfunctional. */); + Vpre_command_hook = Qnil; + + DEFVAR_LISP ("post-command-hook", Vpost_command_hook, + doc: /* Normal hook run after each command is executed. +If an unhandled error happens in running this hook, +the function in which the error occurred is unconditionally removed, since +otherwise the error might happen repeatedly and make Emacs nonfunctional. */); + Vpost_command_hook = Qnil; + +#if 0 + DEFVAR_LISP ("echo-area-clear-hook", ..., + doc: /* Normal hook run when clearing the echo area. */); +#endif + DEFSYM (Qecho_area_clear_hook, "echo-area-clear-hook"); + Fset (Qecho_area_clear_hook, Qnil); + + DEFVAR_LISP ("lucid-menu-bar-dirty-flag", Vlucid_menu_bar_dirty_flag, + doc: /* Non-nil means menu bar, specified Lucid style, needs to be recomputed. */); + Vlucid_menu_bar_dirty_flag = Qnil; + + DEFVAR_LISP ("menu-bar-final-items", Vmenu_bar_final_items, + doc: /* List of menu bar items to move to the end of the menu bar. +The elements of the list are event types that may have menu bar bindings. */); + Vmenu_bar_final_items = Qnil; + + DEFVAR_LISP ("tool-bar-separator-image-expression", Vtool_bar_separator_image_expression, + doc: /* Expression evaluating to the image spec for a tool-bar separator. +This is used internally by graphical displays that do not render +tool-bar separators natively. Otherwise it is unused (e.g. on GTK). */); + Vtool_bar_separator_image_expression = Qnil; + + DEFVAR_KBOARD ("overriding-terminal-local-map", + Voverriding_terminal_local_map, + doc: /* Per-terminal keymap that takes precedence over all other keymaps. +This variable is intended to let commands such as `universal-argument' +set up a different keymap for reading the next command. + +`overriding-terminal-local-map' has a separate binding for each +terminal device. See Info node `(elisp)Multiple Terminals'. */); + + DEFVAR_LISP ("overriding-local-map", Voverriding_local_map, + doc: /* Keymap that replaces (overrides) local keymaps. +If this variable is non-nil, Emacs looks up key bindings in this +keymap INSTEAD OF the keymap char property, minor mode maps, and the +buffer's local map. Hence, the only active keymaps would be +`overriding-terminal-local-map', this keymap, and `global-keymap', in +order of precedence. */); + Voverriding_local_map = Qnil; + + DEFVAR_LISP ("overriding-local-map-menu-flag", Voverriding_local_map_menu_flag, + doc: /* Non-nil means `overriding-local-map' applies to the menu bar. +Otherwise, the menu bar continues to reflect the buffer's local map +and the minor mode maps regardless of `overriding-local-map'. */); + Voverriding_local_map_menu_flag = Qnil; + + DEFVAR_LISP ("special-event-map", Vspecial_event_map, + doc: /* Keymap defining bindings for special events to execute at low level. */); + Vspecial_event_map = list1 (Qkeymap); + + DEFVAR_LISP ("track-mouse", do_mouse_tracking, + doc: /* Non-nil means generate motion events for mouse motion. */); + + DEFVAR_KBOARD ("system-key-alist", Vsystem_key_alist, + doc: /* Alist of system-specific X windows key symbols. +Each element should have the form (N . SYMBOL) where N is the +numeric keysym code (sans the \"system-specific\" bit 1<<28) +and SYMBOL is its name. + +`system-key-alist' has a separate binding for each terminal device. +See Info node `(elisp)Multiple Terminals'. */); + + DEFVAR_KBOARD ("local-function-key-map", Vlocal_function_key_map, + doc: /* Keymap that translates key sequences to key sequences during input. +This is used mainly for mapping key sequences into some preferred +key events (symbols). + +The `read-key-sequence' function replaces any subsequence bound by +`local-function-key-map' with its binding. More precisely, when the +active keymaps have no binding for the current key sequence but +`local-function-key-map' binds a suffix of the sequence to a vector or +string, `read-key-sequence' replaces the matching suffix with its +binding, and continues with the new sequence. + +If the binding is a function, it is called with one argument (the prompt) +and its return value (a key sequence) is used. + +The events that come from bindings in `local-function-key-map' are not +themselves looked up in `local-function-key-map'. + +For example, suppose `local-function-key-map' binds `ESC O P' to [f1]. +Typing `ESC O P' to `read-key-sequence' would return [f1]. Typing +`C-x ESC O P' would return [?\\C-x f1]. If [f1] were a prefix key, +typing `ESC O P x' would return [f1 x]. + +`local-function-key-map' has a separate binding for each terminal +device. See Info node `(elisp)Multiple Terminals'. If you need to +define a binding on all terminals, change `function-key-map' +instead. Initially, `local-function-key-map' is an empty keymap that +has `function-key-map' as its parent on all terminal devices. */); + + DEFVAR_KBOARD ("input-decode-map", Vinput_decode_map, + doc: /* Keymap that decodes input escape sequences. +This is used mainly for mapping ASCII function key sequences into +real Emacs function key events (symbols). + +The `read-key-sequence' function replaces any subsequence bound by +`input-decode-map' with its binding. Contrary to `function-key-map', +this map applies its rebinding regardless of the presence of an ordinary +binding. So it is more like `key-translation-map' except that it applies +before `function-key-map' rather than after. + +If the binding is a function, it is called with one argument (the prompt) +and its return value (a key sequence) is used. + +The events that come from bindings in `input-decode-map' are not +themselves looked up in `input-decode-map'. */); + + DEFVAR_LISP ("function-key-map", Vfunction_key_map, + doc: /* The parent keymap of all `local-function-key-map' instances. +Function key definitions that apply to all terminal devices should go +here. If a mapping is defined in both the current +`local-function-key-map' binding and this variable, then the local +definition will take precedence. */); + Vfunction_key_map = Fmake_sparse_keymap (Qnil); + + DEFVAR_LISP ("key-translation-map", Vkey_translation_map, + doc: /* Keymap of key translations that can override keymaps. +This keymap works like `input-decode-map', but comes after `function-key-map'. +Another difference is that it is global rather than terminal-local. */); + Vkey_translation_map = Fmake_sparse_keymap (Qnil); + + DEFVAR_LISP ("deferred-action-list", Vdeferred_action_list, + doc: /* List of deferred actions to be performed at a later time. +The precise format isn't relevant here; we just check whether it is nil. */); + Vdeferred_action_list = Qnil; + + DEFVAR_LISP ("deferred-action-function", Vdeferred_action_function, + doc: /* Function to call to handle deferred actions, after each command. +This function is called with no arguments after each command +whenever `deferred-action-list' is non-nil. */); + Vdeferred_action_function = Qnil; + + DEFVAR_LISP ("delayed-warnings-list", Vdelayed_warnings_list, + doc: /* List of warnings to be displayed after this command. +Each element must be a list (TYPE MESSAGE [LEVEL [BUFFER-NAME]]), +as per the args of `display-warning' (which see). +If this variable is non-nil, `delayed-warnings-hook' will be run +immediately after running `post-command-hook'. */); + Vdelayed_warnings_list = Qnil; + + DEFVAR_LISP ("timer-list", Vtimer_list, + doc: /* List of active absolute time timers in order of increasing time. */); + Vtimer_list = Qnil; + + DEFVAR_LISP ("timer-idle-list", Vtimer_idle_list, + doc: /* List of active idle-time timers in order of increasing time. */); + Vtimer_idle_list = Qnil; + + DEFVAR_LISP ("input-method-function", Vinput_method_function, + doc: /* If non-nil, the function that implements the current input method. +It's called with one argument, a printing character that was just read. +\(That means a character with code 040...0176.) +Typically this function uses `read-event' to read additional events. +When it does so, it should first bind `input-method-function' to nil +so it will not be called recursively. + +The function should return a list of zero or more events +to be used as input. If it wants to put back some events +to be reconsidered, separately, by the input method, +it can add them to the beginning of `unread-command-events'. + +The input method function can find in `input-method-previous-message' +the previous echo area message. + +The input method function should refer to the variables +`input-method-use-echo-area' and `input-method-exit-on-first-char' +for guidance on what to do. */); + Vinput_method_function = Qlist; + + DEFVAR_LISP ("input-method-previous-message", + Vinput_method_previous_message, + doc: /* When `input-method-function' is called, hold the previous echo area message. +This variable exists because `read-event' clears the echo area +before running the input method. It is nil if there was no message. */); + Vinput_method_previous_message = Qnil; + + DEFVAR_LISP ("show-help-function", Vshow_help_function, + doc: /* If non-nil, the function that implements the display of help. +It's called with one argument, the help string to display. */); + Vshow_help_function = Qnil; + + DEFVAR_LISP ("disable-point-adjustment", Vdisable_point_adjustment, + doc: /* If non-nil, suppress point adjustment after executing a command. + +After a command is executed, if point is moved into a region that has +special properties (e.g. composition, display), we adjust point to +the boundary of the region. But, when a command sets this variable to +non-nil, we suppress the point adjustment. + +This variable is set to nil before reading a command, and is checked +just after executing the command. */); + Vdisable_point_adjustment = Qnil; + + DEFVAR_LISP ("global-disable-point-adjustment", + Vglobal_disable_point_adjustment, + doc: /* If non-nil, always suppress point adjustment. + +The default value is nil, in which case, point adjustment are +suppressed only after special commands that set +`disable-point-adjustment' (which see) to non-nil. */); + Vglobal_disable_point_adjustment = Qnil; + + DEFVAR_LISP ("minibuffer-message-timeout", Vminibuffer_message_timeout, + doc: /* How long to display an echo-area message when the minibuffer is active. +If the value is not a number, such messages don't time out. */); + Vminibuffer_message_timeout = make_number (2); + + DEFVAR_LISP ("throw-on-input", Vthrow_on_input, + doc: /* If non-nil, any keyboard input throws to this symbol. +The value of that variable is passed to `quit-flag' and later causes a +peculiar kind of quitting. */); + Vthrow_on_input = Qnil; + + DEFVAR_LISP ("command-error-function", Vcommand_error_function, + doc: /* Function to output error messages. +Called with three arguments: +- the error data, a list of the form (SIGNALED-CONDITION . SIGNAL-DATA) + such as what `condition-case' would bind its variable to, +- the context (a string which normally goes at the start of the message), +- the Lisp function within which the error was signaled. */); + Vcommand_error_function = intern ("command-error-default-function"); + + DEFVAR_LISP ("enable-disabled-menus-and-buttons", + Venable_disabled_menus_and_buttons, + doc: /* If non-nil, don't ignore events produced by disabled menu items and tool-bar. + +Help functions bind this to allow help on disabled menu items +and tool-bar buttons. */); + Venable_disabled_menus_and_buttons = Qnil; + + DEFVAR_LISP ("select-active-regions", + Vselect_active_regions, + doc: /* If non-nil, an active region automatically sets the primary selection. +If the value is `only', only temporarily active regions (usually made +by mouse-dragging or shift-selection) set the window selection. + +This takes effect only when Transient Mark mode is enabled. */); + Vselect_active_regions = Qt; + + DEFVAR_LISP ("saved-region-selection", + Vsaved_region_selection, + doc: /* Contents of active region prior to buffer modification. +If `select-active-regions' is non-nil, Emacs sets this to the +text in the region before modifying the buffer. The next call to +the function `deactivate-mark' uses this to set the window selection. */); + Vsaved_region_selection = Qnil; + + DEFVAR_LISP ("selection-inhibit-update-commands", + Vselection_inhibit_update_commands, + doc: /* List of commands which should not update the selection. +Normally, if `select-active-regions' is non-nil and the mark remains +active after a command (i.e. the mark was not deactivated), the Emacs +command loop sets the selection to the text in the region. However, +if the command is in this list, the selection is not updated. */); + Vselection_inhibit_update_commands + = list2 (Qhandle_switch_frame, Qhandle_select_window); + + DEFVAR_LISP ("debug-on-event", + Vdebug_on_event, + doc: /* Enter debugger on this event. When Emacs +receives the special event specified by this variable, it will try to +break into the debugger as soon as possible instead of processing the +event normally through `special-event-map'. + +Currently, the only supported values for this +variable are `sigusr1' and `sigusr2'. */); + Vdebug_on_event = intern_c_string ("sigusr2"); + + /* Create the initial keyboard. Qt means 'unset'. */ + initial_kboard = allocate_kboard (Qt); +} + +void +keys_of_keyboard (void) +{ + initial_define_key (global_map, Ctl ('Z'), "suspend-emacs"); + initial_define_key (control_x_map, Ctl ('Z'), "suspend-emacs"); + initial_define_key (meta_map, Ctl ('C'), "exit-recursive-edit"); + initial_define_key (global_map, Ctl (']'), "abort-recursive-edit"); + initial_define_key (meta_map, 'x', "execute-extended-command"); + + initial_define_lispy_key (Vspecial_event_map, "delete-frame", + "handle-delete-frame"); + initial_define_lispy_key (Vspecial_event_map, "ns-put-working-text", + "ns-put-working-text"); + initial_define_lispy_key (Vspecial_event_map, "ns-unput-working-text", + "ns-unput-working-text"); + /* Here we used to use `ignore-event' which would simple set prefix-arg to + current-prefix-arg, as is done in `handle-switch-frame'. + But `handle-switch-frame is not run from the special-map. + Commands from that map are run in a special way that automatically + preserves the prefix-arg. Restoring the prefix arg here is not just + redundant but harmful: + - C-u C-x v = + - current-prefix-arg is set to non-nil, prefix-arg is set to nil. + - after the first prompt, the exit-minibuffer-hook is run which may + iconify a frame and thus push a `iconify-frame' event. + - after running exit-minibuffer-hook, current-prefix-arg is + restored to the non-nil value it had before the prompt. + - we enter the second prompt. + current-prefix-arg is non-nil, prefix-arg is nil. + - before running the first real event, we run the special iconify-frame + event, but we pass the `special' arg to command-execute so + current-prefix-arg and prefix-arg are left untouched. + - here we foolishly copy the non-nil current-prefix-arg to prefix-arg. + - the next key event will have a spuriously non-nil current-prefix-arg. */ + initial_define_lispy_key (Vspecial_event_map, "iconify-frame", + "ignore"); + initial_define_lispy_key (Vspecial_event_map, "make-frame-visible", + "ignore"); + /* Handling it at such a low-level causes read_key_sequence to get + * confused because it doesn't realize that the current_buffer was + * changed by read_char. + * + * initial_define_lispy_key (Vspecial_event_map, "select-window", + * "handle-select-window"); */ + initial_define_lispy_key (Vspecial_event_map, "save-session", + "handle-save-session"); + +#ifdef HAVE_DBUS + /* Define a special event which is raised for dbus callback + functions. */ + initial_define_lispy_key (Vspecial_event_map, "dbus-event", + "dbus-handle-event"); +#endif + +#ifdef USE_FILE_NOTIFY + /* Define a special event which is raised for notification callback + functions. */ + initial_define_lispy_key (Vspecial_event_map, "file-notify", + "file-notify-handle-event"); +#endif /* USE_FILE_NOTIFY */ + + initial_define_lispy_key (Vspecial_event_map, "config-changed-event", + "ignore"); +#if defined (WINDOWSNT) + initial_define_lispy_key (Vspecial_event_map, "language-change", + "ignore"); +#endif + initial_define_lispy_key (Vspecial_event_map, "focus-in", + "handle-focus-in"); + initial_define_lispy_key (Vspecial_event_map, "focus-out", + "handle-focus-out"); +} + +/* Mark the pointers in the kboard objects. + Called by Fgarbage_collect. */ +void +mark_kboards (void) +{ + KBOARD *kb; + Lisp_Object *p; + for (kb = all_kboards; kb; kb = kb->next_kboard) + { + if (kb->kbd_macro_buffer) + for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++) + mark_object (*p); + mark_object (KVAR (kb, Voverriding_terminal_local_map)); + mark_object (KVAR (kb, Vlast_command)); + mark_object (KVAR (kb, Vreal_last_command)); + mark_object (KVAR (kb, Vkeyboard_translate_table)); + mark_object (KVAR (kb, Vlast_repeatable_command)); + mark_object (KVAR (kb, Vprefix_arg)); + mark_object (KVAR (kb, Vlast_prefix_arg)); + mark_object (KVAR (kb, kbd_queue)); + mark_object (KVAR (kb, defining_kbd_macro)); + mark_object (KVAR (kb, Vlast_kbd_macro)); + mark_object (KVAR (kb, Vsystem_key_alist)); + mark_object (KVAR (kb, system_key_syms)); + mark_object (KVAR (kb, Vwindow_system)); + mark_object (KVAR (kb, Vinput_decode_map)); + mark_object (KVAR (kb, Vlocal_function_key_map)); + mark_object (KVAR (kb, Vdefault_minibuffer_frame)); + mark_object (KVAR (kb, echo_string)); + } + { + struct input_event *event; + for (event = kbd_fetch_ptr; event != kbd_store_ptr; event++) + { + if (event == kbd_buffer + KBD_BUFFER_SIZE) + event = kbd_buffer; + /* These two special event types has no Lisp_Objects to mark. */ + if (event->kind != SELECTION_REQUEST_EVENT + && event->kind != SELECTION_CLEAR_EVENT) + { + mark_object (event->x); + mark_object (event->y); + mark_object (event->frame_or_window); + mark_object (event->arg); + } + } + } +} diff --cc test/manual/etags/c-src/emacs/src/lisp.h index 6d34ce3b052,00000000000..0fb068d1a2c mode 100644,000000..100644 --- a/test/manual/etags/c-src/emacs/src/lisp.h +++ b/test/manual/etags/c-src/emacs/src/lisp.h @@@ -1,4817 -1,0 +1,4817 @@@ +/* Fundamental definitions for GNU Emacs Lisp interpreter. + - Copyright (C) 1985-1987, 1993-1995, 1997-2015 Free Software Foundation, ++Copyright (C) 1985-1987, 1993-1995, 1997-2016 Free Software Foundation, +Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef EMACS_LISP_H +#define EMACS_LISP_H + +#include +#include +#include +#include +#include +#include +#include + +#include +#include + +INLINE_HEADER_BEGIN + +/* Define a TYPE constant ID as an externally visible name. Use like this: + + DEFINE_GDB_SYMBOL_BEGIN (TYPE, ID) + # define ID (some integer preprocessor expression of type TYPE) + DEFINE_GDB_SYMBOL_END (ID) + + This hack is for the benefit of compilers that do not make macro + definitions or enums visible to the debugger. It's used for symbols + that .gdbinit needs. */ + +#define DECLARE_GDB_SYM(type, id) type const id EXTERNALLY_VISIBLE +#ifdef MAIN_PROGRAM +# define DEFINE_GDB_SYMBOL_BEGIN(type, id) DECLARE_GDB_SYM (type, id) +# define DEFINE_GDB_SYMBOL_END(id) = id; +#else +# define DEFINE_GDB_SYMBOL_BEGIN(type, id) extern DECLARE_GDB_SYM (type, id) +# define DEFINE_GDB_SYMBOL_END(val) ; +#endif + +/* The ubiquitous max and min macros. */ +#undef min +#undef max +#define max(a, b) ((a) > (b) ? (a) : (b)) +#define min(a, b) ((a) < (b) ? (a) : (b)) + +/* Number of elements in an array. */ +#define ARRAYELTS(arr) (sizeof (arr) / sizeof (arr)[0]) + +/* Number of bits in a Lisp_Object tag. */ +DEFINE_GDB_SYMBOL_BEGIN (int, GCTYPEBITS) +#define GCTYPEBITS 3 +DEFINE_GDB_SYMBOL_END (GCTYPEBITS) + +/* The number of bits needed in an EMACS_INT over and above the number + of bits in a pointer. This is 0 on systems where: + 1. We can specify multiple-of-8 alignment on static variables. + 2. We know malloc returns a multiple of 8. */ +#if (defined alignas \ + && (defined GNU_MALLOC || defined DOUG_LEA_MALLOC || defined __GLIBC__ \ + || defined DARWIN_OS || defined __sun || defined __MINGW32__ \ + || defined CYGWIN)) +# define NONPOINTER_BITS 0 +#else +# define NONPOINTER_BITS GCTYPEBITS +#endif + +/* EMACS_INT - signed integer wide enough to hold an Emacs value + EMACS_INT_MAX - maximum value of EMACS_INT; can be used in #if + pI - printf length modifier for EMACS_INT + EMACS_UINT - unsigned variant of EMACS_INT */ +#ifndef EMACS_INT_MAX +# if INTPTR_MAX <= 0 +# error "INTPTR_MAX misconfigured" +# elif INTPTR_MAX <= INT_MAX >> NONPOINTER_BITS && !defined WIDE_EMACS_INT +typedef int EMACS_INT; +typedef unsigned int EMACS_UINT; +# define EMACS_INT_MAX INT_MAX +# define pI "" +# elif INTPTR_MAX <= LONG_MAX >> NONPOINTER_BITS && !defined WIDE_EMACS_INT +typedef long int EMACS_INT; +typedef unsigned long EMACS_UINT; +# define EMACS_INT_MAX LONG_MAX +# define pI "l" +/* Check versus LLONG_MAX, not LLONG_MAX >> NONPOINTER_BITS. + In theory this is not safe, but in practice it seems to be OK. */ +# elif INTPTR_MAX <= LLONG_MAX +typedef long long int EMACS_INT; +typedef unsigned long long int EMACS_UINT; +# define EMACS_INT_MAX LLONG_MAX +# define pI "ll" +# else +# error "INTPTR_MAX too large" +# endif +#endif + +/* Number of bits to put in each character in the internal representation + of bool vectors. This should not vary across implementations. */ +enum { BOOL_VECTOR_BITS_PER_CHAR = +#define BOOL_VECTOR_BITS_PER_CHAR 8 + BOOL_VECTOR_BITS_PER_CHAR +}; + +/* An unsigned integer type representing a fixed-length bit sequence, + suitable for bool vector words, GC mark bits, etc. Normally it is size_t + for speed, but it is unsigned char on weird platforms. */ +#if BOOL_VECTOR_BITS_PER_CHAR == CHAR_BIT +typedef size_t bits_word; +# define BITS_WORD_MAX SIZE_MAX +enum { BITS_PER_BITS_WORD = CHAR_BIT * sizeof (bits_word) }; +#else +typedef unsigned char bits_word; +# define BITS_WORD_MAX ((1u << BOOL_VECTOR_BITS_PER_CHAR) - 1) +enum { BITS_PER_BITS_WORD = BOOL_VECTOR_BITS_PER_CHAR }; +#endif +verify (BITS_WORD_MAX >> (BITS_PER_BITS_WORD - 1) == 1); + +/* Number of bits in some machine integer types. */ +enum + { + BITS_PER_CHAR = CHAR_BIT, + BITS_PER_SHORT = CHAR_BIT * sizeof (short), + BITS_PER_LONG = CHAR_BIT * sizeof (long int), + BITS_PER_EMACS_INT = CHAR_BIT * sizeof (EMACS_INT) + }; + +/* printmax_t and uprintmax_t are types for printing large integers. + These are the widest integers that are supported for printing. + pMd etc. are conversions for printing them. + On C99 hosts, there's no problem, as even the widest integers work. + Fall back on EMACS_INT on pre-C99 hosts. */ +#ifdef PRIdMAX +typedef intmax_t printmax_t; +typedef uintmax_t uprintmax_t; +# define pMd PRIdMAX +# define pMu PRIuMAX +#else +typedef EMACS_INT printmax_t; +typedef EMACS_UINT uprintmax_t; +# define pMd pI"d" +# define pMu pI"u" +#endif + +/* Use pD to format ptrdiff_t values, which suffice for indexes into + buffers and strings. Emacs never allocates objects larger than + PTRDIFF_MAX bytes, as they cause problems with pointer subtraction. + In C99, pD can always be "t"; configure it here for the sake of + pre-C99 libraries such as glibc 2.0 and Solaris 8. */ +#if PTRDIFF_MAX == INT_MAX +# define pD "" +#elif PTRDIFF_MAX == LONG_MAX +# define pD "l" +#elif PTRDIFF_MAX == LLONG_MAX +# define pD "ll" +#else +# define pD "t" +#endif + +/* Extra internal type checking? */ + +/* Define Emacs versions of 's 'assert (COND)' and 's + 'assume (COND)'. COND should be free of side effects, as it may or + may not be evaluated. + + 'eassert (COND)' checks COND at runtime if ENABLE_CHECKING is + defined and suppress_checking is false, and does nothing otherwise. + Emacs dies if COND is checked and is false. The suppress_checking + variable is initialized to 0 in alloc.c. Set it to 1 using a + debugger to temporarily disable aborting on detected internal + inconsistencies or error conditions. + + In some cases, a good compiler may be able to optimize away the + eassert macro even if ENABLE_CHECKING is true, e.g., if XSTRING (x) + uses eassert to test STRINGP (x), but a particular use of XSTRING + is invoked only after testing that STRINGP (x) is true, making the + test redundant. + + eassume is like eassert except that it also causes the compiler to + assume that COND is true afterwards, regardless of whether runtime + checking is enabled. This can improve performance in some cases, + though it can degrade performance in others. It's often suboptimal + for COND to call external functions or access volatile storage. */ + +#ifndef ENABLE_CHECKING +# define eassert(cond) ((void) (false && (cond))) /* Check COND compiles. */ +# define eassume(cond) assume (cond) +#else /* ENABLE_CHECKING */ + +extern _Noreturn void die (const char *, const char *, int); + +extern bool suppress_checking EXTERNALLY_VISIBLE; + +# define eassert(cond) \ + (suppress_checking || (cond) \ + ? (void) 0 \ + : die (# cond, __FILE__, __LINE__)) +# define eassume(cond) \ + (suppress_checking \ + ? assume (cond) \ + : (cond) \ + ? (void) 0 \ + : die (# cond, __FILE__, __LINE__)) +#endif /* ENABLE_CHECKING */ + + +/* Use the configure flag --enable-check-lisp-object-type to make + Lisp_Object use a struct type instead of the default int. The flag + causes CHECK_LISP_OBJECT_TYPE to be defined. */ + +/***** Select the tagging scheme. *****/ +/* The following option controls the tagging scheme: + - USE_LSB_TAG means that we can assume the least 3 bits of pointers are + always 0, and we can thus use them to hold tag bits, without + restricting our addressing space. + + If ! USE_LSB_TAG, then use the top 3 bits for tagging, thus + restricting our possible address range. + + USE_LSB_TAG not only requires the least 3 bits of pointers returned by + malloc to be 0 but also needs to be able to impose a mult-of-8 alignment + on the few static Lisp_Objects used: lispsym, all the defsubr, and + the two special buffers buffer_defaults and buffer_local_symbols. */ + +enum Lisp_Bits + { + /* 2**GCTYPEBITS. This must be a macro that expands to a literal + integer constant, for MSVC. */ +#define GCALIGNMENT 8 + + /* Number of bits in a Lisp_Object value, not counting the tag. */ + VALBITS = BITS_PER_EMACS_INT - GCTYPEBITS, + + /* Number of bits in a Lisp fixnum tag. */ + INTTYPEBITS = GCTYPEBITS - 1, + + /* Number of bits in a Lisp fixnum value, not counting the tag. */ + FIXNUM_BITS = VALBITS + 1 + }; + +#if GCALIGNMENT != 1 << GCTYPEBITS +# error "GCALIGNMENT and GCTYPEBITS are inconsistent" +#endif + +/* The maximum value that can be stored in a EMACS_INT, assuming all + bits other than the type bits contribute to a nonnegative signed value. + This can be used in #if, e.g., '#if USB_TAG' below expands to an + expression involving VAL_MAX. */ +#define VAL_MAX (EMACS_INT_MAX >> (GCTYPEBITS - 1)) + +/* Whether the least-significant bits of an EMACS_INT contain the tag. + On hosts where pointers-as-ints do not exceed VAL_MAX / 2, USE_LSB_TAG is: + a. unnecessary, because the top bits of an EMACS_INT are unused, and + b. slower, because it typically requires extra masking. + So, USE_LSB_TAG is true only on hosts where it might be useful. */ +DEFINE_GDB_SYMBOL_BEGIN (bool, USE_LSB_TAG) +#define USE_LSB_TAG (VAL_MAX / 2 < INTPTR_MAX) +DEFINE_GDB_SYMBOL_END (USE_LSB_TAG) + +#if !USE_LSB_TAG && !defined WIDE_EMACS_INT +# error "USE_LSB_TAG not supported on this platform; please report this." \ + "Try 'configure --with-wide-int' to work around the problem." +error !; +#endif + +#ifndef alignas +# define alignas(alignment) /* empty */ +# if USE_LSB_TAG +# error "USE_LSB_TAG requires alignas" +# endif +#endif + +#ifdef HAVE_STRUCT_ATTRIBUTE_ALIGNED +# define GCALIGNED __attribute__ ((aligned (GCALIGNMENT))) +#else +# define GCALIGNED /* empty */ +#endif + +/* Some operations are so commonly executed that they are implemented + as macros, not functions, because otherwise runtime performance would + suffer too much when compiling with GCC without optimization. + There's no need to inline everything, just the operations that + would otherwise cause a serious performance problem. + + For each such operation OP, define a macro lisp_h_OP that contains + the operation's implementation. That way, OP can be implemented + via a macro definition like this: + + #define OP(x) lisp_h_OP (x) + + and/or via a function definition like this: + + LISP_MACRO_DEFUN (OP, Lisp_Object, (Lisp_Object x), (x)) + + which macro-expands to this: + + Lisp_Object (OP) (Lisp_Object x) { return lisp_h_OP (x); } + + without worrying about the implementations diverging, since + lisp_h_OP defines the actual implementation. The lisp_h_OP macros + are intended to be private to this include file, and should not be + used elsewhere. + + FIXME: Remove the lisp_h_OP macros, and define just the inline OP + functions, once most developers have access to GCC 4.8 or later and + can use "gcc -Og" to debug. Maybe in the year 2016. See + Bug#11935. + + Commentary for these macros can be found near their corresponding + functions, below. */ + +#if CHECK_LISP_OBJECT_TYPE +# define lisp_h_XLI(o) ((o).i) +# define lisp_h_XIL(i) ((Lisp_Object) { i }) +#else +# define lisp_h_XLI(o) (o) +# define lisp_h_XIL(i) (i) +#endif +#define lisp_h_CHECK_LIST_CONS(x, y) CHECK_TYPE (CONSP (x), Qlistp, y) +#define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x) +#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) +#define lisp_h_CHECK_TYPE(ok, predicate, x) \ + ((ok) ? (void) 0 : (void) wrong_type_argument (predicate, x)) +#define lisp_h_CONSP(x) (XTYPE (x) == Lisp_Cons) +#define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) +#define lisp_h_FLOATP(x) (XTYPE (x) == Lisp_Float) +#define lisp_h_INTEGERP(x) ((XTYPE (x) & (Lisp_Int0 | ~Lisp_Int1)) == Lisp_Int0) +#define lisp_h_MARKERP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Marker) +#define lisp_h_MISCP(x) (XTYPE (x) == Lisp_Misc) +#define lisp_h_NILP(x) EQ (x, Qnil) +#define lisp_h_SET_SYMBOL_VAL(sym, v) \ + (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value = (v)) +#define lisp_h_SYMBOL_CONSTANT_P(sym) (XSYMBOL (sym)->constant) +#define lisp_h_SYMBOL_VAL(sym) \ + (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value) +#define lisp_h_SYMBOLP(x) (XTYPE (x) == Lisp_Symbol) +#define lisp_h_VECTORLIKEP(x) (XTYPE (x) == Lisp_Vectorlike) +#define lisp_h_XCAR(c) XCONS (c)->car +#define lisp_h_XCDR(c) XCONS (c)->u.cdr +#define lisp_h_XCONS(a) \ + (eassert (CONSP (a)), (struct Lisp_Cons *) XUNTAG (a, Lisp_Cons)) +#define lisp_h_XHASH(a) XUINT (a) +#define lisp_h_XPNTR(a) \ + (SYMBOLP (a) ? XSYMBOL (a) : (void *) ((intptr_t) (XLI (a) & VALMASK))) +#ifndef GC_CHECK_CONS_LIST +# define lisp_h_check_cons_list() ((void) 0) +#endif +#if USE_LSB_TAG +# define lisp_h_make_number(n) \ + XIL ((EMACS_INT) (((EMACS_UINT) (n) << INTTYPEBITS) + Lisp_Int0)) +# define lisp_h_XFASTINT(a) XINT (a) +# define lisp_h_XINT(a) (XLI (a) >> INTTYPEBITS) +# define lisp_h_XSYMBOL(a) \ + (eassert (SYMBOLP (a)), \ + (struct Lisp_Symbol *) ((uintptr_t) XLI (a) - Lisp_Symbol \ + + (char *) lispsym)) +# define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK)) +# define lisp_h_XUNTAG(a, type) ((void *) (intptr_t) (XLI (a) - (type))) +#endif + +/* When compiling via gcc -O0, define the key operations as macros, as + Emacs is too slow otherwise. To disable this optimization, compile + with -DINLINING=false. */ +#if (defined __NO_INLINE__ \ + && ! defined __OPTIMIZE__ && ! defined __OPTIMIZE_SIZE__ \ + && ! (defined INLINING && ! INLINING)) +# define XLI(o) lisp_h_XLI (o) +# define XIL(i) lisp_h_XIL (i) +# define CHECK_LIST_CONS(x, y) lisp_h_CHECK_LIST_CONS (x, y) +# define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x) +# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) +# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) +# define CONSP(x) lisp_h_CONSP (x) +# define EQ(x, y) lisp_h_EQ (x, y) +# define FLOATP(x) lisp_h_FLOATP (x) +# define INTEGERP(x) lisp_h_INTEGERP (x) +# define MARKERP(x) lisp_h_MARKERP (x) +# define MISCP(x) lisp_h_MISCP (x) +# define NILP(x) lisp_h_NILP (x) +# define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v) +# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym) +# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym) +# define SYMBOLP(x) lisp_h_SYMBOLP (x) +# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) +# define XCAR(c) lisp_h_XCAR (c) +# define XCDR(c) lisp_h_XCDR (c) +# define XCONS(a) lisp_h_XCONS (a) +# define XHASH(a) lisp_h_XHASH (a) +# define XPNTR(a) lisp_h_XPNTR (a) +# ifndef GC_CHECK_CONS_LIST +# define check_cons_list() lisp_h_check_cons_list () +# endif +# if USE_LSB_TAG +# define make_number(n) lisp_h_make_number (n) +# define XFASTINT(a) lisp_h_XFASTINT (a) +# define XINT(a) lisp_h_XINT (a) +# define XSYMBOL(a) lisp_h_XSYMBOL (a) +# define XTYPE(a) lisp_h_XTYPE (a) +# define XUNTAG(a, type) lisp_h_XUNTAG (a, type) +# endif +#endif + +/* Define NAME as a lisp.h inline function that returns TYPE and has + arguments declared as ARGDECLS and passed as ARGS. ARGDECLS and + ARGS should be parenthesized. Implement the function by calling + lisp_h_NAME ARGS. */ +#define LISP_MACRO_DEFUN(name, type, argdecls, args) \ + INLINE type (name) argdecls { return lisp_h_##name args; } + +/* like LISP_MACRO_DEFUN, except NAME returns void. */ +#define LISP_MACRO_DEFUN_VOID(name, argdecls, args) \ + INLINE void (name) argdecls { lisp_h_##name args; } + + +/* Define the fundamental Lisp data structures. */ + +/* This is the set of Lisp data types. If you want to define a new + data type, read the comments after Lisp_Fwd_Type definition + below. */ + +/* Lisp integers use 2 tags, to give them one extra bit, thus + extending their range from, e.g., -2^28..2^28-1 to -2^29..2^29-1. */ +#define INTMASK (EMACS_INT_MAX >> (INTTYPEBITS - 1)) +#define case_Lisp_Int case Lisp_Int0: case Lisp_Int1 + +/* Idea stolen from GDB. Pedantic GCC complains about enum bitfields, + MSVC doesn't support them, and xlc and Oracle Studio c99 complain + vociferously about them. */ +#if (defined __STRICT_ANSI__ || defined _MSC_VER || defined __IBMC__ \ + || (defined __SUNPRO_C && __STDC__)) +#define ENUM_BF(TYPE) unsigned int +#else +#define ENUM_BF(TYPE) enum TYPE +#endif + + +enum Lisp_Type + { + /* Symbol. XSYMBOL (object) points to a struct Lisp_Symbol. */ + Lisp_Symbol = 0, + + /* Miscellaneous. XMISC (object) points to a union Lisp_Misc, + whose first member indicates the subtype. */ + Lisp_Misc = 1, + + /* Integer. XINT (obj) is the integer value. */ + Lisp_Int0 = 2, + Lisp_Int1 = USE_LSB_TAG ? 6 : 3, + + /* String. XSTRING (object) points to a struct Lisp_String. + The length of the string, and its contents, are stored therein. */ + Lisp_String = 4, + + /* Vector of Lisp objects, or something resembling it. + XVECTOR (object) points to a struct Lisp_Vector, which contains + the size and contents. The size field also contains the type + information, if it's not a real vector object. */ + Lisp_Vectorlike = 5, + + /* Cons. XCONS (object) points to a struct Lisp_Cons. */ + Lisp_Cons = USE_LSB_TAG ? 3 : 6, + + Lisp_Float = 7 + }; + +/* This is the set of data types that share a common structure. + The first member of the structure is a type code from this set. + The enum values are arbitrary, but we'll use large numbers to make it + more likely that we'll spot the error if a random word in memory is + mistakenly interpreted as a Lisp_Misc. */ +enum Lisp_Misc_Type + { + Lisp_Misc_Free = 0x5eab, + Lisp_Misc_Marker, + Lisp_Misc_Overlay, + Lisp_Misc_Save_Value, + Lisp_Misc_Finalizer, + /* Currently floats are not a misc type, + but let's define this in case we want to change that. */ + Lisp_Misc_Float, + /* This is not a type code. It is for range checking. */ + Lisp_Misc_Limit + }; + +/* These are the types of forwarding objects used in the value slot + of symbols for special built-in variables whose value is stored in + C variables. */ +enum Lisp_Fwd_Type + { + Lisp_Fwd_Int, /* Fwd to a C `int' variable. */ + Lisp_Fwd_Bool, /* Fwd to a C boolean var. */ + Lisp_Fwd_Obj, /* Fwd to a C Lisp_Object variable. */ + Lisp_Fwd_Buffer_Obj, /* Fwd to a Lisp_Object field of buffers. */ + Lisp_Fwd_Kboard_Obj /* Fwd to a Lisp_Object field of kboards. */ + }; + +/* If you want to define a new Lisp data type, here are some + instructions. See the thread at + http://lists.gnu.org/archive/html/emacs-devel/2012-10/msg00561.html + for more info. + + First, there are already a couple of Lisp types that can be used if + your new type does not need to be exposed to Lisp programs nor + displayed to users. These are Lisp_Save_Value, a Lisp_Misc + subtype; and PVEC_OTHER, a kind of vectorlike object. The former + is suitable for temporarily stashing away pointers and integers in + a Lisp object. The latter is useful for vector-like Lisp objects + that need to be used as part of other objects, but which are never + shown to users or Lisp code (search for PVEC_OTHER in xterm.c for + an example). + + These two types don't look pretty when printed, so they are + unsuitable for Lisp objects that can be exposed to users. + + To define a new data type, add one more Lisp_Misc subtype or one + more pseudovector subtype. Pseudovectors are more suitable for + objects with several slots that need to support fast random access, + while Lisp_Misc types are for everything else. A pseudovector object + provides one or more slots for Lisp objects, followed by struct + members that are accessible only from C. A Lisp_Misc object is a + wrapper for a C struct that can contain anything you like. + + Explicit freeing is discouraged for Lisp objects in general. But if + you really need to exploit this, use Lisp_Misc (check free_misc in + alloc.c to see why). There is no way to free a vectorlike object. + + To add a new pseudovector type, extend the pvec_type enumeration; + to add a new Lisp_Misc, extend the Lisp_Misc_Type enumeration. + + For a Lisp_Misc, you will also need to add your entry to union + Lisp_Misc (but make sure the first word has the same structure as + the others, starting with a 16-bit member of the Lisp_Misc_Type + enumeration and a 1-bit GC markbit) and make sure the overall size + of the union is not increased by your addition. + + For a new pseudovector, it's highly desirable to limit the size + of your data type by VBLOCK_BYTES_MAX bytes (defined in alloc.c). + Otherwise you will need to change sweep_vectors (also in alloc.c). + + Then you will need to add switch branches in print.c (in + print_object, to print your object, and possibly also in + print_preprocess) and to alloc.c, to mark your object (in + mark_object) and to free it (in gc_sweep). The latter is also the + right place to call any code specific to your data type that needs + to run when the object is recycled -- e.g., free any additional + resources allocated for it that are not Lisp objects. You can even + make a pointer to the function that frees the resources a slot in + your object -- this way, the same object could be used to represent + several disparate C structures. */ + +#ifdef CHECK_LISP_OBJECT_TYPE + +typedef struct { EMACS_INT i; } Lisp_Object; + +#define LISP_INITIALLY(i) {i} + +#undef CHECK_LISP_OBJECT_TYPE +enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true }; +#else /* CHECK_LISP_OBJECT_TYPE */ + +/* If a struct type is not wanted, define Lisp_Object as just a number. */ + +typedef EMACS_INT Lisp_Object; +#define LISP_INITIALLY(i) (i) +enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false }; +#endif /* CHECK_LISP_OBJECT_TYPE */ + +#define LISP_INITIALLY_ZERO LISP_INITIALLY (0) + +/* Forward declarations. */ + +/* Defined in this file. */ +union Lisp_Fwd; +INLINE bool BOOL_VECTOR_P (Lisp_Object); +INLINE bool BUFFER_OBJFWDP (union Lisp_Fwd *); +INLINE bool BUFFERP (Lisp_Object); +INLINE bool CHAR_TABLE_P (Lisp_Object); +INLINE Lisp_Object CHAR_TABLE_REF_ASCII (Lisp_Object, ptrdiff_t); +INLINE bool (CONSP) (Lisp_Object); +INLINE bool (FLOATP) (Lisp_Object); +INLINE bool functionp (Lisp_Object); +INLINE bool (INTEGERP) (Lisp_Object); +INLINE bool (MARKERP) (Lisp_Object); +INLINE bool (MISCP) (Lisp_Object); +INLINE bool (NILP) (Lisp_Object); +INLINE bool OVERLAYP (Lisp_Object); +INLINE bool PROCESSP (Lisp_Object); +INLINE bool PSEUDOVECTORP (Lisp_Object, int); +INLINE bool SAVE_VALUEP (Lisp_Object); +INLINE bool FINALIZERP (Lisp_Object); +INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t, + Lisp_Object); +INLINE bool STRINGP (Lisp_Object); +INLINE bool SUB_CHAR_TABLE_P (Lisp_Object); +INLINE bool SUBRP (Lisp_Object); +INLINE bool (SYMBOLP) (Lisp_Object); +INLINE bool (VECTORLIKEP) (Lisp_Object); +INLINE bool WINDOWP (Lisp_Object); +INLINE bool TERMINALP (Lisp_Object); +INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object); +INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object); +INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object); +INLINE void *(XUNTAG) (Lisp_Object, int); + +/* Defined in chartab.c. */ +extern Lisp_Object char_table_ref (Lisp_Object, int); +extern void char_table_set (Lisp_Object, int, Lisp_Object); + +/* Defined in data.c. */ +extern _Noreturn Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object); +extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object); + +/* Defined in emacs.c. */ +extern bool might_dump; +/* True means Emacs has already been initialized. + Used during startup to detect startup of dumped Emacs. */ +extern bool initialized; + +/* Defined in floatfns.c. */ +extern double extract_float (Lisp_Object); + + +/* Interned state of a symbol. */ + +enum symbol_interned +{ + SYMBOL_UNINTERNED = 0, + SYMBOL_INTERNED = 1, + SYMBOL_INTERNED_IN_INITIAL_OBARRAY = 2 +}; + +enum symbol_redirect +{ + SYMBOL_PLAINVAL = 4, + SYMBOL_VARALIAS = 1, + SYMBOL_LOCALIZED = 2, + SYMBOL_FORWARDED = 3 +}; + +struct Lisp_Symbol +{ + bool_bf gcmarkbit : 1; + + /* Indicates where the value can be found: + 0 : it's a plain var, the value is in the `value' field. + 1 : it's a varalias, the value is really in the `alias' symbol. + 2 : it's a localized var, the value is in the `blv' object. + 3 : it's a forwarding variable, the value is in `forward'. */ + ENUM_BF (symbol_redirect) redirect : 3; + + /* Non-zero means symbol is constant, i.e. changing its value + should signal an error. If the value is 3, then the var + can be changed, but only by `defconst'. */ + unsigned constant : 2; + + /* Interned state of the symbol. This is an enumerator from + enum symbol_interned. */ + unsigned interned : 2; + + /* True means that this variable has been explicitly declared + special (with `defvar' etc), and shouldn't be lexically bound. */ + bool_bf declared_special : 1; + + /* True if pointed to from purespace and hence can't be GC'd. */ + bool_bf pinned : 1; + + /* The symbol's name, as a Lisp string. */ + Lisp_Object name; + + /* Value of the symbol or Qunbound if unbound. Which alternative of the + union is used depends on the `redirect' field above. */ + union { + Lisp_Object value; + struct Lisp_Symbol *alias; + struct Lisp_Buffer_Local_Value *blv; + union Lisp_Fwd *fwd; + } val; + + /* Function value of the symbol or Qnil if not fboundp. */ + Lisp_Object function; + + /* The symbol's property list. */ + Lisp_Object plist; + + /* Next symbol in obarray bucket, if the symbol is interned. */ + struct Lisp_Symbol *next; +}; + +/* Declare a Lisp-callable function. The MAXARGS parameter has the same + meaning as in the DEFUN macro, and is used to construct a prototype. */ +/* We can use the same trick as in the DEFUN macro to generate the + appropriate prototype. */ +#define EXFUN(fnname, maxargs) \ + extern Lisp_Object fnname DEFUN_ARGS_ ## maxargs + +/* Note that the weird token-substitution semantics of ANSI C makes + this work for MANY and UNEVALLED. */ +#define DEFUN_ARGS_MANY (ptrdiff_t, Lisp_Object *) +#define DEFUN_ARGS_UNEVALLED (Lisp_Object) +#define DEFUN_ARGS_0 (void) +#define DEFUN_ARGS_1 (Lisp_Object) +#define DEFUN_ARGS_2 (Lisp_Object, Lisp_Object) +#define DEFUN_ARGS_3 (Lisp_Object, Lisp_Object, Lisp_Object) +#define DEFUN_ARGS_4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) +#define DEFUN_ARGS_5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \ + Lisp_Object) +#define DEFUN_ARGS_6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \ + Lisp_Object, Lisp_Object) +#define DEFUN_ARGS_7 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \ + Lisp_Object, Lisp_Object, Lisp_Object) +#define DEFUN_ARGS_8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \ + Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) + +/* Yield an integer that contains TAG along with PTR. */ +#define TAG_PTR(tag, ptr) \ + ((USE_LSB_TAG ? (tag) : (EMACS_UINT) (tag) << VALBITS) + (uintptr_t) (ptr)) + +/* Yield an integer that contains a symbol tag along with OFFSET. + OFFSET should be the offset in bytes from 'lispsym' to the symbol. */ +#define TAG_SYMOFFSET(offset) \ + TAG_PTR (Lisp_Symbol, \ + ((uintptr_t) (offset) >> (USE_LSB_TAG ? 0 : GCTYPEBITS))) + +/* XLI_BUILTIN_LISPSYM (iQwhatever) is equivalent to + XLI (builtin_lisp_symbol (Qwhatever)), + except the former expands to an integer constant expression. */ +#define XLI_BUILTIN_LISPSYM(iname) TAG_SYMOFFSET ((iname) * sizeof *lispsym) + +/* Declare extern constants for Lisp symbols. These can be helpful + when using a debugger like GDB, on older platforms where the debug + format does not represent C macros. */ +#define DEFINE_LISP_SYMBOL(name) \ + DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ + DEFINE_GDB_SYMBOL_END (LISP_INITIALLY (XLI_BUILTIN_LISPSYM (i##name))) + +/* By default, define macros for Qt, etc., as this leads to a bit + better performance in the core Emacs interpreter. A plugin can + define DEFINE_NON_NIL_Q_SYMBOL_MACROS to be false, to be portable to + other Emacs instances that assign different values to Qt, etc. */ +#ifndef DEFINE_NON_NIL_Q_SYMBOL_MACROS +# define DEFINE_NON_NIL_Q_SYMBOL_MACROS true +#endif + +#include "globals.h" + +/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa. + At the machine level, these operations are no-ops. */ +LISP_MACRO_DEFUN (XLI, EMACS_INT, (Lisp_Object o), (o)) +LISP_MACRO_DEFUN (XIL, Lisp_Object, (EMACS_INT i), (i)) + +/* In the size word of a vector, this bit means the vector has been marked. */ + +DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, ARRAY_MARK_FLAG) +# define ARRAY_MARK_FLAG PTRDIFF_MIN +DEFINE_GDB_SYMBOL_END (ARRAY_MARK_FLAG) + +/* In the size word of a struct Lisp_Vector, this bit means it's really + some other vector-like object. */ +DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, PSEUDOVECTOR_FLAG) +# define PSEUDOVECTOR_FLAG (PTRDIFF_MAX - PTRDIFF_MAX / 2) +DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG) + +/* In a pseudovector, the size field actually contains a word with one + PSEUDOVECTOR_FLAG bit set, and one of the following values extracted + with PVEC_TYPE_MASK to indicate the actual type. */ +enum pvec_type +{ + PVEC_NORMAL_VECTOR, + PVEC_FREE, + PVEC_PROCESS, + PVEC_FRAME, + PVEC_WINDOW, + PVEC_BOOL_VECTOR, + PVEC_BUFFER, + PVEC_HASH_TABLE, + PVEC_TERMINAL, + PVEC_WINDOW_CONFIGURATION, + PVEC_SUBR, + PVEC_OTHER, + /* These should be last, check internal_equal to see why. */ + PVEC_COMPILED, + PVEC_CHAR_TABLE, + PVEC_SUB_CHAR_TABLE, + PVEC_FONT /* Should be last because it's used for range checking. */ +}; + +enum More_Lisp_Bits + { + /* For convenience, we also store the number of elements in these bits. + Note that this size is not necessarily the memory-footprint size, but + only the number of Lisp_Object fields (that need to be traced by GC). + The distinction is used, e.g., by Lisp_Process, which places extra + non-Lisp_Object fields at the end of the structure. */ + PSEUDOVECTOR_SIZE_BITS = 12, + PSEUDOVECTOR_SIZE_MASK = (1 << PSEUDOVECTOR_SIZE_BITS) - 1, + + /* To calculate the memory footprint of the pseudovector, it's useful + to store the size of non-Lisp area in word_size units here. */ + PSEUDOVECTOR_REST_BITS = 12, + PSEUDOVECTOR_REST_MASK = (((1 << PSEUDOVECTOR_REST_BITS) - 1) + << PSEUDOVECTOR_SIZE_BITS), + + /* Used to extract pseudovector subtype information. */ + PSEUDOVECTOR_AREA_BITS = PSEUDOVECTOR_SIZE_BITS + PSEUDOVECTOR_REST_BITS, + PVEC_TYPE_MASK = 0x3f << PSEUDOVECTOR_AREA_BITS + }; + +/* These functions extract various sorts of values from a Lisp_Object. + For example, if tem is a Lisp_Object whose type is Lisp_Cons, + XCONS (tem) is the struct Lisp_Cons * pointing to the memory for + that cons. */ + +/* Mask for the value (as opposed to the type bits) of a Lisp object. */ +DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK) +# define VALMASK (USE_LSB_TAG ? - (1 << GCTYPEBITS) : VAL_MAX) +DEFINE_GDB_SYMBOL_END (VALMASK) + +/* Largest and smallest representable fixnum values. These are the C + values. They are macros for use in static initializers. */ +#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) +#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) + +#if USE_LSB_TAG + +LISP_MACRO_DEFUN (make_number, Lisp_Object, (EMACS_INT n), (n)) +LISP_MACRO_DEFUN (XINT, EMACS_INT, (Lisp_Object a), (a)) +LISP_MACRO_DEFUN (XFASTINT, EMACS_INT, (Lisp_Object a), (a)) +LISP_MACRO_DEFUN (XSYMBOL, struct Lisp_Symbol *, (Lisp_Object a), (a)) +LISP_MACRO_DEFUN (XTYPE, enum Lisp_Type, (Lisp_Object a), (a)) +LISP_MACRO_DEFUN (XUNTAG, void *, (Lisp_Object a, int type), (a, type)) + +#else /* ! USE_LSB_TAG */ + +/* Although compiled only if ! USE_LSB_TAG, the following functions + also work when USE_LSB_TAG; this is to aid future maintenance when + the lisp_h_* macros are eventually removed. */ + +/* Make a Lisp integer representing the value of the low order + bits of N. */ +INLINE Lisp_Object +make_number (EMACS_INT n) +{ + EMACS_INT int0 = Lisp_Int0; + if (USE_LSB_TAG) + { + EMACS_UINT u = n; + n = u << INTTYPEBITS; + n += int0; + } + else + { + n &= INTMASK; + n += (int0 << VALBITS); + } + return XIL (n); +} + +/* Extract A's value as a signed integer. */ +INLINE EMACS_INT +XINT (Lisp_Object a) +{ + EMACS_INT i = XLI (a); + if (! USE_LSB_TAG) + { + EMACS_UINT u = i; + i = u << INTTYPEBITS; + } + return i >> INTTYPEBITS; +} + +/* Like XINT (A), but may be faster. A must be nonnegative. + If ! USE_LSB_TAG, this takes advantage of the fact that Lisp + integers have zero-bits in their tags. */ +INLINE EMACS_INT +XFASTINT (Lisp_Object a) +{ + EMACS_INT int0 = Lisp_Int0; + EMACS_INT n = USE_LSB_TAG ? XINT (a) : XLI (a) - (int0 << VALBITS); + eassert (0 <= n); + return n; +} + +/* Extract A's value as a symbol. */ +INLINE struct Lisp_Symbol * +XSYMBOL (Lisp_Object a) +{ + uintptr_t i = (uintptr_t) XUNTAG (a, Lisp_Symbol); + if (! USE_LSB_TAG) + i <<= GCTYPEBITS; + void *p = (char *) lispsym + i; + return p; +} + +/* Extract A's type. */ +INLINE enum Lisp_Type +XTYPE (Lisp_Object a) +{ + EMACS_UINT i = XLI (a); + return USE_LSB_TAG ? i & ~VALMASK : i >> VALBITS; +} + +/* Extract A's pointer value, assuming A's type is TYPE. */ +INLINE void * +XUNTAG (Lisp_Object a, int type) +{ + intptr_t i = USE_LSB_TAG ? XLI (a) - type : XLI (a) & VALMASK; + return (void *) i; +} + +#endif /* ! USE_LSB_TAG */ + +/* Extract the pointer hidden within A. */ +LISP_MACRO_DEFUN (XPNTR, void *, (Lisp_Object a), (a)) + +/* Extract A's value as an unsigned integer. */ +INLINE EMACS_UINT +XUINT (Lisp_Object a) +{ + EMACS_UINT i = XLI (a); + return USE_LSB_TAG ? i >> INTTYPEBITS : i & INTMASK; +} + +/* Return A's (Lisp-integer sized) hash. Happens to be like XUINT + right now, but XUINT should only be applied to objects we know are + integers. */ +LISP_MACRO_DEFUN (XHASH, EMACS_INT, (Lisp_Object a), (a)) + +/* Like make_number (N), but may be faster. N must be in nonnegative range. */ +INLINE Lisp_Object +make_natnum (EMACS_INT n) +{ + eassert (0 <= n && n <= MOST_POSITIVE_FIXNUM); + EMACS_INT int0 = Lisp_Int0; + return USE_LSB_TAG ? make_number (n) : XIL (n + (int0 << VALBITS)); +} + +/* Return true if X and Y are the same object. */ +LISP_MACRO_DEFUN (EQ, bool, (Lisp_Object x, Lisp_Object y), (x, y)) + +/* Value is true if I doesn't fit into a Lisp fixnum. It is + written this way so that it also works if I is of unsigned + type or if I is a NaN. */ + +#define FIXNUM_OVERFLOW_P(i) \ + (! ((0 <= (i) || MOST_NEGATIVE_FIXNUM <= (i)) && (i) <= MOST_POSITIVE_FIXNUM)) + +INLINE ptrdiff_t +clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) +{ + return num < lower ? lower : num <= upper ? num : upper; +} + + +/* Extract a value or address from a Lisp_Object. */ + +LISP_MACRO_DEFUN (XCONS, struct Lisp_Cons *, (Lisp_Object a), (a)) + +INLINE struct Lisp_Vector * +XVECTOR (Lisp_Object a) +{ + eassert (VECTORLIKEP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct Lisp_String * +XSTRING (Lisp_Object a) +{ + eassert (STRINGP (a)); + return XUNTAG (a, Lisp_String); +} + +/* The index of the C-defined Lisp symbol SYM. + This can be used in a static initializer. */ +#define SYMBOL_INDEX(sym) i##sym + +INLINE struct Lisp_Float * +XFLOAT (Lisp_Object a) +{ + eassert (FLOATP (a)); + return XUNTAG (a, Lisp_Float); +} + +/* Pseudovector types. */ + +INLINE struct Lisp_Process * +XPROCESS (Lisp_Object a) +{ + eassert (PROCESSP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct window * +XWINDOW (Lisp_Object a) +{ + eassert (WINDOWP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct terminal * +XTERMINAL (Lisp_Object a) +{ + eassert (TERMINALP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct Lisp_Subr * +XSUBR (Lisp_Object a) +{ + eassert (SUBRP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct buffer * +XBUFFER (Lisp_Object a) +{ + eassert (BUFFERP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct Lisp_Char_Table * +XCHAR_TABLE (Lisp_Object a) +{ + eassert (CHAR_TABLE_P (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct Lisp_Sub_Char_Table * +XSUB_CHAR_TABLE (Lisp_Object a) +{ + eassert (SUB_CHAR_TABLE_P (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE struct Lisp_Bool_Vector * +XBOOL_VECTOR (Lisp_Object a) +{ + eassert (BOOL_VECTOR_P (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +/* Construct a Lisp_Object from a value or address. */ + +INLINE Lisp_Object +make_lisp_ptr (void *ptr, enum Lisp_Type type) +{ + Lisp_Object a = XIL (TAG_PTR (type, ptr)); + eassert (XTYPE (a) == type && XUNTAG (a, type) == ptr); + return a; +} + +INLINE Lisp_Object +make_lisp_symbol (struct Lisp_Symbol *sym) +{ + Lisp_Object a = XIL (TAG_SYMOFFSET ((char *) sym - (char *) lispsym)); + eassert (XSYMBOL (a) == sym); + return a; +} + +INLINE Lisp_Object +builtin_lisp_symbol (int index) +{ + return make_lisp_symbol (lispsym + index); +} + +#define XSETINT(a, b) ((a) = make_number (b)) +#define XSETFASTINT(a, b) ((a) = make_natnum (b)) +#define XSETCONS(a, b) ((a) = make_lisp_ptr (b, Lisp_Cons)) +#define XSETVECTOR(a, b) ((a) = make_lisp_ptr (b, Lisp_Vectorlike)) +#define XSETSTRING(a, b) ((a) = make_lisp_ptr (b, Lisp_String)) +#define XSETSYMBOL(a, b) ((a) = make_lisp_symbol (b)) +#define XSETFLOAT(a, b) ((a) = make_lisp_ptr (b, Lisp_Float)) +#define XSETMISC(a, b) ((a) = make_lisp_ptr (b, Lisp_Misc)) + +/* Pseudovector types. */ + +#define XSETPVECTYPE(v, code) \ + ((v)->header.size |= PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS)) +#define XSETPVECTYPESIZE(v, code, lispsize, restsize) \ + ((v)->header.size = (PSEUDOVECTOR_FLAG \ + | ((code) << PSEUDOVECTOR_AREA_BITS) \ + | ((restsize) << PSEUDOVECTOR_SIZE_BITS) \ + | (lispsize))) + +/* The cast to struct vectorlike_header * avoids aliasing issues. */ +#define XSETPSEUDOVECTOR(a, b, code) \ + XSETTYPED_PSEUDOVECTOR (a, b, \ + (((struct vectorlike_header *) \ + XUNTAG (a, Lisp_Vectorlike)) \ + ->size), \ + code) +#define XSETTYPED_PSEUDOVECTOR(a, b, size, code) \ + (XSETVECTOR (a, b), \ + eassert ((size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \ + == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS)))) + +#define XSETWINDOW_CONFIGURATION(a, b) \ + (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW_CONFIGURATION)) +#define XSETPROCESS(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_PROCESS)) +#define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) +#define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL)) +#define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) +#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED)) +#define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) +#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) +#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) +#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)) + +/* Efficiently convert a pointer to a Lisp object and back. The + pointer is represented as a Lisp integer, so the garbage collector + does not know about it. The pointer should not have both Lisp_Int1 + bits set, which makes this conversion inherently unportable. */ + +INLINE void * +XINTPTR (Lisp_Object a) +{ + return XUNTAG (a, Lisp_Int0); +} + +INLINE Lisp_Object +make_pointer_integer (void *p) +{ + Lisp_Object a = XIL (TAG_PTR (Lisp_Int0, p)); + eassert (INTEGERP (a) && XINTPTR (a) == p); + return a; +} + +/* Type checking. */ + +LISP_MACRO_DEFUN_VOID (CHECK_TYPE, + (int ok, Lisp_Object predicate, Lisp_Object x), + (ok, predicate, x)) + +/* See the macros in intervals.h. */ + +typedef struct interval *INTERVAL; + +struct GCALIGNED Lisp_Cons + { + /* Car of this cons cell. */ + Lisp_Object car; + + union + { + /* Cdr of this cons cell. */ + Lisp_Object cdr; + + /* Used to chain conses on a free list. */ + struct Lisp_Cons *chain; + } u; + }; + +/* Take the car or cdr of something known to be a cons cell. */ +/* The _addr functions shouldn't be used outside of the minimal set + of code that has to know what a cons cell looks like. Other code not + part of the basic lisp implementation should assume that the car and cdr + fields are not accessible. (What if we want to switch to + a copying collector someday? Cached cons cell field addresses may be + invalidated at arbitrary points.) */ +INLINE Lisp_Object * +xcar_addr (Lisp_Object c) +{ + return &XCONS (c)->car; +} +INLINE Lisp_Object * +xcdr_addr (Lisp_Object c) +{ + return &XCONS (c)->u.cdr; +} + +/* Use these from normal code. */ +LISP_MACRO_DEFUN (XCAR, Lisp_Object, (Lisp_Object c), (c)) +LISP_MACRO_DEFUN (XCDR, Lisp_Object, (Lisp_Object c), (c)) + +/* Use these to set the fields of a cons cell. + + Note that both arguments may refer to the same object, so 'n' + should not be read after 'c' is first modified. */ +INLINE void +XSETCAR (Lisp_Object c, Lisp_Object n) +{ + *xcar_addr (c) = n; +} +INLINE void +XSETCDR (Lisp_Object c, Lisp_Object n) +{ + *xcdr_addr (c) = n; +} + +/* Take the car or cdr of something whose type is not known. */ +INLINE Lisp_Object +CAR (Lisp_Object c) +{ + return (CONSP (c) ? XCAR (c) + : NILP (c) ? Qnil + : wrong_type_argument (Qlistp, c)); +} +INLINE Lisp_Object +CDR (Lisp_Object c) +{ + return (CONSP (c) ? XCDR (c) + : NILP (c) ? Qnil + : wrong_type_argument (Qlistp, c)); +} + +/* Take the car or cdr of something whose type is not known. */ +INLINE Lisp_Object +CAR_SAFE (Lisp_Object c) +{ + return CONSP (c) ? XCAR (c) : Qnil; +} +INLINE Lisp_Object +CDR_SAFE (Lisp_Object c) +{ + return CONSP (c) ? XCDR (c) : Qnil; +} + +/* In a string or vector, the sign bit of the `size' is the gc mark bit. */ + +struct GCALIGNED Lisp_String + { + ptrdiff_t size; + ptrdiff_t size_byte; + INTERVAL intervals; /* Text properties in this string. */ + unsigned char *data; + }; + +/* True if STR is a multibyte string. */ +INLINE bool +STRING_MULTIBYTE (Lisp_Object str) +{ + return 0 <= XSTRING (str)->size_byte; +} + +/* An upper bound on the number of bytes in a Lisp string, not + counting the terminating null. This a tight enough bound to + prevent integer overflow errors that would otherwise occur during + string size calculations. A string cannot contain more bytes than + a fixnum can represent, nor can it be so long that C pointer + arithmetic stops working on the string plus its terminating null. + Although the actual size limit (see STRING_BYTES_MAX in alloc.c) + may be a bit smaller than STRING_BYTES_BOUND, calculating it here + would expose alloc.c internal details that we'd rather keep + private. + + This is a macro for use in static initializers. The cast to + ptrdiff_t ensures that the macro is signed. */ +#define STRING_BYTES_BOUND \ + ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, min (SIZE_MAX, PTRDIFF_MAX) - 1)) + +/* Mark STR as a unibyte string. */ +#define STRING_SET_UNIBYTE(STR) \ + do { \ + if (EQ (STR, empty_multibyte_string)) \ + (STR) = empty_unibyte_string; \ + else \ + XSTRING (STR)->size_byte = -1; \ + } while (false) + +/* Mark STR as a multibyte string. Assure that STR contains only + ASCII characters in advance. */ +#define STRING_SET_MULTIBYTE(STR) \ + do { \ + if (EQ (STR, empty_unibyte_string)) \ + (STR) = empty_multibyte_string; \ + else \ + XSTRING (STR)->size_byte = XSTRING (STR)->size; \ + } while (false) + +/* Convenience functions for dealing with Lisp strings. */ + +INLINE unsigned char * +SDATA (Lisp_Object string) +{ + return XSTRING (string)->data; +} +INLINE char * +SSDATA (Lisp_Object string) +{ + /* Avoid "differ in sign" warnings. */ + return (char *) SDATA (string); +} +INLINE unsigned char +SREF (Lisp_Object string, ptrdiff_t index) +{ + return SDATA (string)[index]; +} +INLINE void +SSET (Lisp_Object string, ptrdiff_t index, unsigned char new) +{ + SDATA (string)[index] = new; +} +INLINE ptrdiff_t +SCHARS (Lisp_Object string) +{ + return XSTRING (string)->size; +} + +#ifdef GC_CHECK_STRING_BYTES +extern ptrdiff_t string_bytes (struct Lisp_String *); +#endif +INLINE ptrdiff_t +STRING_BYTES (struct Lisp_String *s) +{ +#ifdef GC_CHECK_STRING_BYTES + return string_bytes (s); +#else + return s->size_byte < 0 ? s->size : s->size_byte; +#endif +} + +INLINE ptrdiff_t +SBYTES (Lisp_Object string) +{ + return STRING_BYTES (XSTRING (string)); +} +INLINE void +STRING_SET_CHARS (Lisp_Object string, ptrdiff_t newsize) +{ + XSTRING (string)->size = newsize; +} + +/* Header of vector-like objects. This documents the layout constraints on + vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents + compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR + and PSEUDOVECTORP cast their pointers to struct vectorlike_header *, + because when two such pointers potentially alias, a compiler won't + incorrectly reorder loads and stores to their size fields. See + Bug#8546. */ +struct vectorlike_header + { + /* The only field contains various pieces of information: + - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit. + - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain + vector (0) or a pseudovector (1). + - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number + of slots) of the vector. + - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields: + - a) pseudovector subtype held in PVEC_TYPE_MASK field; + - b) number of Lisp_Objects slots at the beginning of the object + held in PSEUDOVECTOR_SIZE_MASK field. These objects are always + traced by the GC; + - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and + measured in word_size units. Rest fields may also include + Lisp_Objects, but these objects usually needs some special treatment + during GC. + There are some exceptions. For PVEC_FREE, b) is always zero. For + PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero. + Current layout limits the pseudovectors to 63 PVEC_xxx subtypes, + 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */ + ptrdiff_t size; + }; + +/* A regular vector is just a header plus an array of Lisp_Objects. */ + +struct Lisp_Vector + { + struct vectorlike_header header; + Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER]; + }; + +/* C11 prohibits alignof (struct Lisp_Vector), so compute it manually. */ +enum + { + ALIGNOF_STRUCT_LISP_VECTOR + = alignof (union { struct vectorlike_header a; Lisp_Object b; }) + }; + +/* A boolvector is a kind of vectorlike, with contents like a string. */ + +struct Lisp_Bool_Vector + { + /* HEADER.SIZE is the vector's size field. It doesn't have the real size, + just the subtype information. */ + struct vectorlike_header header; + /* This is the size in bits. */ + EMACS_INT size; + /* The actual bits, packed into bytes. + Zeros fill out the last word if needed. + The bits are in little-endian order in the bytes, and + the bytes are in little-endian order in the words. */ + bits_word data[FLEXIBLE_ARRAY_MEMBER]; + }; + +INLINE EMACS_INT +bool_vector_size (Lisp_Object a) +{ + EMACS_INT size = XBOOL_VECTOR (a)->size; + eassume (0 <= size); + return size; +} + +INLINE bits_word * +bool_vector_data (Lisp_Object a) +{ + return XBOOL_VECTOR (a)->data; +} + +INLINE unsigned char * +bool_vector_uchar_data (Lisp_Object a) +{ + return (unsigned char *) bool_vector_data (a); +} + +/* The number of data words and bytes in a bool vector with SIZE bits. */ + +INLINE EMACS_INT +bool_vector_words (EMACS_INT size) +{ + eassume (0 <= size && size <= EMACS_INT_MAX - (BITS_PER_BITS_WORD - 1)); + return (size + BITS_PER_BITS_WORD - 1) / BITS_PER_BITS_WORD; +} + +INLINE EMACS_INT +bool_vector_bytes (EMACS_INT size) +{ + eassume (0 <= size && size <= EMACS_INT_MAX - (BITS_PER_BITS_WORD - 1)); + return (size + BOOL_VECTOR_BITS_PER_CHAR - 1) / BOOL_VECTOR_BITS_PER_CHAR; +} + +/* True if A's Ith bit is set. */ + +INLINE bool +bool_vector_bitref (Lisp_Object a, EMACS_INT i) +{ + eassume (0 <= i && i < bool_vector_size (a)); + return !! (bool_vector_uchar_data (a)[i / BOOL_VECTOR_BITS_PER_CHAR] + & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))); +} + +INLINE Lisp_Object +bool_vector_ref (Lisp_Object a, EMACS_INT i) +{ + return bool_vector_bitref (a, i) ? Qt : Qnil; +} + +/* Set A's Ith bit to B. */ + +INLINE void +bool_vector_set (Lisp_Object a, EMACS_INT i, bool b) +{ + unsigned char *addr; + + eassume (0 <= i && i < bool_vector_size (a)); + addr = &bool_vector_uchar_data (a)[i / BOOL_VECTOR_BITS_PER_CHAR]; + + if (b) + *addr |= 1 << (i % BOOL_VECTOR_BITS_PER_CHAR); + else + *addr &= ~ (1 << (i % BOOL_VECTOR_BITS_PER_CHAR)); +} + +/* Some handy constants for calculating sizes + and offsets, mostly of vectorlike objects. */ + +enum + { + header_size = offsetof (struct Lisp_Vector, contents), + bool_header_size = offsetof (struct Lisp_Bool_Vector, data), + word_size = sizeof (Lisp_Object) + }; + +/* Conveniences for dealing with Lisp arrays. */ + +INLINE Lisp_Object +AREF (Lisp_Object array, ptrdiff_t idx) +{ + return XVECTOR (array)->contents[idx]; +} + +INLINE Lisp_Object * +aref_addr (Lisp_Object array, ptrdiff_t idx) +{ + return & XVECTOR (array)->contents[idx]; +} + +INLINE ptrdiff_t +ASIZE (Lisp_Object array) +{ + return XVECTOR (array)->header.size; +} + +INLINE void +ASET (Lisp_Object array, ptrdiff_t idx, Lisp_Object val) +{ + eassert (0 <= idx && idx < ASIZE (array)); + XVECTOR (array)->contents[idx] = val; +} + +INLINE void +gc_aset (Lisp_Object array, ptrdiff_t idx, Lisp_Object val) +{ + /* Like ASET, but also can be used in the garbage collector: + sweep_weak_table calls set_hash_key etc. while the table is marked. */ + eassert (0 <= idx && idx < (ASIZE (array) & ~ARRAY_MARK_FLAG)); + XVECTOR (array)->contents[idx] = val; +} + +/* True, since Qnil's representation is zero. Every place in the code + that assumes Qnil is zero should verify (NIL_IS_ZERO), to make it easy + to find such assumptions later if we change Qnil to be nonzero. */ +enum { NIL_IS_ZERO = XLI_BUILTIN_LISPSYM (iQnil) == 0 }; + +/* Clear the object addressed by P, with size NBYTES, so that all its + bytes are zero and all its Lisp values are nil. */ +INLINE void +memclear (void *p, ptrdiff_t nbytes) +{ + eassert (0 <= nbytes); + verify (NIL_IS_ZERO); + /* Since Qnil is zero, memset suffices. */ + memset (p, 0, nbytes); +} + +/* If a struct is made to look like a vector, this macro returns the length + of the shortest vector that would hold that struct. */ + +#define VECSIZE(type) \ + ((sizeof (type) - header_size + word_size - 1) / word_size) + +/* Like VECSIZE, but used when the pseudo-vector has non-Lisp_Object fields + at the end and we need to compute the number of Lisp_Object fields (the + ones that the GC needs to trace). */ + +#define PSEUDOVECSIZE(type, nonlispfield) \ + ((offsetof (type, nonlispfield) - header_size) / word_size) + +/* Compute A OP B, using the unsigned comparison operator OP. A and B + should be integer expressions. This is not the same as + mathematical comparison; for example, UNSIGNED_CMP (0, <, -1) + returns true. For efficiency, prefer plain unsigned comparison if A + and B's sizes both fit (after integer promotion). */ +#define UNSIGNED_CMP(a, op, b) \ + (max (sizeof ((a) + 0), sizeof ((b) + 0)) <= sizeof (unsigned) \ + ? ((a) + (unsigned) 0) op ((b) + (unsigned) 0) \ + : ((a) + (uintmax_t) 0) op ((b) + (uintmax_t) 0)) + +/* True iff C is an ASCII character. */ +#define ASCII_CHAR_P(c) UNSIGNED_CMP (c, <, 0x80) + +/* A char-table is a kind of vectorlike, with contents are like a + vector but with a few other slots. For some purposes, it makes + sense to handle a char-table with type struct Lisp_Vector. An + element of a char table can be any Lisp objects, but if it is a sub + char-table, we treat it a table that contains information of a + specific range of characters. A sub char-table is like a vector but + with two integer fields between the header and Lisp data, which means + that it has to be marked with some precautions (see mark_char_table + in alloc.c). A sub char-table appears only in an element of a char-table, + and there's no way to access it directly from Emacs Lisp program. */ + +enum CHARTAB_SIZE_BITS + { + CHARTAB_SIZE_BITS_0 = 6, + CHARTAB_SIZE_BITS_1 = 4, + CHARTAB_SIZE_BITS_2 = 5, + CHARTAB_SIZE_BITS_3 = 7 + }; + +extern const int chartab_size[4]; + +struct Lisp_Char_Table + { + /* HEADER.SIZE is the vector's size field, which also holds the + pseudovector type information. It holds the size, too. + The size counts the defalt, parent, purpose, ascii, + contents, and extras slots. */ + struct vectorlike_header header; + + /* This holds a default value, + which is used whenever the value for a specific character is nil. */ + Lisp_Object defalt; + + /* This points to another char table, which we inherit from when the + value for a specific character is nil. The `defalt' slot takes + precedence over this. */ + Lisp_Object parent; + + /* This is a symbol which says what kind of use this char-table is + meant for. */ + Lisp_Object purpose; + + /* The bottom sub char-table for characters of the range 0..127. It + is nil if none of ASCII character has a specific value. */ + Lisp_Object ascii; + + Lisp_Object contents[(1 << CHARTAB_SIZE_BITS_0)]; + + /* These hold additional data. It is a vector. */ + Lisp_Object extras[FLEXIBLE_ARRAY_MEMBER]; + }; + +struct Lisp_Sub_Char_Table + { + /* HEADER.SIZE is the vector's size field, which also holds the + pseudovector type information. It holds the size, too. */ + struct vectorlike_header header; + + /* Depth of this sub char-table. It should be 1, 2, or 3. A sub + char-table of depth 1 contains 16 elements, and each element + covers 4096 (128*32) characters. A sub char-table of depth 2 + contains 32 elements, and each element covers 128 characters. A + sub char-table of depth 3 contains 128 elements, and each element + is for one character. */ + int depth; + + /* Minimum character covered by the sub char-table. */ + int min_char; + + /* Use set_sub_char_table_contents to set this. */ + Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER]; + }; + +INLINE Lisp_Object +CHAR_TABLE_REF_ASCII (Lisp_Object ct, ptrdiff_t idx) +{ + struct Lisp_Char_Table *tbl = NULL; + Lisp_Object val; + do + { + tbl = tbl ? XCHAR_TABLE (tbl->parent) : XCHAR_TABLE (ct); + val = (! SUB_CHAR_TABLE_P (tbl->ascii) ? tbl->ascii + : XSUB_CHAR_TABLE (tbl->ascii)->contents[idx]); + if (NILP (val)) + val = tbl->defalt; + } + while (NILP (val) && ! NILP (tbl->parent)); + + return val; +} + +/* Almost equivalent to Faref (CT, IDX) with optimization for ASCII + characters. Do not check validity of CT. */ +INLINE Lisp_Object +CHAR_TABLE_REF (Lisp_Object ct, int idx) +{ + return (ASCII_CHAR_P (idx) + ? CHAR_TABLE_REF_ASCII (ct, idx) + : char_table_ref (ct, idx)); +} + +/* Equivalent to Faset (CT, IDX, VAL) with optimization for ASCII and + 8-bit European characters. Do not check validity of CT. */ +INLINE void +CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val) +{ + if (ASCII_CHAR_P (idx) && SUB_CHAR_TABLE_P (XCHAR_TABLE (ct)->ascii)) + set_sub_char_table_contents (XCHAR_TABLE (ct)->ascii, idx, val); + else + char_table_set (ct, idx, val); +} + +/* This structure describes a built-in function. + It is generated by the DEFUN macro only. + defsubr makes it into a Lisp object. */ + +struct Lisp_Subr + { + struct vectorlike_header header; + union { + Lisp_Object (*a0) (void); + Lisp_Object (*a1) (Lisp_Object); + Lisp_Object (*a2) (Lisp_Object, Lisp_Object); + Lisp_Object (*a3) (Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*a4) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*a5) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*a6) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*a7) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*a8) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + Lisp_Object (*aUNEVALLED) (Lisp_Object args); + Lisp_Object (*aMANY) (ptrdiff_t, Lisp_Object *); + } function; + short min_args, max_args; + const char *symbol_name; + const char *intspec; + const char *doc; + }; + +enum char_table_specials + { + /* This is the number of slots that every char table must have. This + counts the ordinary slots and the top, defalt, parent, and purpose + slots. */ + CHAR_TABLE_STANDARD_SLOTS = PSEUDOVECSIZE (struct Lisp_Char_Table, extras), + + /* This is an index of first Lisp_Object field in Lisp_Sub_Char_Table + when the latter is treated as an ordinary Lisp_Vector. */ + SUB_CHAR_TABLE_OFFSET = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents) + }; + +/* Return the number of "extra" slots in the char table CT. */ + +INLINE int +CHAR_TABLE_EXTRA_SLOTS (struct Lisp_Char_Table *ct) +{ + return ((ct->header.size & PSEUDOVECTOR_SIZE_MASK) + - CHAR_TABLE_STANDARD_SLOTS); +} + +/* Make sure that sub char-table contents slot is where we think it is. */ +verify (offsetof (struct Lisp_Sub_Char_Table, contents) + == offsetof (struct Lisp_Vector, contents[SUB_CHAR_TABLE_OFFSET])); + +/*********************************************************************** + Symbols + ***********************************************************************/ + +/* Value is name of symbol. */ + +LISP_MACRO_DEFUN (SYMBOL_VAL, Lisp_Object, (struct Lisp_Symbol *sym), (sym)) + +INLINE struct Lisp_Symbol * +SYMBOL_ALIAS (struct Lisp_Symbol *sym) +{ + eassert (sym->redirect == SYMBOL_VARALIAS); + return sym->val.alias; +} +INLINE struct Lisp_Buffer_Local_Value * +SYMBOL_BLV (struct Lisp_Symbol *sym) +{ + eassert (sym->redirect == SYMBOL_LOCALIZED); + return sym->val.blv; +} +INLINE union Lisp_Fwd * +SYMBOL_FWD (struct Lisp_Symbol *sym) +{ + eassert (sym->redirect == SYMBOL_FORWARDED); + return sym->val.fwd; +} + +LISP_MACRO_DEFUN_VOID (SET_SYMBOL_VAL, + (struct Lisp_Symbol *sym, Lisp_Object v), (sym, v)) + +INLINE void +SET_SYMBOL_ALIAS (struct Lisp_Symbol *sym, struct Lisp_Symbol *v) +{ + eassert (sym->redirect == SYMBOL_VARALIAS); + sym->val.alias = v; +} +INLINE void +SET_SYMBOL_BLV (struct Lisp_Symbol *sym, struct Lisp_Buffer_Local_Value *v) +{ + eassert (sym->redirect == SYMBOL_LOCALIZED); + sym->val.blv = v; +} +INLINE void +SET_SYMBOL_FWD (struct Lisp_Symbol *sym, union Lisp_Fwd *v) +{ + eassert (sym->redirect == SYMBOL_FORWARDED); + sym->val.fwd = v; +} + +INLINE Lisp_Object +SYMBOL_NAME (Lisp_Object sym) +{ + return XSYMBOL (sym)->name; +} + +/* Value is true if SYM is an interned symbol. */ + +INLINE bool +SYMBOL_INTERNED_P (Lisp_Object sym) +{ + return XSYMBOL (sym)->interned != SYMBOL_UNINTERNED; +} + +/* Value is true if SYM is interned in initial_obarray. */ + +INLINE bool +SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym) +{ + return XSYMBOL (sym)->interned == SYMBOL_INTERNED_IN_INITIAL_OBARRAY; +} + +/* Value is non-zero if symbol is considered a constant, i.e. its + value cannot be changed (there is an exception for keyword symbols, + whose value can be set to the keyword symbol itself). */ + +LISP_MACRO_DEFUN (SYMBOL_CONSTANT_P, int, (Lisp_Object sym), (sym)) + +/* Placeholder for make-docfile to process. The actual symbol + definition is done by lread.c's defsym. */ +#define DEFSYM(sym, name) /* empty */ + + +/*********************************************************************** + Hash Tables + ***********************************************************************/ + +/* The structure of a Lisp hash table. */ + +struct hash_table_test +{ + /* Name of the function used to compare keys. */ + Lisp_Object name; + + /* User-supplied hash function, or nil. */ + Lisp_Object user_hash_function; + + /* User-supplied key comparison function, or nil. */ + Lisp_Object user_cmp_function; + + /* C function to compare two keys. */ + bool (*cmpfn) (struct hash_table_test *t, Lisp_Object, Lisp_Object); + + /* C function to compute hash code. */ + EMACS_UINT (*hashfn) (struct hash_table_test *t, Lisp_Object); +}; + +struct Lisp_Hash_Table +{ + /* This is for Lisp; the hash table code does not refer to it. */ + struct vectorlike_header header; + + /* Nil if table is non-weak. Otherwise a symbol describing the + weakness of the table. */ + Lisp_Object weak; + + /* When the table is resized, and this is an integer, compute the + new size by adding this to the old size. If a float, compute the + new size by multiplying the old size with this factor. */ + Lisp_Object rehash_size; + + /* Resize hash table when number of entries/ table size is >= this + ratio, a float. */ + Lisp_Object rehash_threshold; + + /* Vector of hash codes. If hash[I] is nil, this means that the + I-th entry is unused. */ + Lisp_Object hash; + + /* Vector used to chain entries. If entry I is free, next[I] is the + entry number of the next free item. If entry I is non-free, + next[I] is the index of the next entry in the collision chain. */ + Lisp_Object next; + + /* Index of first free entry in free list. */ + Lisp_Object next_free; + + /* Bucket vector. A non-nil entry is the index of the first item in + a collision chain. This vector's size can be larger than the + hash table size to reduce collisions. */ + Lisp_Object index; + + /* Only the fields above are traced normally by the GC. The ones below + `count' are special and are either ignored by the GC or traced in + a special way (e.g. because of weakness). */ + + /* Number of key/value entries in the table. */ + ptrdiff_t count; + + /* Vector of keys and values. The key of item I is found at index + 2 * I, the value is found at index 2 * I + 1. + This is gc_marked specially if the table is weak. */ + Lisp_Object key_and_value; + + /* The comparison and hash functions. */ + struct hash_table_test test; + + /* Next weak hash table if this is a weak hash table. The head + of the list is in weak_hash_tables. */ + struct Lisp_Hash_Table *next_weak; +}; + + +INLINE struct Lisp_Hash_Table * +XHASH_TABLE (Lisp_Object a) +{ + return XUNTAG (a, Lisp_Vectorlike); +} + +#define XSET_HASH_TABLE(VAR, PTR) \ + (XSETPSEUDOVECTOR (VAR, PTR, PVEC_HASH_TABLE)) + +INLINE bool +HASH_TABLE_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_HASH_TABLE); +} + +/* Value is the key part of entry IDX in hash table H. */ +INLINE Lisp_Object +HASH_KEY (struct Lisp_Hash_Table *h, ptrdiff_t idx) +{ + return AREF (h->key_and_value, 2 * idx); +} + +/* Value is the value part of entry IDX in hash table H. */ +INLINE Lisp_Object +HASH_VALUE (struct Lisp_Hash_Table *h, ptrdiff_t idx) +{ + return AREF (h->key_and_value, 2 * idx + 1); +} + +/* Value is the index of the next entry following the one at IDX + in hash table H. */ +INLINE Lisp_Object +HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx) +{ + return AREF (h->next, idx); +} + +/* Value is the hash code computed for entry IDX in hash table H. */ +INLINE Lisp_Object +HASH_HASH (struct Lisp_Hash_Table *h, ptrdiff_t idx) +{ + return AREF (h->hash, idx); +} + +/* Value is the index of the element in hash table H that is the + start of the collision list at index IDX in the index vector of H. */ +INLINE Lisp_Object +HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx) +{ + return AREF (h->index, idx); +} + +/* Value is the size of hash table H. */ +INLINE ptrdiff_t +HASH_TABLE_SIZE (struct Lisp_Hash_Table *h) +{ + return ASIZE (h->next); +} + +/* Default size for hash tables if not specified. */ + +enum DEFAULT_HASH_SIZE { DEFAULT_HASH_SIZE = 65 }; + +/* Default threshold specifying when to resize a hash table. The + value gives the ratio of current entries in the hash table and the + size of the hash table. */ + +static double const DEFAULT_REHASH_THRESHOLD = 0.8; + +/* Default factor by which to increase the size of a hash table. */ + +static double const DEFAULT_REHASH_SIZE = 1.5; + +/* Combine two integers X and Y for hashing. The result might not fit + into a Lisp integer. */ + +INLINE EMACS_UINT +sxhash_combine (EMACS_UINT x, EMACS_UINT y) +{ + return (x << 4) + (x >> (BITS_PER_EMACS_INT - 4)) + y; +} + +/* Hash X, returning a value that fits into a fixnum. */ + +INLINE EMACS_UINT +SXHASH_REDUCE (EMACS_UINT x) +{ + return (x ^ x >> (BITS_PER_EMACS_INT - FIXNUM_BITS)) & INTMASK; +} + +/* These structures are used for various misc types. */ + +struct Lisp_Misc_Any /* Supertype of all Misc types. */ +{ + ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_??? */ + bool_bf gcmarkbit : 1; + unsigned spacer : 15; +}; + +struct Lisp_Marker +{ + ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Marker */ + bool_bf gcmarkbit : 1; + unsigned spacer : 13; + /* This flag is temporarily used in the functions + decode/encode_coding_object to record that the marker position + must be adjusted after the conversion. */ + bool_bf need_adjustment : 1; + /* True means normal insertion at the marker's position + leaves the marker after the inserted text. */ + bool_bf insertion_type : 1; + /* This is the buffer that the marker points into, or 0 if it points nowhere. + Note: a chain of markers can contain markers pointing into different + buffers (the chain is per buffer_text rather than per buffer, so it's + shared between indirect buffers). */ + /* This is used for (other than NULL-checking): + - Fmarker_buffer + - Fset_marker: check eq(oldbuf, newbuf) to avoid unchain+rechain. + - unchain_marker: to find the list from which to unchain. + - Fkill_buffer: to only unchain the markers of current indirect buffer. + */ + struct buffer *buffer; + + /* The remaining fields are meaningless in a marker that + does not point anywhere. */ + + /* For markers that point somewhere, + this is used to chain of all the markers in a given buffer. */ + /* We could remove it and use an array in buffer_text instead. + That would also allow to preserve it ordered. */ + struct Lisp_Marker *next; + /* This is the char position where the marker points. */ + ptrdiff_t charpos; + /* This is the byte position. + It's mostly used as a charpos<->bytepos cache (i.e. it's not directly + used to implement the functionality of markers, but rather to (ab)use + markers as a cache for char<->byte mappings). */ + ptrdiff_t bytepos; +}; + +/* START and END are markers in the overlay's buffer, and + PLIST is the overlay's property list. */ +struct Lisp_Overlay +/* An overlay's real data content is: + - plist + - buffer (really there are two buffer pointers, one per marker, + and both points to the same buffer) + - insertion type of both ends (per-marker fields) + - start & start byte (of start marker) + - end & end byte (of end marker) + - next (singly linked list of overlays) + - next fields of start and end markers (singly linked list of markers). + I.e. 9words plus 2 bits, 3words of which are for external linked lists. +*/ + { + ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Overlay */ + bool_bf gcmarkbit : 1; + unsigned spacer : 15; + struct Lisp_Overlay *next; + Lisp_Object start; + Lisp_Object end; + Lisp_Object plist; + }; + +/* Types of data which may be saved in a Lisp_Save_Value. */ + +enum + { + SAVE_UNUSED, + SAVE_INTEGER, + SAVE_FUNCPOINTER, + SAVE_POINTER, + SAVE_OBJECT + }; + +/* Number of bits needed to store one of the above values. */ +enum { SAVE_SLOT_BITS = 3 }; + +/* Number of slots in a save value where save_type is nonzero. */ +enum { SAVE_VALUE_SLOTS = 4 }; + +/* Bit-width and values for struct Lisp_Save_Value's save_type member. */ + +enum { SAVE_TYPE_BITS = SAVE_VALUE_SLOTS * SAVE_SLOT_BITS + 1 }; + +enum Lisp_Save_Type + { + SAVE_TYPE_INT_INT = SAVE_INTEGER + (SAVE_INTEGER << SAVE_SLOT_BITS), + SAVE_TYPE_INT_INT_INT + = (SAVE_INTEGER + (SAVE_TYPE_INT_INT << SAVE_SLOT_BITS)), + SAVE_TYPE_OBJ_OBJ = SAVE_OBJECT + (SAVE_OBJECT << SAVE_SLOT_BITS), + SAVE_TYPE_OBJ_OBJ_OBJ = SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ << SAVE_SLOT_BITS), + SAVE_TYPE_OBJ_OBJ_OBJ_OBJ + = SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ_OBJ << SAVE_SLOT_BITS), + SAVE_TYPE_PTR_INT = SAVE_POINTER + (SAVE_INTEGER << SAVE_SLOT_BITS), + SAVE_TYPE_PTR_OBJ = SAVE_POINTER + (SAVE_OBJECT << SAVE_SLOT_BITS), + SAVE_TYPE_PTR_PTR = SAVE_POINTER + (SAVE_POINTER << SAVE_SLOT_BITS), + SAVE_TYPE_FUNCPTR_PTR_OBJ + = SAVE_FUNCPOINTER + (SAVE_TYPE_PTR_OBJ << SAVE_SLOT_BITS), + + /* This has an extra bit indicating it's raw memory. */ + SAVE_TYPE_MEMORY = SAVE_TYPE_PTR_INT + (1 << (SAVE_TYPE_BITS - 1)) + }; + +/* Special object used to hold a different values for later use. + + This is mostly used to package C integers and pointers to call + record_unwind_protect when two or more values need to be saved. + For example: + + ... + struct my_data *md = get_my_data (); + ptrdiff_t mi = get_my_integer (); + record_unwind_protect (my_unwind, make_save_ptr_int (md, mi)); + ... + + Lisp_Object my_unwind (Lisp_Object arg) + { + struct my_data *md = XSAVE_POINTER (arg, 0); + ptrdiff_t mi = XSAVE_INTEGER (arg, 1); + ... + } + + If ENABLE_CHECKING is in effect, XSAVE_xxx macros do type checking of the + saved objects and raise eassert if type of the saved object doesn't match + the type which is extracted. In the example above, XSAVE_INTEGER (arg, 2) + and XSAVE_OBJECT (arg, 0) are wrong because nothing was saved in slot 2 and + slot 0 is a pointer. */ + +typedef void (*voidfuncptr) (void); + +struct Lisp_Save_Value + { + ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Save_Value */ + bool_bf gcmarkbit : 1; + unsigned spacer : 32 - (16 + 1 + SAVE_TYPE_BITS); + + /* V->data may hold up to SAVE_VALUE_SLOTS entries. The type of + V's data entries are determined by V->save_type. E.g., if + V->save_type == SAVE_TYPE_PTR_OBJ, V->data[0] is a pointer, + V->data[1] is an integer, and V's other data entries are unused. + + If V->save_type == SAVE_TYPE_MEMORY, V->data[0].pointer is the address of + a memory area containing V->data[1].integer potential Lisp_Objects. */ + ENUM_BF (Lisp_Save_Type) save_type : SAVE_TYPE_BITS; + union { + void *pointer; + voidfuncptr funcpointer; + ptrdiff_t integer; + Lisp_Object object; + } data[SAVE_VALUE_SLOTS]; + }; + +/* Return the type of V's Nth saved value. */ +INLINE int +save_type (struct Lisp_Save_Value *v, int n) +{ + eassert (0 <= n && n < SAVE_VALUE_SLOTS); + return (v->save_type >> (SAVE_SLOT_BITS * n) & ((1 << SAVE_SLOT_BITS) - 1)); +} + +/* Get and set the Nth saved pointer. */ + +INLINE void * +XSAVE_POINTER (Lisp_Object obj, int n) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER); + return XSAVE_VALUE (obj)->data[n].pointer; +} +INLINE void +set_save_pointer (Lisp_Object obj, int n, void *val) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER); + XSAVE_VALUE (obj)->data[n].pointer = val; +} +INLINE voidfuncptr +XSAVE_FUNCPOINTER (Lisp_Object obj, int n) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_FUNCPOINTER); + return XSAVE_VALUE (obj)->data[n].funcpointer; +} + +/* Likewise for the saved integer. */ + +INLINE ptrdiff_t +XSAVE_INTEGER (Lisp_Object obj, int n) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER); + return XSAVE_VALUE (obj)->data[n].integer; +} +INLINE void +set_save_integer (Lisp_Object obj, int n, ptrdiff_t val) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER); + XSAVE_VALUE (obj)->data[n].integer = val; +} + +/* Extract Nth saved object. */ + +INLINE Lisp_Object +XSAVE_OBJECT (Lisp_Object obj, int n) +{ + eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_OBJECT); + return XSAVE_VALUE (obj)->data[n].object; +} + +/* A finalizer sentinel. */ +struct Lisp_Finalizer + { + struct Lisp_Misc_Any base; + + /* Circular list of all active weak references. */ + struct Lisp_Finalizer *prev; + struct Lisp_Finalizer *next; + + /* Call FUNCTION when the finalizer becomes unreachable, even if + FUNCTION contains a reference to the finalizer; i.e., call + FUNCTION when it is reachable _only_ through finalizers. */ + Lisp_Object function; + }; + +/* A miscellaneous object, when it's on the free list. */ +struct Lisp_Free + { + ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Free */ + bool_bf gcmarkbit : 1; + unsigned spacer : 15; + union Lisp_Misc *chain; + }; + +/* To get the type field of a union Lisp_Misc, use XMISCTYPE. + It uses one of these struct subtypes to get the type field. */ + +union Lisp_Misc + { + struct Lisp_Misc_Any u_any; /* Supertype of all Misc types. */ + struct Lisp_Free u_free; + struct Lisp_Marker u_marker; + struct Lisp_Overlay u_overlay; + struct Lisp_Save_Value u_save_value; + struct Lisp_Finalizer u_finalizer; + }; + +INLINE union Lisp_Misc * +XMISC (Lisp_Object a) +{ + return XUNTAG (a, Lisp_Misc); +} + +INLINE struct Lisp_Misc_Any * +XMISCANY (Lisp_Object a) +{ + eassert (MISCP (a)); + return & XMISC (a)->u_any; +} + +INLINE enum Lisp_Misc_Type +XMISCTYPE (Lisp_Object a) +{ + return XMISCANY (a)->type; +} + +INLINE struct Lisp_Marker * +XMARKER (Lisp_Object a) +{ + eassert (MARKERP (a)); + return & XMISC (a)->u_marker; +} + +INLINE struct Lisp_Overlay * +XOVERLAY (Lisp_Object a) +{ + eassert (OVERLAYP (a)); + return & XMISC (a)->u_overlay; +} + +INLINE struct Lisp_Save_Value * +XSAVE_VALUE (Lisp_Object a) +{ + eassert (SAVE_VALUEP (a)); + return & XMISC (a)->u_save_value; +} + +INLINE struct Lisp_Finalizer * +XFINALIZER (Lisp_Object a) +{ + eassert (FINALIZERP (a)); + return & XMISC (a)->u_finalizer; +} + + +/* Forwarding pointer to an int variable. + This is allowed only in the value cell of a symbol, + and it means that the symbol's value really lives in the + specified int variable. */ +struct Lisp_Intfwd + { + enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Int */ + EMACS_INT *intvar; + }; + +/* Boolean forwarding pointer to an int variable. + This is like Lisp_Intfwd except that the ostensible + "value" of the symbol is t if the bool variable is true, + nil if it is false. */ +struct Lisp_Boolfwd + { + enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Bool */ + bool *boolvar; + }; + +/* Forwarding pointer to a Lisp_Object variable. + This is allowed only in the value cell of a symbol, + and it means that the symbol's value really lives in the + specified variable. */ +struct Lisp_Objfwd + { + enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Obj */ + Lisp_Object *objvar; + }; + +/* Like Lisp_Objfwd except that value lives in a slot in the + current buffer. Value is byte index of slot within buffer. */ +struct Lisp_Buffer_Objfwd + { + enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Buffer_Obj */ + int offset; + /* One of Qnil, Qintegerp, Qsymbolp, Qstringp, Qfloatp or Qnumberp. */ + Lisp_Object predicate; + }; + +/* struct Lisp_Buffer_Local_Value is used in a symbol value cell when + the symbol has buffer-local or frame-local bindings. (Exception: + some buffer-local variables are built-in, with their values stored + in the buffer structure itself. They are handled differently, + using struct Lisp_Buffer_Objfwd.) + + The `realvalue' slot holds the variable's current value, or a + forwarding pointer to where that value is kept. This value is the + one that corresponds to the loaded binding. To read or set the + variable, you must first make sure the right binding is loaded; + then you can access the value in (or through) `realvalue'. + + `buffer' and `frame' are the buffer and frame for which the loaded + binding was found. If those have changed, to make sure the right + binding is loaded it is necessary to find which binding goes with + the current buffer and selected frame, then load it. To load it, + first unload the previous binding, then copy the value of the new + binding into `realvalue' (or through it). Also update + LOADED-BINDING to point to the newly loaded binding. + + `local_if_set' indicates that merely setting the variable creates a + local binding for the current buffer. Otherwise the latter, setting + the variable does not do that; only make-local-variable does that. */ + +struct Lisp_Buffer_Local_Value + { + /* True means that merely setting the variable creates a local + binding for the current buffer. */ + bool_bf local_if_set : 1; + /* True means this variable can have frame-local bindings, otherwise, it is + can have buffer-local bindings. The two cannot be combined. */ + bool_bf frame_local : 1; + /* True means that the binding now loaded was found. + Presumably equivalent to (defcell!=valcell). */ + bool_bf found : 1; + /* If non-NULL, a forwarding to the C var where it should also be set. */ + union Lisp_Fwd *fwd; /* Should never be (Buffer|Kboard)_Objfwd. */ + /* The buffer or frame for which the loaded binding was found. */ + Lisp_Object where; + /* A cons cell that holds the default value. It has the form + (SYMBOL . DEFAULT-VALUE). */ + Lisp_Object defcell; + /* The cons cell from `where's parameter alist. + It always has the form (SYMBOL . VALUE) + Note that if `forward' is non-nil, VALUE may be out of date. + Also if the currently loaded binding is the default binding, then + this is `eq'ual to defcell. */ + Lisp_Object valcell; + }; + +/* Like Lisp_Objfwd except that value lives in a slot in the + current kboard. */ +struct Lisp_Kboard_Objfwd + { + enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Kboard_Obj */ + int offset; + }; + +union Lisp_Fwd + { + struct Lisp_Intfwd u_intfwd; + struct Lisp_Boolfwd u_boolfwd; + struct Lisp_Objfwd u_objfwd; + struct Lisp_Buffer_Objfwd u_buffer_objfwd; + struct Lisp_Kboard_Objfwd u_kboard_objfwd; + }; + +INLINE enum Lisp_Fwd_Type +XFWDTYPE (union Lisp_Fwd *a) +{ + return a->u_intfwd.type; +} + +INLINE struct Lisp_Buffer_Objfwd * +XBUFFER_OBJFWD (union Lisp_Fwd *a) +{ + eassert (BUFFER_OBJFWDP (a)); + return &a->u_buffer_objfwd; +} + +/* Lisp floating point type. */ +struct Lisp_Float + { + union + { + double data; + struct Lisp_Float *chain; + } u; + }; + +INLINE double +XFLOAT_DATA (Lisp_Object f) +{ + return XFLOAT (f)->u.data; +} + +/* Most hosts nowadays use IEEE floating point, so they use IEC 60559 + representations, have infinities and NaNs, and do not trap on + exceptions. Define IEEE_FLOATING_POINT if this host is one of the + typical ones. The C11 macro __STDC_IEC_559__ is close to what is + wanted here, but is not quite right because Emacs does not require + all the features of C11 Annex F (and does not require C11 at all, + for that matter). */ +enum + { + IEEE_FLOATING_POINT + = (FLT_RADIX == 2 && FLT_MANT_DIG == 24 + && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) + }; + +/* A character, declared with the following typedef, is a member + of some character set associated with the current buffer. */ +#ifndef _UCHAR_T /* Protect against something in ctab.h on AIX. */ +#define _UCHAR_T +typedef unsigned char UCHAR; +#endif + +/* Meanings of slots in a Lisp_Compiled: */ + +enum Lisp_Compiled + { + COMPILED_ARGLIST = 0, + COMPILED_BYTECODE = 1, + COMPILED_CONSTANTS = 2, + COMPILED_STACK_DEPTH = 3, + COMPILED_DOC_STRING = 4, + COMPILED_INTERACTIVE = 5 + }; + +/* Flag bits in a character. These also get used in termhooks.h. + Richard Stallman thinks that MULE + (MUlti-Lingual Emacs) might need 22 bits for the character value + itself, so we probably shouldn't use any bits lower than 0x0400000. */ +enum char_bits + { + CHAR_ALT = 0x0400000, + CHAR_SUPER = 0x0800000, + CHAR_HYPER = 0x1000000, + CHAR_SHIFT = 0x2000000, + CHAR_CTL = 0x4000000, + CHAR_META = 0x8000000, + + CHAR_MODIFIER_MASK = + CHAR_ALT | CHAR_SUPER | CHAR_HYPER | CHAR_SHIFT | CHAR_CTL | CHAR_META, + + /* Actually, the current Emacs uses 22 bits for the character value + itself. */ + CHARACTERBITS = 22 + }; + +/* Data type checking. */ + +LISP_MACRO_DEFUN (NILP, bool, (Lisp_Object x), (x)) + +INLINE bool +NUMBERP (Lisp_Object x) +{ + return INTEGERP (x) || FLOATP (x); +} +INLINE bool +NATNUMP (Lisp_Object x) +{ + return INTEGERP (x) && 0 <= XINT (x); +} + +INLINE bool +RANGED_INTEGERP (intmax_t lo, Lisp_Object x, intmax_t hi) +{ + return INTEGERP (x) && lo <= XINT (x) && XINT (x) <= hi; +} + +#define TYPE_RANGED_INTEGERP(type, x) \ + (INTEGERP (x) \ + && (TYPE_SIGNED (type) ? TYPE_MINIMUM (type) <= XINT (x) : 0 <= XINT (x)) \ + && XINT (x) <= TYPE_MAXIMUM (type)) + +LISP_MACRO_DEFUN (CONSP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (FLOATP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (MISCP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (SYMBOLP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (INTEGERP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (VECTORLIKEP, bool, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN (MARKERP, bool, (Lisp_Object x), (x)) + +INLINE bool +STRINGP (Lisp_Object x) +{ + return XTYPE (x) == Lisp_String; +} +INLINE bool +VECTORP (Lisp_Object x) +{ + return VECTORLIKEP (x) && ! (ASIZE (x) & PSEUDOVECTOR_FLAG); +} +INLINE bool +OVERLAYP (Lisp_Object x) +{ + return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Overlay; +} +INLINE bool +SAVE_VALUEP (Lisp_Object x) +{ + return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value; +} + +INLINE bool +FINALIZERP (Lisp_Object x) +{ + return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Finalizer; +} + +INLINE bool +AUTOLOADP (Lisp_Object x) +{ + return CONSP (x) && EQ (Qautoload, XCAR (x)); +} + +INLINE bool +BUFFER_OBJFWDP (union Lisp_Fwd *a) +{ + return XFWDTYPE (a) == Lisp_Fwd_Buffer_Obj; +} + +INLINE bool +PSEUDOVECTOR_TYPEP (struct vectorlike_header *a, int code) +{ + return ((a->size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) + == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))); +} + +/* True if A is a pseudovector whose code is CODE. */ +INLINE bool +PSEUDOVECTORP (Lisp_Object a, int code) +{ + if (! VECTORLIKEP (a)) + return false; + else + { + /* Converting to struct vectorlike_header * avoids aliasing issues. */ + struct vectorlike_header *h = XUNTAG (a, Lisp_Vectorlike); + return PSEUDOVECTOR_TYPEP (h, code); + } +} + + +/* Test for specific pseudovector types. */ + +INLINE bool +WINDOW_CONFIGURATIONP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_WINDOW_CONFIGURATION); +} + +INLINE bool +PROCESSP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_PROCESS); +} + +INLINE bool +WINDOWP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_WINDOW); +} + +INLINE bool +TERMINALP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_TERMINAL); +} + +INLINE bool +SUBRP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_SUBR); +} + +INLINE bool +COMPILEDP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_COMPILED); +} + +INLINE bool +BUFFERP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_BUFFER); +} + +INLINE bool +CHAR_TABLE_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_CHAR_TABLE); +} + +INLINE bool +SUB_CHAR_TABLE_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_SUB_CHAR_TABLE); +} + +INLINE bool +BOOL_VECTOR_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_BOOL_VECTOR); +} + +INLINE bool +FRAMEP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_FRAME); +} + +/* Test for image (image . spec) */ +INLINE bool +IMAGEP (Lisp_Object x) +{ + return CONSP (x) && EQ (XCAR (x), Qimage); +} + +/* Array types. */ +INLINE bool +ARRAYP (Lisp_Object x) +{ + return VECTORP (x) || STRINGP (x) || CHAR_TABLE_P (x) || BOOL_VECTOR_P (x); +} + +INLINE void +CHECK_LIST (Lisp_Object x) +{ + CHECK_TYPE (CONSP (x) || NILP (x), Qlistp, x); +} + +LISP_MACRO_DEFUN_VOID (CHECK_LIST_CONS, (Lisp_Object x, Lisp_Object y), (x, y)) +LISP_MACRO_DEFUN_VOID (CHECK_SYMBOL, (Lisp_Object x), (x)) +LISP_MACRO_DEFUN_VOID (CHECK_NUMBER, (Lisp_Object x), (x)) + +INLINE void +CHECK_STRING (Lisp_Object x) +{ + CHECK_TYPE (STRINGP (x), Qstringp, x); +} +INLINE void +CHECK_STRING_CAR (Lisp_Object x) +{ + CHECK_TYPE (STRINGP (XCAR (x)), Qstringp, XCAR (x)); +} +INLINE void +CHECK_CONS (Lisp_Object x) +{ + CHECK_TYPE (CONSP (x), Qconsp, x); +} +INLINE void +CHECK_VECTOR (Lisp_Object x) +{ + CHECK_TYPE (VECTORP (x), Qvectorp, x); +} +INLINE void +CHECK_BOOL_VECTOR (Lisp_Object x) +{ + CHECK_TYPE (BOOL_VECTOR_P (x), Qbool_vector_p, x); +} +/* This is a bit special because we always need size afterwards. */ +INLINE ptrdiff_t +CHECK_VECTOR_OR_STRING (Lisp_Object x) +{ + if (VECTORP (x)) + return ASIZE (x); + if (STRINGP (x)) + return SCHARS (x); + wrong_type_argument (Qarrayp, x); +} +INLINE void +CHECK_ARRAY (Lisp_Object x, Lisp_Object predicate) +{ + CHECK_TYPE (ARRAYP (x), predicate, x); +} +INLINE void +CHECK_BUFFER (Lisp_Object x) +{ + CHECK_TYPE (BUFFERP (x), Qbufferp, x); +} +INLINE void +CHECK_WINDOW (Lisp_Object x) +{ + CHECK_TYPE (WINDOWP (x), Qwindowp, x); +} +#ifdef subprocesses +INLINE void +CHECK_PROCESS (Lisp_Object x) +{ + CHECK_TYPE (PROCESSP (x), Qprocessp, x); +} +#endif +INLINE void +CHECK_NATNUM (Lisp_Object x) +{ + CHECK_TYPE (NATNUMP (x), Qwholenump, x); +} + +#define CHECK_RANGED_INTEGER(x, lo, hi) \ + do { \ + CHECK_NUMBER (x); \ + if (! ((lo) <= XINT (x) && XINT (x) <= (hi))) \ + args_out_of_range_3 \ + (x, \ + make_number ((lo) < 0 && (lo) < MOST_NEGATIVE_FIXNUM \ + ? MOST_NEGATIVE_FIXNUM \ + : (lo)), \ + make_number (min (hi, MOST_POSITIVE_FIXNUM))); \ + } while (false) +#define CHECK_TYPE_RANGED_INTEGER(type, x) \ + do { \ + if (TYPE_SIGNED (type)) \ + CHECK_RANGED_INTEGER (x, TYPE_MINIMUM (type), TYPE_MAXIMUM (type)); \ + else \ + CHECK_RANGED_INTEGER (x, 0, TYPE_MAXIMUM (type)); \ + } while (false) + +#define CHECK_NUMBER_COERCE_MARKER(x) \ + do { \ + if (MARKERP ((x))) \ + XSETFASTINT (x, marker_position (x)); \ + else \ + CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x); \ + } while (false) + +INLINE double +XFLOATINT (Lisp_Object n) +{ + return extract_float (n); +} + +INLINE void +CHECK_NUMBER_OR_FLOAT (Lisp_Object x) +{ + CHECK_TYPE (FLOATP (x) || INTEGERP (x), Qnumberp, x); +} + +#define CHECK_NUMBER_OR_FLOAT_COERCE_MARKER(x) \ + do { \ + if (MARKERP (x)) \ + XSETFASTINT (x, marker_position (x)); \ + else \ + CHECK_TYPE (INTEGERP (x) || FLOATP (x), Qnumber_or_marker_p, x); \ + } while (false) + +/* Since we can't assign directly to the CAR or CDR fields of a cons + cell, use these when checking that those fields contain numbers. */ +INLINE void +CHECK_NUMBER_CAR (Lisp_Object x) +{ + Lisp_Object tmp = XCAR (x); + CHECK_NUMBER (tmp); + XSETCAR (x, tmp); +} + +INLINE void +CHECK_NUMBER_CDR (Lisp_Object x) +{ + Lisp_Object tmp = XCDR (x); + CHECK_NUMBER (tmp); + XSETCDR (x, tmp); +} + +/* Define a built-in function for calling from Lisp. + `lname' should be the name to give the function in Lisp, + as a null-terminated C string. + `fnname' should be the name of the function in C. + By convention, it starts with F. + `sname' should be the name for the C constant structure + that records information on this function for internal use. + By convention, it should be the same as `fnname' but with S instead of F. + It's too bad that C macros can't compute this from `fnname'. + `minargs' should be a number, the minimum number of arguments allowed. + `maxargs' should be a number, the maximum number of arguments allowed, + or else MANY or UNEVALLED. + MANY means pass a vector of evaluated arguments, + in the form of an integer number-of-arguments + followed by the address of a vector of Lisp_Objects + which contains the argument values. + UNEVALLED means pass the list of unevaluated arguments + `intspec' says how interactive arguments are to be fetched. + If the string starts with a `(', `intspec' is evaluated and the resulting + list is the list of arguments. + If it's a string that doesn't start with `(', the value should follow + the one of the doc string for `interactive'. + A null string means call interactively with no arguments. + `doc' is documentation for the user. */ + +/* This version of DEFUN declares a function prototype with the right + arguments, so we can catch errors with maxargs at compile-time. */ +#ifdef _MSC_VER +#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ + Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \ + static struct Lisp_Subr alignas (GCALIGNMENT) sname = \ + { { (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) \ + | (sizeof (struct Lisp_Subr) / sizeof (EMACS_INT)) }, \ + { (Lisp_Object (__cdecl *)(void))fnname }, \ + minargs, maxargs, lname, intspec, 0}; \ + Lisp_Object fnname +#else /* not _MSC_VER */ +#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ + static struct Lisp_Subr alignas (GCALIGNMENT) sname = \ + { { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ + { .a ## maxargs = fnname }, \ + minargs, maxargs, lname, intspec, 0}; \ + Lisp_Object fnname +#endif + +/* True if OBJ is a Lisp function. */ +INLINE bool +FUNCTIONP (Lisp_Object obj) +{ + return functionp (obj); +} + +/* defsubr (Sname); + is how we define the symbol for function `name' at start-up time. */ +extern void defsubr (struct Lisp_Subr *); + +enum maxargs + { + MANY = -2, + UNEVALLED = -1 + }; + +/* Call a function F that accepts many args, passing it ARRAY's elements. */ +#define CALLMANY(f, array) (f) (ARRAYELTS (array), array) + +/* Call a function F that accepts many args, passing it the remaining args, + E.g., 'return CALLN (Fformat, fmt, text);' is less error-prone than + '{ Lisp_Object a[2]; a[0] = fmt; a[1] = text; return Fformat (2, a); }'. + CALLN is overkill for simple usages like 'Finsert (1, &text);'. */ +#define CALLN(f, ...) CALLMANY (f, ((Lisp_Object []) {__VA_ARGS__})) + +extern void defvar_lisp (struct Lisp_Objfwd *, const char *, Lisp_Object *); +extern void defvar_lisp_nopro (struct Lisp_Objfwd *, const char *, Lisp_Object *); +extern void defvar_bool (struct Lisp_Boolfwd *, const char *, bool *); +extern void defvar_int (struct Lisp_Intfwd *, const char *, EMACS_INT *); +extern void defvar_kboard (struct Lisp_Kboard_Objfwd *, const char *, int); + +/* Macros we use to define forwarded Lisp variables. + These are used in the syms_of_FILENAME functions. + + An ordinary (not in buffer_defaults, per-buffer, or per-keyboard) + lisp variable is actually a field in `struct emacs_globals'. The + field's name begins with "f_", which is a convention enforced by + these macros. Each such global has a corresponding #define in + globals.h; the plain name should be used in the code. + + E.g., the global "cons_cells_consed" is declared as "int + f_cons_cells_consed" in globals.h, but there is a define: + + #define cons_cells_consed globals.f_cons_cells_consed + + All C code uses the `cons_cells_consed' name. This is all done + this way to support indirection for multi-threaded Emacs. */ + +#define DEFVAR_LISP(lname, vname, doc) \ + do { \ + static struct Lisp_Objfwd o_fwd; \ + defvar_lisp (&o_fwd, lname, &globals.f_ ## vname); \ + } while (false) +#define DEFVAR_LISP_NOPRO(lname, vname, doc) \ + do { \ + static struct Lisp_Objfwd o_fwd; \ + defvar_lisp_nopro (&o_fwd, lname, &globals.f_ ## vname); \ + } while (false) +#define DEFVAR_BOOL(lname, vname, doc) \ + do { \ + static struct Lisp_Boolfwd b_fwd; \ + defvar_bool (&b_fwd, lname, &globals.f_ ## vname); \ + } while (false) +#define DEFVAR_INT(lname, vname, doc) \ + do { \ + static struct Lisp_Intfwd i_fwd; \ + defvar_int (&i_fwd, lname, &globals.f_ ## vname); \ + } while (false) + +#define DEFVAR_BUFFER_DEFAULTS(lname, vname, doc) \ + do { \ + static struct Lisp_Objfwd o_fwd; \ + defvar_lisp_nopro (&o_fwd, lname, &BVAR (&buffer_defaults, vname)); \ + } while (false) + +#define DEFVAR_KBOARD(lname, vname, doc) \ + do { \ + static struct Lisp_Kboard_Objfwd ko_fwd; \ + defvar_kboard (&ko_fwd, lname, offsetof (KBOARD, vname ## _)); \ + } while (false) + +/* Save and restore the instruction and environment pointers, + without affecting the signal mask. */ + +#ifdef HAVE__SETJMP +typedef jmp_buf sys_jmp_buf; +# define sys_setjmp(j) _setjmp (j) +# define sys_longjmp(j, v) _longjmp (j, v) +#elif defined HAVE_SIGSETJMP +typedef sigjmp_buf sys_jmp_buf; +# define sys_setjmp(j) sigsetjmp (j, 0) +# define sys_longjmp(j, v) siglongjmp (j, v) +#else +/* A platform that uses neither _longjmp nor siglongjmp; assume + longjmp does not affect the sigmask. */ +typedef jmp_buf sys_jmp_buf; +# define sys_setjmp(j) setjmp (j) +# define sys_longjmp(j, v) longjmp (j, v) +#endif + + +/* Elisp uses several stacks: + - the C stack. + - the bytecode stack: used internally by the bytecode interpreter. + Allocated from the C stack. + - The specpdl stack: keeps track of active unwind-protect and + dynamic-let-bindings. Allocated from the `specpdl' array, a manually + managed stack. + - The handler stack: keeps track of active catch tags and condition-case + handlers. Allocated in a manually managed stack implemented by a + doubly-linked list allocated via xmalloc and never freed. */ + +/* Structure for recording Lisp call stack for backtrace purposes. */ + +/* The special binding stack holds the outer values of variables while + they are bound by a function application or a let form, stores the + code to be executed for unwind-protect forms. + + NOTE: The specbinding union is defined here, because SPECPDL_INDEX is + used all over the place, needs to be fast, and needs to know the size of + union specbinding. But only eval.c should access it. */ + +enum specbind_tag { + SPECPDL_UNWIND, /* An unwind_protect function on Lisp_Object. */ + SPECPDL_UNWIND_PTR, /* Likewise, on void *. */ + SPECPDL_UNWIND_INT, /* Likewise, on int. */ + SPECPDL_UNWIND_VOID, /* Likewise, with no arg. */ + SPECPDL_BACKTRACE, /* An element of the backtrace. */ + SPECPDL_LET, /* A plain and simple dynamic let-binding. */ + /* Tags greater than SPECPDL_LET must be "subkinds" of LET. */ + SPECPDL_LET_LOCAL, /* A buffer-local let-binding. */ + SPECPDL_LET_DEFAULT /* A global binding for a localized var. */ +}; + +union specbinding + { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + void (*func) (Lisp_Object); + Lisp_Object arg; + } unwind; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + void (*func) (void *); + void *arg; + } unwind_ptr; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + void (*func) (int); + int arg; + } unwind_int; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + void (*func) (void); + } unwind_void; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + /* `where' is not used in the case of SPECPDL_LET. */ + Lisp_Object symbol, old_value, where; + } let; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; + bool_bf debug_on_exit : 1; + Lisp_Object function; + Lisp_Object *args; + ptrdiff_t nargs; + } bt; + }; + +extern union specbinding *specpdl; +extern union specbinding *specpdl_ptr; +extern ptrdiff_t specpdl_size; + +INLINE ptrdiff_t +SPECPDL_INDEX (void) +{ + return specpdl_ptr - specpdl; +} + +/* This structure helps implement the `catch/throw' and `condition-case/signal' + control structures. A struct handler contains all the information needed to + restore the state of the interpreter after a non-local jump. + + handler structures are chained together in a doubly linked list; the `next' + member points to the next outer catchtag and the `nextfree' member points in + the other direction to the next inner element (which is typically the next + free element since we mostly use it on the deepest handler). + + A call like (throw TAG VAL) searches for a catchtag whose `tag_or_ch' + member is TAG, and then unbinds to it. The `val' member is used to + hold VAL while the stack is unwound; `val' is returned as the value + of the catch form. + + All the other members are concerned with restoring the interpreter + state. + + Members are volatile if their values need to survive _longjmp when + a 'struct handler' is a local variable. */ + +enum handlertype { CATCHER, CONDITION_CASE }; + +struct handler +{ + enum handlertype type; + Lisp_Object tag_or_ch; + Lisp_Object val; + struct handler *next; + struct handler *nextfree; + + /* The bytecode interpreter can have several handlers active at the same + time, so when we longjmp to one of them, it needs to know which handler + this was and what was the corresponding internal state. This is stored + here, and when we longjmp we make sure that handlerlist points to the + proper handler. */ + Lisp_Object *bytecode_top; + int bytecode_dest; + + /* Most global vars are reset to their value via the specpdl mechanism, + but a few others are handled by storing their value here. */ +#if true /* GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS, but defined later. */ + struct gcpro *gcpro; +#endif + sys_jmp_buf jmp; + EMACS_INT lisp_eval_depth; + ptrdiff_t pdlcount; + int poll_suppress_count; + int interrupt_input_blocked; + struct byte_stack *byte_stack; +}; + +/* Fill in the components of c, and put it on the list. */ +#define PUSH_HANDLER(c, tag_ch_val, handlertype) \ + if (handlerlist->nextfree) \ + (c) = handlerlist->nextfree; \ + else \ + { \ + (c) = xmalloc (sizeof (struct handler)); \ + (c)->nextfree = NULL; \ + handlerlist->nextfree = (c); \ + } \ + (c)->type = (handlertype); \ + (c)->tag_or_ch = (tag_ch_val); \ + (c)->val = Qnil; \ + (c)->next = handlerlist; \ + (c)->lisp_eval_depth = lisp_eval_depth; \ + (c)->pdlcount = SPECPDL_INDEX (); \ + (c)->poll_suppress_count = poll_suppress_count; \ + (c)->interrupt_input_blocked = interrupt_input_blocked;\ + (c)->gcpro = gcprolist; \ + (c)->byte_stack = byte_stack_list; \ + handlerlist = (c); + + +extern Lisp_Object memory_signal_data; + +/* An address near the bottom of the stack. + Tells GC how to save a copy of the stack. */ +extern char *stack_bottom; + +/* Check quit-flag and quit if it is non-nil. + Typing C-g does not directly cause a quit; it only sets Vquit_flag. + So the program needs to do QUIT at times when it is safe to quit. + Every loop that might run for a long time or might not exit + ought to do QUIT at least once, at a safe place. + Unless that is impossible, of course. + But it is very desirable to avoid creating loops where QUIT is impossible. + + Exception: if you set immediate_quit to true, + then the handler that responds to the C-g does the quit itself. + This is a good thing to do around a loop that has no side effects + and (in particular) cannot call arbitrary Lisp code. + + If quit-flag is set to `kill-emacs' the SIGINT handler has received + a request to exit Emacs when it is safe to do. */ + +extern void process_pending_signals (void); +extern bool volatile pending_signals; + +extern void process_quit_flag (void); +#define QUIT \ + do { \ + if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \ + process_quit_flag (); \ + else if (pending_signals) \ + process_pending_signals (); \ + } while (false) + + +/* True if ought to quit now. */ + +#define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) + +extern Lisp_Object Vascii_downcase_table; +extern Lisp_Object Vascii_canon_table; + +/* Structure for recording stack slots that need marking. */ + +/* This is a chain of structures, each of which points at a Lisp_Object + variable whose value should be marked in garbage collection. + Normally every link of the chain is an automatic variable of a function, + and its `val' points to some argument or local variable of the function. + On exit to the function, the chain is set back to the value it had on entry. + This way, no link remains in the chain when the stack frame containing the + link disappears. + + Every function that can call Feval must protect in this fashion all + Lisp_Object variables whose contents will be used again. */ + +extern struct gcpro *gcprolist; + +struct gcpro +{ + struct gcpro *next; + + /* Address of first protected variable. */ + volatile Lisp_Object *var; + + /* Number of consecutive protected variables. */ + ptrdiff_t nvars; + +#ifdef DEBUG_GCPRO + /* File name where this record is used. */ + const char *name; + + /* Line number in this file. */ + int lineno; + + /* Index in the local chain of records. */ + int idx; + + /* Nesting level. */ + int level; +#endif +}; + +/* Values of GC_MARK_STACK during compilation: + + 0 Use GCPRO as before + 1 Do the real thing, make GCPROs and UNGCPRO no-ops. + 2 Mark the stack, and check that everything GCPRO'd is + marked. + 3 Mark using GCPRO's, mark stack last, and count how many + dead objects are kept alive. + + Formerly, method 0 was used. Currently, method 1 is used unless + otherwise specified by hand when building, e.g., + "make CPPFLAGS='-DGC_MARK_STACK=GC_USE_GCPROS_AS_BEFORE'". + Methods 2 and 3 are present mainly to debug the transition from 0 to 1. */ + +#define GC_USE_GCPROS_AS_BEFORE 0 +#define GC_MAKE_GCPROS_NOOPS 1 +#define GC_MARK_STACK_CHECK_GCPROS 2 +#define GC_USE_GCPROS_CHECK_ZOMBIES 3 + +#ifndef GC_MARK_STACK +#define GC_MARK_STACK GC_MAKE_GCPROS_NOOPS +#endif + +/* Whether we do the stack marking manually. */ +#define BYTE_MARK_STACK !(GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) + + +#if GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS + +/* Do something silly with gcproN vars just so gcc shuts up. */ +/* You get warnings from MIPSPro... */ + +#define GCPRO1(varname) ((void) gcpro1) +#define GCPRO2(varname1, varname2) ((void) gcpro2, (void) gcpro1) +#define GCPRO3(varname1, varname2, varname3) \ + ((void) gcpro3, (void) gcpro2, (void) gcpro1) +#define GCPRO4(varname1, varname2, varname3, varname4) \ + ((void) gcpro4, (void) gcpro3, (void) gcpro2, (void) gcpro1) +#define GCPRO5(varname1, varname2, varname3, varname4, varname5) \ + ((void) gcpro5, (void) gcpro4, (void) gcpro3, (void) gcpro2, (void) gcpro1) +#define GCPRO6(varname1, varname2, varname3, varname4, varname5, varname6) \ + ((void) gcpro6, (void) gcpro5, (void) gcpro4, (void) gcpro3, (void) gcpro2, \ + (void) gcpro1) +#define GCPRO7(a, b, c, d, e, f, g) (GCPRO6 (a, b, c, d, e, f), (void) gcpro7) +#define UNGCPRO ((void) 0) + +#else /* GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS */ + +#ifndef DEBUG_GCPRO + +#define GCPRO1(a) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcprolist = &gcpro1; } + +#define GCPRO2(a, b) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcprolist = &gcpro2; } + +#define GCPRO3(a, b, c) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcprolist = &gcpro3; } + +#define GCPRO4(a, b, c, d) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcprolist = &gcpro4; } + +#define GCPRO5(a, b, c, d, e) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcprolist = &gcpro5; } + +#define GCPRO6(a, b, c, d, e, f) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1; \ + gcprolist = &gcpro6; } + +#define GCPRO7(a, b, c, d, e, f, g) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1; \ + gcpro7.next = &gcpro6; gcpro7.var = &(g); gcpro7.nvars = 1; \ + gcprolist = &gcpro7; } + +#define UNGCPRO (gcprolist = gcpro1.next) + +#else /* !DEBUG_GCPRO */ + +extern int gcpro_level; + +#define GCPRO1(a) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level++; \ + gcprolist = &gcpro1; } + +#define GCPRO2(a, b) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro2.level = gcpro_level++; \ + gcprolist = &gcpro2; } + +#define GCPRO3(a, b, c) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3; \ + gcpro3.level = gcpro_level++; \ + gcprolist = &gcpro3; } + +#define GCPRO4(a, b, c, d) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4; \ + gcpro4.level = gcpro_level++; \ + gcprolist = &gcpro4; } + +#define GCPRO5(a, b, c, d, e) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcpro5.name = __FILE__; gcpro5.lineno = __LINE__; gcpro5.idx = 5; \ + gcpro5.level = gcpro_level++; \ + gcprolist = &gcpro5; } + +#define GCPRO6(a, b, c, d, e, f) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcpro5.name = __FILE__; gcpro5.lineno = __LINE__; gcpro5.idx = 5; \ + gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1; \ + gcpro6.name = __FILE__; gcpro6.lineno = __LINE__; gcpro6.idx = 6; \ + gcpro6.level = gcpro_level++; \ + gcprolist = &gcpro6; } + +#define GCPRO7(a, b, c, d, e, f, g) \ + { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1; \ + gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1; \ + gcpro1.level = gcpro_level; \ + gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1; \ + gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2; \ + gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1; \ + gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3; \ + gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1; \ + gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4; \ + gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1; \ + gcpro5.name = __FILE__; gcpro5.lineno = __LINE__; gcpro5.idx = 5; \ + gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1; \ + gcpro6.name = __FILE__; gcpro6.lineno = __LINE__; gcpro6.idx = 6; \ + gcpro7.next = &gcpro6; gcpro7.var = &(g); gcpro7.nvars = 1; \ + gcpro7.name = __FILE__; gcpro7.lineno = __LINE__; gcpro7.idx = 7; \ + gcpro7.level = gcpro_level++; \ + gcprolist = &gcpro7; } + +#define UNGCPRO \ + (--gcpro_level != gcpro1.level \ + ? emacs_abort () \ + : (void) (gcprolist = gcpro1.next)) + +#endif /* DEBUG_GCPRO */ +#endif /* GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS */ + + +/* Evaluate expr, UNGCPRO, and then return the value of expr. */ +#define RETURN_UNGCPRO(expr) \ + do \ + { \ + Lisp_Object ret_ungc_val; \ + ret_ungc_val = (expr); \ + UNGCPRO; \ + return ret_ungc_val; \ + } \ + while (false) + +/* Call staticpro (&var) to protect static variable `var'. */ + +void staticpro (Lisp_Object *); + +/* Forward declarations for prototypes. */ +struct window; +struct frame; + +/* Copy COUNT Lisp_Objects from ARGS to contents of V starting from OFFSET. */ + +INLINE void +vcopy (Lisp_Object v, ptrdiff_t offset, Lisp_Object *args, ptrdiff_t count) +{ + eassert (0 <= offset && 0 <= count && offset + count <= ASIZE (v)); + memcpy (XVECTOR (v)->contents + offset, args, count * sizeof *args); +} + +/* Functions to modify hash tables. */ + +INLINE void +set_hash_key_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val) +{ + gc_aset (h->key_and_value, 2 * idx, val); +} + +INLINE void +set_hash_value_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val) +{ + gc_aset (h->key_and_value, 2 * idx + 1, val); +} + +/* Use these functions to set Lisp_Object + or pointer slots of struct Lisp_Symbol. */ + +INLINE void +set_symbol_function (Lisp_Object sym, Lisp_Object function) +{ + XSYMBOL (sym)->function = function; +} + +INLINE void +set_symbol_plist (Lisp_Object sym, Lisp_Object plist) +{ + XSYMBOL (sym)->plist = plist; +} + +INLINE void +set_symbol_next (Lisp_Object sym, struct Lisp_Symbol *next) +{ + XSYMBOL (sym)->next = next; +} + +/* Buffer-local (also frame-local) variable access functions. */ + +INLINE int +blv_found (struct Lisp_Buffer_Local_Value *blv) +{ + eassert (blv->found == !EQ (blv->defcell, blv->valcell)); + return blv->found; +} + +/* Set overlay's property list. */ + +INLINE void +set_overlay_plist (Lisp_Object overlay, Lisp_Object plist) +{ + XOVERLAY (overlay)->plist = plist; +} + +/* Get text properties of S. */ + +INLINE INTERVAL +string_intervals (Lisp_Object s) +{ + return XSTRING (s)->intervals; +} + +/* Set text properties of S to I. */ + +INLINE void +set_string_intervals (Lisp_Object s, INTERVAL i) +{ + XSTRING (s)->intervals = i; +} + +/* Set a Lisp slot in TABLE to VAL. Most code should use this instead + of setting slots directly. */ + +INLINE void +set_char_table_defalt (Lisp_Object table, Lisp_Object val) +{ + XCHAR_TABLE (table)->defalt = val; +} +INLINE void +set_char_table_purpose (Lisp_Object table, Lisp_Object val) +{ + XCHAR_TABLE (table)->purpose = val; +} + +/* Set different slots in (sub)character tables. */ + +INLINE void +set_char_table_extras (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) +{ + eassert (0 <= idx && idx < CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (table))); + XCHAR_TABLE (table)->extras[idx] = val; +} + +INLINE void +set_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) +{ + eassert (0 <= idx && idx < (1 << CHARTAB_SIZE_BITS_0)); + XCHAR_TABLE (table)->contents[idx] = val; +} + +INLINE void +set_sub_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) +{ + XSUB_CHAR_TABLE (table)->contents[idx] = val; +} + +/* Defined in data.c. */ +extern Lisp_Object indirect_function (Lisp_Object); +extern Lisp_Object find_symbol_value (Lisp_Object); +enum Arith_Comparison { + ARITH_EQUAL, + ARITH_NOTEQUAL, + ARITH_LESS, + ARITH_GRTR, + ARITH_LESS_OR_EQUAL, + ARITH_GRTR_OR_EQUAL +}; +extern Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2, + enum Arith_Comparison comparison); + +/* Convert the integer I to an Emacs representation, either the integer + itself, or a cons of two or three integers, or if all else fails a float. + I should not have side effects. */ +#define INTEGER_TO_CONS(i) \ + (! FIXNUM_OVERFLOW_P (i) \ + ? make_number (i) \ + : ! ((FIXNUM_OVERFLOW_P (INTMAX_MIN >> 16) \ + || FIXNUM_OVERFLOW_P (UINTMAX_MAX >> 16)) \ + && FIXNUM_OVERFLOW_P ((i) >> 16)) \ + ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \ + : ! ((FIXNUM_OVERFLOW_P (INTMAX_MIN >> 16 >> 24) \ + || FIXNUM_OVERFLOW_P (UINTMAX_MAX >> 16 >> 24)) \ + && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \ + ? Fcons (make_number ((i) >> 16 >> 24), \ + Fcons (make_number ((i) >> 16 & 0xffffff), \ + make_number ((i) & 0xffff))) \ + : make_float (i)) + +/* Convert the Emacs representation CONS back to an integer of type + TYPE, storing the result the variable VAR. Signal an error if CONS + is not a valid representation or is out of range for TYPE. */ +#define CONS_TO_INTEGER(cons, type, var) \ + (TYPE_SIGNED (type) \ + ? ((var) = cons_to_signed (cons, TYPE_MINIMUM (type), TYPE_MAXIMUM (type))) \ + : ((var) = cons_to_unsigned (cons, TYPE_MAXIMUM (type)))) +extern intmax_t cons_to_signed (Lisp_Object, intmax_t, intmax_t); +extern uintmax_t cons_to_unsigned (Lisp_Object, uintmax_t); + +extern struct Lisp_Symbol *indirect_variable (struct Lisp_Symbol *); +extern _Noreturn void args_out_of_range (Lisp_Object, Lisp_Object); +extern _Noreturn void args_out_of_range_3 (Lisp_Object, Lisp_Object, + Lisp_Object); +extern Lisp_Object do_symval_forwarding (union Lisp_Fwd *); +extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object, bool); +extern void syms_of_data (void); +extern void swap_in_global_binding (struct Lisp_Symbol *); + +/* Defined in cmds.c */ +extern void syms_of_cmds (void); +extern void keys_of_cmds (void); + +/* Defined in coding.c. */ +extern Lisp_Object detect_coding_system (const unsigned char *, ptrdiff_t, + ptrdiff_t, bool, bool, Lisp_Object); +extern void init_coding (void); +extern void init_coding_once (void); +extern void syms_of_coding (void); + +/* Defined in character.c. */ +extern ptrdiff_t chars_in_text (const unsigned char *, ptrdiff_t); +extern ptrdiff_t multibyte_chars_in_text (const unsigned char *, ptrdiff_t); +extern void syms_of_character (void); + +/* Defined in charset.c. */ +extern void init_charset (void); +extern void init_charset_once (void); +extern void syms_of_charset (void); +/* Structure forward declarations. */ +struct charset; + +/* Defined in syntax.c. */ +extern void init_syntax_once (void); +extern void syms_of_syntax (void); + +/* Defined in fns.c. */ +enum { NEXT_ALMOST_PRIME_LIMIT = 11 }; +extern EMACS_INT next_almost_prime (EMACS_INT) ATTRIBUTE_CONST; +extern Lisp_Object larger_vector (Lisp_Object, ptrdiff_t, ptrdiff_t); +extern void sweep_weak_hash_tables (void); +EMACS_UINT hash_string (char const *, ptrdiff_t); +EMACS_UINT sxhash (Lisp_Object, int); +Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object); +ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *); +ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object, + EMACS_UINT); +extern struct hash_table_test hashtest_eql, hashtest_equal; +extern void validate_subarray (Lisp_Object, Lisp_Object, Lisp_Object, + ptrdiff_t, ptrdiff_t *, ptrdiff_t *); +extern Lisp_Object substring_both (Lisp_Object, ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t); +extern Lisp_Object merge (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object do_yes_or_no_p (Lisp_Object); +extern Lisp_Object concat2 (Lisp_Object, Lisp_Object); +extern Lisp_Object concat3 (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object nconc2 (Lisp_Object, Lisp_Object); +extern Lisp_Object assq_no_quit (Lisp_Object, Lisp_Object); +extern Lisp_Object assoc_no_quit (Lisp_Object, Lisp_Object); +extern void clear_string_char_byte_cache (void); +extern ptrdiff_t string_char_to_byte (Lisp_Object, ptrdiff_t); +extern ptrdiff_t string_byte_to_char (Lisp_Object, ptrdiff_t); +extern Lisp_Object string_to_multibyte (Lisp_Object); +extern Lisp_Object string_make_unibyte (Lisp_Object); +extern void syms_of_fns (void); + +/* Defined in floatfns.c. */ +extern void syms_of_floatfns (void); +extern Lisp_Object fmod_float (Lisp_Object x, Lisp_Object y); + +/* Defined in fringe.c. */ +extern void syms_of_fringe (void); +extern void init_fringe (void); +#ifdef HAVE_WINDOW_SYSTEM +extern void mark_fringe_data (void); +extern void init_fringe_once (void); +#endif /* HAVE_WINDOW_SYSTEM */ + +/* Defined in image.c. */ +extern int x_bitmap_mask (struct frame *, ptrdiff_t); +extern void reset_image_types (void); +extern void syms_of_image (void); + +/* Defined in insdel.c. */ +extern void move_gap_both (ptrdiff_t, ptrdiff_t); +extern _Noreturn void buffer_overflow (void); +extern void make_gap (ptrdiff_t); +extern void make_gap_1 (struct buffer *, ptrdiff_t); +extern ptrdiff_t copy_text (const unsigned char *, unsigned char *, + ptrdiff_t, bool, bool); +extern int count_combining_before (const unsigned char *, + ptrdiff_t, ptrdiff_t, ptrdiff_t); +extern int count_combining_after (const unsigned char *, + ptrdiff_t, ptrdiff_t, ptrdiff_t); +extern void insert (const char *, ptrdiff_t); +extern void insert_and_inherit (const char *, ptrdiff_t); +extern void insert_1_both (const char *, ptrdiff_t, ptrdiff_t, + bool, bool, bool); +extern void insert_from_gap (ptrdiff_t, ptrdiff_t, bool text_at_gap_tail); +extern void insert_from_string (Lisp_Object, ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t, bool); +extern void insert_from_buffer (struct buffer *, ptrdiff_t, ptrdiff_t, bool); +extern void insert_char (int); +extern void insert_string (const char *); +extern void insert_before_markers (const char *, ptrdiff_t); +extern void insert_before_markers_and_inherit (const char *, ptrdiff_t); +extern void insert_from_string_before_markers (Lisp_Object, ptrdiff_t, + ptrdiff_t, ptrdiff_t, + ptrdiff_t, bool); +extern void del_range (ptrdiff_t, ptrdiff_t); +extern Lisp_Object del_range_1 (ptrdiff_t, ptrdiff_t, bool, bool); +extern void del_range_byte (ptrdiff_t, ptrdiff_t, bool); +extern void del_range_both (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, bool); +extern Lisp_Object del_range_2 (ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t, bool); +extern void modify_text (ptrdiff_t, ptrdiff_t); +extern void prepare_to_modify_buffer (ptrdiff_t, ptrdiff_t, ptrdiff_t *); +extern void prepare_to_modify_buffer_1 (ptrdiff_t, ptrdiff_t, ptrdiff_t *); +extern void invalidate_buffer_caches (struct buffer *, ptrdiff_t, ptrdiff_t); +extern void signal_after_change (ptrdiff_t, ptrdiff_t, ptrdiff_t); +extern void adjust_after_insert (ptrdiff_t, ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t); +extern void adjust_markers_for_delete (ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t); +extern void replace_range (ptrdiff_t, ptrdiff_t, Lisp_Object, bool, bool, bool); +extern void replace_range_2 (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, + const char *, ptrdiff_t, ptrdiff_t, bool); +extern void syms_of_insdel (void); + +/* Defined in dispnew.c. */ +#if (defined PROFILING \ + && (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__)) +_Noreturn void __executable_start (void); +#endif +extern Lisp_Object Vwindow_system; +extern Lisp_Object sit_for (Lisp_Object, bool, int); + +/* Defined in xdisp.c. */ +extern bool noninteractive_need_newline; +extern Lisp_Object echo_area_buffer[2]; +extern void add_to_log (const char *, Lisp_Object, Lisp_Object); +extern void check_message_stack (void); +extern void setup_echo_area_for_printing (bool); +extern bool push_message (void); +extern void pop_message_unwind (void); +extern Lisp_Object restore_message_unwind (Lisp_Object); +extern void restore_message (void); +extern Lisp_Object current_message (void); +extern void clear_message (bool, bool); +extern void message (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); +extern void message1 (const char *); +extern void message1_nolog (const char *); +extern void message3 (Lisp_Object); +extern void message3_nolog (Lisp_Object); +extern void message_dolog (const char *, ptrdiff_t, bool, bool); +extern void message_with_string (const char *, Lisp_Object, bool); +extern void message_log_maybe_newline (void); +extern void update_echo_area (void); +extern void truncate_echo_area (ptrdiff_t); +extern void redisplay (void); + +void set_frame_cursor_types (struct frame *, Lisp_Object); +extern void syms_of_xdisp (void); +extern void init_xdisp (void); +extern Lisp_Object safe_eval (Lisp_Object); +extern bool pos_visible_p (struct window *, ptrdiff_t, int *, + int *, int *, int *, int *, int *); + +/* Defined in xsettings.c. */ +extern void syms_of_xsettings (void); + +/* Defined in vm-limit.c. */ +extern void memory_warnings (void *, void (*warnfun) (const char *)); + +/* Defined in character.c. */ +extern void parse_str_as_multibyte (const unsigned char *, ptrdiff_t, + ptrdiff_t *, ptrdiff_t *); + +/* Defined in alloc.c. */ +extern void check_pure_size (void); +extern void free_misc (Lisp_Object); +extern void allocate_string_data (struct Lisp_String *, EMACS_INT, EMACS_INT); +extern void malloc_warning (const char *); +extern _Noreturn void memory_full (size_t); +extern _Noreturn void buffer_memory_full (ptrdiff_t); +extern bool survives_gc_p (Lisp_Object); +extern void mark_object (Lisp_Object); +#if defined REL_ALLOC && !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC +extern void refill_memory_reserve (void); +#endif +extern const char *pending_malloc_warning; +extern Lisp_Object zero_vector; +extern Lisp_Object *stack_base; +extern EMACS_INT consing_since_gc; +extern EMACS_INT gc_relative_threshold; +extern EMACS_INT memory_full_cons_threshold; +extern Lisp_Object list1 (Lisp_Object); +extern Lisp_Object list2 (Lisp_Object, Lisp_Object); +extern Lisp_Object list3 (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object list4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object list5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object); +enum constype {CONSTYPE_HEAP, CONSTYPE_PURE}; +extern Lisp_Object listn (enum constype, ptrdiff_t, Lisp_Object, ...); + +/* Build a frequently used 2/3/4-integer lists. */ + +INLINE Lisp_Object +list2i (EMACS_INT x, EMACS_INT y) +{ + return list2 (make_number (x), make_number (y)); +} + +INLINE Lisp_Object +list3i (EMACS_INT x, EMACS_INT y, EMACS_INT w) +{ + return list3 (make_number (x), make_number (y), make_number (w)); +} + +INLINE Lisp_Object +list4i (EMACS_INT x, EMACS_INT y, EMACS_INT w, EMACS_INT h) +{ + return list4 (make_number (x), make_number (y), + make_number (w), make_number (h)); +} + +extern Lisp_Object make_uninit_bool_vector (EMACS_INT); +extern Lisp_Object bool_vector_fill (Lisp_Object, Lisp_Object); +extern _Noreturn void string_overflow (void); +extern Lisp_Object make_string (const char *, ptrdiff_t); +extern Lisp_Object make_formatted_string (char *, const char *, ...) + ATTRIBUTE_FORMAT_PRINTF (2, 3); +extern Lisp_Object make_unibyte_string (const char *, ptrdiff_t); + +/* Make unibyte string from C string when the length isn't known. */ + +INLINE Lisp_Object +build_unibyte_string (const char *str) +{ + return make_unibyte_string (str, strlen (str)); +} + +extern Lisp_Object make_multibyte_string (const char *, ptrdiff_t, ptrdiff_t); +extern Lisp_Object make_event_array (ptrdiff_t, Lisp_Object *); +extern Lisp_Object make_uninit_string (EMACS_INT); +extern Lisp_Object make_uninit_multibyte_string (EMACS_INT, EMACS_INT); +extern Lisp_Object make_string_from_bytes (const char *, ptrdiff_t, ptrdiff_t); +extern Lisp_Object make_specified_string (const char *, + ptrdiff_t, ptrdiff_t, bool); +extern Lisp_Object make_pure_string (const char *, ptrdiff_t, ptrdiff_t, bool); +extern Lisp_Object make_pure_c_string (const char *, ptrdiff_t); + +/* Make a string allocated in pure space, use STR as string data. */ + +INLINE Lisp_Object +build_pure_c_string (const char *str) +{ + return make_pure_c_string (str, strlen (str)); +} + +/* Make a string from the data at STR, treating it as multibyte if the + data warrants. */ + +INLINE Lisp_Object +build_string (const char *str) +{ + return make_string (str, strlen (str)); +} + +extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); +extern void make_byte_code (struct Lisp_Vector *); +extern struct Lisp_Vector *allocate_vector (EMACS_INT); + +/* Make an uninitialized vector for SIZE objects. NOTE: you must + be sure that GC cannot happen until the vector is completely + initialized. E.g. the following code is likely to crash: + + v = make_uninit_vector (3); + ASET (v, 0, obj0); + ASET (v, 1, Ffunction_can_gc ()); + ASET (v, 2, obj1); */ + +INLINE Lisp_Object +make_uninit_vector (ptrdiff_t size) +{ + Lisp_Object v; + struct Lisp_Vector *p; + + p = allocate_vector (size); + XSETVECTOR (v, p); + return v; +} + +/* Like above, but special for sub char-tables. */ + +INLINE Lisp_Object +make_uninit_sub_char_table (int depth, int min_char) +{ + int slots = SUB_CHAR_TABLE_OFFSET + chartab_size[depth]; + Lisp_Object v = make_uninit_vector (slots); + + XSETPVECTYPE (XVECTOR (v), PVEC_SUB_CHAR_TABLE); + XSUB_CHAR_TABLE (v)->depth = depth; + XSUB_CHAR_TABLE (v)->min_char = min_char; + return v; +} + +extern struct Lisp_Vector *allocate_pseudovector (int, int, int, + enum pvec_type); + +/* Allocate partially initialized pseudovector where all Lisp_Object + slots are set to Qnil but the rest (if any) is left uninitialized. */ + +#define ALLOCATE_PSEUDOVECTOR(type, field, tag) \ + ((type *) allocate_pseudovector (VECSIZE (type), \ + PSEUDOVECSIZE (type, field), \ + PSEUDOVECSIZE (type, field), tag)) + +/* Allocate fully initialized pseudovector where all Lisp_Object + slots are set to Qnil and the rest (if any) is zeroed. */ + +#define ALLOCATE_ZEROED_PSEUDOVECTOR(type, field, tag) \ + ((type *) allocate_pseudovector (VECSIZE (type), \ + PSEUDOVECSIZE (type, field), \ + VECSIZE (type), tag)) + +extern bool gc_in_progress; +extern bool abort_on_gc; +extern Lisp_Object make_float (double); +extern void display_malloc_warning (void); +extern ptrdiff_t inhibit_garbage_collection (void); +extern Lisp_Object make_save_int_int_int (ptrdiff_t, ptrdiff_t, ptrdiff_t); +extern Lisp_Object make_save_obj_obj_obj_obj (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object); +extern Lisp_Object make_save_ptr (void *); +extern Lisp_Object make_save_ptr_int (void *, ptrdiff_t); +extern Lisp_Object make_save_ptr_ptr (void *, void *); +extern Lisp_Object make_save_funcptr_ptr_obj (void (*) (void), void *, + Lisp_Object); +extern Lisp_Object make_save_memory (Lisp_Object *, ptrdiff_t); +extern void free_save_value (Lisp_Object); +extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object); +extern void free_marker (Lisp_Object); +extern void free_cons (struct Lisp_Cons *); +extern void init_alloc_once (void); +extern void init_alloc (void); +extern void syms_of_alloc (void); +extern struct buffer * allocate_buffer (void); +extern int valid_lisp_object_p (Lisp_Object); +extern int relocatable_string_data_p (const char *); +#ifdef GC_CHECK_CONS_LIST +extern void check_cons_list (void); +#else +INLINE void (check_cons_list) (void) { lisp_h_check_cons_list (); } +#endif + +#ifdef REL_ALLOC +/* Defined in ralloc.c. */ +extern void *r_alloc (void **, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); +extern void r_alloc_free (void **); +extern void *r_re_alloc (void **, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); +extern void r_alloc_reset_variable (void **, void **); +extern void r_alloc_inhibit_buffer_relocation (int); +#endif + +/* Defined in chartab.c. */ +extern Lisp_Object copy_char_table (Lisp_Object); +extern Lisp_Object char_table_ref_and_range (Lisp_Object, int, + int *, int *); +extern void char_table_set_range (Lisp_Object, int, int, Lisp_Object); +extern void map_char_table (void (*) (Lisp_Object, Lisp_Object, + Lisp_Object), + Lisp_Object, Lisp_Object, Lisp_Object); +extern void map_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object), + Lisp_Object, Lisp_Object, + Lisp_Object, struct charset *, + unsigned, unsigned); +extern Lisp_Object uniprop_table (Lisp_Object); +extern void syms_of_chartab (void); + +/* Defined in print.c. */ +extern Lisp_Object Vprin1_to_string_buffer; +extern void debug_print (Lisp_Object) EXTERNALLY_VISIBLE; +extern void temp_output_buffer_setup (const char *); +extern int print_level; +extern void write_string (const char *); +extern void print_error_message (Lisp_Object, Lisp_Object, const char *, + Lisp_Object); +extern Lisp_Object internal_with_output_to_temp_buffer + (const char *, Lisp_Object (*) (Lisp_Object), Lisp_Object); +#define FLOAT_TO_STRING_BUFSIZE 350 +extern int float_to_string (char *, double); +extern void init_print_once (void); +extern void syms_of_print (void); + +/* Defined in doprnt.c. */ +extern ptrdiff_t doprnt (char *, ptrdiff_t, const char *, const char *, + va_list); +extern ptrdiff_t esprintf (char *, char const *, ...) + ATTRIBUTE_FORMAT_PRINTF (2, 3); +extern ptrdiff_t exprintf (char **, ptrdiff_t *, char const *, ptrdiff_t, + char const *, ...) + ATTRIBUTE_FORMAT_PRINTF (5, 6); +extern ptrdiff_t evxprintf (char **, ptrdiff_t *, char const *, ptrdiff_t, + char const *, va_list) + ATTRIBUTE_FORMAT_PRINTF (5, 0); + +/* Defined in lread.c. */ +extern Lisp_Object check_obarray (Lisp_Object); +extern Lisp_Object intern_1 (const char *, ptrdiff_t); +extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t); +extern Lisp_Object intern_driver (Lisp_Object, Lisp_Object, Lisp_Object); +extern void init_symbol (Lisp_Object, Lisp_Object); +extern Lisp_Object oblookup (Lisp_Object, const char *, ptrdiff_t, ptrdiff_t); +INLINE void +LOADHIST_ATTACH (Lisp_Object x) +{ + if (initialized) + Vcurrent_load_list = Fcons (x, Vcurrent_load_list); +} +extern int openp (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object *, Lisp_Object, bool); +extern Lisp_Object string_to_number (char const *, int, bool); +extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object), + Lisp_Object); +extern void dir_warning (const char *, Lisp_Object); +extern void init_obarray (void); +extern void init_lread (void); +extern void syms_of_lread (void); + +INLINE Lisp_Object +intern (const char *str) +{ + return intern_1 (str, strlen (str)); +} + +INLINE Lisp_Object +intern_c_string (const char *str) +{ + return intern_c_string_1 (str, strlen (str)); +} + +/* Defined in eval.c. */ +extern EMACS_INT lisp_eval_depth; +extern Lisp_Object Vautoload_queue; +extern Lisp_Object Vrun_hooks; +extern Lisp_Object Vsignaling_function; +extern Lisp_Object inhibit_lisp_code; +extern struct handler *handlerlist; + +/* To run a normal hook, use the appropriate function from the list below. + The calling convention: + + if (!NILP (Vrun_hooks)) + call1 (Vrun_hooks, Qmy_funny_hook); + + should no longer be used. */ +extern void run_hook (Lisp_Object); +extern void run_hook_with_args_2 (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args, + Lisp_Object (*funcall) + (ptrdiff_t nargs, Lisp_Object *args)); +extern _Noreturn void xsignal (Lisp_Object, Lisp_Object); +extern _Noreturn void xsignal0 (Lisp_Object); +extern _Noreturn void xsignal1 (Lisp_Object, Lisp_Object); +extern _Noreturn void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object); +extern _Noreturn void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object); +extern _Noreturn void signal_error (const char *, Lisp_Object); +extern Lisp_Object eval_sub (Lisp_Object form); +extern Lisp_Object apply1 (Lisp_Object, Lisp_Object); +extern Lisp_Object call0 (Lisp_Object); +extern Lisp_Object call1 (Lisp_Object, Lisp_Object); +extern Lisp_Object call2 (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call7 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object internal_catch (Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object); +extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_n + (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, + Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); +extern void specbind (Lisp_Object, Lisp_Object); +extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object); +extern void record_unwind_protect_ptr (void (*) (void *), void *); +extern void record_unwind_protect_int (void (*) (int), int); +extern void record_unwind_protect_void (void (*) (void)); +extern void record_unwind_protect_nothing (void); +extern void clear_unwind_protect (ptrdiff_t); +extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object); +extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *); +extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object); +extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); +extern _Noreturn void verror (const char *, va_list) + ATTRIBUTE_FORMAT_PRINTF (1, 0); +extern void un_autoload (Lisp_Object); +extern Lisp_Object call_debugger (Lisp_Object arg); +extern void init_eval_once (void); +extern Lisp_Object safe_call (ptrdiff_t, Lisp_Object, ...); +extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object); +extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object); +extern void init_eval (void); +extern void syms_of_eval (void); +extern void unwind_body (Lisp_Object); +extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t); +extern void mark_specpdl (void); +extern void get_backtrace (Lisp_Object array); +Lisp_Object backtrace_top_function (void); +extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol); +extern bool let_shadows_global_binding_p (Lisp_Object symbol); + + +/* Defined in editfns.c. */ +extern void insert1 (Lisp_Object); +extern Lisp_Object format2 (const char *, Lisp_Object, Lisp_Object); +extern Lisp_Object save_excursion_save (void); +extern Lisp_Object save_restriction_save (void); +extern void save_excursion_restore (Lisp_Object); +extern void save_restriction_restore (Lisp_Object); +extern _Noreturn void time_overflow (void); +extern Lisp_Object make_buffer_string (ptrdiff_t, ptrdiff_t, bool); +extern Lisp_Object make_buffer_string_both (ptrdiff_t, ptrdiff_t, ptrdiff_t, + ptrdiff_t, bool); +extern void init_editfns (void); +extern void syms_of_editfns (void); + +/* Defined in buffer.c. */ +extern bool mouse_face_overlay_overlaps (Lisp_Object); +extern _Noreturn void nsberror (Lisp_Object); +extern void adjust_overlays_for_insert (ptrdiff_t, ptrdiff_t); +extern void adjust_overlays_for_delete (ptrdiff_t, ptrdiff_t); +extern void fix_start_end_in_overlays (ptrdiff_t, ptrdiff_t); +extern void report_overlay_modification (Lisp_Object, Lisp_Object, bool, + Lisp_Object, Lisp_Object, Lisp_Object); +extern bool overlay_touches_p (ptrdiff_t); +extern Lisp_Object other_buffer_safely (Lisp_Object); +extern Lisp_Object get_truename_buffer (Lisp_Object); +extern void init_buffer_once (void); +extern void init_buffer (int); +extern void syms_of_buffer (void); +extern void keys_of_buffer (void); + +/* Defined in marker.c. */ + +extern ptrdiff_t marker_position (Lisp_Object); +extern ptrdiff_t marker_byte_position (Lisp_Object); +extern void clear_charpos_cache (struct buffer *); +extern ptrdiff_t buf_charpos_to_bytepos (struct buffer *, ptrdiff_t); +extern ptrdiff_t buf_bytepos_to_charpos (struct buffer *, ptrdiff_t); +extern void unchain_marker (struct Lisp_Marker *marker); +extern Lisp_Object set_marker_restricted (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object set_marker_both (Lisp_Object, Lisp_Object, ptrdiff_t, ptrdiff_t); +extern Lisp_Object set_marker_restricted_both (Lisp_Object, Lisp_Object, + ptrdiff_t, ptrdiff_t); +extern Lisp_Object build_marker (struct buffer *, ptrdiff_t, ptrdiff_t); +extern void syms_of_marker (void); + +/* Defined in fileio.c. */ + +extern Lisp_Object expand_and_dir_to_file (Lisp_Object, Lisp_Object); +extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object, int); +extern void close_file_unwind (int); +extern void fclose_unwind (void *); +extern void restore_point_unwind (Lisp_Object); +extern _Noreturn void report_file_errno (const char *, Lisp_Object, int); +extern _Noreturn void report_file_error (const char *, Lisp_Object); +extern bool internal_delete_file (Lisp_Object); +extern Lisp_Object emacs_readlinkat (int, const char *); +extern bool file_directory_p (const char *); +extern bool file_accessible_directory_p (Lisp_Object); +extern void init_fileio (void); +extern void syms_of_fileio (void); +extern Lisp_Object make_temp_name (Lisp_Object, bool); + +/* Defined in search.c. */ +extern void shrink_regexp_cache (void); +extern void restore_search_regs (void); +extern void record_unwind_save_match_data (void); +struct re_registers; +extern struct re_pattern_buffer *compile_pattern (Lisp_Object, + struct re_registers *, + Lisp_Object, bool, bool); +extern ptrdiff_t fast_string_match_internal (Lisp_Object, Lisp_Object, + Lisp_Object); + +INLINE ptrdiff_t +fast_string_match (Lisp_Object regexp, Lisp_Object string) +{ + return fast_string_match_internal (regexp, string, Qnil); +} + +INLINE ptrdiff_t +fast_string_match_ignore_case (Lisp_Object regexp, Lisp_Object string) +{ + return fast_string_match_internal (regexp, string, Vascii_canon_table); +} + +extern ptrdiff_t fast_c_string_match_ignore_case (Lisp_Object, const char *, + ptrdiff_t); +extern ptrdiff_t fast_looking_at (Lisp_Object, ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t, Lisp_Object); +extern ptrdiff_t find_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t *, ptrdiff_t *, bool); +extern ptrdiff_t scan_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, + ptrdiff_t, bool); +extern ptrdiff_t scan_newline_from_point (ptrdiff_t, ptrdiff_t *, ptrdiff_t *); +extern ptrdiff_t find_newline_no_quit (ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t *); +extern ptrdiff_t find_before_next_newline (ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t *); +extern void syms_of_search (void); +extern void clear_regexp_cache (void); + +/* Defined in minibuf.c. */ + +extern Lisp_Object Vminibuffer_list; +extern Lisp_Object last_minibuf_string; +extern Lisp_Object get_minibuffer (EMACS_INT); +extern void init_minibuf_once (void); +extern void syms_of_minibuf (void); + +/* Defined in callint.c. */ + +extern void syms_of_callint (void); + +/* Defined in casefiddle.c. */ + +extern void syms_of_casefiddle (void); +extern void keys_of_casefiddle (void); + +/* Defined in casetab.c. */ + +extern void init_casetab_once (void); +extern void syms_of_casetab (void); + +/* Defined in keyboard.c. */ + +extern Lisp_Object echo_message_buffer; +extern struct kboard *echo_kboard; +extern void cancel_echoing (void); +extern Lisp_Object last_undo_boundary; +extern bool input_pending; +#ifdef HAVE_STACK_OVERFLOW_HANDLING +extern sigjmp_buf return_to_command_loop; +#endif +extern Lisp_Object menu_bar_items (Lisp_Object); +extern Lisp_Object tool_bar_items (Lisp_Object, int *); +extern void discard_mouse_events (void); +#ifdef USABLE_SIGIO +void handle_input_available_signal (int); +#endif +extern Lisp_Object pending_funcalls; +extern bool detect_input_pending (void); +extern bool detect_input_pending_ignore_squeezables (void); +extern bool detect_input_pending_run_timers (bool); +extern void safe_run_hooks (Lisp_Object); +extern void cmd_error_internal (Lisp_Object, const char *); +extern Lisp_Object command_loop_1 (void); +extern Lisp_Object read_menu_command (void); +extern Lisp_Object recursive_edit_1 (void); +extern void record_auto_save (void); +extern void force_auto_save_soon (void); +extern void init_keyboard (void); +extern void syms_of_keyboard (void); +extern void keys_of_keyboard (void); + +/* Defined in indent.c. */ +extern ptrdiff_t current_column (void); +extern void invalidate_current_column (void); +extern bool indented_beyond_p (ptrdiff_t, ptrdiff_t, EMACS_INT); +extern void syms_of_indent (void); + +/* Defined in frame.c. */ +extern void store_frame_param (struct frame *, Lisp_Object, Lisp_Object); +extern void store_in_alist (Lisp_Object *, Lisp_Object, Lisp_Object); +extern Lisp_Object do_switch_frame (Lisp_Object, int, int, Lisp_Object); +extern Lisp_Object get_frame_param (struct frame *, Lisp_Object); +extern void frames_discard_buffer (Lisp_Object); +extern void syms_of_frame (void); + +/* Defined in emacs.c. */ +extern char **initial_argv; +extern int initial_argc; +#if defined (HAVE_X_WINDOWS) || defined (HAVE_NS) +extern bool display_arg; +#endif +extern Lisp_Object decode_env_path (const char *, const char *, bool); +extern Lisp_Object empty_unibyte_string, empty_multibyte_string; +extern _Noreturn void terminate_due_to_signal (int, int); +#ifdef WINDOWSNT +extern Lisp_Object Vlibrary_cache; +#endif +#if HAVE_SETLOCALE +void fixup_locale (void); +void synchronize_system_messages_locale (void); +void synchronize_system_time_locale (void); +#else +INLINE void fixup_locale (void) {} +INLINE void synchronize_system_messages_locale (void) {} +INLINE void synchronize_system_time_locale (void) {} +#endif +extern void shut_down_emacs (int, Lisp_Object); + +/* True means don't do interactive redisplay and don't change tty modes. */ +extern bool noninteractive; + +/* True means remove site-lisp directories from load-path. */ +extern bool no_site_lisp; + +/* Pipe used to send exit notification to the daemon parent at + startup. On Windows, we use a kernel event instead. */ +#ifndef WINDOWSNT +extern int daemon_pipe[2]; +#define IS_DAEMON (daemon_pipe[1] != 0) +#define DAEMON_RUNNING (daemon_pipe[1] >= 0) +#else /* WINDOWSNT */ +extern void *w32_daemon_event; +#define IS_DAEMON (w32_daemon_event != NULL) +#define DAEMON_RUNNING (w32_daemon_event != INVALID_HANDLE_VALUE) +#endif + +/* True if handling a fatal error already. */ +extern bool fatal_error_in_progress; + +/* True means don't do use window-system-specific display code. */ +extern bool inhibit_window_system; +/* True means that a filter or a sentinel is running. */ +extern bool running_asynch_code; + +/* Defined in process.c. */ +extern void kill_buffer_processes (Lisp_Object); +extern int wait_reading_process_output (intmax_t, int, int, bool, Lisp_Object, + struct Lisp_Process *, int); +/* Max value for the first argument of wait_reading_process_output. */ +#if __GNUC__ == 3 || (__GNUC__ == 4 && __GNUC_MINOR__ <= 5) +/* Work around a bug in GCC 3.4.2, known to be fixed in GCC 4.6.3. + The bug merely causes a bogus warning, but the warning is annoying. */ +# define WAIT_READING_MAX min (TYPE_MAXIMUM (time_t), INTMAX_MAX) +#else +# define WAIT_READING_MAX INTMAX_MAX +#endif +#ifdef HAVE_TIMERFD +extern void add_timer_wait_descriptor (int); +#endif +extern void add_keyboard_wait_descriptor (int); +extern void delete_keyboard_wait_descriptor (int); +#ifdef HAVE_GPM +extern void add_gpm_wait_descriptor (int); +extern void delete_gpm_wait_descriptor (int); +#endif +extern void init_process_emacs (void); +extern void syms_of_process (void); +extern void setup_process_coding_systems (Lisp_Object); + +/* Defined in callproc.c. */ +#ifndef DOS_NT + _Noreturn +#endif +extern int child_setup (int, int, int, char **, bool, Lisp_Object); +extern void init_callproc_1 (void); +extern void init_callproc (void); +extern void set_initial_environment (void); +extern void syms_of_callproc (void); + +/* Defined in doc.c. */ +extern Lisp_Object read_doc_string (Lisp_Object); +extern Lisp_Object get_doc_string (Lisp_Object, bool, bool); +extern void syms_of_doc (void); +extern int read_bytecode_char (bool); + +/* Defined in bytecode.c. */ +extern void syms_of_bytecode (void); +extern struct byte_stack *byte_stack_list; +#if BYTE_MARK_STACK +extern void mark_byte_stack (void); +#endif +extern void unmark_byte_stack (void); +extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object, ptrdiff_t, Lisp_Object *); + +/* Defined in macros.c. */ +extern void init_macros (void); +extern void syms_of_macros (void); + +/* Defined in undo.c. */ +extern void truncate_undo_list (struct buffer *); +extern void record_insert (ptrdiff_t, ptrdiff_t); +extern void record_delete (ptrdiff_t, Lisp_Object, bool); +extern void record_first_change (void); +extern void record_change (ptrdiff_t, ptrdiff_t); +extern void record_property_change (ptrdiff_t, ptrdiff_t, + Lisp_Object, Lisp_Object, + Lisp_Object); +extern void syms_of_undo (void); + +/* Defined in textprop.c. */ +extern void report_interval_modification (Lisp_Object, Lisp_Object); + +/* Defined in menu.c. */ +extern void syms_of_menu (void); + +/* Defined in xmenu.c. */ +extern void syms_of_xmenu (void); + +/* Defined in termchar.h. */ +struct tty_display_info; + +/* Defined in termhooks.h. */ +struct terminal; + +/* Defined in sysdep.c. */ +#ifndef HAVE_GET_CURRENT_DIR_NAME +extern char *get_current_dir_name (void); +#endif +extern void stuff_char (char c); +extern void init_foreground_group (void); +extern void sys_subshell (void); +extern void sys_suspend (void); +extern void discard_tty_input (void); +extern void init_sys_modes (struct tty_display_info *); +extern void reset_sys_modes (struct tty_display_info *); +extern void init_all_sys_modes (void); +extern void reset_all_sys_modes (void); +extern void child_setup_tty (int); +extern void setup_pty (int); +extern int set_window_size (int, int, int); +extern EMACS_INT get_random (void); +extern void seed_random (void *, ptrdiff_t); +extern void init_random (void); +extern void emacs_backtrace (int); +extern _Noreturn void emacs_abort (void) NO_INLINE; +extern int emacs_open (const char *, int, int); +extern int emacs_pipe (int[2]); +extern int emacs_close (int); +extern ptrdiff_t emacs_read (int, void *, ptrdiff_t); +extern ptrdiff_t emacs_write (int, void const *, ptrdiff_t); +extern ptrdiff_t emacs_write_sig (int, void const *, ptrdiff_t); +extern void emacs_perror (char const *); + +extern void unlock_all_files (void); +extern void lock_file (Lisp_Object); +extern void unlock_file (Lisp_Object); +extern void unlock_buffer (struct buffer *); +extern void syms_of_filelock (void); +extern int str_collate (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + +/* Defined in sound.c. */ +extern void syms_of_sound (void); + +/* Defined in category.c. */ +extern void init_category_once (void); +extern Lisp_Object char_category_set (int); +extern void syms_of_category (void); + +/* Defined in ccl.c. */ +extern void syms_of_ccl (void); + +/* Defined in dired.c. */ +extern void syms_of_dired (void); +extern Lisp_Object directory_files_internal (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object, + bool, Lisp_Object); + +/* Defined in term.c. */ +extern int *char_ins_del_vector; +extern void syms_of_term (void); +extern _Noreturn void fatal (const char *msgid, ...) + ATTRIBUTE_FORMAT_PRINTF (1, 2); + +/* Defined in terminal.c. */ +extern void syms_of_terminal (void); + +/* Defined in font.c. */ +extern void syms_of_font (void); +extern void init_font (void); + +#ifdef HAVE_WINDOW_SYSTEM +/* Defined in fontset.c. */ +extern void syms_of_fontset (void); +#endif + +/* Defined in gfilenotify.c */ +#ifdef HAVE_GFILENOTIFY +extern void globals_of_gfilenotify (void); +extern void syms_of_gfilenotify (void); +#endif + +/* Defined in inotify.c */ +#ifdef HAVE_INOTIFY +extern void syms_of_inotify (void); +#endif + +#ifdef HAVE_W32NOTIFY +/* Defined on w32notify.c. */ +extern void syms_of_w32notify (void); +#endif + +/* Defined in xfaces.c. */ +extern Lisp_Object Vface_alternative_font_family_alist; +extern Lisp_Object Vface_alternative_font_registry_alist; +extern void syms_of_xfaces (void); + +#ifdef HAVE_X_WINDOWS +/* Defined in xfns.c. */ +extern void syms_of_xfns (void); + +/* Defined in xsmfns.c. */ +extern void syms_of_xsmfns (void); + +/* Defined in xselect.c. */ +extern void syms_of_xselect (void); + +/* Defined in xterm.c. */ +extern void init_xterm (void); +extern void syms_of_xterm (void); +#endif /* HAVE_X_WINDOWS */ + +#ifdef HAVE_WINDOW_SYSTEM +/* Defined in xterm.c, nsterm.m, w32term.c. */ +extern char *x_get_keysym_name (int); +#endif /* HAVE_WINDOW_SYSTEM */ + +#ifdef HAVE_LIBXML2 +/* Defined in xml.c. */ +extern void syms_of_xml (void); +extern void xml_cleanup_parser (void); +#endif + +#ifdef HAVE_ZLIB +/* Defined in decompress.c. */ +extern void syms_of_decompress (void); +#endif + +#ifdef HAVE_DBUS +/* Defined in dbusbind.c. */ +void init_dbusbind (void); +void syms_of_dbusbind (void); +#endif + + +/* Defined in profiler.c. */ +extern bool profiler_memory_running; +extern void malloc_probe (size_t); +extern void syms_of_profiler (void); + + +#ifdef DOS_NT +/* Defined in msdos.c, w32.c. */ +extern char *emacs_root_dir (void); +#endif /* DOS_NT */ + +/* Defined in lastfile.c. */ +extern char my_edata[]; +extern char my_endbss[]; +extern char *my_endbss_static; + +/* True means ^G can quit instantly. */ +extern bool immediate_quit; + +extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); +extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); +extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); +extern void xfree (void *); +extern void *xnmalloc (ptrdiff_t, ptrdiff_t) ATTRIBUTE_MALLOC_SIZE ((1,2)); +extern void *xnrealloc (void *, ptrdiff_t, ptrdiff_t) + ATTRIBUTE_ALLOC_SIZE ((2,3)); +extern void *xpalloc (void *, ptrdiff_t *, ptrdiff_t, ptrdiff_t, ptrdiff_t); + +extern char *xstrdup (const char *) ATTRIBUTE_MALLOC; +extern char *xlispstrdup (Lisp_Object) ATTRIBUTE_MALLOC; +extern void dupstring (char **, char const *); + +/* Make DEST a copy of STRING's data. Return a pointer to DEST's terminating + null byte. This is like stpcpy, except the source is a Lisp string. */ + +INLINE char * +lispstpcpy (char *dest, Lisp_Object string) +{ + ptrdiff_t len = SBYTES (string); + memcpy (dest, SDATA (string), len + 1); + return dest + len; +} + +extern void xputenv (const char *); + +extern char *egetenv_internal (const char *, ptrdiff_t); + +INLINE char * +egetenv (const char *var) +{ + /* When VAR is a string literal, strlen can be optimized away. */ + return egetenv_internal (var, strlen (var)); +} + +/* Set up the name of the machine we're running on. */ +extern void init_system_name (void); + +/* Return the absolute value of X. X should be a signed integer + expression without side effects, and X's absolute value should not + exceed the maximum for its promoted type. This is called 'eabs' + because 'abs' is reserved by the C standard. */ +#define eabs(x) ((x) < 0 ? -(x) : (x)) + +/* Return a fixnum or float, depending on whether VAL fits in a Lisp + fixnum. */ + +#define make_fixnum_or_float(val) \ + (FIXNUM_OVERFLOW_P (val) ? make_float (val) : make_number (val)) + +/* SAFE_ALLOCA normally allocates memory on the stack, but if size is + larger than MAX_ALLOCA, use xmalloc to avoid overflowing the stack. */ + +enum MAX_ALLOCA { MAX_ALLOCA = 16 * 1024 }; + +extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); + +#define USE_SAFE_ALLOCA \ + ptrdiff_t sa_avail = MAX_ALLOCA; \ + ptrdiff_t sa_count = SPECPDL_INDEX (); bool sa_must_free = false + +#define AVAIL_ALLOCA(size) (sa_avail -= (size), alloca (size)) + +/* SAFE_ALLOCA allocates a simple buffer. */ + +#define SAFE_ALLOCA(size) ((size) <= sa_avail \ + ? AVAIL_ALLOCA (size) \ + : (sa_must_free = true, record_xmalloc (size))) + +/* SAFE_NALLOCA sets BUF to a newly allocated array of MULTIPLIER * + NITEMS items, each of the same type as *BUF. MULTIPLIER must + positive. The code is tuned for MULTIPLIER being a constant. */ + +#define SAFE_NALLOCA(buf, multiplier, nitems) \ + do { \ + if ((nitems) <= sa_avail / sizeof *(buf) / (multiplier)) \ + (buf) = AVAIL_ALLOCA (sizeof *(buf) * (multiplier) * (nitems)); \ + else \ + { \ + (buf) = xnmalloc (nitems, sizeof *(buf) * (multiplier)); \ + sa_must_free = true; \ + record_unwind_protect_ptr (xfree, buf); \ + } \ + } while (false) + +/* SAFE_ALLOCA_STRING allocates a C copy of a Lisp string. */ + +#define SAFE_ALLOCA_STRING(ptr, string) \ + do { \ + (ptr) = SAFE_ALLOCA (SBYTES (string) + 1); \ + memcpy (ptr, SDATA (string), SBYTES (string) + 1); \ + } while (false) + +/* SAFE_FREE frees xmalloced memory and enables GC as needed. */ + +#define SAFE_FREE() \ + do { \ + if (sa_must_free) { \ + sa_must_free = false; \ + unbind_to (sa_count, Qnil); \ + } \ + } while (false) + + +/* Return floor (NBYTES / WORD_SIZE). */ + +INLINE ptrdiff_t +lisp_word_count (ptrdiff_t nbytes) +{ + if (-1 >> 1 == -1) + switch (word_size) + { + case 2: return nbytes >> 1; + case 4: return nbytes >> 2; + case 8: return nbytes >> 3; + case 16: return nbytes >> 4; + } + return nbytes / word_size - (nbytes % word_size < 0); +} + +/* SAFE_ALLOCA_LISP allocates an array of Lisp_Objects. */ + +#define SAFE_ALLOCA_LISP(buf, nelt) \ + do { \ + if ((nelt) <= lisp_word_count (sa_avail)) \ + (buf) = AVAIL_ALLOCA ((nelt) * word_size); \ + else if ((nelt) <= min (PTRDIFF_MAX, SIZE_MAX) / word_size) \ + { \ + Lisp_Object arg_; \ + (buf) = xmalloc ((nelt) * word_size); \ + arg_ = make_save_memory (buf, nelt); \ + sa_must_free = true; \ + record_unwind_protect (free_save_value, arg_); \ + } \ + else \ + memory_full (SIZE_MAX); \ + } while (false) + + +/* If USE_STACK_LISP_OBJECTS, define macros that and functions that allocate + block-scoped conses and strings. These objects are not + managed by the garbage collector, so they are dangerous: passing them + out of their scope (e.g., to user code) results in undefined behavior. + Conversely, they have better performance because GC is not involved. + + This feature is experimental and requires careful debugging. + Build with CPPFLAGS='-DUSE_STACK_LISP_OBJECTS=0' to disable it. */ + +#ifndef USE_STACK_LISP_OBJECTS +# define USE_STACK_LISP_OBJECTS true +#endif + +/* USE_STACK_LISP_OBJECTS requires GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS. */ + +#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS +# undef USE_STACK_LISP_OBJECTS +# define USE_STACK_LISP_OBJECTS false +#endif + +#ifdef GC_CHECK_STRING_BYTES +enum { defined_GC_CHECK_STRING_BYTES = true }; +#else +enum { defined_GC_CHECK_STRING_BYTES = false }; +#endif + +/* Struct inside unions that are typically no larger and aligned enough. */ + +union Aligned_Cons +{ + struct Lisp_Cons s; + double d; intmax_t i; void *p; +}; + +union Aligned_String +{ + struct Lisp_String s; + double d; intmax_t i; void *p; +}; + +/* True for stack-based cons and string implementations, respectively. + Use stack-based strings only if stack-based cons also works. + Otherwise, STACK_CONS would create heap-based cons cells that + could point to stack-based strings, which is a no-no. */ + +enum + { + USE_STACK_CONS = (USE_STACK_LISP_OBJECTS + && alignof (union Aligned_Cons) % GCALIGNMENT == 0), + USE_STACK_STRING = (USE_STACK_CONS + && !defined_GC_CHECK_STRING_BYTES + && alignof (union Aligned_String) % GCALIGNMENT == 0) + }; + +/* Auxiliary macros used for auto allocation of Lisp objects. Please + use these only in macros like AUTO_CONS that declare a local + variable whose lifetime will be clear to the programmer. */ +#define STACK_CONS(a, b) \ + make_lisp_ptr (&(union Aligned_Cons) { { a, { b } } }.s, Lisp_Cons) +#define AUTO_CONS_EXPR(a, b) \ + (USE_STACK_CONS ? STACK_CONS (a, b) : Fcons (a, b)) + +/* Declare NAME as an auto Lisp cons or short list if possible, a + GC-based one otherwise. This is in the sense of the C keyword + 'auto'; i.e., the object has the lifetime of the containing block. + The resulting object should not be made visible to user Lisp code. */ + +#define AUTO_CONS(name, a, b) Lisp_Object name = AUTO_CONS_EXPR (a, b) +#define AUTO_LIST1(name, a) \ + Lisp_Object name = (USE_STACK_CONS ? STACK_CONS (a, Qnil) : list1 (a)) +#define AUTO_LIST2(name, a, b) \ + Lisp_Object name = (USE_STACK_CONS \ + ? STACK_CONS (a, STACK_CONS (b, Qnil)) \ + : list2 (a, b)) +#define AUTO_LIST3(name, a, b, c) \ + Lisp_Object name = (USE_STACK_CONS \ + ? STACK_CONS (a, STACK_CONS (b, STACK_CONS (c, Qnil))) \ + : list3 (a, b, c)) +#define AUTO_LIST4(name, a, b, c, d) \ + Lisp_Object name \ + = (USE_STACK_CONS \ + ? STACK_CONS (a, STACK_CONS (b, STACK_CONS (c, \ + STACK_CONS (d, Qnil)))) \ + : list4 (a, b, c, d)) + +/* Check whether stack-allocated strings are ASCII-only. */ + +#if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS +extern const char *verify_ascii (const char *); +#else +# define verify_ascii(str) (str) +#endif + +/* Declare NAME as an auto Lisp string if possible, a GC-based one if not. + Take its value from STR. STR is not necessarily copied and should + contain only ASCII characters. The resulting Lisp string should + not be modified or made visible to user code. */ + +#define AUTO_STRING(name, str) \ + Lisp_Object name = \ + (USE_STACK_STRING \ + ? (make_lisp_ptr \ + ((&(union Aligned_String) \ + {{strlen (str), -1, 0, (unsigned char *) verify_ascii (str)}}.s), \ + Lisp_String)) \ + : build_string (verify_ascii (str))) + +/* Loop over all tails of a list, checking for cycles. + FIXME: Make tortoise and n internal declarations. + FIXME: Unroll the loop body so we don't need `n'. */ +#define FOR_EACH_TAIL(hare, list, tortoise, n) \ + for ((tortoise) = (hare) = (list), (n) = true; \ + CONSP (hare); \ + (hare = XCDR (hare), (n) = !(n), \ + ((n) \ + ? (EQ (hare, tortoise) \ + ? xsignal1 (Qcircular_list, list) \ + : (void) 0) \ + /* Move tortoise before the next iteration, in case */ \ + /* the next iteration does an Fsetcdr. */ \ + : (void) ((tortoise) = XCDR (tortoise))))) + +/* Do a `for' loop over alist values. */ + +#define FOR_EACH_ALIST_VALUE(head_var, list_var, value_var) \ + for ((list_var) = (head_var); \ + (CONSP (list_var) && ((value_var) = XCDR (XCAR (list_var)), true)); \ + (list_var) = XCDR (list_var)) + +/* Check whether it's time for GC, and run it if so. */ + +INLINE void +maybe_gc (void) +{ + if ((consing_since_gc > gc_cons_threshold + && consing_since_gc > gc_relative_threshold) + || (!NILP (Vmemory_full) + && consing_since_gc > memory_full_cons_threshold)) + Fgarbage_collect (); +} + +INLINE bool +functionp (Lisp_Object object) +{ + if (SYMBOLP (object) && !NILP (Ffboundp (object))) + { + object = Findirect_function (object, Qt); + + if (CONSP (object) && EQ (XCAR (object), Qautoload)) + { + /* Autoloaded symbols are functions, except if they load + macros or keymaps. */ + int i; + for (i = 0; i < 4 && CONSP (object); i++) + object = XCDR (object); + + return ! (CONSP (object) && !NILP (XCAR (object))); + } + } + + if (SUBRP (object)) + return XSUBR (object)->max_args != UNEVALLED; + else if (COMPILEDP (object)) + return true; + else if (CONSP (object)) + { + Lisp_Object car = XCAR (object); + return EQ (car, Qlambda) || EQ (car, Qclosure); + } + else + return false; +} + +INLINE_HEADER_END + +#endif /* EMACS_LISP_H */ diff --cc test/manual/etags/c-src/emacs/src/regex.h index 3dfecf0a7e5,00000000000..f97c1cb38c1 mode 100644,000000..100644 --- a/test/manual/etags/c-src/emacs/src/regex.h +++ b/test/manual/etags/c-src/emacs/src/regex.h @@@ -1,630 -1,0 +1,630 @@@ +/* Definitions for data structures and routines for the regular + expression library, version 0.12. + - Copyright (C) 1985, 1989-1993, 1995, 2000-2015 Free Software ++ Copyright (C) 1985, 1989-1993, 1995, 2000-2016 Free Software + Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#ifndef _REGEX_H +#define _REGEX_H 1 + +/* Allow the use in C++ code. */ +#ifdef __cplusplus +extern "C" { +#endif + +/* POSIX says that must be included (by the caller) before + . */ + +#if !defined _POSIX_C_SOURCE && !defined _POSIX_SOURCE && defined VMS +/* VMS doesn't have `size_t' in , even though POSIX says it + should be there. */ +# include +#endif + +/* The following bits are used to determine the regexp syntax we + recognize. The set/not-set meanings where historically chosen so + that Emacs syntax had the value 0. + The bits are given in alphabetical order, and + the definitions shifted by one from the previous bit; thus, when we + add or remove a bit, only one other definition need change. */ +typedef unsigned long reg_syntax_t; + +/* If this bit is not set, then \ inside a bracket expression is literal. + If set, then such a \ quotes the following character. */ +#define RE_BACKSLASH_ESCAPE_IN_LISTS ((unsigned long int) 1) + +/* If this bit is not set, then + and ? are operators, and \+ and \? are + literals. + If set, then \+ and \? are operators and + and ? are literals. */ +#define RE_BK_PLUS_QM (RE_BACKSLASH_ESCAPE_IN_LISTS << 1) + +/* If this bit is set, then character classes are supported. They are: + [:alpha:], [:upper:], [:lower:], [:digit:], [:alnum:], [:xdigit:], + [:space:], [:print:], [:punct:], [:graph:], and [:cntrl:]. + If not set, then character classes are not supported. */ +#define RE_CHAR_CLASSES (RE_BK_PLUS_QM << 1) + +/* If this bit is set, then ^ and $ are always anchors (outside bracket + expressions, of course). + If this bit is not set, then it depends: + ^ is an anchor if it is at the beginning of a regular + expression or after an open-group or an alternation operator; + $ is an anchor if it is at the end of a regular expression, or + before a close-group or an alternation operator. + + This bit could be (re)combined with RE_CONTEXT_INDEP_OPS, because + POSIX draft 11.2 says that * etc. in leading positions is undefined. + We already implemented a previous draft which made those constructs + invalid, though, so we haven't changed the code back. */ +#define RE_CONTEXT_INDEP_ANCHORS (RE_CHAR_CLASSES << 1) + +/* If this bit is set, then special characters are always special + regardless of where they are in the pattern. + If this bit is not set, then special characters are special only in + some contexts; otherwise they are ordinary. Specifically, + * + ? and intervals are only special when not after the beginning, + open-group, or alternation operator. */ +#define RE_CONTEXT_INDEP_OPS (RE_CONTEXT_INDEP_ANCHORS << 1) + +/* If this bit is set, then *, +, ?, and { cannot be first in an re or + immediately after an alternation or begin-group operator. */ +#define RE_CONTEXT_INVALID_OPS (RE_CONTEXT_INDEP_OPS << 1) + +/* If this bit is set, then . matches newline. + If not set, then it doesn't. */ +#define RE_DOT_NEWLINE (RE_CONTEXT_INVALID_OPS << 1) + +/* If this bit is set, then . doesn't match NUL. + If not set, then it does. */ +#define RE_DOT_NOT_NULL (RE_DOT_NEWLINE << 1) + +/* If this bit is set, nonmatching lists [^...] do not match newline. + If not set, they do. */ +#define RE_HAT_LISTS_NOT_NEWLINE (RE_DOT_NOT_NULL << 1) + +/* If this bit is set, either \{...\} or {...} defines an + interval, depending on RE_NO_BK_BRACES. + If not set, \{, \}, {, and } are literals. */ +#define RE_INTERVALS (RE_HAT_LISTS_NOT_NEWLINE << 1) + +/* If this bit is set, +, ? and | aren't recognized as operators. + If not set, they are. */ +#define RE_LIMITED_OPS (RE_INTERVALS << 1) + +/* If this bit is set, newline is an alternation operator. + If not set, newline is literal. */ +#define RE_NEWLINE_ALT (RE_LIMITED_OPS << 1) + +/* If this bit is set, then `{...}' defines an interval, and \{ and \} + are literals. + If not set, then `\{...\}' defines an interval. */ +#define RE_NO_BK_BRACES (RE_NEWLINE_ALT << 1) + +/* If this bit is set, (...) defines a group, and \( and \) are literals. + If not set, \(...\) defines a group, and ( and ) are literals. */ +#define RE_NO_BK_PARENS (RE_NO_BK_BRACES << 1) + +/* If this bit is set, then \ matches . + If not set, then \ is a back-reference. */ +#define RE_NO_BK_REFS (RE_NO_BK_PARENS << 1) + +/* If this bit is set, then | is an alternation operator, and \| is literal. + If not set, then \| is an alternation operator, and | is literal. */ +#define RE_NO_BK_VBAR (RE_NO_BK_REFS << 1) + +/* If this bit is set, then an ending range point collating higher + than the starting range point, as in [z-a], is invalid. + If not set, then when ending range point collates higher than the + starting range point, the range is ignored. */ +#define RE_NO_EMPTY_RANGES (RE_NO_BK_VBAR << 1) + +/* If this bit is set, then an unmatched ) is ordinary. + If not set, then an unmatched ) is invalid. */ +#define RE_UNMATCHED_RIGHT_PAREN_ORD (RE_NO_EMPTY_RANGES << 1) + +/* If this bit is set, succeed as soon as we match the whole pattern, + without further backtracking. */ +#define RE_NO_POSIX_BACKTRACKING (RE_UNMATCHED_RIGHT_PAREN_ORD << 1) + +/* If this bit is set, do not process the GNU regex operators. + If not set, then the GNU regex operators are recognized. */ +#define RE_NO_GNU_OPS (RE_NO_POSIX_BACKTRACKING << 1) + +/* If this bit is set, then *?, +? and ?? match non greedily. */ +#define RE_FRUGAL (RE_NO_GNU_OPS << 1) + +/* If this bit is set, then (?:...) is treated as a shy group. */ +#define RE_SHY_GROUPS (RE_FRUGAL << 1) + +/* If this bit is set, ^ and $ only match at beg/end of buffer. */ +#define RE_NO_NEWLINE_ANCHOR (RE_SHY_GROUPS << 1) + +/* If this bit is set, turn on internal regex debugging. + If not set, and debugging was on, turn it off. + This only works if regex.c is compiled -DDEBUG. + We define this bit always, so that all that's needed to turn on + debugging is to recompile regex.c; the calling code can always have + this bit set, and it won't affect anything in the normal case. */ +#define RE_DEBUG (RE_NO_NEWLINE_ANCHOR << 1) + +/* This global variable defines the particular regexp syntax to use (for + some interfaces). When a regexp is compiled, the syntax used is + stored in the pattern buffer, so changing this does not affect + already-compiled regexps. */ +extern reg_syntax_t re_syntax_options; + +#ifdef emacs +/* In Emacs, this is the string or buffer in which we + are matching. It is used for looking up syntax properties. */ +extern Lisp_Object re_match_object; +#endif + +/* Roughly the maximum number of failure points on the stack. */ +extern size_t re_max_failures; + + +/* Define combinations of the above bits for the standard possibilities. + (The [[[ comments delimit what gets put into the Texinfo file, so + don't delete them!) */ +/* [[[begin syntaxes]]] */ +#define RE_SYNTAX_EMACS \ + (RE_CHAR_CLASSES | RE_INTERVALS | RE_SHY_GROUPS | RE_FRUGAL) + +#define RE_SYNTAX_AWK \ + (RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DOT_NOT_NULL \ + | RE_NO_BK_PARENS | RE_NO_BK_REFS \ + | RE_NO_BK_VBAR | RE_NO_EMPTY_RANGES \ + | RE_DOT_NEWLINE | RE_CONTEXT_INDEP_ANCHORS \ + | RE_UNMATCHED_RIGHT_PAREN_ORD | RE_NO_GNU_OPS) + +#define RE_SYNTAX_GNU_AWK \ + ((RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DEBUG) \ + & ~(RE_DOT_NOT_NULL | RE_INTERVALS | RE_CONTEXT_INDEP_OPS)) + +#define RE_SYNTAX_POSIX_AWK \ + (RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS \ + | RE_INTERVALS | RE_NO_GNU_OPS) + +#define RE_SYNTAX_GREP \ + (RE_BK_PLUS_QM | RE_CHAR_CLASSES \ + | RE_HAT_LISTS_NOT_NEWLINE | RE_INTERVALS \ + | RE_NEWLINE_ALT) + +#define RE_SYNTAX_EGREP \ + (RE_CHAR_CLASSES | RE_CONTEXT_INDEP_ANCHORS \ + | RE_CONTEXT_INDEP_OPS | RE_HAT_LISTS_NOT_NEWLINE \ + | RE_NEWLINE_ALT | RE_NO_BK_PARENS \ + | RE_NO_BK_VBAR) + +#define RE_SYNTAX_POSIX_EGREP \ + (RE_SYNTAX_EGREP | RE_INTERVALS | RE_NO_BK_BRACES) + +/* P1003.2/D11.2, section 4.20.7.1, lines 5078ff. */ +#define RE_SYNTAX_ED RE_SYNTAX_POSIX_BASIC + +#define RE_SYNTAX_SED RE_SYNTAX_POSIX_BASIC + +/* Syntax bits common to both basic and extended POSIX regex syntax. */ +#define _RE_SYNTAX_POSIX_COMMON \ + (RE_CHAR_CLASSES | RE_DOT_NEWLINE | RE_DOT_NOT_NULL \ + | RE_INTERVALS | RE_NO_EMPTY_RANGES) + +#define RE_SYNTAX_POSIX_BASIC \ + (_RE_SYNTAX_POSIX_COMMON | RE_BK_PLUS_QM) + +/* Differs from ..._POSIX_BASIC only in that RE_BK_PLUS_QM becomes + RE_LIMITED_OPS, i.e., \? \+ \| are not recognized. Actually, this + isn't minimal, since other operators, such as \`, aren't disabled. */ +#define RE_SYNTAX_POSIX_MINIMAL_BASIC \ + (_RE_SYNTAX_POSIX_COMMON | RE_LIMITED_OPS) + +#define RE_SYNTAX_POSIX_EXTENDED \ + (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \ + | RE_CONTEXT_INDEP_OPS | RE_NO_BK_BRACES \ + | RE_NO_BK_PARENS | RE_NO_BK_VBAR \ + | RE_CONTEXT_INVALID_OPS | RE_UNMATCHED_RIGHT_PAREN_ORD) + +/* Differs from ..._POSIX_EXTENDED in that RE_CONTEXT_INDEP_OPS is + removed and RE_NO_BK_REFS is added. */ +#define RE_SYNTAX_POSIX_MINIMAL_EXTENDED \ + (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \ + | RE_CONTEXT_INVALID_OPS | RE_NO_BK_BRACES \ + | RE_NO_BK_PARENS | RE_NO_BK_REFS \ + | RE_NO_BK_VBAR | RE_UNMATCHED_RIGHT_PAREN_ORD) +/* [[[end syntaxes]]] */ + +/* Maximum number of duplicates an interval can allow. Some systems + (erroneously) define this in other header files, but we want our + value, so remove any previous define. */ +#ifdef RE_DUP_MAX +# undef RE_DUP_MAX +#endif +/* If sizeof(int) == 2, then ((1 << 15) - 1) overflows. */ +#define RE_DUP_MAX (0x7fff) + + +/* POSIX `cflags' bits (i.e., information for `regcomp'). */ + +/* If this bit is set, then use extended regular expression syntax. + If not set, then use basic regular expression syntax. */ +#define REG_EXTENDED 1 + +/* If this bit is set, then ignore case when matching. + If not set, then case is significant. */ +#define REG_ICASE (REG_EXTENDED << 1) + +/* If this bit is set, then anchors do not match at newline + characters in the string. + If not set, then anchors do match at newlines. */ +#define REG_NEWLINE (REG_ICASE << 1) + +/* If this bit is set, then report only success or fail in regexec. + If not set, then returns differ between not matching and errors. */ +#define REG_NOSUB (REG_NEWLINE << 1) + + +/* POSIX `eflags' bits (i.e., information for regexec). */ + +/* If this bit is set, then the beginning-of-line operator doesn't match + the beginning of the string (presumably because it's not the + beginning of a line). + If not set, then the beginning-of-line operator does match the + beginning of the string. */ +#define REG_NOTBOL 1 + +/* Like REG_NOTBOL, except for the end-of-line. */ +#define REG_NOTEOL (1 << 1) + + +/* If any error codes are removed, changed, or added, update the + `re_error_msg' table in regex.c. */ +typedef enum +{ +#ifdef _XOPEN_SOURCE + REG_ENOSYS = -1, /* This will never happen for this implementation. */ +#endif + + REG_NOERROR = 0, /* Success. */ + REG_NOMATCH, /* Didn't find a match (for regexec). */ + + /* POSIX regcomp return error codes. (In the order listed in the + standard.) */ + REG_BADPAT, /* Invalid pattern. */ + REG_ECOLLATE, /* Not implemented. */ + REG_ECTYPE, /* Invalid character class name. */ + REG_EESCAPE, /* Trailing backslash. */ + REG_ESUBREG, /* Invalid back reference. */ + REG_EBRACK, /* Unmatched left bracket. */ + REG_EPAREN, /* Parenthesis imbalance. */ + REG_EBRACE, /* Unmatched \{. */ + REG_BADBR, /* Invalid contents of \{\}. */ + REG_ERANGE, /* Invalid range end. */ + REG_ESPACE, /* Ran out of memory. */ + REG_BADRPT, /* No preceding re for repetition op. */ + + /* Error codes we've added. */ + REG_EEND, /* Premature end. */ + REG_ESIZE, /* Compiled pattern bigger than 2^16 bytes. */ + REG_ERPAREN, /* Unmatched ) or \); not returned from regcomp. */ + REG_ERANGEX /* Range striding over charsets. */ +} reg_errcode_t; + +/* This data structure represents a compiled pattern. Before calling + the pattern compiler, the fields `buffer', `allocated', `fastmap', + `translate', and `no_sub' can be set. After the pattern has been + compiled, the `re_nsub' field is available. All other fields are + private to the regex routines. */ + +#ifndef RE_TRANSLATE_TYPE +# define RE_TRANSLATE_TYPE char * +#endif + +struct re_pattern_buffer +{ +/* [[[begin pattern_buffer]]] */ + /* Space that holds the compiled pattern. It is declared as + `unsigned char *' because its elements are + sometimes used as array indexes. */ + unsigned char *buffer; + + /* Number of bytes to which `buffer' points. */ + size_t allocated; + + /* Number of bytes actually used in `buffer'. */ + size_t used; + + /* Syntax setting with which the pattern was compiled. */ + reg_syntax_t syntax; + + /* Pointer to a fastmap, if any, otherwise zero. re_search uses + the fastmap, if there is one, to skip over impossible + starting points for matches. */ + char *fastmap; + + /* Either a translate table to apply to all characters before + comparing them, or zero for no translation. The translation + is applied to a pattern when it is compiled and to a string + when it is matched. */ + RE_TRANSLATE_TYPE translate; + + /* Number of subexpressions found by the compiler. */ + size_t re_nsub; + + /* Zero if this pattern cannot match the empty string, one else. + Well, in truth it's used only in `re_search_2', to see + whether or not we should use the fastmap, so we don't set + this absolutely perfectly; see `re_compile_fastmap'. */ + unsigned can_be_null : 1; + + /* If REGS_UNALLOCATED, allocate space in the `regs' structure + for `max (RE_NREGS, re_nsub + 1)' groups. + If REGS_REALLOCATE, reallocate space if necessary. + If REGS_FIXED, use what's there. */ +#define REGS_UNALLOCATED 0 +#define REGS_REALLOCATE 1 +#define REGS_FIXED 2 + unsigned regs_allocated : 2; + + /* Set to zero when `regex_compile' compiles a pattern; set to one + by `re_compile_fastmap' if it updates the fastmap. */ + unsigned fastmap_accurate : 1; + + /* If set, `re_match_2' does not return information about + subexpressions. */ + unsigned no_sub : 1; + + /* If set, a beginning-of-line anchor doesn't match at the + beginning of the string. */ + unsigned not_bol : 1; + + /* Similarly for an end-of-line anchor. */ + unsigned not_eol : 1; + + /* If true, the compilation of the pattern had to look up the syntax table, + so the compiled pattern is only valid for the current syntax table. */ + unsigned used_syntax : 1; + +#ifdef emacs + /* If true, multi-byte form in the regexp pattern should be + recognized as a multibyte character. */ + unsigned multibyte : 1; + + /* If true, multi-byte form in the target of match should be + recognized as a multibyte character. */ + unsigned target_multibyte : 1; + + /* Charset of unibyte characters at compiling time. */ + int charset_unibyte; +#endif + +/* [[[end pattern_buffer]]] */ +}; + +typedef struct re_pattern_buffer regex_t; + +/* Type for byte offsets within the string. POSIX mandates this to be an int, + but the Open Group has signaled its intention to change the requirement to + be that regoff_t be at least as wide as ptrdiff_t and ssize_t. Current + gnulib sources also use ssize_t, and we need this for supporting buffers and + strings > 2GB on 64-bit hosts. */ +typedef ssize_t regoff_t; + + +/* This is the structure we store register match data in. See + regex.texinfo for a full description of what registers match. */ +struct re_registers +{ + unsigned num_regs; + regoff_t *start; + regoff_t *end; +}; + + +/* If `regs_allocated' is REGS_UNALLOCATED in the pattern buffer, + `re_match_2' returns information about at least this many registers + the first time a `regs' structure is passed. */ +#ifndef RE_NREGS +# define RE_NREGS 30 +#endif + + +/* POSIX specification for registers. Aside from the different names than + `re_registers', POSIX uses an array of structures, instead of a + structure of arrays. */ +typedef struct +{ + regoff_t rm_so; /* Byte offset from string's start to substring's start. */ + regoff_t rm_eo; /* Byte offset from string's start to substring's end. */ +} regmatch_t; + +/* Declarations for routines. */ + +/* Sets the current default syntax to SYNTAX, and return the old syntax. + You can also simply assign to the `re_syntax_options' variable. */ +extern reg_syntax_t re_set_syntax (reg_syntax_t __syntax); + +/* Compile the regular expression PATTERN, with length LENGTH + and syntax given by the global `re_syntax_options', into the buffer + BUFFER. Return NULL if successful, and an error string if not. */ +extern const char *re_compile_pattern (const char *__pattern, size_t __length, + struct re_pattern_buffer *__buffer); + + +/* Compile a fastmap for the compiled pattern in BUFFER; used to + accelerate searches. Return 0 if successful and -2 if was an + internal error. */ +extern int re_compile_fastmap (struct re_pattern_buffer *__buffer); + + +/* Search in the string STRING (with length LENGTH) for the pattern + compiled into BUFFER. Start searching at position START, for RANGE + characters. Return the starting position of the match, -1 for no + match, or -2 for an internal error. Also return register + information in REGS (if REGS and BUFFER->no_sub are nonzero). */ +extern regoff_t re_search (struct re_pattern_buffer *__buffer, + const char *__string, size_t __length, + ssize_t __start, ssize_t __range, + struct re_registers *__regs); + + +/* Like `re_search', but search in the concatenation of STRING1 and + STRING2. Also, stop searching at index START + STOP. */ +extern regoff_t re_search_2 (struct re_pattern_buffer *__buffer, + const char *__string1, size_t __length1, + const char *__string2, size_t __length2, + ssize_t __start, ssize_t __range, + struct re_registers *__regs, + ssize_t __stop); + + +/* Like `re_search', but return how many characters in STRING the regexp + in BUFFER matched, starting at position START. */ +extern regoff_t re_match (struct re_pattern_buffer *__buffer, + const char *__string, size_t __length, + ssize_t __start, struct re_registers *__regs); + + +/* Relates to `re_match' as `re_search_2' relates to `re_search'. */ +extern regoff_t re_match_2 (struct re_pattern_buffer *__buffer, + const char *__string1, size_t __length1, + const char *__string2, size_t __length2, + ssize_t __start, struct re_registers *__regs, + ssize_t __stop); + + +/* Set REGS to hold NUM_REGS registers, storing them in STARTS and + ENDS. Subsequent matches using BUFFER and REGS will use this memory + for recording register information. STARTS and ENDS must be + allocated with malloc, and must each be at least `NUM_REGS * sizeof + (regoff_t)' bytes long. + + If NUM_REGS == 0, then subsequent matches should allocate their own + register data. + + Unless this function is called, the first search or match using + PATTERN_BUFFER will allocate its own register data, without + freeing the old data. */ +extern void re_set_registers (struct re_pattern_buffer *__buffer, + struct re_registers *__regs, + unsigned __num_regs, + regoff_t *__starts, regoff_t *__ends); + +#if defined _REGEX_RE_COMP || defined _LIBC +# ifndef _CRAY +/* 4.2 bsd compatibility. */ +extern char *re_comp (const char *); +extern int re_exec (const char *); +# endif +#endif + +/* GCC 2.95 and later have "__restrict"; C99 compilers have + "restrict", and "configure" may have defined "restrict". + Other compilers use __restrict, __restrict__, and _Restrict, and + 'configure' might #define 'restrict' to those words, so pick a + different name. */ +#ifndef _Restrict_ +# if 199901L <= __STDC_VERSION__ +# define _Restrict_ restrict +# elif 2 < __GNUC__ || (2 == __GNUC__ && 95 <= __GNUC_MINOR__) +# define _Restrict_ __restrict +# else +# define _Restrict_ +# endif +#endif +/* gcc 3.1 and up support the [restrict] syntax. Don't trust + sys/cdefs.h's definition of __restrict_arr, though, as it + mishandles gcc -ansi -pedantic. */ +#ifndef _Restrict_arr_ +# if ((199901L <= __STDC_VERSION__ \ + || ((3 < __GNUC__ || (3 == __GNUC__ && 1 <= __GNUC_MINOR__)) \ + && !defined __STRICT_ANSI__)) \ + && !defined __GNUG__) +# define _Restrict_arr_ _Restrict_ +# else +# define _Restrict_arr_ +# endif +#endif + +/* POSIX compatibility. */ +extern reg_errcode_t regcomp (regex_t *_Restrict_ __preg, + const char *_Restrict_ __pattern, + int __cflags); + +extern reg_errcode_t regexec (const regex_t *_Restrict_ __preg, + const char *_Restrict_ __string, size_t __nmatch, + regmatch_t __pmatch[_Restrict_arr_], + int __eflags); + +extern size_t regerror (int __errcode, const regex_t * __preg, + char *__errbuf, size_t __errbuf_size); + +extern void regfree (regex_t *__preg); + + +#ifdef __cplusplus +} +#endif /* C++ */ + +/* For platform which support the ISO C amendment 1 functionality we + support user defined character classes. */ +#if WIDE_CHAR_SUPPORT +/* Solaris 2.5 has a bug: must be included before . */ +# include +# include +#endif + +#if WIDE_CHAR_SUPPORT +/* The GNU C library provides support for user-defined character classes + and the functions from ISO C amendment 1. */ +# ifdef CHARCLASS_NAME_MAX +# define CHAR_CLASS_MAX_LENGTH CHARCLASS_NAME_MAX +# else +/* This shouldn't happen but some implementation might still have this + problem. Use a reasonable default value. */ +# define CHAR_CLASS_MAX_LENGTH 256 +# endif +typedef wctype_t re_wctype_t; +typedef wchar_t re_wchar_t; +# define re_wctype wctype +# define re_iswctype iswctype +# define re_wctype_to_bit(cc) 0 +#else +# define CHAR_CLASS_MAX_LENGTH 9 /* Namely, `multibyte'. */ +# define btowc(c) c + +/* Character classes. */ +typedef enum { RECC_ERROR = 0, + RECC_ALNUM, RECC_ALPHA, RECC_WORD, + RECC_GRAPH, RECC_PRINT, + RECC_LOWER, RECC_UPPER, + RECC_PUNCT, RECC_CNTRL, + RECC_DIGIT, RECC_XDIGIT, + RECC_BLANK, RECC_SPACE, + RECC_MULTIBYTE, RECC_NONASCII, + RECC_ASCII, RECC_UNIBYTE +} re_wctype_t; + +extern char re_iswctype (int ch, re_wctype_t cc); +extern re_wctype_t re_wctype (const unsigned char* str); + +typedef int re_wchar_t; + +extern void re_set_whitespace_regexp (const char *regexp); + +#endif /* not WIDE_CHAR_SUPPORT */ + +#endif /* regex.h */ + diff --cc test/manual/etags/c-src/etags.c index f2438213d04,00000000000..4465b830602 mode 100644,000000..100644 --- a/test/manual/etags/c-src/etags.c +++ b/test/manual/etags/c-src/etags.c @@@ -1,6563 -1,0 +1,6563 @@@ +/* Tags file maker to go with GNU Emacs -*- coding: utf-8 -*- + +Copyright (C) 1984 The Regents of the University of California + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. +3. Neither the name of the University nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS +BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + - Copyright (C) 1984, 1987-1989, 1993-1995, 1998-2015 Free Software ++Copyright (C) 1984, 1987-1989, 1993-1995, 1998-2016 Free Software +Foundation, Inc. + +This file is not considered part of GNU Emacs. + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . */ + + +/* NB To comply with the above BSD license, copyright information is +reproduced in etc/ETAGS.README. That file should be updated when the +above notices are. + +To the best of our knowledge, this code was originally based on the +ctags.c distributed with BSD4.2, which was copyrighted by the +University of California, as described above. */ + + +/* + * Authors: + * 1983 Ctags originally by Ken Arnold. + * 1984 Fortran added by Jim Kleckner. + * 1984 Ed Pelegri-Llopart added C typedefs. + * 1985 Emacs TAGS format by Richard Stallman. + * 1989 Sam Kendall added C++. + * 1992 Joseph B. Wells improved C and C++ parsing. + * 1993 Francesco Potortì reorganized C and C++. + * 1994 Line-by-line regexp tags by Tom Tromey. + * 2001 Nested classes by Francesco Potortì (concept by Mykola Dzyuba). + * 2002 #line directives by Francesco Potortì. + * + * Francesco Potortì has maintained and improved it since 1993. + */ + +/* + * If you want to add support for a new language, start by looking at the LUA + * language, which is the simplest. Alternatively, consider distributing etags + * together with a configuration file containing regexp definitions for etags. + */ + +char pot_etags_version[] = "@(#) pot revision number is 17.38.1.4"; + +#ifdef DEBUG +# undef DEBUG +# define DEBUG true +#else +# define DEBUG false +# define NDEBUG /* disable assert */ +#endif + +#include + +#ifndef _GNU_SOURCE +# define _GNU_SOURCE 1 /* enables some compiler checks on GNU */ +#endif + +/* WIN32_NATIVE is for XEmacs. + MSDOS, WINDOWSNT, DOS_NT are for Emacs. */ +#ifdef WIN32_NATIVE +# undef MSDOS +# undef WINDOWSNT +# define WINDOWSNT +#endif /* WIN32_NATIVE */ + +#ifdef MSDOS +# undef MSDOS +# define MSDOS true +# include +#else +# define MSDOS false +#endif /* MSDOS */ + +#ifdef WINDOWSNT +# include +# define MAXPATHLEN _MAX_PATH +# undef HAVE_NTGUI +# undef DOS_NT +# define DOS_NT +#endif /* WINDOWSNT */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include +#ifdef NDEBUG +# undef assert /* some systems have a buggy assert.h */ +# define assert(x) ((void) 0) +#endif + +#include +#include + +/* Define CTAGS to make the program "ctags" compatible with the usual one. + Leave it undefined to make the program "etags", which makes emacs-style + tag tables and tags typedefs, #defines and struct/union/enum by default. */ +#ifdef CTAGS +# undef CTAGS +# define CTAGS true +#else +# define CTAGS false +#endif + +#define streq(s,t) (assert ((s)!=NULL || (t)!=NULL), !strcmp (s, t)) +#define strcaseeq(s,t) (assert ((s)!=NULL && (t)!=NULL), !c_strcasecmp (s, t)) +#define strneq(s,t,n) (assert ((s)!=NULL || (t)!=NULL), !strncmp (s, t, n)) +#define strncaseeq(s,t,n) (assert ((s)!=NULL && (t)!=NULL), !c_strncasecmp (s, t, n)) + +#define CHARS 256 /* 2^sizeof(char) */ +#define CHAR(x) ((unsigned int)(x) & (CHARS - 1)) +#define iswhite(c) (_wht[CHAR (c)]) /* c is white (see white) */ +#define notinname(c) (_nin[CHAR (c)]) /* c is not in a name (see nonam) */ +#define begtoken(c) (_btk[CHAR (c)]) /* c can start token (see begtk) */ +#define intoken(c) (_itk[CHAR (c)]) /* c can be in token (see midtk) */ +#define endtoken(c) (_etk[CHAR (c)]) /* c ends tokens (see endtk) */ + +#define ISALNUM(c) isalnum (CHAR (c)) +#define ISALPHA(c) isalpha (CHAR (c)) +#define ISDIGIT(c) isdigit (CHAR (c)) +#define ISLOWER(c) islower (CHAR (c)) + +#define lowcase(c) tolower (CHAR (c)) + + +/* + * xnew, xrnew -- allocate, reallocate storage + * + * SYNOPSIS: Type *xnew (int n, Type); + * void xrnew (OldPointer, int n, Type); + */ +#define xnew(n, Type) ((Type *) xmalloc ((n) * sizeof (Type))) +#define xrnew(op, n, Type) ((op) = (Type *) xrealloc (op, (n) * sizeof (Type))) + +typedef void Lang_function (FILE *); + +typedef struct +{ + const char *suffix; /* file name suffix for this compressor */ + const char *command; /* takes one arg and decompresses to stdout */ +} compressor; + +typedef struct +{ + const char *name; /* language name */ + const char *help; /* detailed help for the language */ + Lang_function *function; /* parse function */ + const char **suffixes; /* name suffixes of this language's files */ + const char **filenames; /* names of this language's files */ + const char **interpreters; /* interpreters for this language */ + bool metasource; /* source used to generate other sources */ +} language; + +typedef struct fdesc +{ + struct fdesc *next; /* for the linked list */ + char *infname; /* uncompressed input file name */ + char *infabsname; /* absolute uncompressed input file name */ + char *infabsdir; /* absolute dir of input file */ + char *taggedfname; /* file name to write in tagfile */ + language *lang; /* language of file */ + char *prop; /* file properties to write in tagfile */ + bool usecharno; /* etags tags shall contain char number */ + bool written; /* entry written in the tags file */ +} fdesc; + +typedef struct node_st +{ /* sorting structure */ + struct node_st *left, *right; /* left and right sons */ + fdesc *fdp; /* description of file to whom tag belongs */ + char *name; /* tag name */ + char *regex; /* search regexp */ + bool valid; /* write this tag on the tag file */ + bool is_func; /* function tag: use regexp in CTAGS mode */ + bool been_warned; /* warning already given for duplicated tag */ + int lno; /* line number tag is on */ + long cno; /* character number line starts on */ +} node; + +/* + * A `linebuffer' is a structure which holds a line of text. + * `readline_internal' reads a line from a stream into a linebuffer + * and works regardless of the length of the line. + * SIZE is the size of BUFFER, LEN is the length of the string in + * BUFFER after readline reads it. + */ +typedef struct +{ + long size; + int len; + char *buffer; +} linebuffer; + +/* Used to support mixing of --lang and file names. */ +typedef struct +{ + enum { + at_language, /* a language specification */ + at_regexp, /* a regular expression */ + at_filename, /* a file name */ + at_stdin, /* read from stdin here */ + at_end /* stop parsing the list */ + } arg_type; /* argument type */ + language *lang; /* language associated with the argument */ + char *what; /* the argument itself */ +} argument; + +/* Structure defining a regular expression. */ +typedef struct regexp +{ + struct regexp *p_next; /* pointer to next in list */ + language *lang; /* if set, use only for this language */ + char *pattern; /* the regexp pattern */ + char *name; /* tag name */ + struct re_pattern_buffer *pat; /* the compiled pattern */ + struct re_registers regs; /* re registers */ + bool error_signaled; /* already signaled for this regexp */ + bool force_explicit_name; /* do not allow implicit tag name */ + bool ignore_case; /* ignore case when matching */ + bool multi_line; /* do a multi-line match on the whole file */ +} regexp; + + +/* Many compilers barf on this: + Lang_function Ada_funcs; + so let's write it this way */ +static void Ada_funcs (FILE *); +static void Asm_labels (FILE *); +static void C_entries (int c_ext, FILE *); +static void default_C_entries (FILE *); +static void plain_C_entries (FILE *); +static void Cjava_entries (FILE *); +static void Cobol_paragraphs (FILE *); +static void Cplusplus_entries (FILE *); +static void Cstar_entries (FILE *); +static void Erlang_functions (FILE *); +static void Forth_words (FILE *); +static void Fortran_functions (FILE *); +static void HTML_labels (FILE *); +static void Lisp_functions (FILE *); +static void Lua_functions (FILE *); +static void Makefile_targets (FILE *); +static void Pascal_functions (FILE *); +static void Perl_functions (FILE *); +static void PHP_functions (FILE *); +static void PS_functions (FILE *); +static void Prolog_functions (FILE *); +static void Python_functions (FILE *); +static void Scheme_functions (FILE *); +static void TeX_commands (FILE *); +static void Texinfo_nodes (FILE *); +static void Yacc_entries (FILE *); +static void just_read_file (FILE *); + +static language *get_language_from_langname (const char *); +static void readline (linebuffer *, FILE *); +static long readline_internal (linebuffer *, FILE *); +static bool nocase_tail (const char *); +static void get_tag (char *, char **); + +static void analyze_regex (char *); +static void free_regexps (void); +static void regex_tag_multiline (void); +static void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); +static _Noreturn void suggest_asking_for_help (void); +_Noreturn void fatal (const char *, const char *); +static _Noreturn void pfatal (const char *); +static void add_node (node *, node **); + +static void init (void); +static void process_file_name (char *, language *); +static void process_file (FILE *, char *, language *); +static void find_entries (FILE *); +static void free_tree (node *); +static void free_fdesc (fdesc *); +static void pfnote (char *, bool, char *, int, int, long); +static void invalidate_nodes (fdesc *, node **); +static void put_entries (node *); + +static char *concat (const char *, const char *, const char *); +static char *skip_spaces (char *); +static char *skip_non_spaces (char *); +static char *skip_name (char *); +static char *savenstr (const char *, int); +static char *savestr (const char *); +static char *etags_getcwd (void); +static char *relative_filename (char *, char *); +static char *absolute_filename (char *, char *); +static char *absolute_dirname (char *, char *); +static bool filename_is_absolute (char *f); +static void canonicalize_filename (char *); +static void linebuffer_init (linebuffer *); +static void linebuffer_setlen (linebuffer *, int); +static void *xmalloc (size_t); +static void *xrealloc (void *, size_t); + + +static char searchar = '/'; /* use /.../ searches */ + +static char *tagfile; /* output file */ +static char *progname; /* name this program was invoked with */ +static char *cwd; /* current working directory */ +static char *tagfiledir; /* directory of tagfile */ +static FILE *tagf; /* ioptr for tags file */ +static ptrdiff_t whatlen_max; /* maximum length of any 'what' member */ + +static fdesc *fdhead; /* head of file description list */ +static fdesc *curfdp; /* current file description */ +static int lineno; /* line number of current line */ +static long charno; /* current character number */ +static long linecharno; /* charno of start of current line */ +static char *dbp; /* pointer to start of current tag */ + +static const int invalidcharno = -1; + +static node *nodehead; /* the head of the binary tree of tags */ +static node *last_node; /* the last node created */ + +static linebuffer lb; /* the current line */ +static linebuffer filebuf; /* a buffer containing the whole file */ +static linebuffer token_name; /* a buffer containing a tag name */ + +/* boolean "functions" (see init) */ +static bool _wht[CHARS], _nin[CHARS], _itk[CHARS], _btk[CHARS], _etk[CHARS]; +static const char + /* white chars */ + *white = " \f\t\n\r\v", + /* not in a name */ + *nonam = " \f\t\n\r()=,;", /* look at make_tag before modifying! */ + /* token ending chars */ + *endtk = " \t\n\r\"'#()[]{}=-+%*/&|^~!<>;,.:?", + /* token starting chars */ + *begtk = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz$~@", + /* valid in-token chars */ + *midtk = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz$0123456789"; + +static bool append_to_tagfile; /* -a: append to tags */ +/* The next five default to true in C and derived languages. */ +static bool typedefs; /* -t: create tags for C and Ada typedefs */ +static bool typedefs_or_cplusplus; /* -T: create tags for C typedefs, level */ + /* 0 struct/enum/union decls, and C++ */ + /* member functions. */ +static bool constantypedefs; /* -d: create tags for C #define, enum */ + /* constants and variables. */ + /* -D: opposite of -d. Default under ctags. */ +static int globals; /* create tags for global variables */ +static int members; /* create tags for C member variables */ +static int declarations; /* --declarations: tag them and extern in C&Co*/ +static int no_line_directive; /* ignore #line directives (undocumented) */ +static int no_duplicates; /* no duplicate tags for ctags (undocumented) */ +static bool update; /* -u: update tags */ +static bool vgrind_style; /* -v: create vgrind style index output */ +static bool no_warnings; /* -w: suppress warnings (undocumented) */ +static bool cxref_style; /* -x: create cxref style output */ +static bool cplusplus; /* .[hc] means C++, not C (undocumented) */ +static bool ignoreindent; /* -I: ignore indentation in C */ +static int packages_only; /* --packages-only: in Ada, only tag packages*/ + +/* STDIN is defined in LynxOS system headers */ +#ifdef STDIN +# undef STDIN +#endif + +#define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ +static bool parsing_stdin; /* --parse-stdin used */ + +static regexp *p_head; /* list of all regexps */ +static bool need_filebuf; /* some regexes are multi-line */ + +static struct option longopts[] = +{ + { "append", no_argument, NULL, 'a' }, + { "packages-only", no_argument, &packages_only, 1 }, + { "c++", no_argument, NULL, 'C' }, + { "declarations", no_argument, &declarations, 1 }, + { "no-line-directive", no_argument, &no_line_directive, 1 }, + { "no-duplicates", no_argument, &no_duplicates, 1 }, + { "help", no_argument, NULL, 'h' }, + { "help", no_argument, NULL, 'H' }, + { "ignore-indentation", no_argument, NULL, 'I' }, + { "language", required_argument, NULL, 'l' }, + { "members", no_argument, &members, 1 }, + { "no-members", no_argument, &members, 0 }, + { "output", required_argument, NULL, 'o' }, + { "regex", required_argument, NULL, 'r' }, + { "no-regex", no_argument, NULL, 'R' }, + { "ignore-case-regex", required_argument, NULL, 'c' }, + { "parse-stdin", required_argument, NULL, STDIN }, + { "version", no_argument, NULL, 'V' }, + +#if CTAGS /* Ctags options */ + { "backward-search", no_argument, NULL, 'B' }, + { "cxref", no_argument, NULL, 'x' }, + { "defines", no_argument, NULL, 'd' }, + { "globals", no_argument, &globals, 1 }, + { "typedefs", no_argument, NULL, 't' }, + { "typedefs-and-c++", no_argument, NULL, 'T' }, + { "update", no_argument, NULL, 'u' }, + { "vgrind", no_argument, NULL, 'v' }, + { "no-warn", no_argument, NULL, 'w' }, + +#else /* Etags options */ + { "no-defines", no_argument, NULL, 'D' }, + { "no-globals", no_argument, &globals, 0 }, + { "include", required_argument, NULL, 'i' }, +#endif + { NULL } +}; + +static compressor compressors[] = +{ + { "z", "gzip -d -c"}, + { "Z", "gzip -d -c"}, + { "gz", "gzip -d -c"}, + { "GZ", "gzip -d -c"}, + { "bz2", "bzip2 -d -c" }, + { "xz", "xz -d -c" }, + { NULL } +}; + +/* + * Language stuff. + */ + +/* Ada code */ +static const char *Ada_suffixes [] = + { "ads", "adb", "ada", NULL }; +static const char Ada_help [] = +"In Ada code, functions, procedures, packages, tasks and types are\n\ +tags. Use the `--packages-only' option to create tags for\n\ +packages only.\n\ +Ada tag names have suffixes indicating the type of entity:\n\ + Entity type: Qualifier:\n\ + ------------ ----------\n\ + function /f\n\ + procedure /p\n\ + package spec /s\n\ + package body /b\n\ + type /t\n\ + task /k\n\ +Thus, `M-x find-tag bidule/b ' will go directly to the\n\ +body of the package `bidule', while `M-x find-tag bidule '\n\ +will just search for any tag `bidule'."; + +/* Assembly code */ +static const char *Asm_suffixes [] = + { "a", /* Unix assembler */ + "asm", /* Microcontroller assembly */ + "def", /* BSO/Tasking definition includes */ + "inc", /* Microcontroller include files */ + "ins", /* Microcontroller include files */ + "s", "sa", /* Unix assembler */ + "S", /* cpp-processed Unix assembler */ + "src", /* BSO/Tasking C compiler output */ + NULL + }; +static const char Asm_help [] = +"In assembler code, labels appearing at the beginning of a line,\n\ +followed by a colon, are tags."; + + +/* Note that .c and .h can be considered C++, if the --c++ flag was + given, or if the `class' or `template' keywords are met inside the file. + That is why default_C_entries is called for these. */ +static const char *default_C_suffixes [] = + { "c", "h", NULL }; +#if CTAGS /* C help for Ctags */ +static const char default_C_help [] = +"In C code, any C function is a tag. Use -t to tag typedefs.\n\ +Use -T to tag definitions of `struct', `union' and `enum'.\n\ +Use -d to tag `#define' macro definitions and `enum' constants.\n\ +Use --globals to tag global variables.\n\ +You can tag function declarations and external variables by\n\ +using `--declarations', and struct members by using `--members'."; +#else /* C help for Etags */ +static const char default_C_help [] = +"In C code, any C function or typedef is a tag, and so are\n\ +definitions of `struct', `union' and `enum'. `#define' macro\n\ +definitions and `enum' constants are tags unless you specify\n\ +`--no-defines'. Global variables are tags unless you specify\n\ +`--no-globals' and so are struct members unless you specify\n\ +`--no-members'. Use of `--no-globals', `--no-defines' and\n\ +`--no-members' can make the tags table file much smaller.\n\ +You can tag function declarations and external variables by\n\ +using `--declarations'."; +#endif /* C help for Ctags and Etags */ + +static const char *Cplusplus_suffixes [] = + { "C", "c++", "cc", "cpp", "cxx", "H", "h++", "hh", "hpp", "hxx", + "M", /* Objective C++ */ + "pdb", /* PostScript with C syntax */ + NULL }; +static const char Cplusplus_help [] = +"In C++ code, all the tag constructs of C code are tagged. (Use\n\ +--help --lang=c --lang=c++ for full help.)\n\ +In addition to C tags, member functions are also recognized. Member\n\ +variables are recognized unless you use the `--no-members' option.\n\ +Tags for variables and functions in classes are named `CLASS::VARIABLE'\n\ +and `CLASS::FUNCTION'. `operator' definitions have tag names like\n\ +`operator+'."; + +static const char *Cjava_suffixes [] = + { "java", NULL }; +static char Cjava_help [] = +"In Java code, all the tags constructs of C and C++ code are\n\ +tagged. (Use --help --lang=c --lang=c++ --lang=java for full help.)"; + + +static const char *Cobol_suffixes [] = + { "COB", "cob", NULL }; +static char Cobol_help [] = +"In Cobol code, tags are paragraph names; that is, any word\n\ +starting in column 8 and followed by a period."; + +static const char *Cstar_suffixes [] = + { "cs", "hs", NULL }; + +static const char *Erlang_suffixes [] = + { "erl", "hrl", NULL }; +static const char Erlang_help [] = +"In Erlang code, the tags are the functions, records and macros\n\ +defined in the file."; + +const char *Forth_suffixes [] = + { "fth", "tok", NULL }; +static const char Forth_help [] = +"In Forth code, tags are words defined by `:',\n\ +constant, code, create, defer, value, variable, buffer:, field."; + +static const char *Fortran_suffixes [] = + { "F", "f", "f90", "for", NULL }; +static const char Fortran_help [] = +"In Fortran code, functions, subroutines and block data are tags."; + +static const char *HTML_suffixes [] = + { "htm", "html", "shtml", NULL }; +static const char HTML_help [] = +"In HTML input files, the tags are the `title' and the `h1', `h2',\n\ +`h3' headers. Also, tags are `name=' in anchors and all\n\ +occurrences of `id='."; + +static const char *Lisp_suffixes [] = + { "cl", "clisp", "el", "l", "lisp", "LSP", "lsp", "ml", NULL }; +static const char Lisp_help [] = +"In Lisp code, any function defined with `defun', any variable\n\ +defined with `defvar' or `defconst', and in general the first\n\ +argument of any expression that starts with `(def' in column zero\n\ +is a tag.\n\ +The `--declarations' option tags \"(defvar foo)\" constructs too."; + +static const char *Lua_suffixes [] = + { "lua", "LUA", NULL }; +static const char Lua_help [] = +"In Lua scripts, all functions are tags."; + +static const char *Makefile_filenames [] = + { "Makefile", "makefile", "GNUMakefile", "Makefile.in", "Makefile.am", NULL}; +static const char Makefile_help [] = +"In makefiles, targets are tags; additionally, variables are tags\n\ +unless you specify `--no-globals'."; + +static const char *Objc_suffixes [] = + { "lm", /* Objective lex file */ + "m", /* Objective C file */ + NULL }; +static const char Objc_help [] = +"In Objective C code, tags include Objective C definitions for classes,\n\ +class categories, methods and protocols. Tags for variables and\n\ +functions in classes are named `CLASS::VARIABLE' and `CLASS::FUNCTION'.\n\ +(Use --help --lang=c --lang=objc --lang=java for full help.)"; + +static const char *Pascal_suffixes [] = + { "p", "pas", NULL }; +static const char Pascal_help [] = +"In Pascal code, the tags are the functions and procedures defined\n\ +in the file."; +/* " // this is for working around an Emacs highlighting bug... */ + +static const char *Perl_suffixes [] = + { "pl", "pm", NULL }; +static const char *Perl_interpreters [] = + { "perl", "@PERL@", NULL }; +static const char Perl_help [] = +"In Perl code, the tags are the packages, subroutines and variables\n\ +defined by the `package', `sub', `my' and `local' keywords. Use\n\ +`--globals' if you want to tag global variables. Tags for\n\ +subroutines are named `PACKAGE::SUB'. The name for subroutines\n\ +defined in the default package is `main::SUB'."; + +static const char *PHP_suffixes [] = + { "php", "php3", "php4", NULL }; +static const char PHP_help [] = +"In PHP code, tags are functions, classes and defines. Unless you use\n\ +the `--no-members' option, vars are tags too."; + +static const char *plain_C_suffixes [] = + { "pc", /* Pro*C file */ + NULL }; + +static const char *PS_suffixes [] = + { "ps", "psw", NULL }; /* .psw is for PSWrap */ +static const char PS_help [] = +"In PostScript code, the tags are the functions."; + +static const char *Prolog_suffixes [] = + { "prolog", NULL }; +static const char Prolog_help [] = +"In Prolog code, tags are predicates and rules at the beginning of\n\ +line."; + +static const char *Python_suffixes [] = + { "py", NULL }; +static const char Python_help [] = +"In Python code, `def' or `class' at the beginning of a line\n\ +generate a tag."; + +/* Can't do the `SCM' or `scm' prefix with a version number. */ +static const char *Scheme_suffixes [] = + { "oak", "sch", "scheme", "SCM", "scm", "SM", "sm", "ss", "t", NULL }; +static const char Scheme_help [] = +"In Scheme code, tags include anything defined with `def' or with a\n\ +construct whose name starts with `def'. They also include\n\ +variables set with `set!' at top level in the file."; + +static const char *TeX_suffixes [] = + { "bib", "clo", "cls", "ltx", "sty", "TeX", "tex", NULL }; +static const char TeX_help [] = +"In LaTeX text, the argument of any of the commands `\\chapter',\n\ +`\\section', `\\subsection', `\\subsubsection', `\\eqno', `\\label',\n\ +`\\ref', `\\cite', `\\bibitem', `\\part', `\\appendix', `\\entry',\n\ +`\\index', `\\def', `\\newcommand', `\\renewcommand',\n\ +`\\newenvironment' or `\\renewenvironment' is a tag.\n\ +\n\ +Other commands can be specified by setting the environment variable\n\ +`TEXTAGS' to a colon-separated list like, for example,\n\ + TEXTAGS=\"mycommand:myothercommand\"."; + + +static const char *Texinfo_suffixes [] = + { "texi", "texinfo", "txi", NULL }; +static const char Texinfo_help [] = +"for texinfo files, lines starting with @node are tagged."; + +static const char *Yacc_suffixes [] = + { "y", "y++", "ym", "yxx", "yy", NULL }; /* .ym is Objective yacc file */ +static const char Yacc_help [] = +"In Bison or Yacc input files, each rule defines as a tag the\n\ +nonterminal it constructs. The portions of the file that contain\n\ +C code are parsed as C code (use --help --lang=c --lang=yacc\n\ +for full help)."; + +static const char auto_help [] = +"`auto' is not a real language, it indicates to use\n\ +a default language for files base on file name suffix and file contents."; + +static const char none_help [] = +"`none' is not a real language, it indicates to only do\n\ +regexp processing on files."; + +static const char no_lang_help [] = +"No detailed help available for this language."; + + +/* + * Table of languages. + * + * It is ok for a given function to be listed under more than one + * name. I just didn't. + */ + +static language lang_names [] = +{ + { "ada", Ada_help, Ada_funcs, Ada_suffixes }, + { "asm", Asm_help, Asm_labels, Asm_suffixes }, + { "c", default_C_help, default_C_entries, default_C_suffixes }, + { "c++", Cplusplus_help, Cplusplus_entries, Cplusplus_suffixes }, + { "c*", no_lang_help, Cstar_entries, Cstar_suffixes }, + { "cobol", Cobol_help, Cobol_paragraphs, Cobol_suffixes }, + { "erlang", Erlang_help, Erlang_functions, Erlang_suffixes }, + { "forth", Forth_help, Forth_words, Forth_suffixes }, + { "fortran", Fortran_help, Fortran_functions, Fortran_suffixes }, + { "html", HTML_help, HTML_labels, HTML_suffixes }, + { "java", Cjava_help, Cjava_entries, Cjava_suffixes }, + { "lisp", Lisp_help, Lisp_functions, Lisp_suffixes }, + { "lua", Lua_help, Lua_functions, Lua_suffixes }, + { "makefile", Makefile_help,Makefile_targets,NULL,Makefile_filenames}, + { "objc", Objc_help, plain_C_entries, Objc_suffixes }, + { "pascal", Pascal_help, Pascal_functions, Pascal_suffixes }, + { "perl",Perl_help,Perl_functions,Perl_suffixes,NULL,Perl_interpreters}, + { "php", PHP_help, PHP_functions, PHP_suffixes }, + { "postscript",PS_help, PS_functions, PS_suffixes }, + { "proc", no_lang_help, plain_C_entries, plain_C_suffixes }, + { "prolog", Prolog_help, Prolog_functions, Prolog_suffixes }, + { "python", Python_help, Python_functions, Python_suffixes }, + { "scheme", Scheme_help, Scheme_functions, Scheme_suffixes }, + { "tex", TeX_help, TeX_commands, TeX_suffixes }, + { "texinfo", Texinfo_help, Texinfo_nodes, Texinfo_suffixes }, + { "yacc", Yacc_help,Yacc_entries,Yacc_suffixes,NULL,NULL,true}, + { "auto", auto_help }, /* default guessing scheme */ + { "none", none_help, just_read_file }, /* regexp matching only */ + { NULL } /* end of list */ +}; + + +static void +print_language_names (void) +{ + language *lang; + const char **name, **ext; + + puts ("\nThese are the currently supported languages, along with the\n\ +default file names and dot suffixes:"); + for (lang = lang_names; lang->name != NULL; lang++) + { + printf (" %-*s", 10, lang->name); + if (lang->filenames != NULL) + for (name = lang->filenames; *name != NULL; name++) + printf (" %s", *name); + if (lang->suffixes != NULL) + for (ext = lang->suffixes; *ext != NULL; ext++) + printf (" .%s", *ext); + puts (""); + } + puts ("where `auto' means use default language for files based on file\n\ +name suffix, and `none' means only do regexp processing on files.\n\ +If no language is specified and no matching suffix is found,\n\ +the first line of the file is read for a sharp-bang (#!) sequence\n\ +followed by the name of an interpreter. If no such sequence is found,\n\ +Fortran is tried first; if no tags are found, C is tried next.\n\ +When parsing any C file, a \"class\" or \"template\" keyword\n\ +switches to C++."); + puts ("Compressed files are supported using gzip, bzip2, and xz.\n\ +\n\ +For detailed help on a given language use, for example,\n\ +etags --help --lang=ada."); +} + +#ifndef EMACS_NAME +# define EMACS_NAME "standalone" +#endif +#ifndef VERSION +# define VERSION "17.38.1.4" +#endif +static _Noreturn void +print_version (void) +{ + char emacs_copyright[] = COPYRIGHT; + + printf ("%s (%s %s)\n", (CTAGS) ? "ctags" : "etags", EMACS_NAME, VERSION); + puts (emacs_copyright); + puts ("This program is distributed under the terms in ETAGS.README"); + + exit (EXIT_SUCCESS); +} + +#ifndef PRINT_UNDOCUMENTED_OPTIONS_HELP +# define PRINT_UNDOCUMENTED_OPTIONS_HELP false +#endif + +static _Noreturn void +print_help (argument *argbuffer) +{ + bool help_for_lang = false; + + for (; argbuffer->arg_type != at_end; argbuffer++) + if (argbuffer->arg_type == at_language) + { + if (help_for_lang) + puts (""); + puts (argbuffer->lang->help); + help_for_lang = true; + } + + if (help_for_lang) + exit (EXIT_SUCCESS); + + printf ("Usage: %s [options] [[regex-option ...] file-name] ...\n\ +\n\ +These are the options accepted by %s.\n", progname, progname); + puts ("You may use unambiguous abbreviations for the long option names."); + puts (" A - as file name means read names from stdin (one per line).\n\ +Absolute names are stored in the output file as they are.\n\ +Relative ones are stored relative to the output file's directory.\n"); + + puts ("-a, --append\n\ + Append tag entries to existing tags file."); + + puts ("--packages-only\n\ + For Ada files, only generate tags for packages."); + + if (CTAGS) + puts ("-B, --backward-search\n\ + Write the search commands for the tag entries using '?', the\n\ + backward-search command instead of '/', the forward-search command."); + + /* This option is mostly obsolete, because etags can now automatically + detect C++. Retained for backward compatibility and for debugging and + experimentation. In principle, we could want to tag as C++ even + before any "class" or "template" keyword. + puts ("-C, --c++\n\ + Treat files whose name suffix defaults to C language as C++ files."); + */ + + puts ("--declarations\n\ + In C and derived languages, create tags for function declarations,"); + if (CTAGS) + puts ("\tand create tags for extern variables if --globals is used."); + else + puts + ("\tand create tags for extern variables unless --no-globals is used."); + + if (CTAGS) + puts ("-d, --defines\n\ + Create tag entries for C #define constants and enum constants, too."); + else + puts ("-D, --no-defines\n\ + Don't create tag entries for C #define constants and enum constants.\n\ + This makes the tags file smaller."); + + if (!CTAGS) + puts ("-i FILE, --include=FILE\n\ + Include a note in tag file indicating that, when searching for\n\ + a tag, one should also consult the tags file FILE after\n\ + checking the current file."); + + puts ("-l LANG, --language=LANG\n\ + Force the following files to be considered as written in the\n\ + named language up to the next --language=LANG option."); + + if (CTAGS) + puts ("--globals\n\ + Create tag entries for global variables in some languages."); + else + puts ("--no-globals\n\ + Do not create tag entries for global variables in some\n\ + languages. This makes the tags file smaller."); + + if (PRINT_UNDOCUMENTED_OPTIONS_HELP) + puts ("--no-line-directive\n\ + Ignore #line preprocessor directives in C and derived languages."); + + if (CTAGS) + puts ("--members\n\ + Create tag entries for members of structures in some languages."); + else + puts ("--no-members\n\ + Do not create tag entries for members of structures\n\ + in some languages."); + + puts ("-r REGEXP, --regex=REGEXP or --regex=@regexfile\n\ + Make a tag for each line matching a regular expression pattern\n\ + in the following files. {LANGUAGE}REGEXP uses REGEXP for LANGUAGE\n\ + files only. REGEXFILE is a file containing one REGEXP per line.\n\ + REGEXP takes the form /TAGREGEXP/TAGNAME/MODS, where TAGNAME/ is\n\ + optional. The TAGREGEXP pattern is anchored (as if preceded by ^)."); + puts (" If TAGNAME/ is present, the tags created are named.\n\ + For example Tcl named tags can be created with:\n\ + --regex=\"/proc[ \\t]+\\([^ \\t]+\\)/\\1/.\".\n\ + MODS are optional one-letter modifiers: `i' means to ignore case,\n\ + `m' means to allow multi-line matches, `s' implies `m' and\n\ + causes dot to match any character, including newline."); + + puts ("-R, --no-regex\n\ + Don't create tags from regexps for the following files."); + + puts ("-I, --ignore-indentation\n\ + In C and C++ do not assume that a closing brace in the first\n\ + column is the final brace of a function or structure definition."); + + puts ("-o FILE, --output=FILE\n\ + Write the tags to FILE."); + + puts ("--parse-stdin=NAME\n\ + Read from standard input and record tags as belonging to file NAME."); + + if (CTAGS) + { + puts ("-t, --typedefs\n\ + Generate tag entries for C and Ada typedefs."); + puts ("-T, --typedefs-and-c++\n\ + Generate tag entries for C typedefs, C struct/enum/union tags,\n\ + and C++ member functions."); + } + + if (CTAGS) + puts ("-u, --update\n\ + Update the tag entries for the given files, leaving tag\n\ + entries for other files in place. Currently, this is\n\ + implemented by deleting the existing entries for the given\n\ + files and then rewriting the new entries at the end of the\n\ + tags file. It is often faster to simply rebuild the entire\n\ + tag file than to use this."); + + if (CTAGS) + { + puts ("-v, --vgrind\n\ + Print on the standard output an index of items intended for\n\ + human consumption, similar to the output of vgrind. The index\n\ + is sorted, and gives the page number of each item."); + + if (PRINT_UNDOCUMENTED_OPTIONS_HELP) + puts ("-w, --no-duplicates\n\ + Do not create duplicate tag entries, for compatibility with\n\ + traditional ctags."); + + if (PRINT_UNDOCUMENTED_OPTIONS_HELP) + puts ("-w, --no-warn\n\ + Suppress warning messages about duplicate tag entries."); + + puts ("-x, --cxref\n\ + Like --vgrind, but in the style of cxref, rather than vgrind.\n\ + The output uses line numbers instead of page numbers, but\n\ + beyond that the differences are cosmetic; try both to see\n\ + which you like."); + } + + puts ("-V, --version\n\ + Print the version of the program.\n\ +-h, --help\n\ + Print this help message.\n\ + Followed by one or more `--language' options prints detailed\n\ + help about tag generation for the specified languages."); + + print_language_names (); + + puts (""); + puts ("Report bugs to bug-gnu-emacs@gnu.org"); + + exit (EXIT_SUCCESS); +} + + +int +main (int argc, char **argv) +{ + int i; + unsigned int nincluded_files; + char **included_files; + argument *argbuffer; + int current_arg, file_count; + linebuffer filename_lb; + bool help_asked = false; + ptrdiff_t len; + char *optstring; + int opt; + + progname = argv[0]; + nincluded_files = 0; + included_files = xnew (argc, char *); + current_arg = 0; + file_count = 0; + + /* Allocate enough no matter what happens. Overkill, but each one + is small. */ + argbuffer = xnew (argc, argument); + + /* + * Always find typedefs and structure tags. + * Also default to find macro constants, enum constants, struct + * members and global variables. Do it for both etags and ctags. + */ + typedefs = typedefs_or_cplusplus = constantypedefs = true; + globals = members = true; + + /* When the optstring begins with a '-' getopt_long does not rearrange the + non-options arguments to be at the end, but leaves them alone. */ + optstring = concat ("-ac:Cf:Il:o:r:RSVhH", + (CTAGS) ? "BxdtTuvw" : "Di:", + ""); + + while ((opt = getopt_long (argc, argv, optstring, longopts, NULL)) != EOF) + switch (opt) + { + case 0: + /* If getopt returns 0, then it has already processed a + long-named option. We should do nothing. */ + break; + + case 1: + /* This means that a file name has been seen. Record it. */ + argbuffer[current_arg].arg_type = at_filename; + argbuffer[current_arg].what = optarg; + len = strlen (optarg); + if (whatlen_max < len) + whatlen_max = len; + ++current_arg; + ++file_count; + break; + + case STDIN: + /* Parse standard input. Idea by Vivek . */ + argbuffer[current_arg].arg_type = at_stdin; + argbuffer[current_arg].what = optarg; + len = strlen (optarg); + if (whatlen_max < len) + whatlen_max = len; + ++current_arg; + ++file_count; + if (parsing_stdin) + fatal ("cannot parse standard input more than once", (char *)NULL); + parsing_stdin = true; + break; + + /* Common options. */ + case 'a': append_to_tagfile = true; break; + case 'C': cplusplus = true; break; + case 'f': /* for compatibility with old makefiles */ + case 'o': + if (tagfile) + { + error ("-o option may only be given once."); + suggest_asking_for_help (); + /* NOTREACHED */ + } + tagfile = optarg; + break; + case 'I': + case 'S': /* for backward compatibility */ + ignoreindent = true; + break; + case 'l': + { + language *lang = get_language_from_langname (optarg); + if (lang != NULL) + { + argbuffer[current_arg].lang = lang; + argbuffer[current_arg].arg_type = at_language; + ++current_arg; + } + } + break; + case 'c': + /* Backward compatibility: support obsolete --ignore-case-regexp. */ + optarg = concat (optarg, "i", ""); /* memory leak here */ + /* FALLTHRU */ + case 'r': + argbuffer[current_arg].arg_type = at_regexp; + argbuffer[current_arg].what = optarg; + len = strlen (optarg); + if (whatlen_max < len) + whatlen_max = len; + ++current_arg; + break; + case 'R': + argbuffer[current_arg].arg_type = at_regexp; + argbuffer[current_arg].what = NULL; + ++current_arg; + break; + case 'V': + print_version (); + break; + case 'h': + case 'H': + help_asked = true; + break; + + /* Etags options */ + case 'D': constantypedefs = false; break; + case 'i': included_files[nincluded_files++] = optarg; break; + + /* Ctags options. */ + case 'B': searchar = '?'; break; + case 'd': constantypedefs = true; break; + case 't': typedefs = true; break; + case 'T': typedefs = typedefs_or_cplusplus = true; break; + case 'u': update = true; break; + case 'v': vgrind_style = true; /*FALLTHRU*/ + case 'x': cxref_style = true; break; + case 'w': no_warnings = true; break; + default: + suggest_asking_for_help (); + /* NOTREACHED */ + } + + /* No more options. Store the rest of arguments. */ + for (; optind < argc; optind++) + { + argbuffer[current_arg].arg_type = at_filename; + argbuffer[current_arg].what = argv[optind]; + len = strlen (argv[optind]); + if (whatlen_max < len) + whatlen_max = len; + ++current_arg; + ++file_count; + } + + argbuffer[current_arg].arg_type = at_end; + + if (help_asked) + print_help (argbuffer); + /* NOTREACHED */ + + if (nincluded_files == 0 && file_count == 0) + { + error ("no input files specified."); + suggest_asking_for_help (); + /* NOTREACHED */ + } + + if (tagfile == NULL) + tagfile = savestr (CTAGS ? "tags" : "TAGS"); + cwd = etags_getcwd (); /* the current working directory */ + if (cwd[strlen (cwd) - 1] != '/') + { + char *oldcwd = cwd; + cwd = concat (oldcwd, "/", ""); + free (oldcwd); + } + + /* Compute base directory for relative file names. */ + if (streq (tagfile, "-") + || strneq (tagfile, "/dev/", 5)) + tagfiledir = cwd; /* relative file names are relative to cwd */ + else + { + canonicalize_filename (tagfile); + tagfiledir = absolute_dirname (tagfile, cwd); + } + + init (); /* set up boolean "functions" */ + + linebuffer_init (&lb); + linebuffer_init (&filename_lb); + linebuffer_init (&filebuf); + linebuffer_init (&token_name); + + if (!CTAGS) + { + if (streq (tagfile, "-")) + { + tagf = stdout; + SET_BINARY (fileno (stdout)); + } + else + tagf = fopen (tagfile, append_to_tagfile ? "ab" : "wb"); + if (tagf == NULL) + pfatal (tagfile); + } + + /* + * Loop through files finding functions. + */ + for (i = 0; i < current_arg; i++) + { + static language *lang; /* non-NULL if language is forced */ + char *this_file; + + switch (argbuffer[i].arg_type) + { + case at_language: + lang = argbuffer[i].lang; + break; + case at_regexp: + analyze_regex (argbuffer[i].what); + break; + case at_filename: + this_file = argbuffer[i].what; + /* Input file named "-" means read file names from stdin + (one per line) and use them. */ + if (streq (this_file, "-")) + { + if (parsing_stdin) + fatal ("cannot parse standard input AND read file names from it", + (char *)NULL); + while (readline_internal (&filename_lb, stdin) > 0) + process_file_name (filename_lb.buffer, lang); + } + else + process_file_name (this_file, lang); + break; + case at_stdin: + this_file = argbuffer[i].what; + process_file (stdin, this_file, lang); + break; + } + } + + free_regexps (); + free (lb.buffer); + free (filebuf.buffer); + free (token_name.buffer); + + if (!CTAGS || cxref_style) + { + /* Write the remaining tags to tagf (ETAGS) or stdout (CXREF). */ + put_entries (nodehead); + free_tree (nodehead); + nodehead = NULL; + if (!CTAGS) + { + fdesc *fdp; + + /* Output file entries that have no tags. */ + for (fdp = fdhead; fdp != NULL; fdp = fdp->next) + if (!fdp->written) + fprintf (tagf, "\f\n%s,0\n", fdp->taggedfname); + + while (nincluded_files-- > 0) + fprintf (tagf, "\f\n%s,include\n", *included_files++); + + if (fclose (tagf) == EOF) + pfatal (tagfile); + } + + exit (EXIT_SUCCESS); + } + + /* From here on, we are in (CTAGS && !cxref_style) */ + if (update) + { + char *cmd = + xmalloc (strlen (tagfile) + whatlen_max + + sizeof "mv..OTAGS;fgrep -v '\t\t' OTAGS >;rm OTAGS"); + for (i = 0; i < current_arg; ++i) + { + switch (argbuffer[i].arg_type) + { + case at_filename: + case at_stdin: + break; + default: + continue; /* the for loop */ + } + char *z = stpcpy (cmd, "mv "); + z = stpcpy (z, tagfile); + z = stpcpy (z, " OTAGS;fgrep -v '\t"); + z = stpcpy (z, argbuffer[i].what); + z = stpcpy (z, "\t' OTAGS >"); + z = stpcpy (z, tagfile); + strcpy (z, ";rm OTAGS"); + if (system (cmd) != EXIT_SUCCESS) + fatal ("failed to execute shell command", (char *)NULL); + } + free (cmd); + append_to_tagfile = true; + } + + tagf = fopen (tagfile, append_to_tagfile ? "ab" : "wb"); + if (tagf == NULL) + pfatal (tagfile); + put_entries (nodehead); /* write all the tags (CTAGS) */ + free_tree (nodehead); + nodehead = NULL; + if (fclose (tagf) == EOF) + pfatal (tagfile); + + if (CTAGS) + if (append_to_tagfile || update) + { + char *cmd = xmalloc (2 * strlen (tagfile) + sizeof "sort -u -o.."); + /* Maybe these should be used: + setenv ("LC_COLLATE", "C", 1); + setenv ("LC_ALL", "C", 1); */ + char *z = stpcpy (cmd, "sort -u -o "); + z = stpcpy (z, tagfile); + *z++ = ' '; + strcpy (z, tagfile); + exit (system (cmd)); + } + return EXIT_SUCCESS; +} + + +/* + * Return a compressor given the file name. If EXTPTR is non-zero, + * return a pointer into FILE where the compressor-specific + * extension begins. If no compressor is found, NULL is returned + * and EXTPTR is not significant. + * Idea by Vladimir Alexiev (1998) + */ +static compressor * +get_compressor_from_suffix (char *file, char **extptr) +{ + compressor *compr; + char *slash, *suffix; + + /* File has been processed by canonicalize_filename, + so we don't need to consider backslashes on DOS_NT. */ + slash = strrchr (file, '/'); + suffix = strrchr (file, '.'); + if (suffix == NULL || suffix < slash) + return NULL; + if (extptr != NULL) + *extptr = suffix; + suffix += 1; + /* Let those poor souls who live with DOS 8+3 file name limits get + some solace by treating foo.cgz as if it were foo.c.gz, etc. + Only the first do loop is run if not MSDOS */ + do + { + for (compr = compressors; compr->suffix != NULL; compr++) + if (streq (compr->suffix, suffix)) + return compr; + if (!MSDOS) + break; /* do it only once: not really a loop */ + if (extptr != NULL) + *extptr = ++suffix; + } while (*suffix != '\0'); + return NULL; +} + + + +/* + * Return a language given the name. + */ +static language * +get_language_from_langname (const char *name) +{ + language *lang; + + if (name == NULL) + error ("empty language name"); + else + { + for (lang = lang_names; lang->name != NULL; lang++) + if (streq (name, lang->name)) + return lang; + error ("unknown language \"%s\"", name); + } + + return NULL; +} + + +/* + * Return a language given the interpreter name. + */ +static language * +get_language_from_interpreter (char *interpreter) +{ + language *lang; + const char **iname; + + if (interpreter == NULL) + return NULL; + for (lang = lang_names; lang->name != NULL; lang++) + if (lang->interpreters != NULL) + for (iname = lang->interpreters; *iname != NULL; iname++) + if (streq (*iname, interpreter)) + return lang; + + return NULL; +} + + + +/* + * Return a language given the file name. + */ +static language * +get_language_from_filename (char *file, int case_sensitive) +{ + language *lang; + const char **name, **ext, *suffix; + + /* Try whole file name first. */ + for (lang = lang_names; lang->name != NULL; lang++) + if (lang->filenames != NULL) + for (name = lang->filenames; *name != NULL; name++) + if ((case_sensitive) + ? streq (*name, file) + : strcaseeq (*name, file)) + return lang; + + /* If not found, try suffix after last dot. */ + suffix = strrchr (file, '.'); + if (suffix == NULL) + return NULL; + suffix += 1; + for (lang = lang_names; lang->name != NULL; lang++) + if (lang->suffixes != NULL) + for (ext = lang->suffixes; *ext != NULL; ext++) + if ((case_sensitive) + ? streq (*ext, suffix) + : strcaseeq (*ext, suffix)) + return lang; + return NULL; +} + + +/* + * This routine is called on each file argument. + */ +static void +process_file_name (char *file, language *lang) +{ + struct stat stat_buf; + FILE *inf; + fdesc *fdp; + compressor *compr; + char *compressed_name, *uncompressed_name; + char *ext, *real_name; + int retval; + + canonicalize_filename (file); + if (streq (file, tagfile) && !streq (tagfile, "-")) + { + error ("skipping inclusion of %s in self.", file); + return; + } + if ((compr = get_compressor_from_suffix (file, &ext)) == NULL) + { + compressed_name = NULL; + real_name = uncompressed_name = savestr (file); + } + else + { + real_name = compressed_name = savestr (file); + uncompressed_name = savenstr (file, ext - file); + } + + /* If the canonicalized uncompressed name + has already been dealt with, skip it silently. */ + for (fdp = fdhead; fdp != NULL; fdp = fdp->next) + { + assert (fdp->infname != NULL); + if (streq (uncompressed_name, fdp->infname)) + goto cleanup; + } + + if (stat (real_name, &stat_buf) != 0) + { + /* Reset real_name and try with a different name. */ + real_name = NULL; + if (compressed_name != NULL) /* try with the given suffix */ + { + if (stat (uncompressed_name, &stat_buf) == 0) + real_name = uncompressed_name; + } + else /* try all possible suffixes */ + { + for (compr = compressors; compr->suffix != NULL; compr++) + { + compressed_name = concat (file, ".", compr->suffix); + if (stat (compressed_name, &stat_buf) != 0) + { + if (MSDOS) + { + char *suf = compressed_name + strlen (file); + size_t suflen = strlen (compr->suffix) + 1; + for ( ; suf[1]; suf++, suflen--) + { + memmove (suf, suf + 1, suflen); + if (stat (compressed_name, &stat_buf) == 0) + { + real_name = compressed_name; + break; + } + } + if (real_name != NULL) + break; + } /* MSDOS */ + free (compressed_name); + compressed_name = NULL; + } + else + { + real_name = compressed_name; + break; + } + } + } + if (real_name == NULL) + { + perror (file); + goto cleanup; + } + } /* try with a different name */ + + if (!S_ISREG (stat_buf.st_mode)) + { + error ("skipping %s: it is not a regular file.", real_name); + goto cleanup; + } + if (real_name == compressed_name) + { + char *cmd = concat (compr->command, " ", real_name); + inf = popen (cmd, "r" FOPEN_BINARY); + free (cmd); + } + else + inf = fopen (real_name, "r" FOPEN_BINARY); + if (inf == NULL) + { + perror (real_name); + goto cleanup; + } + + process_file (inf, uncompressed_name, lang); + + if (real_name == compressed_name) + retval = pclose (inf); + else + retval = fclose (inf); + if (retval < 0) + pfatal (file); + + cleanup: + free (compressed_name); + free (uncompressed_name); + last_node = NULL; + curfdp = NULL; + return; +} + +static void +process_file (FILE *fh, char *fn, language *lang) +{ + static const fdesc emptyfdesc; + fdesc *fdp; + + /* Create a new input file description entry. */ + fdp = xnew (1, fdesc); + *fdp = emptyfdesc; + fdp->next = fdhead; + fdp->infname = savestr (fn); + fdp->lang = lang; + fdp->infabsname = absolute_filename (fn, cwd); + fdp->infabsdir = absolute_dirname (fn, cwd); + if (filename_is_absolute (fn)) + { + /* An absolute file name. Canonicalize it. */ + fdp->taggedfname = absolute_filename (fn, NULL); + } + else + { + /* A file name relative to cwd. Make it relative + to the directory of the tags file. */ + fdp->taggedfname = relative_filename (fn, tagfiledir); + } + fdp->usecharno = true; /* use char position when making tags */ + fdp->prop = NULL; + fdp->written = false; /* not written on tags file yet */ + + fdhead = fdp; + curfdp = fdhead; /* the current file description */ + + find_entries (fh); + + /* If not Ctags, and if this is not metasource and if it contained no #line + directives, we can write the tags and free all nodes pointing to + curfdp. */ + if (!CTAGS + && curfdp->usecharno /* no #line directives in this file */ + && !curfdp->lang->metasource) + { + node *np, *prev; + + /* Look for the head of the sublist relative to this file. See add_node + for the structure of the node tree. */ + prev = NULL; + for (np = nodehead; np != NULL; prev = np, np = np->left) + if (np->fdp == curfdp) + break; + + /* If we generated tags for this file, write and delete them. */ + if (np != NULL) + { + /* This is the head of the last sublist, if any. The following + instructions depend on this being true. */ + assert (np->left == NULL); + + assert (fdhead == curfdp); + assert (last_node->fdp == curfdp); + put_entries (np); /* write tags for file curfdp->taggedfname */ + free_tree (np); /* remove the written nodes */ + if (prev == NULL) + nodehead = NULL; /* no nodes left */ + else + prev->left = NULL; /* delete the pointer to the sublist */ + } + } +} + +/* + * This routine sets up the boolean pseudo-functions which work + * by setting boolean flags dependent upon the corresponding character. + * Every char which is NOT in that string is not a white char. Therefore, + * all of the array "_wht" is set to false, and then the elements + * subscripted by the chars in "white" are set to true. Thus "_wht" + * of a char is true if it is the string "white", else false. + */ +static void +init (void) +{ + const char *sp; + int i; + + for (i = 0; i < CHARS; i++) + iswhite (i) = notinname (i) = begtoken (i) = intoken (i) = endtoken (i) + = false; + for (sp = white; *sp != '\0'; sp++) iswhite (*sp) = true; + for (sp = nonam; *sp != '\0'; sp++) notinname (*sp) = true; + notinname ('\0') = notinname ('\n'); + for (sp = begtk; *sp != '\0'; sp++) begtoken (*sp) = true; + begtoken ('\0') = begtoken ('\n'); + for (sp = midtk; *sp != '\0'; sp++) intoken (*sp) = true; + intoken ('\0') = intoken ('\n'); + for (sp = endtk; *sp != '\0'; sp++) endtoken (*sp) = true; + endtoken ('\0') = endtoken ('\n'); +} + +/* + * This routine opens the specified file and calls the function + * which finds the function and type definitions. + */ +static void +find_entries (FILE *inf) +{ + char *cp; + language *lang = curfdp->lang; + Lang_function *parser = NULL; + + /* If user specified a language, use it. */ + if (lang != NULL && lang->function != NULL) + { + parser = lang->function; + } + + /* Else try to guess the language given the file name. */ + if (parser == NULL) + { + lang = get_language_from_filename (curfdp->infname, true); + if (lang != NULL && lang->function != NULL) + { + curfdp->lang = lang; + parser = lang->function; + } + } + + /* Else look for sharp-bang as the first two characters. */ + if (parser == NULL + && readline_internal (&lb, inf) > 0 + && lb.len >= 2 + && lb.buffer[0] == '#' + && lb.buffer[1] == '!') + { + char *lp; + + /* Set lp to point at the first char after the last slash in the + line or, if no slashes, at the first nonblank. Then set cp to + the first successive blank and terminate the string. */ + lp = strrchr (lb.buffer+2, '/'); + if (lp != NULL) + lp += 1; + else + lp = skip_spaces (lb.buffer + 2); + cp = skip_non_spaces (lp); + *cp = '\0'; + + if (strlen (lp) > 0) + { + lang = get_language_from_interpreter (lp); + if (lang != NULL && lang->function != NULL) + { + curfdp->lang = lang; + parser = lang->function; + } + } + } + + /* We rewind here, even if inf may be a pipe. We fail if the + length of the first line is longer than the pipe block size, + which is unlikely. */ + rewind (inf); + + /* Else try to guess the language given the case insensitive file name. */ + if (parser == NULL) + { + lang = get_language_from_filename (curfdp->infname, false); + if (lang != NULL && lang->function != NULL) + { + curfdp->lang = lang; + parser = lang->function; + } + } + + /* Else try Fortran or C. */ + if (parser == NULL) + { + node *old_last_node = last_node; + + curfdp->lang = get_language_from_langname ("fortran"); + find_entries (inf); + + if (old_last_node == last_node) + /* No Fortran entries found. Try C. */ + { + /* We do not tag if rewind fails. + Only the file name will be recorded in the tags file. */ + rewind (inf); + curfdp->lang = get_language_from_langname (cplusplus ? "c++" : "c"); + find_entries (inf); + } + return; + } + + if (!no_line_directive + && curfdp->lang != NULL && curfdp->lang->metasource) + /* It may be that this is a bingo.y file, and we already parsed a bingo.c + file, or anyway we parsed a file that is automatically generated from + this one. If this is the case, the bingo.c file contained #line + directives that generated tags pointing to this file. Let's delete + them all before parsing this file, which is the real source. */ + { + fdesc **fdpp = &fdhead; + while (*fdpp != NULL) + if (*fdpp != curfdp + && streq ((*fdpp)->taggedfname, curfdp->taggedfname)) + /* We found one of those! We must delete both the file description + and all tags referring to it. */ + { + fdesc *badfdp = *fdpp; + + /* Delete the tags referring to badfdp->taggedfname + that were obtained from badfdp->infname. */ + invalidate_nodes (badfdp, &nodehead); + + *fdpp = badfdp->next; /* remove the bad description from the list */ + free_fdesc (badfdp); + } + else + fdpp = &(*fdpp)->next; /* advance the list pointer */ + } + + assert (parser != NULL); + + /* Generic initializations before reading from file. */ + linebuffer_setlen (&filebuf, 0); /* reset the file buffer */ + + /* Generic initializations before parsing file with readline. */ + lineno = 0; /* reset global line number */ + charno = 0; /* reset global char number */ + linecharno = 0; /* reset global char number of line start */ + + parser (inf); + + regex_tag_multiline (); +} + + +/* + * Check whether an implicitly named tag should be created, + * then call `pfnote'. + * NAME is a string that is internally copied by this function. + * + * TAGS format specification + * Idea by Sam Kendall (1997) + * The following is explained in some more detail in etc/ETAGS.EBNF. + * + * make_tag creates tags with "implicit tag names" (unnamed tags) + * if the following are all true, assuming NONAM=" \f\t\n\r()=,;": + * 1. NAME does not contain any of the characters in NONAM; + * 2. LINESTART contains name as either a rightmost, or rightmost but + * one character, substring; + * 3. the character, if any, immediately before NAME in LINESTART must + * be a character in NONAM; + * 4. the character, if any, immediately after NAME in LINESTART must + * also be a character in NONAM. + * + * The implementation uses the notinname() macro, which recognizes the + * characters stored in the string `nonam'. + * etags.el needs to use the same characters that are in NONAM. + */ +static void +make_tag (const char *name, /* tag name, or NULL if unnamed */ + int namelen, /* tag length */ + bool is_func, /* tag is a function */ + char *linestart, /* start of the line where tag is */ + int linelen, /* length of the line where tag is */ + int lno, /* line number */ + long int cno) /* character number */ +{ + bool named = (name != NULL && namelen > 0); + char *nname = NULL; + + if (!CTAGS && named) /* maybe set named to false */ + /* Let's try to make an implicit tag name, that is, create an unnamed tag + such that etags.el can guess a name from it. */ + { + int i; + register const char *cp = name; + + for (i = 0; i < namelen; i++) + if (notinname (*cp++)) + break; + if (i == namelen) /* rule #1 */ + { + cp = linestart + linelen - namelen; + if (notinname (linestart[linelen-1])) + cp -= 1; /* rule #4 */ + if (cp >= linestart /* rule #2 */ + && (cp == linestart + || notinname (cp[-1])) /* rule #3 */ + && strneq (name, cp, namelen)) /* rule #2 */ + named = false; /* use implicit tag name */ + } + } + + if (named) + nname = savenstr (name, namelen); + + pfnote (nname, is_func, linestart, linelen, lno, cno); +} + +/* Record a tag. */ +static void +pfnote (char *name, bool is_func, char *linestart, int linelen, int lno, + long int cno) + /* tag name, or NULL if unnamed */ + /* tag is a function */ + /* start of the line where tag is */ + /* length of the line where tag is */ + /* line number */ + /* character number */ +{ + register node *np; + + assert (name == NULL || name[0] != '\0'); + if (CTAGS && name == NULL) + return; + + np = xnew (1, node); + + /* If ctags mode, change name "main" to M. */ + if (CTAGS && !cxref_style && streq (name, "main")) + { + char *fp = strrchr (curfdp->taggedfname, '/'); + np->name = concat ("M", fp == NULL ? curfdp->taggedfname : fp + 1, ""); + fp = strrchr (np->name, '.'); + if (fp != NULL && fp[1] != '\0' && fp[2] == '\0') + fp[0] = '\0'; + } + else + np->name = name; + np->valid = true; + np->been_warned = false; + np->fdp = curfdp; + np->is_func = is_func; + np->lno = lno; + if (np->fdp->usecharno) + /* Our char numbers are 0-base, because of C language tradition? + ctags compatibility? old versions compatibility? I don't know. + Anyway, since emacs's are 1-base we expect etags.el to take care + of the difference. If we wanted to have 1-based numbers, we would + uncomment the +1 below. */ + np->cno = cno /* + 1 */ ; + else + np->cno = invalidcharno; + np->left = np->right = NULL; + if (CTAGS && !cxref_style) + { + if (strlen (linestart) < 50) + np->regex = concat (linestart, "$", ""); + else + np->regex = savenstr (linestart, 50); + } + else + np->regex = savenstr (linestart, linelen); + + add_node (np, &nodehead); +} + +/* + * free_tree () + * recurse on left children, iterate on right children. + */ +static void +free_tree (register node *np) +{ + while (np) + { + register node *node_right = np->right; + free_tree (np->left); + free (np->name); + free (np->regex); + free (np); + np = node_right; + } +} + +/* + * free_fdesc () + * delete a file description + */ +static void +free_fdesc (register fdesc *fdp) +{ + free (fdp->infname); + free (fdp->infabsname); + free (fdp->infabsdir); + free (fdp->taggedfname); + free (fdp->prop); + free (fdp); +} + +/* + * add_node () + * Adds a node to the tree of nodes. In etags mode, sort by file + * name. In ctags mode, sort by tag name. Make no attempt at + * balancing. + * + * add_node is the only function allowed to add nodes, so it can + * maintain state. + */ +static void +add_node (node *np, node **cur_node_p) +{ + register int dif; + register node *cur_node = *cur_node_p; + + if (cur_node == NULL) + { + *cur_node_p = np; + last_node = np; + return; + } + + if (!CTAGS) + /* Etags Mode */ + { + /* For each file name, tags are in a linked sublist on the right + pointer. The first tags of different files are a linked list + on the left pointer. last_node points to the end of the last + used sublist. */ + if (last_node != NULL && last_node->fdp == np->fdp) + { + /* Let's use the same sublist as the last added node. */ + assert (last_node->right == NULL); + last_node->right = np; + last_node = np; + } + else if (cur_node->fdp == np->fdp) + { + /* Scanning the list we found the head of a sublist which is + good for us. Let's scan this sublist. */ + add_node (np, &cur_node->right); + } + else + /* The head of this sublist is not good for us. Let's try the + next one. */ + add_node (np, &cur_node->left); + } /* if ETAGS mode */ + + else + { + /* Ctags Mode */ + dif = strcmp (np->name, cur_node->name); + + /* + * If this tag name matches an existing one, then + * do not add the node, but maybe print a warning. + */ + if (no_duplicates && !dif) + { + if (np->fdp == cur_node->fdp) + { + if (!no_warnings) + { + fprintf (stderr, "Duplicate entry in file %s, line %d: %s\n", + np->fdp->infname, lineno, np->name); + fprintf (stderr, "Second entry ignored\n"); + } + } + else if (!cur_node->been_warned && !no_warnings) + { + fprintf + (stderr, + "Duplicate entry in files %s and %s: %s (Warning only)\n", + np->fdp->infname, cur_node->fdp->infname, np->name); + cur_node->been_warned = true; + } + return; + } + + /* Actually add the node */ + add_node (np, dif < 0 ? &cur_node->left : &cur_node->right); + } /* if CTAGS mode */ +} + +/* + * invalidate_nodes () + * Scan the node tree and invalidate all nodes pointing to the + * given file description (CTAGS case) or free them (ETAGS case). + */ +static void +invalidate_nodes (fdesc *badfdp, node **npp) +{ + node *np = *npp; + + if (np == NULL) + return; + + if (CTAGS) + { + if (np->left != NULL) + invalidate_nodes (badfdp, &np->left); + if (np->fdp == badfdp) + np->valid = false; + if (np->right != NULL) + invalidate_nodes (badfdp, &np->right); + } + else + { + assert (np->fdp != NULL); + if (np->fdp == badfdp) + { + *npp = np->left; /* detach the sublist from the list */ + np->left = NULL; /* isolate it */ + free_tree (np); /* free it */ + invalidate_nodes (badfdp, npp); + } + else + invalidate_nodes (badfdp, &np->left); + } +} + + +static int total_size_of_entries (node *); +static int number_len (long) ATTRIBUTE_CONST; + +/* Length of a non-negative number's decimal representation. */ +static int +number_len (long int num) +{ + int len = 1; + while ((num /= 10) > 0) + len += 1; + return len; +} + +/* + * Return total number of characters that put_entries will output for + * the nodes in the linked list at the right of the specified node. + * This count is irrelevant with etags.el since emacs 19.34 at least, + * but is still supplied for backward compatibility. + */ +static int +total_size_of_entries (register node *np) +{ + register int total = 0; + + for (; np != NULL; np = np->right) + if (np->valid) + { + total += strlen (np->regex) + 1; /* pat\177 */ + if (np->name != NULL) + total += strlen (np->name) + 1; /* name\001 */ + total += number_len ((long) np->lno) + 1; /* lno, */ + if (np->cno != invalidcharno) /* cno */ + total += number_len (np->cno); + total += 1; /* newline */ + } + + return total; +} + +static void +put_entries (register node *np) +{ + register char *sp; + static fdesc *fdp = NULL; + + if (np == NULL) + return; + + /* Output subentries that precede this one */ + if (CTAGS) + put_entries (np->left); + + /* Output this entry */ + if (np->valid) + { + if (!CTAGS) + { + /* Etags mode */ + if (fdp != np->fdp) + { + fdp = np->fdp; + fprintf (tagf, "\f\n%s,%d\n", + fdp->taggedfname, total_size_of_entries (np)); + fdp->written = true; + } + fputs (np->regex, tagf); + fputc ('\177', tagf); + if (np->name != NULL) + { + fputs (np->name, tagf); + fputc ('\001', tagf); + } + fprintf (tagf, "%d,", np->lno); + if (np->cno != invalidcharno) + fprintf (tagf, "%ld", np->cno); + fputs ("\n", tagf); + } + else + { + /* Ctags mode */ + if (np->name == NULL) + error ("internal error: NULL name in ctags mode."); + + if (cxref_style) + { + if (vgrind_style) + fprintf (stdout, "%s %s %d\n", + np->name, np->fdp->taggedfname, (np->lno + 63) / 64); + else + fprintf (stdout, "%-16s %3d %-16s %s\n", + np->name, np->lno, np->fdp->taggedfname, np->regex); + } + else + { + fprintf (tagf, "%s\t%s\t", np->name, np->fdp->taggedfname); + + if (np->is_func) + { /* function or #define macro with args */ + putc (searchar, tagf); + putc ('^', tagf); + + for (sp = np->regex; *sp; sp++) + { + if (*sp == '\\' || *sp == searchar) + putc ('\\', tagf); + putc (*sp, tagf); + } + putc (searchar, tagf); + } + else + { /* anything else; text pattern inadequate */ + fprintf (tagf, "%d", np->lno); + } + putc ('\n', tagf); + } + } + } /* if this node contains a valid tag */ + + /* Output subentries that follow this one */ + put_entries (np->right); + if (!CTAGS) + put_entries (np->left); +} + + +/* C extensions. */ +#define C_EXT 0x00fff /* C extensions */ +#define C_PLAIN 0x00000 /* C */ +#define C_PLPL 0x00001 /* C++ */ +#define C_STAR 0x00003 /* C* */ +#define C_JAVA 0x00005 /* JAVA */ +#define C_AUTO 0x01000 /* C, but switch to C++ if `class' is met */ +#define YACC 0x10000 /* yacc file */ + +/* + * The C symbol tables. + */ +enum sym_type +{ + st_none, + st_C_objprot, st_C_objimpl, st_C_objend, + st_C_gnumacro, + st_C_ignore, st_C_attribute, + st_C_javastruct, + st_C_operator, + st_C_class, st_C_template, + st_C_struct, st_C_extern, st_C_enum, st_C_define, st_C_typedef +}; + +/* Feed stuff between (but not including) %[ and %] lines to: + gperf -m 5 +%[ +%compare-strncmp +%enum +%struct-type +struct C_stab_entry { char *name; int c_ext; enum sym_type type; } +%% +if, 0, st_C_ignore +for, 0, st_C_ignore +while, 0, st_C_ignore +switch, 0, st_C_ignore +return, 0, st_C_ignore +__attribute__, 0, st_C_attribute +GTY, 0, st_C_attribute +@interface, 0, st_C_objprot +@protocol, 0, st_C_objprot +@implementation,0, st_C_objimpl +@end, 0, st_C_objend +import, (C_JAVA & ~C_PLPL), st_C_ignore +package, (C_JAVA & ~C_PLPL), st_C_ignore +friend, C_PLPL, st_C_ignore +extends, (C_JAVA & ~C_PLPL), st_C_javastruct +implements, (C_JAVA & ~C_PLPL), st_C_javastruct +interface, (C_JAVA & ~C_PLPL), st_C_struct +class, 0, st_C_class +namespace, C_PLPL, st_C_struct +domain, C_STAR, st_C_struct +union, 0, st_C_struct +struct, 0, st_C_struct +extern, 0, st_C_extern +enum, 0, st_C_enum +typedef, 0, st_C_typedef +define, 0, st_C_define +undef, 0, st_C_define +operator, C_PLPL, st_C_operator +template, 0, st_C_template +# DEFUN used in emacs, the next three used in glibc (SYSCALL only for mach). +DEFUN, 0, st_C_gnumacro +SYSCALL, 0, st_C_gnumacro +ENTRY, 0, st_C_gnumacro +PSEUDO, 0, st_C_gnumacro +# These are defined inside C functions, so currently they are not met. +# EXFUN used in glibc, DEFVAR_* in emacs. +#EXFUN, 0, st_C_gnumacro +#DEFVAR_, 0, st_C_gnumacro +%] +and replace lines between %< and %> with its output, then: + - remove the #if characterset check + - make in_word_set static and not inline. */ +/*%<*/ +/* C code produced by gperf version 3.0.1 */ +/* Command-line: gperf -m 5 */ +/* Computed positions: -k'2-3' */ + +struct C_stab_entry { const char *name; int c_ext; enum sym_type type; }; +/* maximum key range = 33, duplicates = 0 */ + +static int +hash (const char *str, int len) +{ + static char const asso_values[] = + { + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 3, + 26, 35, 35, 35, 35, 35, 35, 35, 27, 35, + 35, 35, 35, 24, 0, 35, 35, 35, 35, 0, + 35, 35, 35, 35, 35, 1, 35, 16, 35, 6, + 23, 0, 0, 35, 22, 0, 35, 35, 5, 0, + 0, 15, 1, 35, 6, 35, 8, 19, 35, 16, + 4, 5, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35 + }; + int hval = len; + + switch (hval) + { + default: + hval += asso_values[(unsigned char) str[2]]; + /*FALLTHROUGH*/ + case 2: + hval += asso_values[(unsigned char) str[1]]; + break; + } + return hval; +} + +static struct C_stab_entry * +in_word_set (register const char *str, register unsigned int len) +{ + enum + { + TOTAL_KEYWORDS = 33, + MIN_WORD_LENGTH = 2, + MAX_WORD_LENGTH = 15, + MIN_HASH_VALUE = 2, + MAX_HASH_VALUE = 34 + }; + + static struct C_stab_entry wordlist[] = + { + {""}, {""}, + {"if", 0, st_C_ignore}, + {"GTY", 0, st_C_attribute}, + {"@end", 0, st_C_objend}, + {"union", 0, st_C_struct}, + {"define", 0, st_C_define}, + {"import", (C_JAVA & ~C_PLPL), st_C_ignore}, + {"template", 0, st_C_template}, + {"operator", C_PLPL, st_C_operator}, + {"@interface", 0, st_C_objprot}, + {"implements", (C_JAVA & ~C_PLPL), st_C_javastruct}, + {"friend", C_PLPL, st_C_ignore}, + {"typedef", 0, st_C_typedef}, + {"return", 0, st_C_ignore}, + {"@implementation",0, st_C_objimpl}, + {"@protocol", 0, st_C_objprot}, + {"interface", (C_JAVA & ~C_PLPL), st_C_struct}, + {"extern", 0, st_C_extern}, + {"extends", (C_JAVA & ~C_PLPL), st_C_javastruct}, + {"struct", 0, st_C_struct}, + {"domain", C_STAR, st_C_struct}, + {"switch", 0, st_C_ignore}, + {"enum", 0, st_C_enum}, + {"for", 0, st_C_ignore}, + {"namespace", C_PLPL, st_C_struct}, + {"class", 0, st_C_class}, + {"while", 0, st_C_ignore}, + {"undef", 0, st_C_define}, + {"package", (C_JAVA & ~C_PLPL), st_C_ignore}, + {"__attribute__", 0, st_C_attribute}, + {"SYSCALL", 0, st_C_gnumacro}, + {"ENTRY", 0, st_C_gnumacro}, + {"PSEUDO", 0, st_C_gnumacro}, + {"DEFUN", 0, st_C_gnumacro} + }; + + if (len <= MAX_WORD_LENGTH && len >= MIN_WORD_LENGTH) + { + int key = hash (str, len); + + if (key <= MAX_HASH_VALUE && key >= 0) + { + const char *s = wordlist[key].name; + + if (*str == *s && !strncmp (str + 1, s + 1, len - 1) && s[len] == '\0') + return &wordlist[key]; + } + } + return 0; +} +/*%>*/ + +static enum sym_type +C_symtype (char *str, int len, int c_ext) +{ + register struct C_stab_entry *se = in_word_set (str, len); + + if (se == NULL || (se->c_ext && !(c_ext & se->c_ext))) + return st_none; + return se->type; +} + + +/* + * Ignoring __attribute__ ((list)) + */ +static bool inattribute; /* looking at an __attribute__ construct */ + +/* + * C functions and variables are recognized using a simple + * finite automaton. fvdef is its state variable. + */ +static enum +{ + fvnone, /* nothing seen */ + fdefunkey, /* Emacs DEFUN keyword seen */ + fdefunname, /* Emacs DEFUN name seen */ + foperator, /* func: operator keyword seen (cplpl) */ + fvnameseen, /* function or variable name seen */ + fstartlist, /* func: just after open parenthesis */ + finlist, /* func: in parameter list */ + flistseen, /* func: after parameter list */ + fignore, /* func: before open brace */ + vignore /* var-like: ignore until ';' */ +} fvdef; + +static bool fvextern; /* func or var: extern keyword seen; */ + +/* + * typedefs are recognized using a simple finite automaton. + * typdef is its state variable. + */ +static enum +{ + tnone, /* nothing seen */ + tkeyseen, /* typedef keyword seen */ + ttypeseen, /* defined type seen */ + tinbody, /* inside typedef body */ + tend, /* just before typedef tag */ + tignore /* junk after typedef tag */ +} typdef; + +/* + * struct-like structures (enum, struct and union) are recognized + * using another simple finite automaton. `structdef' is its state + * variable. + */ +static enum +{ + snone, /* nothing seen yet, + or in struct body if bracelev > 0 */ + skeyseen, /* struct-like keyword seen */ + stagseen, /* struct-like tag seen */ + scolonseen /* colon seen after struct-like tag */ +} structdef; + +/* + * When objdef is different from onone, objtag is the name of the class. + */ +static const char *objtag = ""; + +/* + * Yet another little state machine to deal with preprocessor lines. + */ +static enum +{ + dnone, /* nothing seen */ + dsharpseen, /* '#' seen as first char on line */ + ddefineseen, /* '#' and 'define' seen */ + dignorerest /* ignore rest of line */ +} definedef; + +/* + * State machine for Objective C protocols and implementations. + * Idea by Tom R.Hageman (1995) + */ +static enum +{ + onone, /* nothing seen */ + oprotocol, /* @interface or @protocol seen */ + oimplementation, /* @implementations seen */ + otagseen, /* class name seen */ + oparenseen, /* parenthesis before category seen */ + ocatseen, /* category name seen */ + oinbody, /* in @implementation body */ + omethodsign, /* in @implementation body, after +/- */ + omethodtag, /* after method name */ + omethodcolon, /* after method colon */ + omethodparm, /* after method parameter */ + oignore /* wait for @end */ +} objdef; + + +/* + * Use this structure to keep info about the token read, and how it + * should be tagged. Used by the make_C_tag function to build a tag. + */ +static struct tok +{ + char *line; /* string containing the token */ + int offset; /* where the token starts in LINE */ + int length; /* token length */ + /* + The previous members can be used to pass strings around for generic + purposes. The following ones specifically refer to creating tags. In this + case the token contained here is the pattern that will be used to create a + tag. + */ + bool valid; /* do not create a tag; the token should be + invalidated whenever a state machine is + reset prematurely */ + bool named; /* create a named tag */ + int lineno; /* source line number of tag */ + long linepos; /* source char number of tag */ +} token; /* latest token read */ + +/* + * Variables and functions for dealing with nested structures. + * Idea by Mykola Dzyuba (2001) + */ +static void pushclass_above (int, char *, int); +static void popclass_above (int); +static void write_classname (linebuffer *, const char *qualifier); + +static struct { + char **cname; /* nested class names */ + int *bracelev; /* nested class brace level */ + int nl; /* class nesting level (elements used) */ + int size; /* length of the array */ +} cstack; /* stack for nested declaration tags */ +/* Current struct nesting depth (namespace, class, struct, union, enum). */ +#define nestlev (cstack.nl) +/* After struct keyword or in struct body, not inside a nested function. */ +#define instruct (structdef == snone && nestlev > 0 \ + && bracelev == cstack.bracelev[nestlev-1] + 1) + +static void +pushclass_above (int bracelev, char *str, int len) +{ + int nl; + + popclass_above (bracelev); + nl = cstack.nl; + if (nl >= cstack.size) + { + int size = cstack.size *= 2; + xrnew (cstack.cname, size, char *); + xrnew (cstack.bracelev, size, int); + } + assert (nl == 0 || cstack.bracelev[nl-1] < bracelev); + cstack.cname[nl] = (str == NULL) ? NULL : savenstr (str, len); + cstack.bracelev[nl] = bracelev; + cstack.nl = nl + 1; +} + +static void +popclass_above (int bracelev) +{ + int nl; + + for (nl = cstack.nl - 1; + nl >= 0 && cstack.bracelev[nl] >= bracelev; + nl--) + { + free (cstack.cname[nl]); + cstack.nl = nl; + } +} + +static void +write_classname (linebuffer *cn, const char *qualifier) +{ + int i, len; + int qlen = strlen (qualifier); + + if (cstack.nl == 0 || cstack.cname[0] == NULL) + { + len = 0; + cn->len = 0; + cn->buffer[0] = '\0'; + } + else + { + len = strlen (cstack.cname[0]); + linebuffer_setlen (cn, len); + strcpy (cn->buffer, cstack.cname[0]); + } + for (i = 1; i < cstack.nl; i++) + { + char *s = cstack.cname[i]; + if (s == NULL) + continue; + linebuffer_setlen (cn, len + qlen + strlen (s)); + len += sprintf (cn->buffer + len, "%s%s", qualifier, s); + } +} + + +static bool consider_token (char *, int, int, int *, int, int, bool *); +static void make_C_tag (bool); + +/* + * consider_token () + * checks to see if the current token is at the start of a + * function or variable, or corresponds to a typedef, or + * is a struct/union/enum tag, or #define, or an enum constant. + * + * *IS_FUNC_OR_VAR gets true if the token is a function or #define macro + * with args. C_EXTP points to which language we are looking at. + * + * Globals + * fvdef IN OUT + * structdef IN OUT + * definedef IN OUT + * typdef IN OUT + * objdef IN OUT + */ + +static bool +consider_token (char *str, int len, int c, int *c_extp, + int bracelev, int parlev, bool *is_func_or_var) + /* IN: token pointer */ + /* IN: token length */ + /* IN: first char after the token */ + /* IN, OUT: C extensions mask */ + /* IN: brace level */ + /* IN: parenthesis level */ + /* OUT: function or variable found */ +{ + /* When structdef is stagseen, scolonseen, or snone with bracelev > 0, + structtype is the type of the preceding struct-like keyword, and + structbracelev is the brace level where it has been seen. */ + static enum sym_type structtype; + static int structbracelev; + static enum sym_type toktype; + + + toktype = C_symtype (str, len, *c_extp); + + /* + * Skip __attribute__ + */ + if (toktype == st_C_attribute) + { + inattribute = true; + return false; + } + + /* + * Advance the definedef state machine. + */ + switch (definedef) + { + case dnone: + /* We're not on a preprocessor line. */ + if (toktype == st_C_gnumacro) + { + fvdef = fdefunkey; + return false; + } + break; + case dsharpseen: + if (toktype == st_C_define) + { + definedef = ddefineseen; + } + else + { + definedef = dignorerest; + } + return false; + case ddefineseen: + /* + * Make a tag for any macro, unless it is a constant + * and constantypedefs is false. + */ + definedef = dignorerest; + *is_func_or_var = (c == '('); + if (!*is_func_or_var && !constantypedefs) + return false; + else + return true; + case dignorerest: + return false; + default: + error ("internal error: definedef value."); + } + + /* + * Now typedefs + */ + switch (typdef) + { + case tnone: + if (toktype == st_C_typedef) + { + if (typedefs) + typdef = tkeyseen; + fvextern = false; + fvdef = fvnone; + return false; + } + break; + case tkeyseen: + switch (toktype) + { + case st_none: + case st_C_class: + case st_C_struct: + case st_C_enum: + typdef = ttypeseen; + } + break; + case ttypeseen: + if (structdef == snone && fvdef == fvnone) + { + fvdef = fvnameseen; + return true; + } + break; + case tend: + switch (toktype) + { + case st_C_class: + case st_C_struct: + case st_C_enum: + return false; + } + return true; + } + + switch (toktype) + { + case st_C_javastruct: + if (structdef == stagseen) + structdef = scolonseen; + return false; + case st_C_template: + case st_C_class: + if ((*c_extp & C_AUTO) /* automatic detection of C++ language */ + && bracelev == 0 + && definedef == dnone && structdef == snone + && typdef == tnone && fvdef == fvnone) + *c_extp = (*c_extp | C_PLPL) & ~C_AUTO; + if (toktype == st_C_template) + break; + /* FALLTHRU */ + case st_C_struct: + case st_C_enum: + if (parlev == 0 + && fvdef != vignore + && (typdef == tkeyseen + || (typedefs_or_cplusplus && structdef == snone))) + { + structdef = skeyseen; + structtype = toktype; + structbracelev = bracelev; + if (fvdef == fvnameseen) + fvdef = fvnone; + } + return false; + } + + if (structdef == skeyseen) + { + structdef = stagseen; + return true; + } + + if (typdef != tnone) + definedef = dnone; + + /* Detect Objective C constructs. */ + switch (objdef) + { + case onone: + switch (toktype) + { + case st_C_objprot: + objdef = oprotocol; + return false; + case st_C_objimpl: + objdef = oimplementation; + return false; + } + break; + case oimplementation: + /* Save the class tag for functions or variables defined inside. */ + objtag = savenstr (str, len); + objdef = oinbody; + return false; + case oprotocol: + /* Save the class tag for categories. */ + objtag = savenstr (str, len); + objdef = otagseen; + *is_func_or_var = true; + return true; + case oparenseen: + objdef = ocatseen; + *is_func_or_var = true; + return true; + case oinbody: + break; + case omethodsign: + if (parlev == 0) + { + fvdef = fvnone; + objdef = omethodtag; + linebuffer_setlen (&token_name, len); + memcpy (token_name.buffer, str, len); + token_name.buffer[len] = '\0'; + return true; + } + return false; + case omethodcolon: + if (parlev == 0) + objdef = omethodparm; + return false; + case omethodparm: + if (parlev == 0) + { + int oldlen = token_name.len; + fvdef = fvnone; + objdef = omethodtag; + linebuffer_setlen (&token_name, oldlen + len); + memcpy (token_name.buffer + oldlen, str, len); + token_name.buffer[oldlen + len] = '\0'; + return true; + } + return false; + case oignore: + if (toktype == st_C_objend) + { + /* Memory leakage here: the string pointed by objtag is + never released, because many tests would be needed to + avoid breaking on incorrect input code. The amount of + memory leaked here is the sum of the lengths of the + class tags. + free (objtag); */ + objdef = onone; + } + return false; + } + + /* A function, variable or enum constant? */ + switch (toktype) + { + case st_C_extern: + fvextern = true; + switch (fvdef) + { + case finlist: + case flistseen: + case fignore: + case vignore: + break; + default: + fvdef = fvnone; + } + return false; + case st_C_ignore: + fvextern = false; + fvdef = vignore; + return false; + case st_C_operator: + fvdef = foperator; + *is_func_or_var = true; + return true; + case st_none: + if (constantypedefs + && structdef == snone + && structtype == st_C_enum && bracelev > structbracelev + /* Don't tag tokens in expressions that assign values to enum + constants. */ + && fvdef != vignore) + return true; /* enum constant */ + switch (fvdef) + { + case fdefunkey: + if (bracelev > 0) + break; + fvdef = fdefunname; /* GNU macro */ + *is_func_or_var = true; + return true; + case fvnone: + switch (typdef) + { + case ttypeseen: + return false; + case tnone: + if ((strneq (str, "asm", 3) && endtoken (str[3])) + || (strneq (str, "__asm__", 7) && endtoken (str[7]))) + { + fvdef = vignore; + return false; + } + break; + } + /* FALLTHRU */ + case fvnameseen: + if (len >= 10 && strneq (str+len-10, "::operator", 10)) + { + if (*c_extp & C_AUTO) /* automatic detection of C++ */ + *c_extp = (*c_extp | C_PLPL) & ~C_AUTO; + fvdef = foperator; + *is_func_or_var = true; + return true; + } + if (bracelev > 0 && !instruct) + break; + fvdef = fvnameseen; /* function or variable */ + *is_func_or_var = true; + return true; + } + break; + } + + return false; +} + + +/* + * C_entries often keeps pointers to tokens or lines which are older than + * the line currently read. By keeping two line buffers, and switching + * them at end of line, it is possible to use those pointers. + */ +static struct +{ + long linepos; + linebuffer lb; +} lbs[2]; + +#define current_lb_is_new (newndx == curndx) +#define switch_line_buffers() (curndx = 1 - curndx) + +#define curlb (lbs[curndx].lb) +#define newlb (lbs[newndx].lb) +#define curlinepos (lbs[curndx].linepos) +#define newlinepos (lbs[newndx].linepos) + +#define plainc ((c_ext & C_EXT) == C_PLAIN) +#define cplpl (c_ext & C_PLPL) +#define cjava ((c_ext & C_JAVA) == C_JAVA) + +#define CNL_SAVE_DEFINEDEF() \ +do { \ + curlinepos = charno; \ + readline (&curlb, inf); \ + lp = curlb.buffer; \ + quotednl = false; \ + newndx = curndx; \ +} while (0) + +#define CNL() \ +do { \ + CNL_SAVE_DEFINEDEF(); \ + if (savetoken.valid) \ + { \ + token = savetoken; \ + savetoken.valid = false; \ + } \ + definedef = dnone; \ +} while (0) + + +static void +make_C_tag (bool isfun) +{ + /* This function is never called when token.valid is false, but + we must protect against invalid input or internal errors. */ + if (token.valid) + make_tag (token_name.buffer, token_name.len, isfun, token.line, + token.offset+token.length+1, token.lineno, token.linepos); + else if (DEBUG) + { /* this branch is optimized away if !DEBUG */ + make_tag (concat ("INVALID TOKEN:-->", token_name.buffer, ""), + token_name.len + 17, isfun, token.line, + token.offset+token.length+1, token.lineno, token.linepos); + error ("INVALID TOKEN"); + } + + token.valid = false; +} + + +/* + * C_entries () + * This routine finds functions, variables, typedefs, + * #define's, enum constants and struct/union/enum definitions in + * C syntax and adds them to the list. + */ +static void +C_entries (int c_ext, FILE *inf) + /* extension of C */ + /* input file */ +{ + register char c; /* latest char read; '\0' for end of line */ + register char *lp; /* pointer one beyond the character `c' */ + int curndx, newndx; /* indices for current and new lb */ + register int tokoff; /* offset in line of start of current token */ + register int toklen; /* length of current token */ + const char *qualifier; /* string used to qualify names */ + int qlen; /* length of qualifier */ + int bracelev; /* current brace level */ + int bracketlev; /* current bracket level */ + int parlev; /* current parenthesis level */ + int attrparlev; /* __attribute__ parenthesis level */ + int templatelev; /* current template level */ + int typdefbracelev; /* bracelev where a typedef struct body begun */ + bool incomm, inquote, inchar, quotednl, midtoken; + bool yacc_rules; /* in the rules part of a yacc file */ + struct tok savetoken = {0}; /* token saved during preprocessor handling */ + + + linebuffer_init (&lbs[0].lb); + linebuffer_init (&lbs[1].lb); + if (cstack.size == 0) + { + cstack.size = (DEBUG) ? 1 : 4; + cstack.nl = 0; + cstack.cname = xnew (cstack.size, char *); + cstack.bracelev = xnew (cstack.size, int); + } + + tokoff = toklen = typdefbracelev = 0; /* keep compiler quiet */ + curndx = newndx = 0; + lp = curlb.buffer; + *lp = 0; + + fvdef = fvnone; fvextern = false; typdef = tnone; + structdef = snone; definedef = dnone; objdef = onone; + yacc_rules = false; + midtoken = inquote = inchar = incomm = quotednl = false; + token.valid = savetoken.valid = false; + bracelev = bracketlev = parlev = attrparlev = templatelev = 0; + if (cjava) + { qualifier = "."; qlen = 1; } + else + { qualifier = "::"; qlen = 2; } + + + while (!feof (inf)) + { + c = *lp++; + if (c == '\\') + { + /* If we are at the end of the line, the next character is a + '\0'; do not skip it, because it is what tells us + to read the next line. */ + if (*lp == '\0') + { + quotednl = true; + continue; + } + lp++; + c = ' '; + } + else if (incomm) + { + switch (c) + { + case '*': + if (*lp == '/') + { + c = *lp++; + incomm = false; + } + break; + case '\0': + /* Newlines inside comments do not end macro definitions in + traditional cpp. */ + CNL_SAVE_DEFINEDEF (); + break; + } + continue; + } + else if (inquote) + { + switch (c) + { + case '"': + inquote = false; + break; + case '\0': + /* Newlines inside strings do not end macro definitions + in traditional cpp, even though compilers don't + usually accept them. */ + CNL_SAVE_DEFINEDEF (); + break; + } + continue; + } + else if (inchar) + { + switch (c) + { + case '\0': + /* Hmmm, something went wrong. */ + CNL (); + /* FALLTHRU */ + case '\'': + inchar = false; + break; + } + continue; + } + else switch (c) + { + case '"': + inquote = true; + if (bracketlev > 0) + continue; + if (inattribute) + break; + switch (fvdef) + { + case fdefunkey: + case fstartlist: + case finlist: + case fignore: + case vignore: + break; + default: + fvextern = false; + fvdef = fvnone; + } + continue; + case '\'': + inchar = true; + if (bracketlev > 0) + continue; + if (inattribute) + break; + if (fvdef != finlist && fvdef != fignore && fvdef != vignore) + { + fvextern = false; + fvdef = fvnone; + } + continue; + case '/': + if (*lp == '*') + { + incomm = true; + lp++; + c = ' '; + if (bracketlev > 0) + continue; + } + else if (/* cplpl && */ *lp == '/') + { + c = '\0'; + } + break; + case '%': + if ((c_ext & YACC) && *lp == '%') + { + /* Entering or exiting rules section in yacc file. */ + lp++; + definedef = dnone; fvdef = fvnone; fvextern = false; + typdef = tnone; structdef = snone; + midtoken = inquote = inchar = incomm = quotednl = false; + bracelev = 0; + yacc_rules = !yacc_rules; + continue; + } + else + break; + case '#': + if (definedef == dnone) + { + char *cp; + bool cpptoken = true; + + /* Look back on this line. If all blanks, or nonblanks + followed by an end of comment, this is a preprocessor + token. */ + for (cp = newlb.buffer; cp < lp-1; cp++) + if (!iswhite (*cp)) + { + if (*cp == '*' && cp[1] == '/') + { + cp++; + cpptoken = true; + } + else + cpptoken = false; + } + if (cpptoken) + { + definedef = dsharpseen; + /* This is needed for tagging enum values: when there are + preprocessor conditionals inside the enum, we need to + reset the value of fvdef so that the next enum value is + tagged even though the one before it did not end in a + comma. */ + if (fvdef == vignore && instruct && parlev == 0) + { + if (strneq (cp, "#if", 3) || strneq (cp, "#el", 3)) + fvdef = fvnone; + } + } + } /* if (definedef == dnone) */ + continue; + case '[': + bracketlev++; + continue; + default: + if (bracketlev > 0) + { + if (c == ']') + --bracketlev; + else if (c == '\0') + CNL_SAVE_DEFINEDEF (); + continue; + } + break; + } /* switch (c) */ + + + /* Consider token only if some involved conditions are satisfied. */ + if (typdef != tignore + && definedef != dignorerest + && fvdef != finlist + && templatelev == 0 + && (definedef != dnone + || structdef != scolonseen) + && !inattribute) + { + if (midtoken) + { + if (endtoken (c)) + { + if (c == ':' && *lp == ':' && begtoken (lp[1])) + /* This handles :: in the middle, + but not at the beginning of an identifier. + Also, space-separated :: is not recognized. */ + { + if (c_ext & C_AUTO) /* automatic detection of C++ */ + c_ext = (c_ext | C_PLPL) & ~C_AUTO; + lp += 2; + toklen += 2; + c = lp[-1]; + goto still_in_token; + } + else + { + bool funorvar = false; + + if (yacc_rules + || consider_token (newlb.buffer + tokoff, toklen, c, + &c_ext, bracelev, parlev, + &funorvar)) + { + if (fvdef == foperator) + { + char *oldlp = lp; + lp = skip_spaces (lp-1); + if (*lp != '\0') + lp += 1; + while (*lp != '\0' + && !iswhite (*lp) && *lp != '(') + lp += 1; + c = *lp++; + toklen += lp - oldlp; + } + token.named = false; + if (!plainc + && nestlev > 0 && definedef == dnone) + /* in struct body */ + { + int len; + write_classname (&token_name, qualifier); + len = token_name.len; + linebuffer_setlen (&token_name, len+qlen+toklen); + sprintf (token_name.buffer + len, "%s%.*s", + qualifier, toklen, newlb.buffer + tokoff); + token.named = true; + } + else if (objdef == ocatseen) + /* Objective C category */ + { + int len = strlen (objtag) + 2 + toklen; + linebuffer_setlen (&token_name, len); + sprintf (token_name.buffer, "%s(%.*s)", + objtag, toklen, newlb.buffer + tokoff); + token.named = true; + } + else if (objdef == omethodtag + || objdef == omethodparm) + /* Objective C method */ + { + token.named = true; + } + else if (fvdef == fdefunname) + /* GNU DEFUN and similar macros */ + { + bool defun = (newlb.buffer[tokoff] == 'F'); + int off = tokoff; + int len = toklen; + + /* Rewrite the tag so that emacs lisp DEFUNs + can be found by their elisp name */ + if (defun) + { + off += 1; + len -= 1; + } + linebuffer_setlen (&token_name, len); + memcpy (token_name.buffer, + newlb.buffer + off, len); + token_name.buffer[len] = '\0'; + if (defun) + while (--len >= 0) + if (token_name.buffer[len] == '_') + token_name.buffer[len] = '-'; + token.named = defun; + } + else + { + linebuffer_setlen (&token_name, toklen); + memcpy (token_name.buffer, + newlb.buffer + tokoff, toklen); + token_name.buffer[toklen] = '\0'; + /* Name macros and members. */ + token.named = (structdef == stagseen + || typdef == ttypeseen + || typdef == tend + || (funorvar + && definedef == dignorerest) + || (funorvar + && definedef == dnone + && structdef == snone + && bracelev > 0)); + } + token.lineno = lineno; + token.offset = tokoff; + token.length = toklen; + token.line = newlb.buffer; + token.linepos = newlinepos; + token.valid = true; + + if (definedef == dnone + && (fvdef == fvnameseen + || fvdef == foperator + || structdef == stagseen + || typdef == tend + || typdef == ttypeseen + || objdef != onone)) + { + if (current_lb_is_new) + switch_line_buffers (); + } + else if (definedef != dnone + || fvdef == fdefunname + || instruct) + make_C_tag (funorvar); + } + else /* not yacc and consider_token failed */ + { + if (inattribute && fvdef == fignore) + { + /* We have just met __attribute__ after a + function parameter list: do not tag the + function again. */ + fvdef = fvnone; + } + } + midtoken = false; + } + } /* if (endtoken (c)) */ + else if (intoken (c)) + still_in_token: + { + toklen++; + continue; + } + } /* if (midtoken) */ + else if (begtoken (c)) + { + switch (definedef) + { + case dnone: + switch (fvdef) + { + case fstartlist: + /* This prevents tagging fb in + void (__attribute__((noreturn)) *fb) (void); + Fixing this is not easy and not very important. */ + fvdef = finlist; + continue; + case flistseen: + if (plainc || declarations) + { + make_C_tag (true); /* a function */ + fvdef = fignore; + } + break; + } + if (structdef == stagseen && !cjava) + { + popclass_above (bracelev); + structdef = snone; + } + break; + case dsharpseen: + savetoken = token; + break; + } + if (!yacc_rules || lp == newlb.buffer + 1) + { + tokoff = lp - 1 - newlb.buffer; + toklen = 1; + midtoken = true; + } + continue; + } /* if (begtoken) */ + } /* if must look at token */ + + + /* Detect end of line, colon, comma, semicolon and various braces + after having handled a token.*/ + switch (c) + { + case ':': + if (inattribute) + break; + if (yacc_rules && token.offset == 0 && token.valid) + { + make_C_tag (false); /* a yacc function */ + break; + } + if (definedef != dnone) + break; + switch (objdef) + { + case otagseen: + objdef = oignore; + make_C_tag (true); /* an Objective C class */ + break; + case omethodtag: + case omethodparm: + objdef = omethodcolon; + int toklen = token_name.len; + linebuffer_setlen (&token_name, toklen + 1); + strcpy (token_name.buffer + toklen, ":"); + break; + } + if (structdef == stagseen) + { + structdef = scolonseen; + break; + } + /* Should be useless, but may be work as a safety net. */ + if (cplpl && fvdef == flistseen) + { + make_C_tag (true); /* a function */ + fvdef = fignore; + break; + } + break; + case ';': + if (definedef != dnone || inattribute) + break; + switch (typdef) + { + case tend: + case ttypeseen: + make_C_tag (false); /* a typedef */ + typdef = tnone; + fvdef = fvnone; + break; + case tnone: + case tinbody: + case tignore: + switch (fvdef) + { + case fignore: + if (typdef == tignore || cplpl) + fvdef = fvnone; + break; + case fvnameseen: + if ((globals && bracelev == 0 && (!fvextern || declarations)) + || (members && instruct)) + make_C_tag (false); /* a variable */ + fvextern = false; + fvdef = fvnone; + token.valid = false; + break; + case flistseen: + if ((declarations + && (cplpl || !instruct) + && (typdef == tnone || (typdef != tignore && instruct))) + || (members + && plainc && instruct)) + make_C_tag (true); /* a function */ + /* FALLTHRU */ + default: + fvextern = false; + fvdef = fvnone; + if (declarations + && cplpl && structdef == stagseen) + make_C_tag (false); /* forward declaration */ + else + token.valid = false; + } /* switch (fvdef) */ + /* FALLTHRU */ + default: + if (!instruct) + typdef = tnone; + } + if (structdef == stagseen) + structdef = snone; + break; + case ',': + if (definedef != dnone || inattribute) + break; + switch (objdef) + { + case omethodtag: + case omethodparm: + make_C_tag (true); /* an Objective C method */ + objdef = oinbody; + break; + } + switch (fvdef) + { + case fdefunkey: + case foperator: + case fstartlist: + case finlist: + case fignore: + break; + case vignore: + if (instruct && parlev == 0) + fvdef = fvnone; + break; + case fdefunname: + fvdef = fignore; + break; + case fvnameseen: + if (parlev == 0 + && ((globals + && bracelev == 0 + && templatelev == 0 + && (!fvextern || declarations)) + || (members && instruct))) + make_C_tag (false); /* a variable */ + break; + case flistseen: + if ((declarations && typdef == tnone && !instruct) + || (members && typdef != tignore && instruct)) + { + make_C_tag (true); /* a function */ + fvdef = fvnameseen; + } + else if (!declarations) + fvdef = fvnone; + token.valid = false; + break; + default: + fvdef = fvnone; + } + if (structdef == stagseen) + structdef = snone; + break; + case ']': + if (definedef != dnone || inattribute) + break; + if (structdef == stagseen) + structdef = snone; + switch (typdef) + { + case ttypeseen: + case tend: + typdef = tignore; + make_C_tag (false); /* a typedef */ + break; + case tnone: + case tinbody: + switch (fvdef) + { + case foperator: + case finlist: + case fignore: + case vignore: + break; + case fvnameseen: + if ((members && bracelev == 1) + || (globals && bracelev == 0 + && (!fvextern || declarations))) + make_C_tag (false); /* a variable */ + /* FALLTHRU */ + default: + fvdef = fvnone; + } + break; + } + break; + case '(': + if (inattribute) + { + attrparlev++; + break; + } + if (definedef != dnone) + break; + if (objdef == otagseen && parlev == 0) + objdef = oparenseen; + switch (fvdef) + { + case fvnameseen: + if (typdef == ttypeseen + && *lp != '*' + && !instruct) + { + /* This handles constructs like: + typedef void OperatorFun (int fun); */ + make_C_tag (false); + typdef = tignore; + fvdef = fignore; + break; + } + /* FALLTHRU */ + case foperator: + fvdef = fstartlist; + break; + case flistseen: + fvdef = finlist; + break; + } + parlev++; + break; + case ')': + if (inattribute) + { + if (--attrparlev == 0) + inattribute = false; + break; + } + if (definedef != dnone) + break; + if (objdef == ocatseen && parlev == 1) + { + make_C_tag (true); /* an Objective C category */ + objdef = oignore; + } + if (--parlev == 0) + { + switch (fvdef) + { + case fstartlist: + case finlist: + fvdef = flistseen; + break; + } + if (!instruct + && (typdef == tend + || typdef == ttypeseen)) + { + typdef = tignore; + make_C_tag (false); /* a typedef */ + } + } + else if (parlev < 0) /* can happen due to ill-conceived #if's. */ + parlev = 0; + break; + case '{': + if (definedef != dnone) + break; + if (typdef == ttypeseen) + { + /* Whenever typdef is set to tinbody (currently only + here), typdefbracelev should be set to bracelev. */ + typdef = tinbody; + typdefbracelev = bracelev; + } + switch (fvdef) + { + case flistseen: + make_C_tag (true); /* a function */ + /* FALLTHRU */ + case fignore: + fvdef = fvnone; + break; + case fvnone: + switch (objdef) + { + case otagseen: + make_C_tag (true); /* an Objective C class */ + objdef = oignore; + break; + case omethodtag: + case omethodparm: + make_C_tag (true); /* an Objective C method */ + objdef = oinbody; + break; + default: + /* Neutralize `extern "C" {' grot. */ + if (bracelev == 0 && structdef == snone && nestlev == 0 + && typdef == tnone) + bracelev = -1; + } + break; + } + switch (structdef) + { + case skeyseen: /* unnamed struct */ + pushclass_above (bracelev, NULL, 0); + structdef = snone; + break; + case stagseen: /* named struct or enum */ + case scolonseen: /* a class */ + pushclass_above (bracelev,token.line+token.offset, token.length); + structdef = snone; + make_C_tag (false); /* a struct or enum */ + break; + } + bracelev += 1; + break; + case '*': + if (definedef != dnone) + break; + if (fvdef == fstartlist) + { + fvdef = fvnone; /* avoid tagging `foo' in `foo (*bar()) ()' */ + token.valid = false; + } + break; + case '}': + if (definedef != dnone) + break; + bracelev -= 1; + if (!ignoreindent && lp == newlb.buffer + 1) + { + if (bracelev != 0) + token.valid = false; /* unexpected value, token unreliable */ + bracelev = 0; /* reset brace level if first column */ + parlev = 0; /* also reset paren level, just in case... */ + } + else if (bracelev < 0) + { + token.valid = false; /* something gone amiss, token unreliable */ + bracelev = 0; + } + if (bracelev == 0 && fvdef == vignore) + fvdef = fvnone; /* end of function */ + popclass_above (bracelev); + structdef = snone; + /* Only if typdef == tinbody is typdefbracelev significant. */ + if (typdef == tinbody && bracelev <= typdefbracelev) + { + assert (bracelev == typdefbracelev); + typdef = tend; + } + break; + case '=': + if (definedef != dnone) + break; + switch (fvdef) + { + case foperator: + case finlist: + case fignore: + case vignore: + break; + case fvnameseen: + if ((members && bracelev == 1) + || (globals && bracelev == 0 && (!fvextern || declarations))) + make_C_tag (false); /* a variable */ + /* FALLTHRU */ + default: + fvdef = vignore; + } + break; + case '<': + if (cplpl + && (structdef == stagseen || fvdef == fvnameseen)) + { + templatelev++; + break; + } + goto resetfvdef; + case '>': + if (templatelev > 0) + { + templatelev--; + break; + } + goto resetfvdef; + case '+': + case '-': + if (objdef == oinbody && bracelev == 0) + { + objdef = omethodsign; + break; + } + /* FALLTHRU */ + resetfvdef: + case '#': case '~': case '&': case '%': case '/': + case '|': case '^': case '!': case '.': case '?': + if (definedef != dnone) + break; + /* These surely cannot follow a function tag in C. */ + switch (fvdef) + { + case foperator: + case finlist: + case fignore: + case vignore: + break; + default: + fvdef = fvnone; + } + break; + case '\0': + if (objdef == otagseen) + { + make_C_tag (true); /* an Objective C class */ + objdef = oignore; + } + /* If a macro spans multiple lines don't reset its state. */ + if (quotednl) + CNL_SAVE_DEFINEDEF (); + else + CNL (); + break; + } /* switch (c) */ + + } /* while not eof */ + + free (lbs[0].lb.buffer); + free (lbs[1].lb.buffer); +} + +/* + * Process either a C++ file or a C file depending on the setting + * of a global flag. + */ +static void +default_C_entries (FILE *inf) +{ + C_entries (cplusplus ? C_PLPL : C_AUTO, inf); +} + +/* Always do plain C. */ +static void +plain_C_entries (FILE *inf) +{ + C_entries (0, inf); +} + +/* Always do C++. */ +static void +Cplusplus_entries (FILE *inf) +{ + C_entries (C_PLPL, inf); +} + +/* Always do Java. */ +static void +Cjava_entries (FILE *inf) +{ + C_entries (C_JAVA, inf); +} + +/* Always do C*. */ +static void +Cstar_entries (FILE *inf) +{ + C_entries (C_STAR, inf); +} + +/* Always do Yacc. */ +static void +Yacc_entries (FILE *inf) +{ + C_entries (YACC, inf); +} + + +/* Useful macros. */ +#define LOOP_ON_INPUT_LINES(file_pointer, line_buffer, char_pointer) \ + for (; /* loop initialization */ \ + !feof (file_pointer) /* loop test */ \ + && /* instructions at start of loop */ \ + (readline (&line_buffer, file_pointer), \ + char_pointer = line_buffer.buffer, \ + true); \ + ) + +#define LOOKING_AT(cp, kw) /* kw is the keyword, a literal string */ \ + ((assert ("" kw), true) /* syntax error if not a literal string */ \ + && strneq ((cp), kw, sizeof (kw)-1) /* cp points at kw */ \ + && notinname ((cp)[sizeof (kw)-1]) /* end of kw */ \ + && ((cp) = skip_spaces ((cp)+sizeof (kw)-1))) /* skip spaces */ + +/* Similar to LOOKING_AT but does not use notinname, does not skip */ +#define LOOKING_AT_NOCASE(cp, kw) /* the keyword is a literal string */ \ + ((assert ("" kw), true) /* syntax error if not a literal string */ \ + && strncaseeq ((cp), kw, sizeof (kw)-1) /* cp points at kw */ \ + && ((cp) += sizeof (kw)-1)) /* skip spaces */ + +/* + * Read a file, but do no processing. This is used to do regexp + * matching on files that have no language defined. + */ +static void +just_read_file (FILE *inf) +{ + while (!feof (inf)) + readline (&lb, inf); +} + + +/* Fortran parsing */ + +static void F_takeprec (void); +static void F_getit (FILE *); + +static void +F_takeprec (void) +{ + dbp = skip_spaces (dbp); + if (*dbp != '*') + return; + dbp++; + dbp = skip_spaces (dbp); + if (strneq (dbp, "(*)", 3)) + { + dbp += 3; + return; + } + if (!ISDIGIT (*dbp)) + { + --dbp; /* force failure */ + return; + } + do + dbp++; + while (ISDIGIT (*dbp)); +} + +static void +F_getit (FILE *inf) +{ + register char *cp; + + dbp = skip_spaces (dbp); + if (*dbp == '\0') + { + readline (&lb, inf); + dbp = lb.buffer; + if (dbp[5] != '&') + return; + dbp += 6; + dbp = skip_spaces (dbp); + } + if (!ISALPHA (*dbp) && *dbp != '_' && *dbp != '$') + return; + for (cp = dbp + 1; *cp != '\0' && intoken (*cp); cp++) + continue; + make_tag (dbp, cp-dbp, true, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); +} + + +static void +Fortran_functions (FILE *inf) +{ + LOOP_ON_INPUT_LINES (inf, lb, dbp) + { + if (*dbp == '%') + dbp++; /* Ratfor escape to fortran */ + dbp = skip_spaces (dbp); + if (*dbp == '\0') + continue; + + if (LOOKING_AT_NOCASE (dbp, "recursive")) + dbp = skip_spaces (dbp); + + if (LOOKING_AT_NOCASE (dbp, "pure")) + dbp = skip_spaces (dbp); + + if (LOOKING_AT_NOCASE (dbp, "elemental")) + dbp = skip_spaces (dbp); + + switch (lowcase (*dbp)) + { + case 'i': + if (nocase_tail ("integer")) + F_takeprec (); + break; + case 'r': + if (nocase_tail ("real")) + F_takeprec (); + break; + case 'l': + if (nocase_tail ("logical")) + F_takeprec (); + break; + case 'c': + if (nocase_tail ("complex") || nocase_tail ("character")) + F_takeprec (); + break; + case 'd': + if (nocase_tail ("double")) + { + dbp = skip_spaces (dbp); + if (*dbp == '\0') + continue; + if (nocase_tail ("precision")) + break; + continue; + } + break; + } + dbp = skip_spaces (dbp); + if (*dbp == '\0') + continue; + switch (lowcase (*dbp)) + { + case 'f': + if (nocase_tail ("function")) + F_getit (inf); + continue; + case 's': + if (nocase_tail ("subroutine")) + F_getit (inf); + continue; + case 'e': + if (nocase_tail ("entry")) + F_getit (inf); + continue; + case 'b': + if (nocase_tail ("blockdata") || nocase_tail ("block data")) + { + dbp = skip_spaces (dbp); + if (*dbp == '\0') /* assume un-named */ + make_tag ("blockdata", 9, true, + lb.buffer, dbp - lb.buffer, lineno, linecharno); + else + F_getit (inf); /* look for name */ + } + continue; + } + } +} + + +/* + * Ada parsing + * Original code by + * Philippe Waroquiers (1998) + */ + +/* Once we are positioned after an "interesting" keyword, let's get + the real tag value necessary. */ +static void +Ada_getit (FILE *inf, const char *name_qualifier) +{ + register char *cp; + char *name; + char c; + + while (!feof (inf)) + { + dbp = skip_spaces (dbp); + if (*dbp == '\0' + || (dbp[0] == '-' && dbp[1] == '-')) + { + readline (&lb, inf); + dbp = lb.buffer; + } + switch (lowcase (*dbp)) + { + case 'b': + if (nocase_tail ("body")) + { + /* Skipping body of procedure body or package body or .... + resetting qualifier to body instead of spec. */ + name_qualifier = "/b"; + continue; + } + break; + case 't': + /* Skipping type of task type or protected type ... */ + if (nocase_tail ("type")) + continue; + break; + } + if (*dbp == '"') + { + dbp += 1; + for (cp = dbp; *cp != '\0' && *cp != '"'; cp++) + continue; + } + else + { + dbp = skip_spaces (dbp); + for (cp = dbp; + (*cp != '\0' + && (ISALPHA (*cp) || ISDIGIT (*cp) || *cp == '_' || *cp == '.')); + cp++) + continue; + if (cp == dbp) + return; + } + c = *cp; + *cp = '\0'; + name = concat (dbp, name_qualifier, ""); + *cp = c; + make_tag (name, strlen (name), true, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + free (name); + if (c == '"') + dbp = cp + 1; + return; + } +} + +static void +Ada_funcs (FILE *inf) +{ + bool inquote = false; + bool skip_till_semicolumn = false; + + LOOP_ON_INPUT_LINES (inf, lb, dbp) + { + while (*dbp != '\0') + { + /* Skip a string i.e. "abcd". */ + if (inquote || (*dbp == '"')) + { + dbp = strchr (dbp + !inquote, '"'); + if (dbp != NULL) + { + inquote = false; + dbp += 1; + continue; /* advance char */ + } + else + { + inquote = true; + break; /* advance line */ + } + } + + /* Skip comments. */ + if (dbp[0] == '-' && dbp[1] == '-') + break; /* advance line */ + + /* Skip character enclosed in single quote i.e. 'a' + and skip single quote starting an attribute i.e. 'Image. */ + if (*dbp == '\'') + { + dbp++ ; + if (*dbp != '\0') + dbp++; + continue; + } + + if (skip_till_semicolumn) + { + if (*dbp == ';') + skip_till_semicolumn = false; + dbp++; + continue; /* advance char */ + } + + /* Search for beginning of a token. */ + if (!begtoken (*dbp)) + { + dbp++; + continue; /* advance char */ + } + + /* We are at the beginning of a token. */ + switch (lowcase (*dbp)) + { + case 'f': + if (!packages_only && nocase_tail ("function")) + Ada_getit (inf, "/f"); + else + break; /* from switch */ + continue; /* advance char */ + case 'p': + if (!packages_only && nocase_tail ("procedure")) + Ada_getit (inf, "/p"); + else if (nocase_tail ("package")) + Ada_getit (inf, "/s"); + else if (nocase_tail ("protected")) /* protected type */ + Ada_getit (inf, "/t"); + else + break; /* from switch */ + continue; /* advance char */ + + case 'u': + if (typedefs && !packages_only && nocase_tail ("use")) + { + /* when tagging types, avoid tagging use type Pack.Typename; + for this, we will skip everything till a ; */ + skip_till_semicolumn = true; + continue; /* advance char */ + } + + case 't': + if (!packages_only && nocase_tail ("task")) + Ada_getit (inf, "/k"); + else if (typedefs && !packages_only && nocase_tail ("type")) + { + Ada_getit (inf, "/t"); + while (*dbp != '\0') + dbp += 1; + } + else + break; /* from switch */ + continue; /* advance char */ + } + + /* Look for the end of the token. */ + while (!endtoken (*dbp)) + dbp++; + + } /* advance char */ + } /* advance line */ +} + + +/* + * Unix and microcontroller assembly tag handling + * Labels: /^[a-zA-Z_.$][a-zA_Z0-9_.$]*[: ^I^J]/ + * Idea by Bob Weiner, Motorola Inc. (1994) + */ +static void +Asm_labels (FILE *inf) +{ + register char *cp; + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + /* If first char is alphabetic or one of [_.$], test for colon + following identifier. */ + if (ISALPHA (*cp) || *cp == '_' || *cp == '.' || *cp == '$') + { + /* Read past label. */ + cp++; + while (ISALNUM (*cp) || *cp == '_' || *cp == '.' || *cp == '$') + cp++; + if (*cp == ':' || iswhite (*cp)) + /* Found end of label, so copy it and add it to the table. */ + make_tag (lb.buffer, cp - lb.buffer, true, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + } + } +} + + +/* + * Perl support + * Perl sub names: /^sub[ \t\n]+[^ \t\n{]+/ + * /^use constant[ \t\n]+[^ \t\n{=,;]+/ + * Perl variable names: /^(my|local).../ + * Original code by Bart Robinson (1995) + * Additions by Michael Ernst (1997) + * Ideas by Kai Großjohann (2001) + */ +static void +Perl_functions (FILE *inf) +{ + char *package = savestr ("main"); /* current package name */ + register char *cp; + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + cp = skip_spaces (cp); + + if (LOOKING_AT (cp, "package")) + { + free (package); + get_tag (cp, &package); + } + else if (LOOKING_AT (cp, "sub")) + { + char *pos, *sp; + + subr: + sp = cp; + while (!notinname (*cp)) + cp++; + if (cp == sp) + continue; /* nothing found */ + if ((pos = strchr (sp, ':')) != NULL + && pos < cp && pos[1] == ':') + /* The name is already qualified. */ + make_tag (sp, cp - sp, true, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + else + /* Qualify it. */ + { + char savechar, *name; + + savechar = *cp; + *cp = '\0'; + name = concat (package, "::", sp); + *cp = savechar; + make_tag (name, strlen (name), true, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + free (name); + } + } + else if (LOOKING_AT (cp, "use constant") + || LOOKING_AT (cp, "use constant::defer")) + { + /* For hash style multi-constant like + use constant { FOO => 123, + BAR => 456 }; + only the first FOO is picked up. Parsing across the value + expressions would be difficult in general, due to possible nested + hashes, here-documents, etc. */ + if (*cp == '{') + cp = skip_spaces (cp+1); + goto subr; + } + else if (globals) /* only if we are tagging global vars */ + { + /* Skip a qualifier, if any. */ + bool qual = LOOKING_AT (cp, "my") || LOOKING_AT (cp, "local"); + /* After "my" or "local", but before any following paren or space. */ + char *varstart = cp; + + if (qual /* should this be removed? If yes, how? */ + && (*cp == '$' || *cp == '@' || *cp == '%')) + { + varstart += 1; + do + cp++; + while (ISALNUM (*cp) || *cp == '_'); + } + else if (qual) + { + /* Should be examining a variable list at this point; + could insist on seeing an open parenthesis. */ + while (*cp != '\0' && *cp != ';' && *cp != '=' && *cp != ')') + cp++; + } + else + continue; + + make_tag (varstart, cp - varstart, false, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + } + } + free (package); +} + + +/* + * Python support + * Look for /^[\t]*def[ \t\n]+[^ \t\n(:]+/ or /^class[ \t\n]+[^ \t\n(:]+/ + * Idea by Eric S. Raymond (1997) + * More ideas by seb bacon (2002) + */ +static void +Python_functions (FILE *inf) +{ + register char *cp; + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + cp = skip_spaces (cp); + if (LOOKING_AT (cp, "def") || LOOKING_AT (cp, "class")) + { + char *name = cp; + while (!notinname (*cp) && *cp != ':') + cp++; + make_tag (name, cp - name, true, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + } + } +} + + +/* + * PHP support + * Look for: + * - /^[ \t]*function[ \t\n]+[^ \t\n(]+/ + * - /^[ \t]*class[ \t\n]+[^ \t\n]+/ + * - /^[ \t]*define\(\"[^\"]+/ + * Only with --members: + * - /^[ \t]*var[ \t\n]+\$[^ \t\n=;]/ + * Idea by Diez B. Roggisch (2001) + */ +static void +PHP_functions (FILE *inf) +{ + char *cp, *name; + bool search_identifier = false; + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + cp = skip_spaces (cp); + name = cp; + if (search_identifier + && *cp != '\0') + { + while (!notinname (*cp)) + cp++; + make_tag (name, cp - name, true, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + search_identifier = false; + } + else if (LOOKING_AT (cp, "function")) + { + if (*cp == '&') + cp = skip_spaces (cp+1); + if (*cp != '\0') + { + name = cp; + while (!notinname (*cp)) + cp++; + make_tag (name, cp - name, true, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + } + else + search_identifier = true; + } + else if (LOOKING_AT (cp, "class")) + { + if (*cp != '\0') + { + name = cp; + while (*cp != '\0' && !iswhite (*cp)) + cp++; + make_tag (name, cp - name, false, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + } + else + search_identifier = true; + } + else if (strneq (cp, "define", 6) + && (cp = skip_spaces (cp+6)) + && *cp++ == '(' + && (*cp == '"' || *cp == '\'')) + { + char quote = *cp++; + name = cp; + while (*cp != quote && *cp != '\0') + cp++; + make_tag (name, cp - name, false, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + } + else if (members + && LOOKING_AT (cp, "var") + && *cp == '$') + { + name = cp; + while (!notinname (*cp)) + cp++; + make_tag (name, cp - name, false, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + } + } +} + + +/* + * Cobol tag functions + * We could look for anything that could be a paragraph name. + * i.e. anything that starts in column 8 is one word and ends in a full stop. + * Idea by Corny de Souza (1993) + */ +static void +Cobol_paragraphs (FILE *inf) +{ + register char *bp, *ep; + + LOOP_ON_INPUT_LINES (inf, lb, bp) + { + if (lb.len < 9) + continue; + bp += 8; + + /* If eoln, compiler option or comment ignore whole line. */ + if (bp[-1] != ' ' || !ISALNUM (bp[0])) + continue; + + for (ep = bp; ISALNUM (*ep) || *ep == '-'; ep++) + continue; + if (*ep++ == '.') + make_tag (bp, ep - bp, true, + lb.buffer, ep - lb.buffer + 1, lineno, linecharno); + } +} + + +/* + * Makefile support + * Ideas by Assar Westerlund (2001) + */ +static void +Makefile_targets (FILE *inf) +{ + register char *bp; + + LOOP_ON_INPUT_LINES (inf, lb, bp) + { + if (*bp == '\t' || *bp == '#') + continue; + while (*bp != '\0' && *bp != '=' && *bp != ':') + bp++; + if (*bp == ':' || (globals && *bp == '=')) + { + /* We should detect if there is more than one tag, but we do not. + We just skip initial and final spaces. */ + char * namestart = skip_spaces (lb.buffer); + while (--bp > namestart) + if (!notinname (*bp)) + break; + make_tag (namestart, bp - namestart + 1, true, + lb.buffer, bp - lb.buffer + 2, lineno, linecharno); + } + } +} + + +/* + * Pascal parsing + * Original code by Mosur K. Mohan (1989) + * + * Locates tags for procedures & functions. Doesn't do any type- or + * var-definitions. It does look for the keyword "extern" or + * "forward" immediately following the procedure statement; if found, + * the tag is skipped. + */ +static void +Pascal_functions (FILE *inf) +{ + linebuffer tline; /* mostly copied from C_entries */ + long save_lcno; + int save_lineno, namelen, taglen; + char c, *name; + + bool /* each of these flags is true if: */ + incomment, /* point is inside a comment */ + inquote, /* point is inside '..' string */ + get_tagname, /* point is after PROCEDURE/FUNCTION + keyword, so next item = potential tag */ + found_tag, /* point is after a potential tag */ + inparms, /* point is within parameter-list */ + verify_tag; /* point has passed the parm-list, so the + next token will determine whether this + is a FORWARD/EXTERN to be ignored, or + whether it is a real tag */ + + save_lcno = save_lineno = namelen = taglen = 0; /* keep compiler quiet */ + name = NULL; /* keep compiler quiet */ + dbp = lb.buffer; + *dbp = '\0'; + linebuffer_init (&tline); + + incomment = inquote = false; + found_tag = false; /* have a proc name; check if extern */ + get_tagname = false; /* found "procedure" keyword */ + inparms = false; /* found '(' after "proc" */ + verify_tag = false; /* check if "extern" is ahead */ + + + while (!feof (inf)) /* long main loop to get next char */ + { + c = *dbp++; + if (c == '\0') /* if end of line */ + { + readline (&lb, inf); + dbp = lb.buffer; + if (*dbp == '\0') + continue; + if (!((found_tag && verify_tag) + || get_tagname)) + c = *dbp++; /* only if don't need *dbp pointing + to the beginning of the name of + the procedure or function */ + } + if (incomment) + { + if (c == '}') /* within { } comments */ + incomment = false; + else if (c == '*' && *dbp == ')') /* within (* *) comments */ + { + dbp++; + incomment = false; + } + continue; + } + else if (inquote) + { + if (c == '\'') + inquote = false; + continue; + } + else + switch (c) + { + case '\'': + inquote = true; /* found first quote */ + continue; + case '{': /* found open { comment */ + incomment = true; + continue; + case '(': + if (*dbp == '*') /* found open (* comment */ + { + incomment = true; + dbp++; + } + else if (found_tag) /* found '(' after tag, i.e., parm-list */ + inparms = true; + continue; + case ')': /* end of parms list */ + if (inparms) + inparms = false; + continue; + case ';': + if (found_tag && !inparms) /* end of proc or fn stmt */ + { + verify_tag = true; + break; + } + continue; + } + if (found_tag && verify_tag && (*dbp != ' ')) + { + /* Check if this is an "extern" declaration. */ + if (*dbp == '\0') + continue; + if (lowcase (*dbp) == 'e') + { + if (nocase_tail ("extern")) /* superfluous, really! */ + { + found_tag = false; + verify_tag = false; + } + } + else if (lowcase (*dbp) == 'f') + { + if (nocase_tail ("forward")) /* check for forward reference */ + { + found_tag = false; + verify_tag = false; + } + } + if (found_tag && verify_tag) /* not external proc, so make tag */ + { + found_tag = false; + verify_tag = false; + make_tag (name, namelen, true, + tline.buffer, taglen, save_lineno, save_lcno); + continue; + } + } + if (get_tagname) /* grab name of proc or fn */ + { + char *cp; + + if (*dbp == '\0') + continue; + + /* Find block name. */ + for (cp = dbp + 1; *cp != '\0' && !endtoken (*cp); cp++) + continue; + + /* Save all values for later tagging. */ + linebuffer_setlen (&tline, lb.len); + strcpy (tline.buffer, lb.buffer); + save_lineno = lineno; + save_lcno = linecharno; + name = tline.buffer + (dbp - lb.buffer); + namelen = cp - dbp; + taglen = cp - lb.buffer + 1; + + dbp = cp; /* set dbp to e-o-token */ + get_tagname = false; + found_tag = true; + continue; + + /* And proceed to check for "extern". */ + } + else if (!incomment && !inquote && !found_tag) + { + /* Check for proc/fn keywords. */ + switch (lowcase (c)) + { + case 'p': + if (nocase_tail ("rocedure")) /* c = 'p', dbp has advanced */ + get_tagname = true; + continue; + case 'f': + if (nocase_tail ("unction")) + get_tagname = true; + continue; + } + } + } /* while not eof */ + + free (tline.buffer); +} + + +/* + * Lisp tag functions + * look for (def or (DEF, quote or QUOTE + */ + +static void L_getit (void); + +static void +L_getit (void) +{ + if (*dbp == '\'') /* Skip prefix quote */ + dbp++; + else if (*dbp == '(') + { + dbp++; + /* Try to skip "(quote " */ + if (!LOOKING_AT (dbp, "quote") && !LOOKING_AT (dbp, "QUOTE")) + /* Ok, then skip "(" before name in (defstruct (foo)) */ + dbp = skip_spaces (dbp); + } + get_tag (dbp, NULL); +} + +static void +Lisp_functions (FILE *inf) +{ + LOOP_ON_INPUT_LINES (inf, lb, dbp) + { + if (dbp[0] != '(') + continue; + + /* "(defvar foo)" is a declaration rather than a definition. */ + if (! declarations) + { + char *p = dbp + 1; + if (LOOKING_AT (p, "defvar")) + { + p = skip_name (p); /* past var name */ + p = skip_spaces (p); + if (*p == ')') + continue; + } + } + + if (strneq (dbp + 1, "cl-", 3) || strneq (dbp + 1, "CL-", 3)) + dbp += 3; + + if (strneq (dbp+1, "def", 3) || strneq (dbp+1, "DEF", 3)) + { + dbp = skip_non_spaces (dbp); + dbp = skip_spaces (dbp); + L_getit (); + } + else + { + /* Check for (foo::defmumble name-defined ... */ + do + dbp++; + while (!notinname (*dbp) && *dbp != ':'); + if (*dbp == ':') + { + do + dbp++; + while (*dbp == ':'); + + if (strneq (dbp, "def", 3) || strneq (dbp, "DEF", 3)) + { + dbp = skip_non_spaces (dbp); + dbp = skip_spaces (dbp); + L_getit (); + } + } + } + } +} + + +/* + * Lua script language parsing + * Original code by David A. Capello (2004) + * + * "function" and "local function" are tags if they start at column 1. + */ +static void +Lua_functions (FILE *inf) +{ + register char *bp; + + LOOP_ON_INPUT_LINES (inf, lb, bp) + { + if (bp[0] != 'f' && bp[0] != 'l') + continue; + + (void)LOOKING_AT (bp, "local"); /* skip possible "local" */ + + if (LOOKING_AT (bp, "function")) + get_tag (bp, NULL); + } +} + + +/* + * PostScript tags + * Just look for lines where the first character is '/' + * Also look at "defineps" for PSWrap + * Ideas by: + * Richard Mlynarik (1997) + * Masatake Yamato (1999) + */ +static void +PS_functions (FILE *inf) +{ + register char *bp, *ep; + + LOOP_ON_INPUT_LINES (inf, lb, bp) + { + if (bp[0] == '/') + { + for (ep = bp+1; + *ep != '\0' && *ep != ' ' && *ep != '{'; + ep++) + continue; + make_tag (bp, ep - bp, true, + lb.buffer, ep - lb.buffer + 1, lineno, linecharno); + } + else if (LOOKING_AT (bp, "defineps")) + get_tag (bp, NULL); + } +} + + +/* + * Forth tags + * Ignore anything after \ followed by space or in ( ) + * Look for words defined by : + * Look for constant, code, create, defer, value, and variable + * OBP extensions: Look for buffer:, field, + * Ideas by Eduardo Horvath (2004) + */ +static void +Forth_words (FILE *inf) +{ + register char *bp; + + LOOP_ON_INPUT_LINES (inf, lb, bp) + while ((bp = skip_spaces (bp))[0] != '\0') + if (bp[0] == '\\' && iswhite (bp[1])) + break; /* read next line */ + else if (bp[0] == '(' && iswhite (bp[1])) + do /* skip to ) or eol */ + bp++; + while (*bp != ')' && *bp != '\0'); + else if ((bp[0] == ':' && iswhite (bp[1]) && bp++) + || LOOKING_AT_NOCASE (bp, "constant") + || LOOKING_AT_NOCASE (bp, "code") + || LOOKING_AT_NOCASE (bp, "create") + || LOOKING_AT_NOCASE (bp, "defer") + || LOOKING_AT_NOCASE (bp, "value") + || LOOKING_AT_NOCASE (bp, "variable") + || LOOKING_AT_NOCASE (bp, "buffer:") + || LOOKING_AT_NOCASE (bp, "field")) + get_tag (skip_spaces (bp), NULL); /* Yay! A definition! */ + else + bp = skip_non_spaces (bp); +} + + +/* + * Scheme tag functions + * look for (def... xyzzy + * (def... (xyzzy + * (def ... ((...(xyzzy .... + * (set! xyzzy + * Original code by Ken Haase (1985?) + */ +static void +Scheme_functions (FILE *inf) +{ + register char *bp; + + LOOP_ON_INPUT_LINES (inf, lb, bp) + { + if (strneq (bp, "(def", 4) || strneq (bp, "(DEF", 4)) + { + bp = skip_non_spaces (bp+4); + /* Skip over open parens and white space. Don't continue past + '\0'. */ + while (*bp && notinname (*bp)) + bp++; + get_tag (bp, NULL); + } + if (LOOKING_AT (bp, "(SET!") || LOOKING_AT (bp, "(set!")) + get_tag (bp, NULL); + } +} + + +/* Find tags in TeX and LaTeX input files. */ + +/* TEX_toktab is a table of TeX control sequences that define tags. + * Each entry records one such control sequence. + * + * Original code from who knows whom. + * Ideas by: + * Stefan Monnier (2002) + */ + +static linebuffer *TEX_toktab = NULL; /* Table with tag tokens */ + +/* Default set of control sequences to put into TEX_toktab. + The value of environment var TEXTAGS is prepended to this. */ +static const char *TEX_defenv = "\ +:chapter:section:subsection:subsubsection:eqno:label:ref:cite:bibitem\ +:part:appendix:entry:index:def\ +:newcommand:renewcommand:newenvironment:renewenvironment"; + +static void TEX_mode (FILE *); +static void TEX_decode_env (const char *, const char *); + +static char TEX_esc = '\\'; +static char TEX_opgrp = '{'; +static char TEX_clgrp = '}'; + +/* + * TeX/LaTeX scanning loop. + */ +static void +TeX_commands (FILE *inf) +{ + char *cp; + linebuffer *key; + + /* Select either \ or ! as escape character. */ + TEX_mode (inf); + + /* Initialize token table once from environment. */ + if (TEX_toktab == NULL) + TEX_decode_env ("TEXTAGS", TEX_defenv); + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + /* Look at each TEX keyword in line. */ + for (;;) + { + /* Look for a TEX escape. */ + while (*cp++ != TEX_esc) + if (cp[-1] == '\0' || cp[-1] == '%') + goto tex_next_line; + + for (key = TEX_toktab; key->buffer != NULL; key++) + if (strneq (cp, key->buffer, key->len)) + { + char *p; + int namelen, linelen; + bool opgrp = false; + + cp = skip_spaces (cp + key->len); + if (*cp == TEX_opgrp) + { + opgrp = true; + cp++; + } + for (p = cp; + (!iswhite (*p) && *p != '#' && + *p != TEX_opgrp && *p != TEX_clgrp); + p++) + continue; + namelen = p - cp; + linelen = lb.len; + if (!opgrp || *p == TEX_clgrp) + { + while (*p != '\0' && *p != TEX_opgrp && *p != TEX_clgrp) + p++; + linelen = p - lb.buffer + 1; + } + make_tag (cp, namelen, true, + lb.buffer, linelen, lineno, linecharno); + goto tex_next_line; /* We only tag a line once */ + } + } + tex_next_line: + ; + } +} + +#define TEX_LESC '\\' +#define TEX_SESC '!' + +/* Figure out whether TeX's escapechar is '\\' or '!' and set grouping + chars accordingly. */ +static void +TEX_mode (FILE *inf) +{ + int c; + + while ((c = getc (inf)) != EOF) + { + /* Skip to next line if we hit the TeX comment char. */ + if (c == '%') + while (c != '\n' && c != EOF) + c = getc (inf); + else if (c == TEX_LESC || c == TEX_SESC ) + break; + } + + if (c == TEX_LESC) + { + TEX_esc = TEX_LESC; + TEX_opgrp = '{'; + TEX_clgrp = '}'; + } + else + { + TEX_esc = TEX_SESC; + TEX_opgrp = '<'; + TEX_clgrp = '>'; + } + /* If the input file is compressed, inf is a pipe, and rewind may fail. + No attempt is made to correct the situation. */ + rewind (inf); +} + +/* Read environment and prepend it to the default string. + Build token table. */ +static void +TEX_decode_env (const char *evarname, const char *defenv) +{ + register const char *env, *p; + int i, len; + + /* Append default string to environment. */ + env = getenv (evarname); + if (!env) + env = defenv; + else + env = concat (env, defenv, ""); + + /* Allocate a token table */ + for (len = 1, p = env; p;) + if ((p = strchr (p, ':')) && *++p != '\0') + len++; + TEX_toktab = xnew (len, linebuffer); + + /* Unpack environment string into token table. Be careful about */ + /* zero-length strings (leading ':', "::" and trailing ':') */ + for (i = 0; *env != '\0';) + { + p = strchr (env, ':'); + if (!p) /* End of environment string. */ + p = env + strlen (env); + if (p - env > 0) + { /* Only non-zero strings. */ + TEX_toktab[i].buffer = savenstr (env, p - env); + TEX_toktab[i].len = p - env; + i++; + } + if (*p) + env = p + 1; + else + { + TEX_toktab[i].buffer = NULL; /* Mark end of table. */ + TEX_toktab[i].len = 0; + break; + } + } +} + + +/* Texinfo support. Dave Love, Mar. 2000. */ +static void +Texinfo_nodes (FILE *inf) +{ + char *cp, *start; + LOOP_ON_INPUT_LINES (inf, lb, cp) + if (LOOKING_AT (cp, "@node")) + { + start = cp; + while (*cp != '\0' && *cp != ',') + cp++; + make_tag (start, cp - start, true, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + } +} + + +/* + * HTML support. + * Contents of , <h1>, <h2>, <h3> are tags. + * Contents of <a name=xxx> are tags with name xxx. + * + * Francesco Potortì, 2002. + */ +static void +HTML_labels (FILE *inf) +{ + bool getnext = false; /* next text outside of HTML tags is a tag */ + bool skiptag = false; /* skip to the end of the current HTML tag */ + bool intag = false; /* inside an html tag, looking for ID= */ + bool inanchor = false; /* when INTAG, is an anchor, look for NAME= */ + char *end; + + + linebuffer_setlen (&token_name, 0); /* no name in buffer */ + + LOOP_ON_INPUT_LINES (inf, lb, dbp) + for (;;) /* loop on the same line */ + { + if (skiptag) /* skip HTML tag */ + { + while (*dbp != '\0' && *dbp != '>') + dbp++; + if (*dbp == '>') + { + dbp += 1; + skiptag = false; + continue; /* look on the same line */ + } + break; /* go to next line */ + } + + else if (intag) /* look for "name=" or "id=" */ + { + while (*dbp != '\0' && *dbp != '>' + && lowcase (*dbp) != 'n' && lowcase (*dbp) != 'i') + dbp++; + if (*dbp == '\0') + break; /* go to next line */ + if (*dbp == '>') + { + dbp += 1; + intag = false; + continue; /* look on the same line */ + } + if ((inanchor && LOOKING_AT_NOCASE (dbp, "name=")) + || LOOKING_AT_NOCASE (dbp, "id=")) + { + bool quoted = (dbp[0] == '"'); + + if (quoted) + for (end = ++dbp; *end != '\0' && *end != '"'; end++) + continue; + else + for (end = dbp; *end != '\0' && intoken (*end); end++) + continue; + linebuffer_setlen (&token_name, end - dbp); + memcpy (token_name.buffer, dbp, end - dbp); + token_name.buffer[end - dbp] = '\0'; + + dbp = end; + intag = false; /* we found what we looked for */ + skiptag = true; /* skip to the end of the tag */ + getnext = true; /* then grab the text */ + continue; /* look on the same line */ + } + dbp += 1; + } + + else if (getnext) /* grab next tokens and tag them */ + { + dbp = skip_spaces (dbp); + if (*dbp == '\0') + break; /* go to next line */ + if (*dbp == '<') + { + intag = true; + inanchor = (lowcase (dbp[1]) == 'a' && !intoken (dbp[2])); + continue; /* look on the same line */ + } + + for (end = dbp + 1; *end != '\0' && *end != '<'; end++) + continue; + make_tag (token_name.buffer, token_name.len, true, + dbp, end - dbp, lineno, linecharno); + linebuffer_setlen (&token_name, 0); /* no name in buffer */ + getnext = false; + break; /* go to next line */ + } + + else /* look for an interesting HTML tag */ + { + while (*dbp != '\0' && *dbp != '<') + dbp++; + if (*dbp == '\0') + break; /* go to next line */ + intag = true; + if (lowcase (dbp[1]) == 'a' && !intoken (dbp[2])) + { + inanchor = true; + continue; /* look on the same line */ + } + else if (LOOKING_AT_NOCASE (dbp, "<title>") + || LOOKING_AT_NOCASE (dbp, "<h1>") + || LOOKING_AT_NOCASE (dbp, "<h2>") + || LOOKING_AT_NOCASE (dbp, "<h3>")) + { + intag = false; + getnext = true; + continue; /* look on the same line */ + } + dbp += 1; + } + } +} + + +/* + * Prolog support + * + * Assumes that the predicate or rule starts at column 0. + * Only the first clause of a predicate or rule is added. + * Original code by Sunichirou Sugou (1989) + * Rewritten by Anders Lindgren (1996) + */ +static size_t prolog_pr (char *, char *); +static void prolog_skip_comment (linebuffer *, FILE *); +static size_t prolog_atom (char *, size_t); + +static void +Prolog_functions (FILE *inf) +{ + char *cp, *last; + size_t len; + size_t allocated; + + allocated = 0; + len = 0; + last = NULL; + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + if (cp[0] == '\0') /* Empty line */ + continue; + else if (iswhite (cp[0])) /* Not a predicate */ + continue; + else if (cp[0] == '/' && cp[1] == '*') /* comment. */ + prolog_skip_comment (&lb, inf); + else if ((len = prolog_pr (cp, last)) > 0) + { + /* Predicate or rule. Store the function name so that we + only generate a tag for the first clause. */ + if (last == NULL) + last = xnew (len + 1, char); + else if (len + 1 > allocated) + xrnew (last, len + 1, char); + allocated = len + 1; + memcpy (last, cp, len); + last[len] = '\0'; + } + } + free (last); +} + + +static void +prolog_skip_comment (linebuffer *plb, FILE *inf) +{ + char *cp; + + do + { + for (cp = plb->buffer; *cp != '\0'; cp++) + if (cp[0] == '*' && cp[1] == '/') + return; + readline (plb, inf); + } + while (!feof (inf)); +} + +/* + * A predicate or rule definition is added if it matches: + * <beginning of line><Prolog Atom><whitespace>( + * or <beginning of line><Prolog Atom><whitespace>:- + * + * It is added to the tags database if it doesn't match the + * name of the previous clause header. + * + * Return the size of the name of the predicate or rule, or 0 if no + * header was found. + */ +static size_t +prolog_pr (char *s, char *last) + + /* Name of last clause. */ +{ + size_t pos; + size_t len; + + pos = prolog_atom (s, 0); + if (! pos) + return 0; + + len = pos; + pos = skip_spaces (s + pos) - s; + + if ((s[pos] == '.' + || (s[pos] == '(' && (pos += 1)) + || (s[pos] == ':' && s[pos + 1] == '-' && (pos += 2))) + && (last == NULL /* save only the first clause */ + || len != strlen (last) + || !strneq (s, last, len))) + { + make_tag (s, len, true, s, pos, lineno, linecharno); + return len; + } + else + return 0; +} + +/* + * Consume a Prolog atom. + * Return the number of bytes consumed, or 0 if there was an error. + * + * A prolog atom, in this context, could be one of: + * - An alphanumeric sequence, starting with a lower case letter. + * - A quoted arbitrary string. Single quotes can escape themselves. + * Backslash quotes everything. + */ +static size_t +prolog_atom (char *s, size_t pos) +{ + size_t origpos; + + origpos = pos; + + if (ISLOWER (s[pos]) || (s[pos] == '_')) + { + /* The atom is unquoted. */ + pos++; + while (ISALNUM (s[pos]) || (s[pos] == '_')) + { + pos++; + } + return pos - origpos; + } + else if (s[pos] == '\'') + { + pos++; + + for (;;) + { + if (s[pos] == '\'') + { + pos++; + if (s[pos] != '\'') + break; + pos++; /* A double quote */ + } + else if (s[pos] == '\0') + /* Multiline quoted atoms are ignored. */ + return 0; + else if (s[pos] == '\\') + { + if (s[pos+1] == '\0') + return 0; + pos += 2; + } + else + pos++; + } + return pos - origpos; + } + else + return 0; +} + + +/* + * Support for Erlang + * + * Generates tags for functions, defines, and records. + * Assumes that Erlang functions start at column 0. + * Original code by Anders Lindgren (1996) + */ +static int erlang_func (char *, char *); +static void erlang_attribute (char *); +static int erlang_atom (char *); + +static void +Erlang_functions (FILE *inf) +{ + char *cp, *last; + int len; + int allocated; + + allocated = 0; + len = 0; + last = NULL; + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + if (cp[0] == '\0') /* Empty line */ + continue; + else if (iswhite (cp[0])) /* Not function nor attribute */ + continue; + else if (cp[0] == '%') /* comment */ + continue; + else if (cp[0] == '"') /* Sometimes, strings start in column one */ + continue; + else if (cp[0] == '-') /* attribute, e.g. "-define" */ + { + erlang_attribute (cp); + if (last != NULL) + { + free (last); + last = NULL; + } + } + else if ((len = erlang_func (cp, last)) > 0) + { + /* + * Function. Store the function name so that we only + * generates a tag for the first clause. + */ + if (last == NULL) + last = xnew (len + 1, char); + else if (len + 1 > allocated) + xrnew (last, len + 1, char); + allocated = len + 1; + memcpy (last, cp, len); + last[len] = '\0'; + } + } + free (last); +} + + +/* + * A function definition is added if it matches: + * <beginning of line><Erlang Atom><whitespace>( + * + * It is added to the tags database if it doesn't match the + * name of the previous clause header. + * + * Return the size of the name of the function, or 0 if no function + * was found. + */ +static int +erlang_func (char *s, char *last) + + /* Name of last clause. */ +{ + int pos; + int len; + + pos = erlang_atom (s); + if (pos < 1) + return 0; + + len = pos; + pos = skip_spaces (s + pos) - s; + + /* Save only the first clause. */ + if (s[pos++] == '(' + && (last == NULL + || len != (int)strlen (last) + || !strneq (s, last, len))) + { + make_tag (s, len, true, s, pos, lineno, linecharno); + return len; + } + + return 0; +} + + +/* + * Handle attributes. Currently, tags are generated for defines + * and records. + * + * They are on the form: + * -define(foo, bar). + * -define(Foo(M, N), M+N). + * -record(graph, {vtab = notable, cyclic = true}). + */ +static void +erlang_attribute (char *s) +{ + char *cp = s; + + if ((LOOKING_AT (cp, "-define") || LOOKING_AT (cp, "-record")) + && *cp++ == '(') + { + int len = erlang_atom (skip_spaces (cp)); + if (len > 0) + make_tag (cp, len, true, s, cp + len - s, lineno, linecharno); + } + return; +} + + +/* + * Consume an Erlang atom (or variable). + * Return the number of bytes consumed, or -1 if there was an error. + */ +static int +erlang_atom (char *s) +{ + int pos = 0; + + if (ISALPHA (s[pos]) || s[pos] == '_') + { + /* The atom is unquoted. */ + do + pos++; + while (ISALNUM (s[pos]) || s[pos] == '_'); + } + else if (s[pos] == '\'') + { + for (pos++; s[pos] != '\''; pos++) + if (s[pos] == '\0' /* multiline quoted atoms are ignored */ + || (s[pos] == '\\' && s[++pos] == '\0')) + return 0; + pos++; + } + + return pos; +} + + +static char *scan_separators (char *); +static void add_regex (char *, language *); +static char *substitute (char *, char *, struct re_registers *); + +/* + * Take a string like "/blah/" and turn it into "blah", verifying + * that the first and last characters are the same, and handling + * quoted separator characters. Actually, stops on the occurrence of + * an unquoted separator. Also process \t, \n, etc. and turn into + * appropriate characters. Works in place. Null terminates name string. + * Returns pointer to terminating separator, or NULL for + * unterminated regexps. + */ +static char * +scan_separators (char *name) +{ + char sep = name[0]; + char *copyto = name; + bool quoted = false; + + for (++name; *name != '\0'; ++name) + { + if (quoted) + { + switch (*name) + { + case 'a': *copyto++ = '\007'; break; /* BEL (bell) */ + case 'b': *copyto++ = '\b'; break; /* BS (back space) */ + case 'd': *copyto++ = 0177; break; /* DEL (delete) */ + case 'e': *copyto++ = 033; break; /* ESC (delete) */ + case 'f': *copyto++ = '\f'; break; /* FF (form feed) */ + case 'n': *copyto++ = '\n'; break; /* NL (new line) */ + case 'r': *copyto++ = '\r'; break; /* CR (carriage return) */ + case 't': *copyto++ = '\t'; break; /* TAB (horizontal tab) */ + case 'v': *copyto++ = '\v'; break; /* VT (vertical tab) */ + default: + if (*name == sep) + *copyto++ = sep; + else + { + /* Something else is quoted, so preserve the quote. */ + *copyto++ = '\\'; + *copyto++ = *name; + } + break; + } + quoted = false; + } + else if (*name == '\\') + quoted = true; + else if (*name == sep) + break; + else + *copyto++ = *name; + } + if (*name != sep) + name = NULL; /* signal unterminated regexp */ + + /* Terminate copied string. */ + *copyto = '\0'; + return name; +} + +/* Look at the argument of --regex or --no-regex and do the right + thing. Same for each line of a regexp file. */ +static void +analyze_regex (char *regex_arg) +{ + if (regex_arg == NULL) + { + free_regexps (); /* --no-regex: remove existing regexps */ + return; + } + + /* A real --regexp option or a line in a regexp file. */ + switch (regex_arg[0]) + { + /* Comments in regexp file or null arg to --regex. */ + case '\0': + case ' ': + case '\t': + break; + + /* Read a regex file. This is recursive and may result in a + loop, which will stop when the file descriptors are exhausted. */ + case '@': + { + FILE *regexfp; + linebuffer regexbuf; + char *regexfile = regex_arg + 1; + + /* regexfile is a file containing regexps, one per line. */ + regexfp = fopen (regexfile, "r" FOPEN_BINARY); + if (regexfp == NULL) + pfatal (regexfile); + linebuffer_init (®exbuf); + while (readline_internal (®exbuf, regexfp) > 0) + analyze_regex (regexbuf.buffer); + free (regexbuf.buffer); + fclose (regexfp); + } + break; + + /* Regexp to be used for a specific language only. */ + case '{': + { + language *lang; + char *lang_name = regex_arg + 1; + char *cp; + + for (cp = lang_name; *cp != '}'; cp++) + if (*cp == '\0') + { + error ("unterminated language name in regex: %s", regex_arg); + return; + } + *cp++ = '\0'; + lang = get_language_from_langname (lang_name); + if (lang == NULL) + return; + add_regex (cp, lang); + } + break; + + /* Regexp to be used for any language. */ + default: + add_regex (regex_arg, NULL); + break; + } +} + +/* Separate the regexp pattern, compile it, + and care for optional name and modifiers. */ +static void +add_regex (char *regexp_pattern, language *lang) +{ + static struct re_pattern_buffer zeropattern; + char sep, *pat, *name, *modifiers; + char empty = '\0'; + const char *err; + struct re_pattern_buffer *patbuf; + regexp *rp; + bool + force_explicit_name = true, /* do not use implicit tag names */ + ignore_case = false, /* case is significant */ + multi_line = false, /* matches are done one line at a time */ + single_line = false; /* dot does not match newline */ + + + if (strlen (regexp_pattern) < 3) + { + error ("null regexp"); + return; + } + sep = regexp_pattern[0]; + name = scan_separators (regexp_pattern); + if (name == NULL) + { + error ("%s: unterminated regexp", regexp_pattern); + return; + } + if (name[1] == sep) + { + error ("null name for regexp \"%s\"", regexp_pattern); + return; + } + modifiers = scan_separators (name); + if (modifiers == NULL) /* no terminating separator --> no name */ + { + modifiers = name; + name = ∅ + } + else + modifiers += 1; /* skip separator */ + + /* Parse regex modifiers. */ + for (; modifiers[0] != '\0'; modifiers++) + switch (modifiers[0]) + { + case 'N': + if (modifiers == name) + error ("forcing explicit tag name but no name, ignoring"); + force_explicit_name = true; + break; + case 'i': + ignore_case = true; + break; + case 's': + single_line = true; + /* FALLTHRU */ + case 'm': + multi_line = true; + need_filebuf = true; + break; + default: + error ("invalid regexp modifier `%c', ignoring", modifiers[0]); + break; + } + + patbuf = xnew (1, struct re_pattern_buffer); + *patbuf = zeropattern; + if (ignore_case) + { + static char lc_trans[CHARS]; + int i; + for (i = 0; i < CHARS; i++) + lc_trans[i] = lowcase (i); + patbuf->translate = lc_trans; /* translation table to fold case */ + } + + if (multi_line) + pat = concat ("^", regexp_pattern, ""); /* anchor to beginning of line */ + else + pat = regexp_pattern; + + if (single_line) + re_set_syntax (RE_SYNTAX_EMACS | RE_DOT_NEWLINE); + else + re_set_syntax (RE_SYNTAX_EMACS); + + err = re_compile_pattern (pat, strlen (pat), patbuf); + if (multi_line) + free (pat); + if (err != NULL) + { + error ("%s while compiling pattern", err); + return; + } + + rp = p_head; + p_head = xnew (1, regexp); + p_head->pattern = savestr (regexp_pattern); + p_head->p_next = rp; + p_head->lang = lang; + p_head->pat = patbuf; + p_head->name = savestr (name); + p_head->error_signaled = false; + p_head->force_explicit_name = force_explicit_name; + p_head->ignore_case = ignore_case; + p_head->multi_line = multi_line; +} + +/* + * Do the substitutions indicated by the regular expression and + * arguments. + */ +static char * +substitute (char *in, char *out, struct re_registers *regs) +{ + char *result, *t; + int size, dig, diglen; + + result = NULL; + size = strlen (out); + + /* Pass 1: figure out how much to allocate by finding all \N strings. */ + if (out[size - 1] == '\\') + fatal ("pattern error in \"%s\"", out); + for (t = strchr (out, '\\'); + t != NULL; + t = strchr (t + 2, '\\')) + if (ISDIGIT (t[1])) + { + dig = t[1] - '0'; + diglen = regs->end[dig] - regs->start[dig]; + size += diglen - 2; + } + else + size -= 1; + + /* Allocate space and do the substitutions. */ + assert (size >= 0); + result = xnew (size + 1, char); + + for (t = result; *out != '\0'; out++) + if (*out == '\\' && ISDIGIT (*++out)) + { + dig = *out - '0'; + diglen = regs->end[dig] - regs->start[dig]; + memcpy (t, in + regs->start[dig], diglen); + t += diglen; + } + else + *t++ = *out; + *t = '\0'; + + assert (t <= result + size); + assert (t - result == (int)strlen (result)); + + return result; +} + +/* Deallocate all regexps. */ +static void +free_regexps (void) +{ + regexp *rp; + while (p_head != NULL) + { + rp = p_head->p_next; + free (p_head->pattern); + free (p_head->name); + free (p_head); + p_head = rp; + } + return; +} + +/* + * Reads the whole file as a single string from `filebuf' and looks for + * multi-line regular expressions, creating tags on matches. + * readline already dealt with normal regexps. + * + * Idea by Ben Wing <ben@666.com> (2002). + */ +static void +regex_tag_multiline (void) +{ + char *buffer = filebuf.buffer; + regexp *rp; + char *name; + + for (rp = p_head; rp != NULL; rp = rp->p_next) + { + int match = 0; + + if (!rp->multi_line) + continue; /* skip normal regexps */ + + /* Generic initializations before parsing file from memory. */ + lineno = 1; /* reset global line number */ + charno = 0; /* reset global char number */ + linecharno = 0; /* reset global char number of line start */ + + /* Only use generic regexps or those for the current language. */ + if (rp->lang != NULL && rp->lang != curfdp->lang) + continue; + + while (match >= 0 && match < filebuf.len) + { + match = re_search (rp->pat, buffer, filebuf.len, charno, + filebuf.len - match, &rp->regs); + switch (match) + { + case -2: + /* Some error. */ + if (!rp->error_signaled) + { + error ("regexp stack overflow while matching \"%s\"", + rp->pattern); + rp->error_signaled = true; + } + break; + case -1: + /* No match. */ + break; + default: + if (match == rp->regs.end[0]) + { + if (!rp->error_signaled) + { + error ("regexp matches the empty string: \"%s\"", + rp->pattern); + rp->error_signaled = true; + } + match = -3; /* exit from while loop */ + break; + } + + /* Match occurred. Construct a tag. */ + while (charno < rp->regs.end[0]) + if (buffer[charno++] == '\n') + lineno++, linecharno = charno; + name = rp->name; + if (name[0] == '\0') + name = NULL; + else /* make a named tag */ + name = substitute (buffer, rp->name, &rp->regs); + if (rp->force_explicit_name) + /* Force explicit tag name, if a name is there. */ + pfnote (name, true, buffer + linecharno, + charno - linecharno + 1, lineno, linecharno); + else + make_tag (name, strlen (name), true, buffer + linecharno, + charno - linecharno + 1, lineno, linecharno); + break; + } + } + } +} + + +static bool +nocase_tail (const char *cp) +{ + register int len = 0; + + while (*cp != '\0' && lowcase (*cp) == lowcase (dbp[len])) + cp++, len++; + if (*cp == '\0' && !intoken (dbp[len])) + { + dbp += len; + return true; + } + return false; +} + +static void +get_tag (register char *bp, char **namepp) +{ + register char *cp = bp; + + if (*bp != '\0') + { + /* Go till you get to white space or a syntactic break */ + for (cp = bp + 1; !notinname (*cp); cp++) + continue; + make_tag (bp, cp - bp, true, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + } + + if (namepp != NULL) + *namepp = savenstr (bp, cp - bp); +} + +/* + * Read a line of text from `stream' into `lbp', excluding the + * newline or CR-NL, if any. Return the number of characters read from + * `stream', which is the length of the line including the newline. + * + * On DOS or Windows we do not count the CR character, if any before the + * NL, in the returned length; this mirrors the behavior of Emacs on those + * platforms (for text files, it translates CR-NL to NL as it reads in the + * file). + * + * If multi-line regular expressions are requested, each line read is + * appended to `filebuf'. + */ +static long +readline_internal (linebuffer *lbp, register FILE *stream) +{ + char *buffer = lbp->buffer; + register char *p = lbp->buffer; + register char *pend; + int chars_deleted; + + pend = p + lbp->size; /* Separate to avoid 386/IX compiler bug. */ + + for (;;) + { + register int c = getc (stream); + if (p == pend) + { + /* We're at the end of linebuffer: expand it. */ + lbp->size *= 2; + xrnew (buffer, lbp->size, char); + p += buffer - lbp->buffer; + pend = buffer + lbp->size; + lbp->buffer = buffer; + } + if (c == EOF) + { + *p = '\0'; + chars_deleted = 0; + break; + } + if (c == '\n') + { + if (p > buffer && p[-1] == '\r') + { + p -= 1; +#ifdef DOS_NT + /* Assume CRLF->LF translation will be performed by Emacs + when loading this file, so CRs won't appear in the buffer. + It would be cleaner to compensate within Emacs; + however, Emacs does not know how many CRs were deleted + before any given point in the file. */ + chars_deleted = 1; +#else + chars_deleted = 2; +#endif + } + else + { + chars_deleted = 1; + } + *p = '\0'; + break; + } + *p++ = c; + } + lbp->len = p - buffer; + + if (need_filebuf /* we need filebuf for multi-line regexps */ + && chars_deleted > 0) /* not at EOF */ + { + while (filebuf.size <= filebuf.len + lbp->len + 1) /* +1 for \n */ + { + /* Expand filebuf. */ + filebuf.size *= 2; + xrnew (filebuf.buffer, filebuf.size, char); + } + memcpy (filebuf.buffer + filebuf.len, lbp->buffer, lbp->len); + filebuf.len += lbp->len; + filebuf.buffer[filebuf.len++] = '\n'; + filebuf.buffer[filebuf.len] = '\0'; + } + + return lbp->len + chars_deleted; +} + +/* + * Like readline_internal, above, but in addition try to match the + * input line against relevant regular expressions and manage #line + * directives. + */ +static void +readline (linebuffer *lbp, FILE *stream) +{ + long result; + + linecharno = charno; /* update global char number of line start */ + result = readline_internal (lbp, stream); /* read line */ + lineno += 1; /* increment global line number */ + charno += result; /* increment global char number */ + + /* Honor #line directives. */ + if (!no_line_directive) + { + static bool discard_until_line_directive; + + /* Check whether this is a #line directive. */ + if (result > 12 && strneq (lbp->buffer, "#line ", 6)) + { + unsigned int lno; + int start = 0; + + if (sscanf (lbp->buffer, "#line %u \"%n", &lno, &start) >= 1 + && start > 0) /* double quote character found */ + { + char *endp = lbp->buffer + start; + + while ((endp = strchr (endp, '"')) != NULL + && endp[-1] == '\\') + endp++; + if (endp != NULL) + /* Ok, this is a real #line directive. Let's deal with it. */ + { + char *taggedabsname; /* absolute name of original file */ + char *taggedfname; /* name of original file as given */ + char *name; /* temp var */ + + discard_until_line_directive = false; /* found it */ + name = lbp->buffer + start; + *endp = '\0'; + canonicalize_filename (name); + taggedabsname = absolute_filename (name, tagfiledir); + if (filename_is_absolute (name) + || filename_is_absolute (curfdp->infname)) + taggedfname = savestr (taggedabsname); + else + taggedfname = relative_filename (taggedabsname,tagfiledir); + + if (streq (curfdp->taggedfname, taggedfname)) + /* The #line directive is only a line number change. We + deal with this afterwards. */ + free (taggedfname); + else + /* The tags following this #line directive should be + attributed to taggedfname. In order to do this, set + curfdp accordingly. */ + { + fdesc *fdp; /* file description pointer */ + + /* Go look for a file description already set up for the + file indicated in the #line directive. If there is + one, use it from now until the next #line + directive. */ + for (fdp = fdhead; fdp != NULL; fdp = fdp->next) + if (streq (fdp->infname, curfdp->infname) + && streq (fdp->taggedfname, taggedfname)) + /* If we remove the second test above (after the &&) + then all entries pertaining to the same file are + coalesced in the tags file. If we use it, then + entries pertaining to the same file but generated + from different files (via #line directives) will + go into separate sections in the tags file. These + alternatives look equivalent. The first one + destroys some apparently useless information. */ + { + curfdp = fdp; + free (taggedfname); + break; + } + /* Else, if we already tagged the real file, skip all + input lines until the next #line directive. */ + if (fdp == NULL) /* not found */ + for (fdp = fdhead; fdp != NULL; fdp = fdp->next) + if (streq (fdp->infabsname, taggedabsname)) + { + discard_until_line_directive = true; + free (taggedfname); + break; + } + /* Else create a new file description and use that from + now on, until the next #line directive. */ + if (fdp == NULL) /* not found */ + { + fdp = fdhead; + fdhead = xnew (1, fdesc); + *fdhead = *curfdp; /* copy curr. file description */ + fdhead->next = fdp; + fdhead->infname = savestr (curfdp->infname); + fdhead->infabsname = savestr (curfdp->infabsname); + fdhead->infabsdir = savestr (curfdp->infabsdir); + fdhead->taggedfname = taggedfname; + fdhead->usecharno = false; + fdhead->prop = NULL; + fdhead->written = false; + curfdp = fdhead; + } + } + free (taggedabsname); + lineno = lno - 1; + readline (lbp, stream); + return; + } /* if a real #line directive */ + } /* if #line is followed by a number */ + } /* if line begins with "#line " */ + + /* If we are here, no #line directive was found. */ + if (discard_until_line_directive) + { + if (result > 0) + { + /* Do a tail recursion on ourselves, thus discarding the contents + of the line buffer. */ + readline (lbp, stream); + return; + } + /* End of file. */ + discard_until_line_directive = false; + return; + } + } /* if #line directives should be considered */ + + { + int match; + regexp *rp; + char *name; + + /* Match against relevant regexps. */ + if (lbp->len > 0) + for (rp = p_head; rp != NULL; rp = rp->p_next) + { + /* Only use generic regexps or those for the current language. + Also do not use multiline regexps, which is the job of + regex_tag_multiline. */ + if ((rp->lang != NULL && rp->lang != fdhead->lang) + || rp->multi_line) + continue; + + match = re_match (rp->pat, lbp->buffer, lbp->len, 0, &rp->regs); + switch (match) + { + case -2: + /* Some error. */ + if (!rp->error_signaled) + { + error ("regexp stack overflow while matching \"%s\"", + rp->pattern); + rp->error_signaled = true; + } + break; + case -1: + /* No match. */ + break; + case 0: + /* Empty string matched. */ + if (!rp->error_signaled) + { + error ("regexp matches the empty string: \"%s\"", rp->pattern); + rp->error_signaled = true; + } + break; + default: + /* Match occurred. Construct a tag. */ + name = rp->name; + if (name[0] == '\0') + name = NULL; + else /* make a named tag */ + name = substitute (lbp->buffer, rp->name, &rp->regs); + if (rp->force_explicit_name) + /* Force explicit tag name, if a name is there. */ + pfnote (name, true, lbp->buffer, match, lineno, linecharno); + else + make_tag (name, strlen (name), true, + lbp->buffer, match, lineno, linecharno); + break; + } + } + } +} + + +/* + * Return a pointer to a space of size strlen(cp)+1 allocated + * with xnew where the string CP has been copied. + */ +static char * +savestr (const char *cp) +{ + return savenstr (cp, strlen (cp)); +} + +/* + * Return a pointer to a space of size LEN+1 allocated with xnew where + * the string CP has been copied for at most the first LEN characters. + */ +static char * +savenstr (const char *cp, int len) +{ + char *dp = xnew (len + 1, char); + dp[len] = '\0'; + return memcpy (dp, cp, len); +} + +/* Skip spaces (end of string is not space), return new pointer. */ +static char * +skip_spaces (char *cp) +{ + while (iswhite (*cp)) + cp++; + return cp; +} + +/* Skip non spaces, except end of string, return new pointer. */ +static char * +skip_non_spaces (char *cp) +{ + while (*cp != '\0' && !iswhite (*cp)) + cp++; + return cp; +} + +/* Skip any chars in the "name" class.*/ +static char * +skip_name (char *cp) +{ + /* '\0' is a notinname() so loop stops there too */ + while (! notinname (*cp)) + cp++; + return cp; +} + +/* Print error message and exit. */ +void +fatal (const char *s1, const char *s2) +{ + error (s1, s2); + exit (EXIT_FAILURE); +} + +static void +pfatal (const char *s1) +{ + perror (s1); + exit (EXIT_FAILURE); +} + +static void +suggest_asking_for_help (void) +{ + fprintf (stderr, "\tTry `%s --help' for a complete list of options.\n", + progname); + exit (EXIT_FAILURE); +} + +/* Output a diagnostic with printf-style FORMAT and args. */ +static void +error (const char *format, ...) +{ + va_list ap; + va_start (ap, format); + fprintf (stderr, "%s: ", progname); + vfprintf (stderr, format, ap); + fprintf (stderr, "\n"); + va_end (ap); +} + +/* Return a newly-allocated string whose contents + concatenate those of s1, s2, s3. */ +static char * +concat (const char *s1, const char *s2, const char *s3) +{ + int len1 = strlen (s1), len2 = strlen (s2), len3 = strlen (s3); + char *result = xnew (len1 + len2 + len3 + 1, char); + + strcpy (result, s1); + strcpy (result + len1, s2); + strcpy (result + len1 + len2, s3); + + return result; +} + + +/* Does the same work as the system V getcwd, but does not need to + guess the buffer size in advance. */ +static char * +etags_getcwd (void) +{ + int bufsize = 200; + char *path = xnew (bufsize, char); + + while (getcwd (path, bufsize) == NULL) + { + if (errno != ERANGE) + pfatal ("getcwd"); + bufsize *= 2; + free (path); + path = xnew (bufsize, char); + } + + canonicalize_filename (path); + return path; +} + +/* Return a newly allocated string containing the file name of FILE + relative to the absolute directory DIR (which should end with a slash). */ +static char * +relative_filename (char *file, char *dir) +{ + char *fp, *dp, *afn, *res; + int i; + + /* Find the common root of file and dir (with a trailing slash). */ + afn = absolute_filename (file, cwd); + fp = afn; + dp = dir; + while (*fp++ == *dp++) + continue; + fp--, dp--; /* back to the first differing char */ +#ifdef DOS_NT + if (fp == afn && afn[0] != '/') /* cannot build a relative name */ + return afn; +#endif + do /* look at the equal chars until '/' */ + fp--, dp--; + while (*fp != '/'); + + /* Build a sequence of "../" strings for the resulting relative file name. */ + i = 0; + while ((dp = strchr (dp + 1, '/')) != NULL) + i += 1; + res = xnew (3*i + strlen (fp + 1) + 1, char); + char *z = res; + while (i-- > 0) + z = stpcpy (z, "../"); + + /* Add the file name relative to the common root of file and dir. */ + strcpy (z, fp + 1); + free (afn); + + return res; +} + +/* Return a newly allocated string containing the absolute file name + of FILE given DIR (which should end with a slash). */ +static char * +absolute_filename (char *file, char *dir) +{ + char *slashp, *cp, *res; + + if (filename_is_absolute (file)) + res = savestr (file); +#ifdef DOS_NT + /* We don't support non-absolute file names with a drive + letter, like `d:NAME' (it's too much hassle). */ + else if (file[1] == ':') + fatal ("%s: relative file names with drive letters not supported", file); +#endif + else + res = concat (dir, file, ""); + + /* Delete the "/dirname/.." and "/." substrings. */ + slashp = strchr (res, '/'); + while (slashp != NULL && slashp[0] != '\0') + { + if (slashp[1] == '.') + { + if (slashp[2] == '.' + && (slashp[3] == '/' || slashp[3] == '\0')) + { + cp = slashp; + do + cp--; + while (cp >= res && !filename_is_absolute (cp)); + if (cp < res) + cp = slashp; /* the absolute name begins with "/.." */ +#ifdef DOS_NT + /* Under MSDOS and NT we get `d:/NAME' as absolute + file name, so the luser could say `d:/../NAME'. + We silently treat this as `d:/NAME'. */ + else if (cp[0] != '/') + cp = slashp; +#endif + memmove (cp, slashp + 3, strlen (slashp + 2)); + slashp = cp; + continue; + } + else if (slashp[2] == '/' || slashp[2] == '\0') + { + memmove (slashp, slashp + 2, strlen (slashp + 1)); + continue; + } + } + + slashp = strchr (slashp + 1, '/'); + } + + if (res[0] == '\0') /* just a safety net: should never happen */ + { + free (res); + return savestr ("/"); + } + else + return res; +} + +/* Return a newly allocated string containing the absolute + file name of dir where FILE resides given DIR (which should + end with a slash). */ +static char * +absolute_dirname (char *file, char *dir) +{ + char *slashp, *res; + char save; + + slashp = strrchr (file, '/'); + if (slashp == NULL) + return savestr (dir); + save = slashp[1]; + slashp[1] = '\0'; + res = absolute_filename (file, dir); + slashp[1] = save; + + return res; +} + +/* Whether the argument string is an absolute file name. The argument + string must have been canonicalized with canonicalize_filename. */ +static bool +filename_is_absolute (char *fn) +{ + return (fn[0] == '/' +#ifdef DOS_NT + || (ISALPHA (fn[0]) && fn[1] == ':' && fn[2] == '/') +#endif + ); +} + +/* Downcase DOS drive letter and collapse separators into single slashes. + Works in place. */ +static void +canonicalize_filename (register char *fn) +{ + register char* cp; + char sep = '/'; + +#ifdef DOS_NT + /* Canonicalize drive letter case. */ +# define ISUPPER(c) isupper (CHAR (c)) + if (fn[0] != '\0' && fn[1] == ':' && ISUPPER (fn[0])) + fn[0] = lowcase (fn[0]); + + sep = '\\'; +#endif + + /* Collapse multiple separators into a single slash. */ + for (cp = fn; *cp != '\0'; cp++, fn++) + if (*cp == sep) + { + *fn = '/'; + while (cp[1] == sep) + cp++; + } + else + *fn = *cp; + *fn = '\0'; +} + + +/* Initialize a linebuffer for use. */ +static void +linebuffer_init (linebuffer *lbp) +{ + lbp->size = (DEBUG) ? 3 : 200; + lbp->buffer = xnew (lbp->size, char); + lbp->buffer[0] = '\0'; + lbp->len = 0; +} + +/* Set the minimum size of a string contained in a linebuffer. */ +static void +linebuffer_setlen (linebuffer *lbp, int toksize) +{ + while (lbp->size <= toksize) + { + lbp->size *= 2; + xrnew (lbp->buffer, lbp->size, char); + } + lbp->len = toksize; +} + +/* Like malloc but get fatal error if memory is exhausted. */ +static void * +xmalloc (size_t size) +{ + void *result = malloc (size); + if (result == NULL) + fatal ("virtual memory exhausted", (char *)NULL); + return result; +} + +static void * +xrealloc (void *ptr, size_t size) +{ + void *result = realloc (ptr, size); + if (result == NULL) + fatal ("virtual memory exhausted", (char *)NULL); + return result; +} + +/* + * Local Variables: + * indent-tabs-mode: t + * tab-width: 8 + * fill-column: 79 + * c-font-lock-extra-types: ("FILE" "bool" "language" "linebuffer" "fdesc" "node" "regexp") + * c-file-style: "gnu" + * End: + */ + +/* etags.c ends here */ diff --cc test/manual/etags/c-src/exit.c index b8cd22ba3c7,00000000000..86afda9ed01 mode 100644,000000..100644 --- a/test/manual/etags/c-src/exit.c +++ b/test/manual/etags/c-src/exit.c @@@ -1,77 -1,0 +1,77 @@@ - /* Copyright (C) 1991 Free Software Foundation, Inc. ++/* Copyright (C) 1991, 2016 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +The GNU C Library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with the GNU C Library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#include <ansidecl.h> +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> +#include "exit.h" + +#ifdef HAVE_GNU_LD +CONST struct + { + size_t n; + void EXFUN((*fn[1]), (NOARGS)); + } __libc_atexit; +#endif + +/* Call all functions registered with `atexit' and `on_exit', + in the reverse of the order in which they were registered + perform stdio cleanup, and terminate program execution with STATUS. */ +__NORETURN +void +DEFUN(exit, (status), int status) +{ + register CONST struct exit_function_list *l; + + for (l = __exit_funcs; l != NULL; l = l->next) + { + register size_t i = l->idx; + while (i-- > 0) + { + CONST struct exit_function *CONST f = &l->fns[i]; + switch (f->flavor) + { + case ef_free: + break; + case ef_on: + (*f->func.on.fn)(status, f->func.on.arg); + break; + case ef_at: + (*f->func.at)(); + break; + } + } + } + +#ifdef HAVE_GNU_LD + { + void EXFUN((*CONST *fn), (NOARGS)); + for (fn = __libc_atexit.fn; *fn != NULL; ++fn) + (**fn) (); + } +#else + { + extern void EXFUN(_cleanup, (NOARGS)); + _cleanup(); + } +#endif + + _exit(status); +} + diff --cc test/manual/etags/c-src/exit.strange_suffix index b8cd22ba3c7,00000000000..86afda9ed01 mode 100644,000000..100644 --- a/test/manual/etags/c-src/exit.strange_suffix +++ b/test/manual/etags/c-src/exit.strange_suffix @@@ -1,77 -1,0 +1,77 @@@ - /* Copyright (C) 1991 Free Software Foundation, Inc. ++/* Copyright (C) 1991, 2016 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +The GNU C Library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with the GNU C Library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#include <ansidecl.h> +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> +#include "exit.h" + +#ifdef HAVE_GNU_LD +CONST struct + { + size_t n; + void EXFUN((*fn[1]), (NOARGS)); + } __libc_atexit; +#endif + +/* Call all functions registered with `atexit' and `on_exit', + in the reverse of the order in which they were registered + perform stdio cleanup, and terminate program execution with STATUS. */ +__NORETURN +void +DEFUN(exit, (status), int status) +{ + register CONST struct exit_function_list *l; + + for (l = __exit_funcs; l != NULL; l = l->next) + { + register size_t i = l->idx; + while (i-- > 0) + { + CONST struct exit_function *CONST f = &l->fns[i]; + switch (f->flavor) + { + case ef_free: + break; + case ef_on: + (*f->func.on.fn)(status, f->func.on.arg); + break; + case ef_at: + (*f->func.at)(); + break; + } + } + } + +#ifdef HAVE_GNU_LD + { + void EXFUN((*CONST *fn), (NOARGS)); + for (fn = __libc_atexit.fn; *fn != NULL; ++fn) + (**fn) (); + } +#else + { + extern void EXFUN(_cleanup, (NOARGS)); + _cleanup(); + } +#endif + + _exit(status); +} + diff --cc test/manual/etags/c-src/getopt.h index 93a5cf77816,00000000000..aa2eb1dc173 mode 100644,000000..100644 --- a/test/manual/etags/c-src/getopt.h +++ b/test/manual/etags/c-src/getopt.h @@@ -1,125 -1,0 +1,125 @@@ +/* Declarations for getopt. - Copyright (C) 1989, 1990, 1991, 1992 Free Software Foundation, Inc. ++ Copyright (C) 1989-1992, 2016 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by the + Free Software Foundation; either version 2, or (at your option) any + later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifndef _GETOPT_H +#define _GETOPT_H 1 + +#ifdef __cplusplus +extern "C" { +#endif + +/* For communication from `getopt' to the caller. + When `getopt' finds an option that takes an argument, + the argument value is returned here. + Also, when `ordering' is RETURN_IN_ORDER, + each non-option ARGV-element is returned here. */ + +extern char *optarg; + +/* Index in ARGV of the next element to be scanned. + This is used for communication to and from the caller + and for communication between successive calls to `getopt'. + + On entry to `getopt', zero means this is the first call; initialize. + + When `getopt' returns EOF, this is the index of the first of the + non-option elements that the caller should itself scan. + + Otherwise, `optind' communicates from one call to the next + how much of ARGV has been scanned so far. */ + +extern int optind; + +/* Callers store zero here to inhibit the error message `getopt' prints + for unrecognized options. */ + +extern int opterr; + +/* Describe the long-named options requested by the application. + The LONG_OPTIONS argument to getopt_long or getopt_long_only is a vector + of `struct option' terminated by an element containing a name which is + zero. + + The field `has_arg' is: + no_argument (or 0) if the option does not take an argument, + required_argument (or 1) if the option requires an argument, + optional_argument (or 2) if the option takes an optional argument. + + If the field `flag' is not NULL, it points to a variable that is set + to the value given in the field `val' when the option is found, but + left unchanged if the option is not found. + + To have a long-named option do something other than set an `int' to + a compiled-in constant, such as set a value from `optarg', set the + option's `flag' field to zero and its `val' field to a nonzero + value (the equivalent single-letter option character, if there is + one). For long options that have a zero `flag' field, `getopt' + returns the contents of the `val' field. */ + +struct option +{ +#if __STDC__ + const char *name; +#else + char *name; +#endif + /* has_arg can't be an enum because some compilers complain about + type mismatches in all the code that assumes it is an int. */ + int has_arg; + int *flag; + int val; +}; + +/* Names for the values of the `has_arg' field of `struct option'. */ + +#define no_argument 0 +#define required_argument 1 +#define optional_argument 2 + +#if __STDC__ +#if defined(__GNU_LIBRARY__) +/* Many other libraries have conflicting prototypes for getopt, with + differences in the consts, in stdlib.h. To avoid compilation + errors, only prototype getopt for the GNU C library. */ +extern int getopt (int argc, char *const *argv, const char *shortopts); +#else /* not __GNU_LIBRARY__ */ +extern int getopt (); +#endif /* not __GNU_LIBRARY__ */ +extern int getopt_long (int argc, char *const *argv, const char *shortopts, + const struct option *longopts, int *longind); +extern int getopt_long_only (int argc, char *const *argv, + const char *shortopts, + const struct option *longopts, int *longind); + +/* Internal only. Users should not call this directly. */ +extern int _getopt_internal (int argc, char *const *argv, + const char *shortopts, + const struct option *longopts, int *longind, + int long_only); +#else /* not __STDC__ */ +extern int getopt (); +extern int getopt_long (); +extern int getopt_long_only (); + +extern int _getopt_internal (); +#endif /* not __STDC__ */ + +#ifdef __cplusplus +} +#endif + +#endif /* _GETOPT_H */ diff --cc test/manual/etags/c-src/sysdep.h index 298a0e4c5b2,00000000000..6409fcc1e1d mode 100644,000000..100644 --- a/test/manual/etags/c-src/sysdep.h +++ b/test/manual/etags/c-src/sysdep.h @@@ -1,57 -1,0 +1,57 @@@ - /* Copyright (C) 1992, 1993 Free Software Foundation, Inc. ++/* Copyright (C) 1992-1993, 2016 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +The GNU C Library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with the GNU C Library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#include <sysdeps/unix/sysdep.h> + +#define ENTRY(name) \ + .globl _##name; \ + .align 2; \ + _##name##: + +#define PSEUDO(name, syscall_name, args) \ + .text; \ + .globl syscall_error; \ + ENTRY (name) \ + XCHG_##args + movl $SYS_##syscall_name, %eax; \ + int $0x80; \ + test %eax, %eax; \ + jl syscall_error; \ + XCHG_##args + +/* Linux takes system call arguments in registers: + 1: %ebx + 2: %ecx + 3: %edx + 4: %esi + 5: %edi + We put the arguments into registers from the stack, + and save the registers, by using the 386 `xchg' instruction + to swap the values in both directions. */ + +#define XCHG_0 /* No arguments to frob. */ +#define XCHG_1 xchg 8(%esp), %ebx; XCHG_0 +#define XCHG_2 xchg 12(%esp), %ecx; XCHG_1 +#define XCHG_3 xchg 16(%esp), %edx; XCHG_2 +#define XCHG_4 xchg 20(%esp), %esi; XCHG_3 +#define XCHG_5 xchg 24(%esp), %edi; XCHG_3 + +#define r0 %eax /* Normal return-value register. */ +#define r1 %edx /* Secondary return-value register. */ +#define scratch %ecx /* Call-clobbered register for random use. */ +#define MOVE(x,y) movl x, y diff --cc test/manual/etags/el-src/emacs/lisp/progmodes/etags.el index 4e079200ee0,00000000000..6c28ba35a4c mode 100644,000000..100644 --- a/test/manual/etags/el-src/emacs/lisp/progmodes/etags.el +++ b/test/manual/etags/el-src/emacs/lisp/progmodes/etags.el @@@ -1,2153 -1,0 +1,2153 @@@ +;;; etags.el --- etags facility for Emacs -*- lexical-binding: t -*- + - ;; Copyright (C) 1985-1986, 1988-1989, 1992-1996, 1998, 2000-2015 Free ++;; Copyright (C) 1985-1986, 1988-1989, 1992-1996, 1998, 2000-2016 Free +;; Software Foundation, Inc. + +;; Author: Roland McGrath <roland@gnu.org> +;; Maintainer: emacs-devel@gnu.org +;; Keywords: tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ring) +(require 'button) +(require 'xref) + +;;;###autoload +(defvar tags-file-name nil + "File name of tags table. +To switch to a new tags table, setting this variable is sufficient. +If you set this variable, do not also set `tags-table-list'. +Use the `etags' program to make a tags table file.") +;; Make M-x set-variable tags-file-name like M-x visit-tags-table. +;;;###autoload (put 'tags-file-name 'variable-interactive (purecopy "fVisit tags table: ")) +;;;###autoload (put 'tags-file-name 'safe-local-variable 'stringp) + +(defgroup etags nil "Tags tables." + :group 'tools) + +;;;###autoload +(defcustom tags-case-fold-search 'default + "Whether tags operations should be case-sensitive. +A value of t means case-insensitive, a value of nil means case-sensitive. +Any other value means use the setting of `case-fold-search'." + :group 'etags + :type '(choice (const :tag "Case-sensitive" nil) + (const :tag "Case-insensitive" t) + (other :tag "Use default" default)) + :version "21.1") + +;;;###autoload +;; Use `visit-tags-table-buffer' to cycle through tags tables in this list. +(defcustom tags-table-list nil + "List of file names of tags tables to search. +An element that is a directory means the file \"TAGS\" in that directory. +To switch to a new list of tags tables, setting this variable is sufficient. +If you set this variable, do not also set `tags-file-name'. +Use the `etags' program to make a tags table file." + :group 'etags + :type '(repeat file)) + +;;;###autoload +(defcustom tags-compression-info-list + (purecopy '("" ".Z" ".bz2" ".gz" ".xz" ".tgz")) + "List of extensions tried by etags when `auto-compression-mode' is on. +An empty string means search the non-compressed file." + :version "24.1" ; added xz + :type '(repeat string) + :group 'etags) + +;; !!! tags-compression-info-list should probably be replaced by access +;; to directory list and matching jka-compr-compression-info-list. Currently, +;; this implementation forces each modification of +;; jka-compr-compression-info-list to be reflected in this var. +;; An alternative could be to say that introducing a special +;; element in this list (e.g. t) means : try at this point +;; using directory listing and regexp matching using +;; jka-compr-compression-info-list. + + +;;;###autoload +(defcustom tags-add-tables 'ask-user + "Control whether to add a new tags table to the current list. +t means do; nil means don't (always start a new list). +Any other value means ask the user whether to add a new tags table +to the current list (as opposed to starting a new list)." + :group 'etags + :type '(choice (const :tag "Do" t) + (const :tag "Don't" nil) + (other :tag "Ask" ask-user))) + +(defcustom tags-revert-without-query nil + "Non-nil means reread a TAGS table without querying, if it has changed." + :group 'etags + :type 'boolean) + +(defvar tags-table-computed-list nil + "List of tags tables to search, computed from `tags-table-list'. +This includes tables implicitly included by other tables. The list is not +always complete: the included tables of a table are not known until that +table is read into core. An element that is t is a placeholder +indicating that the preceding element is a table that has not been read +into core and might contain included tables to search. +See `tags-table-check-computed-list'.") + +(defvar tags-table-computed-list-for nil + "Value of `tags-table-list' that `tags-table-computed-list' corresponds to. +If `tags-table-list' changes, `tags-table-computed-list' is thrown away and +recomputed; see `tags-table-check-computed-list'.") + +(defvar tags-table-list-pointer nil + "Pointer into `tags-table-computed-list' for the current state of searching. +Use `visit-tags-table-buffer' to cycle through tags tables in this list.") + +(defvar tags-table-list-started-at nil + "Pointer into `tags-table-computed-list', where the current search started.") + +(defvar tags-table-set-list nil + "List of sets of tags table which have been used together in the past. +Each element is a list of strings which are file names.") + +;;;###autoload +(defcustom find-tag-hook nil + "Hook to be run by \\[find-tag] after finding a tag. See `run-hooks'. +The value in the buffer in which \\[find-tag] is done is used, +not the value in the buffer \\[find-tag] goes to." + :group 'etags + :type 'hook) + +;;;###autoload +(defcustom find-tag-default-function nil + "A function of no arguments used by \\[find-tag] to pick a default tag. +If nil, and the symbol that is the value of `major-mode' +has a `find-tag-default-function' property (see `put'), that is used. +Otherwise, `find-tag-default' is used." + :group 'etags + :type '(choice (const nil) function)) + +(define-obsolete-variable-alias 'find-tag-marker-ring-length + 'xref-marker-ring-length "25.1") + +(defcustom tags-tag-face 'default + "Face for tags in the output of `tags-apropos'." + :group 'etags + :type 'face + :version "21.1") + +(defcustom tags-apropos-verbose nil + "If non-nil, print the name of the tags file in the *Tags List* buffer." + :group 'etags + :type 'boolean + :version "21.1") + +(defcustom tags-apropos-additional-actions nil + "Specify additional actions for `tags-apropos'. + +If non-nil, value should be a list of triples (TITLE FUNCTION +TO-SEARCH). For each triple, `tags-apropos' processes TO-SEARCH and +lists tags from it. TO-SEARCH should be an alist, obarray, or symbol. +If it is a symbol, the symbol's value is used. +TITLE, a string, is a title used to label the additional list of tags. +FUNCTION is a function to call when a symbol is selected in the +*Tags List* buffer. It will be called with one argument SYMBOL which +is the symbol being selected. + +Example value: + + '((\"Emacs Lisp\" Info-goto-emacs-command-node obarray) + (\"Common Lisp\" common-lisp-hyperspec common-lisp-hyperspec-obarray) + (\"SCWM\" scwm-documentation scwm-obarray))" + :group 'etags + :type '(repeat (list (string :tag "Title") + function + (sexp :tag "Tags to search"))) + :version "21.1") + +(defvaralias 'find-tag-marker-ring 'xref--marker-ring) +(make-obsolete-variable + 'find-tag-marker-ring + "use `xref-push-marker-stack' or `xref-pop-marker-stack' instead." + "25.1") + +(defvar default-tags-table-function nil + "If non-nil, a function to choose a default tags file for a buffer. +This function receives no arguments and should return the default +tags table file to use for the current buffer.") + +(defvar tags-location-ring (make-ring xref-marker-ring-length) + "Ring of markers which are locations visited by \\[find-tag]. +Pop back to the last location with \\[negative-argument] \\[find-tag].") + +;; Tags table state. +;; These variables are local in tags table buffers. + +(defvar tags-table-files nil + "List of file names covered by current tags table. +nil means it has not yet been computed; +use function `tags-table-files' to do so.") + +(defvar tags-completion-table nil + "Obarray of tag names defined in current tags table.") + +(defvar tags-included-tables nil + "List of tags tables included by the current tags table.") + +(defvar next-file-list nil + "List of files for \\[next-file] to process.") + +;; Hooks for file formats. + +(defvar tags-table-format-functions '(etags-recognize-tags-table + tags-recognize-empty-tags-table) + "Hook to be called in a tags table buffer to identify the type of tags table. +The functions are called in order, with no arguments, +until one returns non-nil. The function should make buffer-local bindings +of the format-parsing tags function variables if successful.") + +(defvar file-of-tag-function nil + "Function to do the work of `file-of-tag' (which see). +One optional argument, a boolean specifying to return complete path (nil) or +relative path (non-nil).") +(defvar tags-table-files-function nil + "Function to do the work of function `tags-table-files' (which see).") +(defvar tags-completion-table-function nil + "Function to build the `tags-completion-table'.") +(defvar snarf-tag-function nil + "Function to get info about a matched tag for `goto-tag-location-function'. +One optional argument, specifying to use explicit tag (non-nil) or not (nil). +The default is nil.") +(defvar goto-tag-location-function nil + "Function of to go to the location in the buffer specified by a tag. +One argument, the tag info returned by `snarf-tag-function'.") +(defvar find-tag-regexp-search-function nil + "Search function passed to `find-tag-in-order' for finding a regexp tag.") +(defvar find-tag-regexp-tag-order nil + "Tag order passed to `find-tag-in-order' for finding a regexp tag.") +(defvar find-tag-regexp-next-line-after-failure-p nil + "Flag passed to `find-tag-in-order' for finding a regexp tag.") +(defvar find-tag-search-function nil + "Search function passed to `find-tag-in-order' for finding a tag.") +(defvar find-tag-tag-order nil + "Tag order passed to `find-tag-in-order' for finding a tag.") +(defvar find-tag-next-line-after-failure-p nil + "Flag passed to `find-tag-in-order' for finding a tag.") +(defvar list-tags-function nil + "Function to do the work of `list-tags' (which see).") +(defvar tags-apropos-function nil + "Function to do the work of `tags-apropos' (which see).") +(defvar tags-included-tables-function nil + "Function to do the work of function `tags-included-tables' (which see).") +(defvar verify-tags-table-function nil + "Function to return t if current buffer contains valid tags file.") + +(defun initialize-new-tags-table () + "Initialize the tags table in the current buffer. +Return non-nil if it is a valid tags table, and +in that case, also make the tags table state variables +buffer-local and set them to nil." + (set (make-local-variable 'tags-table-files) nil) + (set (make-local-variable 'tags-completion-table) nil) + (set (make-local-variable 'tags-included-tables) nil) + ;; We used to initialize find-tag-marker-ring and tags-location-ring + ;; here, to new empty rings. But that is wrong, because those + ;; are global. + + ;; Value is t if we have found a valid tags table buffer. + (run-hook-with-args-until-success 'tags-table-format-functions)) + +;;;###autoload +(defun tags-table-mode () + "Major mode for tags table file buffers." + (interactive) + (setq major-mode 'tags-table-mode ;FIXME: Use define-derived-mode. + mode-name "Tags Table" + buffer-undo-list t) + (initialize-new-tags-table)) + +;;;###autoload +(defun visit-tags-table (file &optional local) + "Tell tags commands to use tags table file FILE. +FILE should be the name of a file created with the `etags' program. +A directory name is ok too; it means file TAGS in that directory. + +Normally \\[visit-tags-table] sets the global value of `tags-file-name'. +With a prefix arg, set the buffer-local value instead. +When you find a tag with \\[find-tag], the buffer it finds the tag +in is given a local value of this variable which is the name of the tags +file the tag was in." + (interactive (list (read-file-name "Visit tags table (default TAGS): " + default-directory + (expand-file-name "TAGS" + default-directory) + t) + current-prefix-arg)) + (or (stringp file) (signal 'wrong-type-argument (list 'stringp file))) + ;; Bind tags-file-name so we can control below whether the local or + ;; global value gets set. + ;; Calling visit-tags-table-buffer with tags-file-name set to FILE will + ;; initialize a buffer for FILE and set tags-file-name to the + ;; fully-expanded name. + (let ((tags-file-name file)) + (save-excursion + (or (visit-tags-table-buffer file) + (signal 'file-error (list "Visiting tags table" + "No such file or directory" + file))) + ;; Set FILE to the expanded name. + (setq file tags-file-name))) + (if local + ;; Set the local value of tags-file-name. + (set (make-local-variable 'tags-file-name) file) + ;; Set the global value of tags-file-name. + (setq-default tags-file-name file))) + +(defun tags-table-check-computed-list () + "Compute `tags-table-computed-list' from `tags-table-list' if necessary." + (let ((expanded-list (mapcar 'tags-expand-table-name tags-table-list))) + (or (equal tags-table-computed-list-for expanded-list) + ;; The list (or default-directory) has changed since last computed. + (let* ((compute-for (mapcar 'copy-sequence expanded-list)) + (tables (copy-sequence compute-for)) ;Mutated in the loop. + (computed nil) + table-buffer) + + (while tables + (setq computed (cons (car tables) computed) + table-buffer (get-file-buffer (car tables))) + (if (and table-buffer + ;; There is a buffer visiting the file. Now make sure + ;; it is initialized as a tag table buffer. + (save-excursion + (tags-verify-table (buffer-file-name table-buffer)))) + (with-current-buffer table-buffer + ;; Needed so long as etags-tags-included-tables + ;; does not save-excursion. + (save-excursion + (if (tags-included-tables) + ;; Insert the included tables into the list we + ;; are processing. + (setcdr tables (nconc (mapcar 'tags-expand-table-name + (tags-included-tables)) + (cdr tables)))))) + ;; This table is not in core yet. Insert a placeholder + ;; saying we must read it into core to check for included + ;; tables before searching the next table in the list. + (setq computed (cons t computed))) + (setq tables (cdr tables))) + + ;; Record the tags-table-list value (and the context of the + ;; current directory) we computed from. + (setq tags-table-computed-list-for compute-for + tags-table-computed-list (nreverse computed)))))) + +(defun tags-table-extend-computed-list () + "Extend `tags-table-computed-list' to remove the first t placeholder. + +An element of the list that is t is a placeholder indicating that the +preceding element is a table that has not been read in and might +contain included tables to search. This function reads in the first +such table and puts its included tables into the list." + (let ((list tags-table-computed-list)) + (while (not (eq (nth 1 list) t)) + (setq list (cdr list))) + (save-excursion + (if (tags-verify-table (car list)) + ;; We are now in the buffer visiting (car LIST). Extract its + ;; list of included tables and insert it into the computed list. + (let ((tables (tags-included-tables)) + (computed nil) + table-buffer) + (while tables + (setq computed (cons (car tables) computed) + table-buffer (get-file-buffer (car tables))) + (if table-buffer + (with-current-buffer table-buffer + (if (tags-included-tables) + ;; Insert the included tables into the list we + ;; are processing. + (setcdr tables (append (tags-included-tables) + tables)))) + ;; This table is not in core yet. Insert a placeholder + ;; saying we must read it into core to check for included + ;; tables before searching the next table in the list. + (setq computed (cons t computed))) + (setq tables (cdr tables))) + (setq computed (nreverse computed)) + ;; COMPUTED now contains the list of included tables (and + ;; tables included by them, etc.). Now splice this into the + ;; current list. + (setcdr list (nconc computed (cdr (cdr list))))) + ;; It was not a valid table, so just remove the following placeholder. + (setcdr list (cdr (cdr list))))))) + +(defun tags-expand-table-name (file) + "Expand tags table name FILE into a complete file name." + (setq file (expand-file-name file)) + (if (file-directory-p file) + (expand-file-name "TAGS" file) + file)) + +;; Like member, but comparison is done after tags-expand-table-name on both +;; sides and elements of LIST that are t are skipped. +(defun tags-table-list-member (file list) + "Like (member FILE LIST) after applying `tags-expand-table-name'. +More precisely, apply `tags-expand-table-name' to FILE +and each element of LIST, returning the link whose car is the first match. +If an element of LIST is t, ignore it." + (setq file (tags-expand-table-name file)) + (while (and list + (or (eq (car list) t) + (not (string= file (tags-expand-table-name (car list)))))) + (setq list (cdr list))) + list) + +(defun tags-verify-table (file) + "Read FILE into a buffer and verify that it is a valid tags table. +Sets the current buffer to one visiting FILE (if it exists). +Returns non-nil if it is a valid table." + (if (get-file-buffer file) + ;; The file is already in a buffer. Check for the visited file + ;; having changed since we last used it. + (progn + (set-buffer (get-file-buffer file)) + (or verify-tags-table-function (tags-table-mode)) + (if (or (verify-visited-file-modtime (current-buffer)) + ;; Decide whether to revert the file. + ;; revert-without-query can say to revert + ;; or the user can say to revert. + (not (or (let ((tail revert-without-query) + (found nil)) + (while tail + (if (string-match (car tail) buffer-file-name) + (setq found t)) + (setq tail (cdr tail))) + found) + tags-revert-without-query + (yes-or-no-p + (format "Tags file %s has changed, read new contents? " + file))))) + (and verify-tags-table-function + (funcall verify-tags-table-function)) + (revert-buffer t t) + (tags-table-mode))) + (when (file-exists-p file) + (let* ((buf (find-file-noselect file)) + (newfile (buffer-file-name buf))) + (unless (string= file newfile) + ;; find-file-noselect has changed the file name. + ;; Propagate the change to tags-file-name and tags-table-list. + (let ((tail (member file tags-table-list))) + (if tail (setcar tail newfile))) + (if (eq file tags-file-name) (setq tags-file-name newfile))) + ;; Only change buffer now that we're done using potentially + ;; buffer-local variables. + (set-buffer buf) + (tags-table-mode))))) + +;; Subroutine of visit-tags-table-buffer. Search the current tags tables +;; for one that has tags for THIS-FILE (or that includes a table that +;; does). Return the name of the first table listing THIS-FILE; if +;; the table is one included by another table, it is the master table that +;; we return. If CORE-ONLY is non-nil, check only tags tables that are +;; already in buffers--don't visit any new files. +(defun tags-table-including (this-file core-only) + "Search current tags tables for tags for THIS-FILE. +Subroutine of `visit-tags-table-buffer'. +Looks for a tags table that has such tags or that includes a table +that has them. Returns the name of the first such table. +Non-nil CORE-ONLY means check only tags tables that are already in +buffers. If CORE-ONLY is nil, it is ignored." + (let ((tables tags-table-computed-list) + (found nil)) + ;; Loop over the list, looking for a table containing tags for THIS-FILE. + (while (and (not found) + tables) + + (if core-only + ;; Skip tables not in core. + (while (eq (nth 1 tables) t) + (setq tables (cdr (cdr tables)))) + (if (eq (nth 1 tables) t) + ;; This table has not been read into core yet. Read it in now. + (tags-table-extend-computed-list))) + + (if tables + ;; Select the tags table buffer and get the file list up to date. + (let ((tags-file-name (car tables))) + (visit-tags-table-buffer 'same) + (if (member this-file (mapcar 'expand-file-name + (tags-table-files))) + ;; Found it. + (setq found tables)))) + (setq tables (cdr tables))) + (if found + ;; Now determine if the table we found was one included by another + ;; table, not explicitly listed. We do this by checking each + ;; element of the computed list to see if it appears in the user's + ;; explicit list; the last element we will check is FOUND itself. + ;; Then we return the last one which did in fact appear in + ;; tags-table-list. + (let ((could-be nil) + (elt tags-table-computed-list)) + (while (not (eq elt (cdr found))) + (if (tags-table-list-member (car elt) tags-table-list) + ;; This table appears in the user's list, so it could be + ;; the one which includes the table we found. + (setq could-be (car elt))) + (setq elt (cdr elt)) + (if (eq t (car elt)) + (setq elt (cdr elt)))) + ;; The last element we found in the computed list before FOUND + ;; that appears in the user's list will be the table that + ;; included the one we found. + could-be)))) + +(defun tags-next-table () + "Move `tags-table-list-pointer' along and set `tags-file-name'. +Subroutine of `visit-tags-table-buffer'.\ +Returns nil when out of tables." + ;; If there is a placeholder element next, compute the list to replace it. + (while (eq (nth 1 tags-table-list-pointer) t) + (tags-table-extend-computed-list)) + + ;; Go to the next table in the list. + (setq tags-table-list-pointer (cdr tags-table-list-pointer)) + (or tags-table-list-pointer + ;; Wrap around. + (setq tags-table-list-pointer tags-table-computed-list)) + + (if (eq tags-table-list-pointer tags-table-list-started-at) + ;; We have come full circle. No more tables. + (setq tags-table-list-pointer nil) + ;; Set tags-file-name to the name from the list. It is already expanded. + (setq tags-file-name (car tags-table-list-pointer)))) + +;;;###autoload +(defun visit-tags-table-buffer (&optional cont) + "Select the buffer containing the current tags table. +If optional arg is a string, visit that file as a tags table. +If optional arg is t, visit the next table in `tags-table-list'. +If optional arg is the atom `same', don't look for a new table; + just select the buffer visiting `tags-file-name'. +If arg is nil or absent, choose a first buffer from information in + `tags-file-name', `tags-table-list', `tags-table-list-pointer'. +Returns t if it visits a tags table, or nil if there are no more in the list." + + ;; Set tags-file-name to the tags table file we want to visit. + (cond ((eq cont 'same) + ;; Use the ambient value of tags-file-name. + (or tags-file-name + (user-error "%s" + (substitute-command-keys + (concat "No tags table in use; " + "use \\[visit-tags-table] to select one"))))) + ((eq t cont) + ;; Find the next table. + (if (tags-next-table) + ;; Skip over nonexistent files. + (while (and (not (or (get-file-buffer tags-file-name) + (file-exists-p tags-file-name))) + (tags-next-table))))) + (t + ;; Pick a table out of our hat. + (tags-table-check-computed-list) ;Get it up to date, we might use it. + (setq tags-file-name + (or + ;; If passed a string, use that. + (if (stringp cont) + (prog1 cont + (setq cont nil))) + ;; First, try a local variable. + (cdr (assq 'tags-file-name (buffer-local-variables))) + ;; Second, try a user-specified function to guess. + (and default-tags-table-function + (funcall default-tags-table-function)) + ;; Third, look for a tags table that contains tags for the + ;; current buffer's file. If one is found, the lists will + ;; be frobnicated, and CONT will be set non-nil so we don't + ;; do it below. + (and buffer-file-name + (or + ;; First check only tables already in buffers. + (tags-table-including buffer-file-name t) + ;; Since that didn't find any, now do the + ;; expensive version: reading new files. + (tags-table-including buffer-file-name nil))) + ;; Fourth, use the user variable tags-file-name, if it is + ;; not already in the current list. + (and tags-file-name + (not (tags-table-list-member tags-file-name + tags-table-computed-list)) + tags-file-name) + ;; Fifth, use the user variable giving the table list. + ;; Find the first element of the list that actually exists. + (let ((list tags-table-list) + file) + (while (and list + (setq file (tags-expand-table-name (car list))) + (not (get-file-buffer file)) + (not (file-exists-p file))) + (setq list (cdr list))) + (car list)) + ;; Finally, prompt the user for a file name. + (expand-file-name + (read-file-name "Visit tags table (default TAGS): " + default-directory + "TAGS" + t)))))) + + ;; Expand the table name into a full file name. + (setq tags-file-name (tags-expand-table-name tags-file-name)) + + (unless (and (eq cont t) (null tags-table-list-pointer)) + ;; Verify that tags-file-name names a valid tags table. + ;; Bind another variable with the value of tags-file-name + ;; before we switch buffers, in case tags-file-name is buffer-local. + (let ((curbuf (current-buffer)) + (local-tags-file-name tags-file-name)) + (if (tags-verify-table local-tags-file-name) + + ;; We have a valid tags table. + (progn + ;; Bury the tags table buffer so it + ;; doesn't get in the user's way. + (bury-buffer (current-buffer)) + + ;; If this was a new table selection (CONT is nil), make + ;; sure tags-table-list includes the chosen table, and + ;; update the list pointer variables. + (or cont + ;; Look in the list for the table we chose. + (let ((found (tags-table-list-member + local-tags-file-name + tags-table-computed-list))) + (if found + ;; There it is. Just switch to it. + (setq tags-table-list-pointer found + tags-table-list-started-at found) + + ;; The table is not in the current set. + ;; Try to find it in another previously used set. + (let ((sets tags-table-set-list)) + (while (and sets + (not (tags-table-list-member + local-tags-file-name + (car sets)))) + (setq sets (cdr sets))) + (if sets + ;; Found in some other set. Switch to that set. + (progn + (or (memq tags-table-list tags-table-set-list) + ;; Save the current list. + (setq tags-table-set-list + (cons tags-table-list + tags-table-set-list))) + (setq tags-table-list (car sets))) + + ;; Not found in any existing set. + (if (and tags-table-list + (or (eq t tags-add-tables) + (and tags-add-tables + (y-or-n-p + (concat "Keep current list of " + "tags tables also? "))))) + ;; Add it to the current list. + (setq tags-table-list (cons local-tags-file-name + tags-table-list)) + + ;; Make a fresh list, and store the old one. + (message "Starting a new list of tags tables") + (or (null tags-table-list) + (memq tags-table-list tags-table-set-list) + (setq tags-table-set-list + (cons tags-table-list + tags-table-set-list))) + ;; Clear out buffers holding old tables. + (dolist (table tags-table-list) + ;; The list can contain items t. + (if (stringp table) + (let ((buffer (find-buffer-visiting table))) + (if buffer + (kill-buffer buffer))))) + (setq tags-table-list (list local-tags-file-name)))) + + ;; Recompute tags-table-computed-list. + (tags-table-check-computed-list) + ;; Set the tags table list state variables to start + ;; over from tags-table-computed-list. + (setq tags-table-list-started-at tags-table-computed-list + tags-table-list-pointer + tags-table-computed-list))))) + + ;; Return of t says the tags table is valid. + t) + + ;; The buffer was not valid. Don't use it again. + (set-buffer curbuf) + (kill-local-variable 'tags-file-name) + (if (eq local-tags-file-name tags-file-name) + (setq tags-file-name nil)) + (user-error (if (file-exists-p local-tags-file-name) + "File %s is not a valid tags table" + "File %s does not exist") + local-tags-file-name))))) + +(defun tags-reset-tags-tables () + "Reset tags state to cancel effect of any previous \\[visit-tags-table] or \\[find-tag]." + (interactive) + ;; Clear out the markers we are throwing away. + (let ((i 0)) + (while (< i xref-marker-ring-length) + (if (aref (cddr tags-location-ring) i) + (set-marker (aref (cddr tags-location-ring) i) nil)) + (setq i (1+ i)))) + (xref-clear-marker-stack) + (setq tags-file-name nil + tags-location-ring (make-ring xref-marker-ring-length) + tags-table-list nil + tags-table-computed-list nil + tags-table-computed-list-for nil + tags-table-list-pointer nil + tags-table-list-started-at nil + tags-table-set-list nil)) + +(defun file-of-tag (&optional relative) + "Return the file name of the file whose tags point is within. +Assumes the tags table is the current buffer. +If RELATIVE is non-nil, file name returned is relative to tags +table file's directory. If RELATIVE is nil, file name returned +is complete." + (funcall file-of-tag-function relative)) + +;;;###autoload +(defun tags-table-files () + "Return a list of files in the current tags table. +Assumes the tags table is the current buffer. The file names are returned +as they appeared in the `etags' command that created the table, usually +without directory names." + (or tags-table-files + (setq tags-table-files + (funcall tags-table-files-function)))) + +(defun tags-included-tables () + "Return a list of tags tables included by the current table. +Assumes the tags table is the current buffer." + (or tags-included-tables + (setq tags-included-tables (funcall tags-included-tables-function)))) + +(defun tags-completion-table () + "Build `tags-completion-table' on demand. +The tags included in the completion table are those in the current +tags table and its (recursively) included tags tables." + (or tags-completion-table + ;; No cached value for this buffer. + (condition-case () + (let (current-table combined-table) + (message "Making tags completion table for %s..." buffer-file-name) + (save-excursion + ;; Iterate over the current list of tags tables. + (while (visit-tags-table-buffer (and combined-table t)) + ;; Find possible completions in this table. + (setq current-table (funcall tags-completion-table-function)) + ;; Merge this buffer's completions into the combined table. + (if combined-table + (mapatoms + (lambda (sym) (intern (symbol-name sym) combined-table)) + current-table) + (setq combined-table current-table)))) + (message "Making tags completion table for %s...done" + buffer-file-name) + ;; Cache the result in a buffer-local variable. + (setq tags-completion-table combined-table)) + (quit (message "Tags completion table construction aborted.") + (setq tags-completion-table nil))))) + +;;;###autoload +(defun tags-lazy-completion-table () + (let ((buf (current-buffer))) + (lambda (string pred action) + (with-current-buffer buf + (save-excursion + ;; If we need to ask for the tag table, allow that. + (let ((enable-recursive-minibuffers t)) + (visit-tags-table-buffer)) + (complete-with-action action (tags-completion-table) string pred)))))) + +;;;###autoload (defun tags-completion-at-point-function () +;;;###autoload (if (or tags-table-list tags-file-name) +;;;###autoload (progn +;;;###autoload (load "etags") +;;;###autoload (tags-completion-at-point-function)))) + +(defun tags-completion-at-point-function () + "Using tags, return a completion table for the text around point. +If no tags table is loaded, do nothing and return nil." + (when (or tags-table-list tags-file-name) + (let ((completion-ignore-case (if (memq tags-case-fold-search '(t nil)) + tags-case-fold-search + case-fold-search)) + (pattern (funcall (or find-tag-default-function + (get major-mode 'find-tag-default-function) + 'find-tag-default))) + beg) + (when pattern + (save-excursion + (forward-char (1- (length pattern))) + (search-backward pattern) + (setq beg (point)) + (forward-char (length pattern)) + (list beg (point) (tags-lazy-completion-table) :exclusive 'no)))))) + +(defun find-tag-tag (string) + "Read a tag name, with defaulting and completion." + (let* ((completion-ignore-case (if (memq tags-case-fold-search '(t nil)) + tags-case-fold-search + case-fold-search)) + (default (funcall (or find-tag-default-function + (get major-mode 'find-tag-default-function) + 'find-tag-default))) + (spec (completing-read (if default + (format "%s (default %s): " + (substring string 0 (string-match "[ :]+\\'" string)) + default) + string) + (tags-lazy-completion-table) + nil nil nil nil default))) + (if (equal spec "") + (or default (user-error "There is no default tag")) + spec))) + +(defvar last-tag nil + "Last tag found by \\[find-tag].") + +(defun find-tag-interactive (prompt &optional no-default) + "Get interactive arguments for tag functions. +The functions using this are `find-tag-noselect', +`find-tag-other-window', and `find-tag-regexp'." + (if (and current-prefix-arg last-tag) + (list nil (if (< (prefix-numeric-value current-prefix-arg) 0) + '- + t)) + (list (if no-default + (read-string prompt) + (find-tag-tag prompt))))) + +(defvar find-tag-history nil) ; Doc string? + +;; Dynamic bondage: +(defvar etags-case-fold-search) +(defvar etags-syntax-table) +(defvar local-find-tag-hook) + +;;;###autoload +(defun find-tag-noselect (tagname &optional next-p regexp-p) + "Find tag (in current tags table) whose name contains TAGNAME. +Returns the buffer containing the tag's definition and moves its point there, +but does not select the buffer. +The default for TAGNAME is the expression in the buffer near point. + +If second arg NEXT-P is t (interactively, with prefix arg), search for +another tag that matches the last tagname or regexp used. When there are +multiple matches for a tag, more exact matches are found first. If NEXT-P +is the atom `-' (interactively, with prefix arg that is a negative number +or just \\[negative-argument]), pop back to the previous tag gone to. + +If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp. + +A marker representing the point when this command is invoked is pushed +onto a ring and may be popped back to with \\[pop-tag-mark]. +Contrast this with the ring of marks gone to by the command. + +See documentation of variable `tags-file-name'." + (interactive (find-tag-interactive "Find tag: ")) + + (setq find-tag-history (cons tagname find-tag-history)) + ;; Save the current buffer's value of `find-tag-hook' before + ;; selecting the tags table buffer. For the same reason, save value + ;; of `tags-file-name' in case it has a buffer-local value. + (let ((local-find-tag-hook find-tag-hook)) + (if (eq '- next-p) + ;; Pop back to a previous location. + (if (ring-empty-p tags-location-ring) + (user-error "No previous tag locations") + (let ((marker (ring-remove tags-location-ring 0))) + (prog1 + ;; Move to the saved location. + (set-buffer (or (marker-buffer marker) + (error "The marked buffer has been deleted"))) + (goto-char (marker-position marker)) + ;; Kill that marker so it doesn't slow down editing. + (set-marker marker nil nil) + ;; Run the user's hook. Do we really want to do this for pop? + (run-hooks 'local-find-tag-hook)))) + ;; Record whence we came. + (xref-push-marker-stack) + (if (and next-p last-tag) + ;; Find the same table we last used. + (visit-tags-table-buffer 'same) + ;; Pick a table to use. + (visit-tags-table-buffer) + ;; Record TAGNAME for a future call with NEXT-P non-nil. + (setq last-tag tagname)) + ;; Record the location so we can pop back to it later. + (let ((marker (make-marker))) + (with-current-buffer + ;; find-tag-in-order does the real work. + (find-tag-in-order + (if (and next-p last-tag) last-tag tagname) + (if regexp-p + find-tag-regexp-search-function + find-tag-search-function) + (if regexp-p + find-tag-regexp-tag-order + find-tag-tag-order) + (if regexp-p + find-tag-regexp-next-line-after-failure-p + find-tag-next-line-after-failure-p) + (if regexp-p "matching" "containing") + (or (not next-p) (not last-tag))) + (set-marker marker (point)) + (run-hooks 'local-find-tag-hook) + (ring-insert tags-location-ring marker) + (current-buffer)))))) + +;;;###autoload +(defun find-tag (tagname &optional next-p regexp-p) + "Find tag (in current tags table) whose name contains TAGNAME. +Select the buffer containing the tag's definition, and move point there. +The default for TAGNAME is the expression in the buffer around or before point. + +If second arg NEXT-P is t (interactively, with prefix arg), search for +another tag that matches the last tagname or regexp used. When there are +multiple matches for a tag, more exact matches are found first. If NEXT-P +is the atom `-' (interactively, with prefix arg that is a negative number +or just \\[negative-argument]), pop back to the previous tag gone to. + +If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp. + +A marker representing the point when this command is invoked is pushed +onto a ring and may be popped back to with \\[pop-tag-mark]. +Contrast this with the ring of marks gone to by the command. + +See documentation of variable `tags-file-name'." + (interactive (find-tag-interactive "Find tag: ")) + (let* ((buf (find-tag-noselect tagname next-p regexp-p)) + (pos (with-current-buffer buf (point)))) + (condition-case nil + (switch-to-buffer buf) + (error (pop-to-buffer buf))) + (goto-char pos))) + +;;;###autoload +(defun find-tag-other-window (tagname &optional next-p regexp-p) + "Find tag (in current tags table) whose name contains TAGNAME. +Select the buffer containing the tag's definition in another window, and +move point there. The default for TAGNAME is the expression in the buffer +around or before point. + +If second arg NEXT-P is t (interactively, with prefix arg), search for +another tag that matches the last tagname or regexp used. When there are +multiple matches for a tag, more exact matches are found first. If NEXT-P +is negative (interactively, with prefix arg that is a negative number or +just \\[negative-argument]), pop back to the previous tag gone to. + +If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp. + +A marker representing the point when this command is invoked is pushed +onto a ring and may be popped back to with \\[pop-tag-mark]. +Contrast this with the ring of marks gone to by the command. + +See documentation of variable `tags-file-name'." + (declare (obsolete xref-find-definitions-other-window "25.1")) + (interactive (find-tag-interactive "Find tag other window: ")) + + ;; This hair is to deal with the case where the tag is found in the + ;; selected window's buffer; without the hair, point is moved in both + ;; windows. To prevent this, we save the selected window's point before + ;; doing find-tag-noselect, and restore it after. + (let* ((window-point (window-point)) + (tagbuf (find-tag-noselect tagname next-p regexp-p)) + (tagpoint (progn (set-buffer tagbuf) (point)))) + (set-window-point (prog1 + (selected-window) + (switch-to-buffer-other-window tagbuf) + ;; We have to set this new window's point; it + ;; might already have been displaying a + ;; different portion of tagbuf, in which case + ;; switch-to-buffer-other-window doesn't set + ;; the window's point from the buffer. + (set-window-point (selected-window) tagpoint)) + window-point))) + +;;;###autoload +(defun find-tag-other-frame (tagname &optional next-p) + "Find tag (in current tags table) whose name contains TAGNAME. +Select the buffer containing the tag's definition in another frame, and +move point there. The default for TAGNAME is the expression in the buffer +around or before point. + +If second arg NEXT-P is t (interactively, with prefix arg), search for +another tag that matches the last tagname or regexp used. When there are +multiple matches for a tag, more exact matches are found first. If NEXT-P +is negative (interactively, with prefix arg that is a negative number or +just \\[negative-argument]), pop back to the previous tag gone to. + +If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp. + +A marker representing the point when this command is invoked is pushed +onto a ring and may be popped back to with \\[pop-tag-mark]. +Contrast this with the ring of marks gone to by the command. + +See documentation of variable `tags-file-name'." + (declare (obsolete xref-find-definitions-other-frame "25.1")) + (interactive (find-tag-interactive "Find tag other frame: ")) + (let ((pop-up-frames t)) + (find-tag-other-window tagname next-p))) + +;;;###autoload +(defun find-tag-regexp (regexp &optional next-p other-window) + "Find tag (in current tags table) whose name matches REGEXP. +Select the buffer containing the tag's definition and move point there. + +If second arg NEXT-P is t (interactively, with prefix arg), search for +another tag that matches the last tagname or regexp used. When there are +multiple matches for a tag, more exact matches are found first. If NEXT-P +is negative (interactively, with prefix arg that is a negative number or +just \\[negative-argument]), pop back to the previous tag gone to. + +If third arg OTHER-WINDOW is non-nil, select the buffer in another window. + +A marker representing the point when this command is invoked is pushed +onto a ring and may be popped back to with \\[pop-tag-mark]. +Contrast this with the ring of marks gone to by the command. + +See documentation of variable `tags-file-name'." + (declare (obsolete xref-find-apropos "25.1")) + (interactive (find-tag-interactive "Find tag regexp: " t)) + ;; We go through find-tag-other-window to do all the display hair there. + (funcall (if other-window 'find-tag-other-window 'find-tag) + regexp next-p t)) + +;;;###autoload +(defalias 'pop-tag-mark 'xref-pop-marker-stack) + + +(defvar tag-lines-already-matched nil + "Matches remembered between calls.") ; Doc string: calls to what? + +(defun find-tag-in-order (pattern + search-forward-func + order + next-line-after-failure-p + matching + first-search) + "Internal tag-finding function. +PATTERN is a string to pass to arg SEARCH-FORWARD-FUNC, and to any +member of the function list ORDER. If ORDER is nil, use saved state +to continue a previous search. + +Arg NEXT-LINE-AFTER-FAILURE-P is non-nil if after a failed match, +point should be moved to the next line. + +Arg MATCHING is a string, an English `-ing' word, to be used in an +error message." +;; Algorithm is as follows: +;; For each qualifier-func in ORDER, go to beginning of tags file, and +;; perform inner loop: for each naive match for PATTERN found using +;; SEARCH-FORWARD-FUNC, qualify the naive match using qualifier-func. If +;; it qualifies, go to the specified line in the specified source file +;; and return. Qualified matches are remembered to avoid repetition. +;; State is saved so that the loop can be continued. + (let (file ;name of file containing tag + tag-info ;where to find the tag in FILE + (first-table t) + (tag-order order) + (match-marker (make-marker)) + goto-func + (case-fold-search (if (memq tags-case-fold-search '(nil t)) + tags-case-fold-search + case-fold-search)) + ) + (save-excursion + + (if first-search + ;; This is the start of a search for a fresh tag. + ;; Clear the list of tags matched by the previous search. + ;; find-tag-noselect has already put us in the first tags table + ;; buffer before we got called. + (setq tag-lines-already-matched nil) + ;; Continuing to search for the tag specified last time. + ;; tag-lines-already-matched lists locations matched in previous + ;; calls so we don't visit the same tag twice if it matches twice + ;; during two passes with different qualification predicates. + ;; Switch to the current tags table buffer. + (visit-tags-table-buffer 'same)) + + ;; Get a qualified match. + (catch 'qualified-match-found + + ;; Iterate over the list of tags tables. + (while (or first-table + (visit-tags-table-buffer t)) + + (and first-search first-table + ;; Start at beginning of tags file. + (goto-char (point-min))) + + (setq first-table nil) + + ;; Iterate over the list of ordering predicates. + (while order + (while (funcall search-forward-func pattern nil t) + ;; Naive match found. Qualify the match. + (and (funcall (car order) pattern) + ;; Make sure it is not a previous qualified match. + (not (member (set-marker match-marker (point-at-bol)) + tag-lines-already-matched)) + (throw 'qualified-match-found nil)) + (if next-line-after-failure-p + (forward-line 1))) + ;; Try the next flavor of match. + (setq order (cdr order)) + (goto-char (point-min))) + (setq order tag-order)) + ;; We throw out on match, so only get here if there were no matches. + ;; Clear out the markers we use to avoid duplicate matches so they + ;; don't slow down editing and are immediately available for GC. + (while tag-lines-already-matched + (set-marker (car tag-lines-already-matched) nil nil) + (setq tag-lines-already-matched (cdr tag-lines-already-matched))) + (set-marker match-marker nil nil) + (user-error "No %stags %s %s" (if first-search "" "more ") + matching pattern)) + + ;; Found a tag; extract location info. + (beginning-of-line) + (setq tag-lines-already-matched (cons match-marker + tag-lines-already-matched)) + ;; Expand the filename, using the tags table buffer's default-directory. + ;; We should be able to search for file-name backwards in file-of-tag: + ;; the beginning-of-line is ok except when positioned on a "file-name" tag. + (setq file (expand-file-name + (if (memq (car order) '(tag-exact-file-name-match-p + tag-file-name-match-p + tag-partial-file-name-match-p)) + (save-excursion (forward-line 1) + (file-of-tag)) + (file-of-tag))) + tag-info (funcall snarf-tag-function)) + + ;; Get the local value in the tags table buffer before switching buffers. + (setq goto-func goto-tag-location-function) + (tag-find-file-of-tag-noselect file) + (widen) + (push-mark) + (funcall goto-func tag-info) + + ;; Return the buffer where the tag was found. + (current-buffer)))) + +(defun tag-find-file-of-tag-noselect (file) + "Find the right line in the specified FILE." + ;; If interested in compressed-files, search files with extensions. + ;; Otherwise, search only the real file. + (let* ((buffer-search-extensions (if auto-compression-mode + tags-compression-info-list + '(""))) + the-buffer + (file-search-extensions buffer-search-extensions)) + ;; search a buffer visiting the file with each possible extension + ;; Note: there is a small inefficiency in find-buffer-visiting : + ;; truename is computed even if not needed. Not too sure about this + ;; but I suspect truename computation accesses the disk. + ;; It is maybe a good idea to optimize this find-buffer-visiting. + ;; An alternative would be to use only get-file-buffer + ;; but this looks less "sure" to find the buffer for the file. + (while (and (not the-buffer) buffer-search-extensions) + (setq the-buffer (find-buffer-visiting (concat file (car buffer-search-extensions)))) + (setq buffer-search-extensions (cdr buffer-search-extensions))) + ;; if found a buffer but file modified, ensure we re-read ! + (if (and the-buffer (not (verify-visited-file-modtime the-buffer))) + (find-file-noselect (buffer-file-name the-buffer))) + ;; if no buffer found, search for files with possible extensions on disk + (while (and (not the-buffer) file-search-extensions) + (if (not (file-exists-p (concat file (car file-search-extensions)))) + (setq file-search-extensions (cdr file-search-extensions)) + (setq the-buffer (find-file-noselect (concat file (car file-search-extensions)))))) + (if (not the-buffer) + (if auto-compression-mode + (error "File %s (with or without extensions %s) not found" file tags-compression-info-list) + (error "File %s not found" file)) + (set-buffer the-buffer)))) + +(defun tag-find-file-of-tag (file) ; Doc string? + (let ((buf (tag-find-file-of-tag-noselect file))) + (condition-case nil + (switch-to-buffer buf) + (error (pop-to-buffer buf))))) + +;; `etags' TAGS file format support. + +(defun etags-recognize-tags-table () + "If `etags-verify-tags-table', make buffer-local format variables. +If current buffer is a valid etags TAGS file, then give it +buffer-local values of tags table format variables." + (and (etags-verify-tags-table) + ;; It is annoying to flash messages on the screen briefly, + ;; and this message is not useful. -- rms + ;; (message "%s is an `etags' TAGS file" buffer-file-name) + (mapc (lambda (elt) (set (make-local-variable (car elt)) (cdr elt))) + '((file-of-tag-function . etags-file-of-tag) + (tags-table-files-function . etags-tags-table-files) + (tags-completion-table-function . etags-tags-completion-table) + (snarf-tag-function . etags-snarf-tag) + (goto-tag-location-function . etags-goto-tag-location) + (find-tag-regexp-search-function . re-search-forward) + (find-tag-regexp-tag-order . (tag-re-match-p)) + (find-tag-regexp-next-line-after-failure-p . t) + (find-tag-search-function . search-forward) + (find-tag-tag-order . (tag-exact-file-name-match-p + tag-file-name-match-p + tag-exact-match-p + tag-implicit-name-match-p + tag-symbol-match-p + tag-word-match-p + tag-partial-file-name-match-p + tag-any-match-p)) + (find-tag-next-line-after-failure-p . nil) + (list-tags-function . etags-list-tags) + (tags-apropos-function . etags-tags-apropos) + (tags-included-tables-function . etags-tags-included-tables) + (verify-tags-table-function . etags-verify-tags-table) + )))) + +(defun etags-verify-tags-table () + "Return non-nil if the current buffer is a valid etags TAGS file." + ;; Use eq instead of = in case char-after returns nil. + (eq (char-after (point-min)) ?\f)) + +(defun etags-file-of-tag (&optional relative) ; Doc string? + (save-excursion + (re-search-backward "\f\n\\([^\n]+\\),[0-9]*\n") + (let ((str (convert-standard-filename + (buffer-substring (match-beginning 1) (match-end 1))))) + (if relative + str + (expand-file-name str (file-truename default-directory)))))) + + +(defun etags-tags-completion-table () ; Doc string? + (let ((table (make-vector 511 0)) + (progress-reporter + (make-progress-reporter + (format "Making tags completion table for %s..." buffer-file-name) + (point-min) (point-max)))) + (save-excursion + (goto-char (point-min)) + ;; This monster regexp matches an etags tag line. + ;; \1 is the string to match; + ;; \2 is not interesting; + ;; \3 is the guessed tag name; XXX guess should be better eg DEFUN + ;; \4 is not interesting; + ;; \5 is the explicitly-specified tag name. + ;; \6 is the line to start searching at; + ;; \7 is the char to start searching at. + (while (re-search-forward + "^\\(\\([^\177]+[^-a-zA-Z0-9_+*$:\177]+\\)?\ +\\([-a-zA-Z0-9_+*$?:]+\\)[^-a-zA-Z0-9_+*$?:\177]*\\)\177\ +\\(\\([^\n\001]+\\)\001\\)?\\([0-9]+\\)?,\\([0-9]+\\)?\n" + nil t) + (intern (prog1 (if (match-beginning 5) + ;; There is an explicit tag name. + (buffer-substring (match-beginning 5) (match-end 5)) + ;; No explicit tag name. Best guess. + (buffer-substring (match-beginning 3) (match-end 3))) + (progress-reporter-update progress-reporter (point))) + table))) + table)) + +(defun etags-snarf-tag (&optional use-explicit) ; Doc string? + (let (tag-text line startpos explicit-start) + (if (save-excursion + (forward-line -1) + (looking-at "\f\n")) + ;; The match was for a source file name, not any tag within a file. + ;; Give text of t, meaning to go exactly to the location we specify, + ;; the beginning of the file. + (setq tag-text t + line nil + startpos (point-min)) + + ;; Find the end of the tag and record the whole tag text. + (search-forward "\177") + (setq tag-text (buffer-substring (1- (point)) (point-at-bol))) + ;; If use-explicit is non nil and explicit tag is present, use it as part of + ;; return value. Else just skip it. + (setq explicit-start (point)) + (when (and (search-forward "\001" (point-at-bol 2) t) + use-explicit) + (setq tag-text (buffer-substring explicit-start (1- (point))))) + + + (if (looking-at "[0-9]") + (setq line (string-to-number (buffer-substring + (point) + (progn (skip-chars-forward "0-9") + (point)))))) + (search-forward ",") + (if (looking-at "[0-9]") + (setq startpos (string-to-number (buffer-substring + (point) + (progn (skip-chars-forward "0-9") + (point))))))) + ;; Leave point on the next line of the tags file. + (forward-line 1) + (cons tag-text (cons line startpos)))) + +(defun etags-goto-tag-location (tag-info) + "Go to location of tag specified by TAG-INFO. +TAG-INFO is a cons (TEXT LINE . POSITION). +TEXT is the initial part of a line containing the tag. +LINE is the line number. +POSITION is the (one-based) char position of TEXT within the file. + +If TEXT is t, it means the tag refers to exactly LINE or POSITION, +whichever is present, LINE having preference, no searching. +Either LINE or POSITION can be nil. POSITION is used if present. + +If the tag isn't exactly at the given position, then look near that +position using a search window that expands progressively until it +hits the start of file." + (let ((startpos (cdr (cdr tag-info))) + (line (car (cdr tag-info))) + offset found pat) + (if (eq (car tag-info) t) + ;; Direct file tag. + (cond (line (progn (goto-char (point-min)) + (forward-line (1- line)))) + (startpos (goto-char startpos)) + (t (error "etags.el BUG: bogus direct file tag"))) + ;; This constant is 1/2 the initial search window. + ;; There is no sense in making it too small, + ;; since just going around the loop once probably + ;; costs about as much as searching 2000 chars. + (setq offset 1000 + found nil + pat (concat (if (eq selective-display t) + "\\(^\\|\^m\\)" "^") + (regexp-quote (car tag-info)))) + ;; The character position in the tags table is 0-origin. + ;; Convert it to a 1-origin Emacs character position. + (if startpos (setq startpos (1+ startpos))) + ;; If no char pos was given, try the given line number. + (or startpos + (if line + (setq startpos (progn (goto-char (point-min)) + (forward-line (1- line)) + (point))))) + (or startpos + (setq startpos (point-min))) + ;; First see if the tag is right at the specified location. + (goto-char startpos) + (setq found (looking-at pat)) + (while (and (not found) + (progn + (goto-char (- startpos offset)) + (not (bobp)))) + (setq found + (re-search-forward pat (+ startpos offset) t) + offset (* 3 offset))) ; expand search window + (or found + (re-search-forward pat nil t) + (user-error "Rerun etags: `%s' not found in %s" + pat buffer-file-name))) + ;; Position point at the right place + ;; if the search string matched an extra Ctrl-m at the beginning. + (and (eq selective-display t) + (looking-at "\^m") + (forward-char 1)) + (beginning-of-line))) + +(defun etags-list-tags (file) ; Doc string? + (goto-char (point-min)) + (when (re-search-forward (concat "\f\n" "\\(" file "\\)" ",") nil t) + (let ((path (save-excursion (forward-line 1) (file-of-tag))) + ;; Get the local value in the tags table + ;; buffer before switching buffers. + (goto-func goto-tag-location-function) + tag tag-info pt) + (forward-line 1) + (while (not (or (eobp) (looking-at "\f"))) + ;; We used to use explicit tags when available, but the current goto-func + ;; can only handle implicit tags. + (setq tag-info (save-excursion (funcall snarf-tag-function nil)) + tag (car tag-info) + pt (with-current-buffer standard-output (point))) + (princ tag) + (when (= (aref tag 0) ?\() (princ " ...)")) + (with-current-buffer standard-output + (make-text-button pt (point) + 'tag-info tag-info + 'file-path path + 'goto-func goto-func + 'action (lambda (button) + (let ((tag-info (button-get button 'tag-info)) + (goto-func (button-get button 'goto-func))) + (tag-find-file-of-tag (button-get button 'file-path)) + (widen) + (funcall goto-func tag-info))) + 'follow-link t + 'face tags-tag-face + 'type 'button)) + (terpri) + (forward-line 1)) + t))) + +(defmacro tags-with-face (face &rest body) + "Execute BODY, give output to `standard-output' face FACE." + (let ((pp (make-symbol "start"))) + `(let ((,pp (with-current-buffer standard-output (point)))) + ,@body + (put-text-property ,pp (with-current-buffer standard-output (point)) + 'face ,face standard-output)))) + +(defun etags-tags-apropos-additional (regexp) + "Display tags matching REGEXP from `tags-apropos-additional-actions'." + (with-current-buffer standard-output + (dolist (oba tags-apropos-additional-actions) + (princ "\n\n") + (tags-with-face 'highlight (princ (car oba))) + (princ":\n\n") + (let* ((beg (point)) + (symbs (car (cddr oba))) + (ins-symb (lambda (sy) + (let ((sn (symbol-name sy))) + (when (string-match regexp sn) + (make-text-button (point) + (progn (princ sy) (point)) + 'action-internal(cadr oba) + 'action (lambda (button) (funcall + (button-get button 'action-internal) + (button-get button 'item))) + 'item sn + 'face tags-tag-face + 'follow-link t + 'type 'button) + (terpri)))))) + (when (symbolp symbs) + (if (boundp symbs) + (setq symbs (symbol-value symbs)) + (insert "symbol `" (symbol-name symbs) "' has no value\n") + (setq symbs nil))) + (if (vectorp symbs) + (mapatoms ins-symb symbs) + (dolist (sy symbs) + (funcall ins-symb (car sy)))) + (sort-lines nil beg (point)))))) + +(defun etags-tags-apropos (string) ; Doc string? + (when tags-apropos-verbose + (princ "Tags in file `") + (tags-with-face 'highlight (princ buffer-file-name)) + (princ "':\n\n")) + (goto-char (point-min)) + (let ((progress-reporter (make-progress-reporter + (format "Making tags apropos buffer for `%s'..." + string) + (point-min) (point-max)))) + (while (re-search-forward string nil t) + (progress-reporter-update progress-reporter (point)) + (beginning-of-line) + + (let* ( ;; Get the local value in the tags table + ;; buffer before switching buffers. + (goto-func goto-tag-location-function) + (tag-info (save-excursion (funcall snarf-tag-function))) + (tag (if (eq t (car tag-info)) nil (car tag-info))) + (file-path (save-excursion (if tag (file-of-tag) + (save-excursion (forward-line 1) + (file-of-tag))))) + (file-label (if tag (file-of-tag t) + (save-excursion (forward-line 1) + (file-of-tag t)))) + (pt (with-current-buffer standard-output (point)))) + (if tag + (progn + (princ (format "[%s]: " file-label)) + (princ tag) + (when (= (aref tag 0) ?\() (princ " ...)")) + (with-current-buffer standard-output + (make-text-button pt (point) + 'tag-info tag-info + 'file-path file-path + 'goto-func goto-func + 'action (lambda (button) + (let ((tag-info (button-get button 'tag-info)) + (goto-func (button-get button 'goto-func))) + (tag-find-file-of-tag (button-get button 'file-path)) + (widen) + (funcall goto-func tag-info))) + 'follow-link t + 'face tags-tag-face + 'type 'button))) + (princ (format "- %s" file-label)) + (with-current-buffer standard-output + (make-text-button pt (point) + 'file-path file-path + 'action (lambda (button) + (tag-find-file-of-tag (button-get button 'file-path)) + ;; Get the local value in the tags table + ;; buffer before switching buffers. + (goto-char (point-min))) + 'follow-link t + 'face tags-tag-face + 'type 'button)))) + (terpri) + (forward-line 1)) + (message nil)) + (when tags-apropos-verbose (princ "\n"))) + +(defun etags-tags-table-files () ; Doc string? + (let ((files nil) + beg) + (goto-char (point-min)) + (while (search-forward "\f\n" nil t) + (setq beg (point)) + (end-of-line) + (skip-chars-backward "^," beg) + (or (looking-at "include$") + (push (convert-standard-filename + (buffer-substring beg (1- (point)))) + files))) + (nreverse files))) + +;; FIXME? Should this save-excursion? +(defun etags-tags-included-tables () ; Doc string? + (let ((files nil) + beg) + (goto-char (point-min)) + (while (search-forward "\f\n" nil t) + (setq beg (point)) + (end-of-line) + (skip-chars-backward "^," beg) + (when (looking-at "include$") + ;; Expand in the default-directory of the tags table buffer. + (push (expand-file-name (convert-standard-filename + (buffer-substring beg (1- (point))))) + files))) + (nreverse files))) + +;; Empty tags file support. + +(defun tags-recognize-empty-tags-table () + "Return non-nil if current buffer is empty. +If empty, make buffer-local values of the tags table format variables +that do nothing." + (and (zerop (buffer-size)) + (mapc (lambda (sym) (set (make-local-variable sym) 'ignore)) + '(tags-table-files-function + tags-completion-table-function + find-tag-regexp-search-function + find-tag-search-function + tags-apropos-function + tags-included-tables-function)) + (set (make-local-variable 'verify-tags-table-function) + (lambda () (zerop (buffer-size)))))) + +;; Match qualifier functions for tagnames. +;; These functions assume the etags file format defined in etc/ETAGS.EBNF. + +;; This might be a neat idea, but it's too hairy at the moment. +;;(defmacro tags-with-syntax (&rest body) +;; `(with-syntax-table +;; (with-current-buffer (find-file-noselect (file-of-tag)) +;; (syntax-table)) +;; ,@body)) +;;(put 'tags-with-syntax 'edebug-form-spec '(&rest form)) + +;; exact file name match, i.e. searched tag must match complete file +;; name including directories parts if there are some. +(defun tag-exact-file-name-match-p (tag) + "Return non-nil if TAG matches complete file name. +Any directory part of the file name is also matched." + (and (looking-at ",[0-9\n]") + (save-excursion (backward-char (+ 2 (length tag))) + (looking-at "\f\n")))) + +;; file name match as above, but searched tag must match the file +;; name not including the directories if there are some. +(defun tag-file-name-match-p (tag) + "Return non-nil if TAG matches file name, excluding directory part." + (and (looking-at ",[0-9\n]") + (save-excursion (backward-char (1+ (length tag))) + (looking-at "/")))) + +;; this / to detect we are after a directory separator is ok for unix, +;; is there a variable that contains the regexp for directory separator +;; on whatever operating system ? +;; Looks like ms-win will lose here :). + +;; t if point is at a tag line that matches TAG exactly. +;; point should be just after a string that matches TAG. +(defun tag-exact-match-p (tag) + "Return non-nil if current tag line matches TAG exactly. +Point should be just after a string that matches TAG." + ;; The match is really exact if there is an explicit tag name. + (or (and (eq (char-after (point)) ?\001) + (eq (char-after (- (point) (length tag) 1)) ?\177)) + ;; We are not on the explicit tag name, but perhaps it follows. + (looking-at (concat "[^\177\n]*\177" (regexp-quote tag) "\001")))) + +;; t if point is at a tag line that has an implicit name. +;; point should be just after a string that matches TAG. +(defun tag-implicit-name-match-p (tag) + "Return non-nil if current tag line has an implicit name. +Point should be just after a string that matches TAG." + ;; Look at the comment of the make_tag function in lib-src/etags.c for + ;; a textual description of the four rules. + (and (string-match "^[^ \t()=,;]+$" tag) ;rule #1 + (looking-at "[ \t()=,;]?\177") ;rules #2 and #4 + (save-excursion + (backward-char (1+ (length tag))) + (looking-at "[\n \t()=,;]")))) ;rule #3 + +;; t if point is at a tag line that matches TAG as a symbol. +;; point should be just after a string that matches TAG. +(defun tag-symbol-match-p (tag) + "Return non-nil if current tag line matches TAG as a symbol. +Point should be just after a string that matches TAG." + (and (looking-at "\\Sw.*\177") (looking-at "\\S_.*\177") + (save-excursion + (backward-char (1+ (length tag))) + (and (looking-at "\\Sw") (looking-at "\\S_"))))) + +;; t if point is at a tag line that matches TAG as a word. +;; point should be just after a string that matches TAG. +(defun tag-word-match-p (tag) + "Return non-nil if current tag line matches TAG as a word. +Point should be just after a string that matches TAG." + (and (looking-at "\\b.*\177") + (save-excursion (backward-char (length tag)) + (looking-at "\\b")))) + +;; partial file name match, i.e. searched tag must match a substring +;; of the file name (potentially including a directory separator). +(defun tag-partial-file-name-match-p (_tag) + "Return non-nil if current tag matches file name. +This is a substring match, and it can include directory separators. +Point should be just after a string that matches TAG." + (and (looking-at ".*,[0-9\n]") + (save-excursion (beginning-of-line) + (backward-char 2) + (looking-at "\f\n")))) + +;; t if point is in a tag line with a tag containing TAG as a substring. +(defun tag-any-match-p (_tag) + "Return non-nil if current tag line contains TAG as a substring." + (looking-at ".*\177")) + +;; t if point is at a tag line that matches RE as a regexp. +(defun tag-re-match-p (re) + "Return non-nil if current tag line matches regexp RE." + (save-excursion + (beginning-of-line) + (let ((bol (point))) + (and (search-forward "\177" (line-end-position) t) + (re-search-backward re bol t))))) + +(defcustom tags-loop-revert-buffers nil + "Non-nil means tags-scanning loops should offer to reread changed files. +These loops normally read each file into Emacs, but when a file +is already visited, they use the existing buffer. +When this flag is non-nil, they offer to revert the existing buffer +in the case where the file has changed since you visited it." + :type 'boolean + :group 'etags) + +;;;###autoload +(defun next-file (&optional initialize novisit) + "Select next file among files in current tags table. + +A first argument of t (prefix arg, if interactive) initializes to the +beginning of the list of files in the tags table. If the argument is +neither nil nor t, it is evalled to initialize the list of files. + +Non-nil second argument NOVISIT means use a temporary buffer + to save time and avoid uninteresting warnings. + +Value is nil if the file was already visited; +if the file was newly read in, the value is the filename." + ;; Make the interactive arg t if there was any prefix arg. + (interactive (list (if current-prefix-arg t))) + (cond ((not initialize) + ;; Not the first run. + ) + ((eq initialize t) + ;; Initialize the list from the tags table. + (save-excursion + ;; Visit the tags table buffer to get its list of files. + (visit-tags-table-buffer) + ;; Copy the list so we can setcdr below, and expand the file + ;; names while we are at it, in this buffer's default directory. + (setq next-file-list (mapcar 'expand-file-name (tags-table-files))) + ;; Iterate over all the tags table files, collecting + ;; a complete list of referenced file names. + (while (visit-tags-table-buffer t) + ;; Find the tail of the working list and chain on the new + ;; sublist for this tags table. + (let ((tail next-file-list)) + (while (cdr tail) + (setq tail (cdr tail))) + ;; Use a copy so the next loop iteration will not modify the + ;; list later returned by (tags-table-files). + (if tail + (setcdr tail (mapcar 'expand-file-name (tags-table-files))) + (setq next-file-list (mapcar 'expand-file-name + (tags-table-files)))))))) + (t + ;; Initialize the list by evalling the argument. + (setq next-file-list (eval initialize)))) + (unless next-file-list + (and novisit + (get-buffer " *next-file*") + (kill-buffer " *next-file*")) + (user-error "All files processed")) + (let* ((next (car next-file-list)) + (buffer (get-file-buffer next)) + (new (not buffer))) + ;; Advance the list before trying to find the file. + ;; If we get an error finding the file, don't get stuck on it. + (setq next-file-list (cdr next-file-list)) + ;; Optionally offer to revert buffers + ;; if the files have changed on disk. + (and buffer tags-loop-revert-buffers + (not (verify-visited-file-modtime buffer)) + (y-or-n-p + (format + (if (buffer-modified-p buffer) + "File %s changed on disk. Discard your edits? " + "File %s changed on disk. Reread from disk? ") + next)) + (with-current-buffer buffer + (revert-buffer t t))) + (if (not (and new novisit)) + (find-file next novisit) + ;; Like find-file, but avoids random warning messages. + (switch-to-buffer (get-buffer-create " *next-file*")) + (kill-all-local-variables) + (erase-buffer) + (setq new next) + (insert-file-contents new nil)) + new)) + +(defvar tags-loop-operate nil + "Form for `tags-loop-continue' to eval to change one file.") + +(defvar tags-loop-scan + '(user-error "%s" + (substitute-command-keys + "No \\[tags-search] or \\[tags-query-replace] in progress")) + "Form for `tags-loop-continue' to eval to scan one file. +If it returns non-nil, this file needs processing by evalling +`tags-loop-operate'. Otherwise, move on to the next file.") + +(defun tags-loop-eval (form) + "Evaluate FORM and return its result. +Bind `case-fold-search' during the evaluation, depending on the value of +`tags-case-fold-search'." + (let ((case-fold-search (if (memq tags-case-fold-search '(t nil)) + tags-case-fold-search + case-fold-search))) + (eval form))) + + +;;;###autoload +(defun tags-loop-continue (&optional first-time) + "Continue last \\[tags-search] or \\[tags-query-replace] command. +Used noninteractively with non-nil argument to begin such a command (the +argument is passed to `next-file', which see). + +Two variables control the processing we do on each file: the value of +`tags-loop-scan' is a form to be executed on each file to see if it is +interesting (it returns non-nil if so) and `tags-loop-operate' is a form to +evaluate to operate on an interesting file. If the latter evaluates to +nil, we exit; otherwise we scan the next file." + (declare (obsolete "use `xref-find-definitions' interface instead." "25.1")) + (interactive) + (let (new + ;; Non-nil means we have finished one file + ;; and should not scan it again. + file-finished + original-point + (messaged nil)) + (while + (progn + ;; Scan files quickly for the first or next interesting one. + ;; This starts at point in the current buffer. + (while (or first-time file-finished + (save-restriction + (widen) + (not (tags-loop-eval tags-loop-scan)))) + ;; If nothing was found in the previous file, and + ;; that file isn't in a temp buffer, restore point to + ;; where it was. + (when original-point + (goto-char original-point)) + + (setq file-finished nil) + (setq new (next-file first-time t)) + + ;; If NEW is non-nil, we got a temp buffer, + ;; and NEW is the file name. + (when (or messaged + (and (not first-time) + (> baud-rate search-slow-speed) + (setq messaged t))) + (message "Scanning file %s..." (or new buffer-file-name))) + + (setq first-time nil) + (setq original-point (if new nil (point))) + (goto-char (point-min))) + + ;; If we visited it in a temp buffer, visit it now for real. + (if new + (let ((pos (point))) + (erase-buffer) + (set-buffer (find-file-noselect new)) + (setq new nil) ;No longer in a temp buffer. + (widen) + (goto-char pos)) + (push-mark original-point t)) + + (switch-to-buffer (current-buffer)) + + ;; Now operate on the file. + ;; If value is non-nil, continue to scan the next file. + (tags-loop-eval tags-loop-operate)) + (setq file-finished t)) + (and messaged + (null tags-loop-operate) + (message "Scanning file %s...found" buffer-file-name)))) + +;;;###autoload +(defun tags-search (regexp &optional file-list-form) + "Search through all files listed in tags table for match for REGEXP. +Stops when a match is found. +To continue searching for next match, use command \\[tags-loop-continue]. + +If FILE-LIST-FORM is non-nil, it should be a form that, when +evaluated, will return a list of file names. The search will be +restricted to these files. + +Also see the documentation of the `tags-file-name' variable." + (interactive "sTags search (regexp): ") + (if (and (equal regexp "") + (eq (car tags-loop-scan) 're-search-forward) + (null tags-loop-operate)) + ;; Continue last tags-search as if by M-,. + (tags-loop-continue nil) + (setq tags-loop-scan `(re-search-forward ',regexp nil t) + tags-loop-operate nil) + (tags-loop-continue (or file-list-form t)))) + +;;;###autoload +(defun tags-query-replace (from to &optional delimited file-list-form) + "Do `query-replace-regexp' of FROM with TO on all files listed in tags table. +Third arg DELIMITED (prefix arg) means replace only word-delimited matches. +If you exit (\\[keyboard-quit], RET or q), you can resume the query replace +with the command \\[tags-loop-continue]. +Fourth arg FILE-LIST-FORM non-nil means initialize the replacement loop. +Fifth and sixth arguments START and END are accepted, for compatibility +with `query-replace-regexp', and ignored. + +If FILE-LIST-FORM is non-nil, it is a form to evaluate to +produce the list of files to search. + +See also the documentation of the variable `tags-file-name'." + (interactive (query-replace-read-args "Tags query replace (regexp)" t t)) + (setq tags-loop-scan `(let ,(unless (equal from (downcase from)) + '((case-fold-search nil))) + (if (re-search-forward ',from nil t) + ;; When we find a match, move back + ;; to the beginning of it so perform-replace + ;; will see it. + (goto-char (match-beginning 0)))) + tags-loop-operate `(perform-replace ',from ',to t t ',delimited + nil multi-query-replace-map)) + (tags-loop-continue (or file-list-form t))) + +(defun tags-complete-tags-table-file (string predicate what) ; Doc string? + (save-excursion + ;; If we need to ask for the tag table, allow that. + (let ((enable-recursive-minibuffers t)) + (visit-tags-table-buffer)) + (if (eq what t) + (all-completions string (tags-table-files) predicate) + (try-completion string (tags-table-files) predicate)))) + +;;;###autoload +(defun list-tags (file &optional _next-match) + "Display list of tags in file FILE. +This searches only the first table in the list, and no included tables. +FILE should be as it appeared in the `etags' command, usually without a +directory specification." + (interactive (list (completing-read "List tags in file: " + 'tags-complete-tags-table-file + nil t nil))) + (with-output-to-temp-buffer "*Tags List*" + (princ "Tags in file `") + (tags-with-face 'highlight (princ file)) + (princ "':\n\n") + (save-excursion + (let ((first-time t) + (gotany nil)) + (while (visit-tags-table-buffer (not first-time)) + (setq first-time nil) + (if (funcall list-tags-function file) + (setq gotany t))) + (or gotany + (user-error "File %s not in current tags tables" file))))) + (with-current-buffer "*Tags List*" + (require 'apropos) + (with-no-warnings + (apropos-mode)) + (setq buffer-read-only t))) + +;;;###autoload +(defun tags-apropos (regexp) + "Display list of all tags in tags table REGEXP matches." + (declare (obsolete xref-find-apropos "25.1")) + (interactive "sTags apropos (regexp): ") + (with-output-to-temp-buffer "*Tags List*" + (princ "Click mouse-2 to follow tags.\n\nTags matching regexp `") + (tags-with-face 'highlight (princ regexp)) + (princ "':\n\n") + (save-excursion + (let ((first-time t)) + (while (visit-tags-table-buffer (not first-time)) + (setq first-time nil) + (funcall tags-apropos-function regexp)))) + (etags-tags-apropos-additional regexp)) + (with-current-buffer "*Tags List*" + (eval-and-compile (require 'apropos)) + (apropos-mode) + ;; apropos-mode is derived from fundamental-mode and it kills + ;; all local variables. + (setq buffer-read-only t))) + +;; XXX Kludge interface. + +(define-button-type 'tags-select-tags-table + 'action 'select-tags-table-select + 'follow-link t + 'help-echo "RET, t or mouse-2: select tags table") + +;; XXX If a file is in multiple tables, selection may get the wrong one. +;;;###autoload +(defun select-tags-table () + "Select a tags table file from a menu of those you have already used. +The list of tags tables to select from is stored in `tags-table-set-list'; +see the doc of that variable if you want to add names to the list." + (interactive) + (pop-to-buffer "*Tags Table List*") + (setq buffer-read-only nil + buffer-undo-list t) + (erase-buffer) + (let ((set-list tags-table-set-list) + (desired-point nil) + b) + (when tags-table-list + (setq desired-point (point-marker)) + (setq b (point)) + (princ (mapcar 'abbreviate-file-name tags-table-list) (current-buffer)) + (make-text-button b (point) 'type 'tags-select-tags-table + 'etags-table (car tags-table-list)) + (insert "\n")) + (while set-list + (unless (eq (car set-list) tags-table-list) + (setq b (point)) + (princ (mapcar 'abbreviate-file-name (car set-list)) (current-buffer)) + (make-text-button b (point) 'type 'tags-select-tags-table + 'etags-table (car (car set-list))) + (insert "\n")) + (setq set-list (cdr set-list))) + (when tags-file-name + (or desired-point + (setq desired-point (point-marker))) + (setq b (point)) + (insert (abbreviate-file-name tags-file-name)) + (make-text-button b (point) 'type 'tags-select-tags-table + 'etags-table tags-file-name) + (insert "\n")) + (setq set-list (delete tags-file-name + (apply 'nconc (cons (copy-sequence tags-table-list) + (mapcar 'copy-sequence + tags-table-set-list))))) + (while set-list + (setq b (point)) + (insert (abbreviate-file-name (car set-list))) + (make-text-button b (point) 'type 'tags-select-tags-table + 'etags-table (car set-list)) + (insert "\n") + (setq set-list (delete (car set-list) set-list))) + (goto-char (point-min)) + (insert-before-markers + "Type `t' to select a tags table or set of tags tables:\n\n") + (if desired-point + (goto-char desired-point)) + (set-window-start (selected-window) 1 t)) + (set-buffer-modified-p nil) + (select-tags-table-mode)) + +(defvar select-tags-table-mode-map ; Doc string? + (let ((map (make-sparse-keymap))) + (set-keymap-parent map button-buffer-map) + (define-key map "t" 'push-button) + (define-key map " " 'next-line) + (define-key map "\^?" 'previous-line) + (define-key map "n" 'next-line) + (define-key map "p" 'previous-line) + (define-key map "q" 'select-tags-table-quit) + map)) + +(define-derived-mode select-tags-table-mode special-mode "Select Tags Table" + "Major mode for choosing a current tags table among those already loaded." + (setq buffer-read-only t)) + +(defun select-tags-table-select (button) + "Select the tags table named on this line." + (interactive (list (or (button-at (line-beginning-position)) + (error "No tags table on current line")))) + (let ((name (button-get button 'etags-table))) + (visit-tags-table name) + (select-tags-table-quit) + (message "Tags table now %s" name))) + +(defun select-tags-table-quit () + "Kill the buffer and delete the selected window." + (interactive) + (quit-window t (selected-window))) + +;;;###autoload +(defun complete-tag () + "Perform tags completion on the text around point. +Completes to the set of names listed in the current tags table. +The string to complete is chosen in the same way as the default +for \\[find-tag] (which see)." + (interactive) + (or tags-table-list + tags-file-name + (user-error "%s" + (substitute-command-keys + "No tags table loaded; try \\[visit-tags-table]"))) + (let ((comp-data (tags-completion-at-point-function))) + (if (null comp-data) + (user-error "Nothing to complete") + (completion-in-region (car comp-data) (cadr comp-data) + (nth 2 comp-data) + (plist-get (nthcdr 3 comp-data) :predicate))))) + + +;;; Xref backend + +;; Stop searching if we find more than xref-limit matches, as the xref +;; infrastructure is not designed to handle very long lists. +;; Switching to some kind of lazy list might be better, but hopefully +;; we hit the limit rarely. +(defconst etags--xref-limit 1000) + +(defvar etags-xref-find-definitions-tag-order '(tag-exact-match-p + tag-implicit-name-match-p + tag-symbol-match-p) + "Tag order used in `etags-xref-find' to look for definitions.") + +;;;###autoload +(defun etags-xref-find (action id) + (pcase action + (`definitions (etags--xref-find-definitions id)) + (`references + (let ((dirs (if tags-table-list + (mapcar #'file-name-directory tags-table-list) + ;; If no tags files are loaded, prompt for the dir. + (list (read-directory-name "In directory: " nil nil t))))) + (cl-mapcan + (lambda (dir) + (xref-collect-references id dir)) + dirs))) + (`apropos (etags--xref-find-definitions id t)))) + +(defun etags--xref-find-definitions (pattern &optional regexp?) + ;; This emulates the behaviour of `find-tag-in-order' but instead of + ;; returning one match at a time all matches are returned as list. + ;; NOTE: find-tag-tag-order is typically a buffer-local variable. + (let* ((xrefs '()) + (first-time t) + (search-fun (if regexp? #'re-search-forward #'search-forward)) + (marks (make-hash-table :test 'equal)) + (case-fold-search (if (memq tags-case-fold-search '(nil t)) + tags-case-fold-search + case-fold-search))) + (save-excursion + (while (visit-tags-table-buffer (not first-time)) + (setq first-time nil) + (dolist (order-fun (cond (regexp? find-tag-regexp-tag-order) + (t etags-xref-find-definitions-tag-order))) + (goto-char (point-min)) + (while (and (funcall search-fun pattern nil t) + (< (hash-table-count marks) etags--xref-limit)) + (when (funcall order-fun pattern) + (beginning-of-line) + (pcase-let* ((tag-info (etags-snarf-tag)) + (`(,hint ,line . _) tag-info)) + (unless (eq hint t) ; hint==t if we are in a filename line + (let* ((file (file-of-tag)) + (mark-key (cons file line))) + (unless (gethash mark-key marks) + (let ((loc (xref-make-etags-location + tag-info (expand-file-name file)))) + (push (xref-make hint loc) xrefs) + (puthash mark-key t marks))))))))))) + (nreverse xrefs))) + +(defclass xref-etags-location (xref-location) + ((tag-info :type list :initarg :tag-info) + (file :type string :initarg :file + :reader xref-location-group)) + :documentation "Location of an etags tag.") + +(defun xref-make-etags-location (tag-info file) + (make-instance 'xref-etags-location :tag-info tag-info + :file (expand-file-name file))) + +(cl-defmethod xref-location-marker ((l xref-etags-location)) + (with-slots (tag-info file) l + (let ((buffer (find-file-noselect file))) + (with-current-buffer buffer + (etags-goto-tag-location tag-info) + (point-marker))))) + +(cl-defmethod xref-location-line ((l xref-etags-location)) + (with-slots (tag-info) l + (nth 1 tag-info))) + + +(provide 'etags) + +;;; etags.el ends here diff --cc test/manual/etags/tex-src/texinfo.tex index 203dca72c22,00000000000..aa745c68471 mode 100644,000000..100644 --- a/test/manual/etags/tex-src/texinfo.tex +++ b/test/manual/etags/tex-src/texinfo.tex @@@ -1,3350 -1,0 +1,3351 @@@ +%% TeX macros to handle texinfo files + - % Copyright (C) 1985, 1986, 1988, 1990, 1991 Free Software Foundation, Inc. ++% Copyright (C) 1985-1986, 1988, 1990-1991, 2016 Free Software ++% Foundation, Inc. + +%This texinfo.tex file is free software; you can redistribute it and/or +%modify it under the terms of the GNU General Public License as +%published by the Free Software Foundation; either version 2, or (at +%your option) any later version. + +%This texinfo.tex file is distributed in the hope that it will be +%useful, but WITHOUT ANY WARRANTY; without even the implied warranty +%of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +%General Public License for more details. + +%You should have received a copy of the GNU General Public License +%along with this texinfo.tex file; see the file COPYING. If not, write +%to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, +%USA. + + +%In other words, you are welcome to use, share and improve this program. +%You are forbidden to forbid anyone else to use, share and improve +%what you give them. Help stamp out software-hoarding! + +\def\texinfoversion{2.73} +\message{Loading texinfo package [Version \texinfoversion]:} +\message{} + +% Print the version number if in a .fmt file. +\everyjob{\message{[Texinfo version \texinfoversion]}\message{}} + +% Save some parts of plain tex whose names we will redefine. + +\let\ptexlbrace=\{ +\let\ptexrbrace=\} +\let\ptexdots=\dots +\let\ptexdot=\. +\let\ptexstar=\* +\let\ptexend=\end +\let\ptexbullet=\bullet +\let\ptexb=\b +\let\ptexc=\c +\let\ptexi=\i +\let\ptext=\t +\let\ptexl=\l +\let\ptexL=\L + +\def\tie{\penalty 10000\ } % Save plain tex definition of ~. + +\message{Basics,} +\chardef\other=12 + +% If this character appears in an error message or help string, it +% starts a new line in the output. +\newlinechar = `^^J + +\hyphenation{ap-pen-dix} +\hyphenation{mini-buf-fer mini-buf-fers} +\hyphenation{eshell} + +% Margin to add to right of even pages, to left of odd pages. +\newdimen \bindingoffset \bindingoffset=0pt +\newdimen \normaloffset \normaloffset=\hoffset +\newdimen\pagewidth \newdimen\pageheight +\pagewidth=\hsize \pageheight=\vsize + +% Sometimes it is convenient to have everything in the transcript file +% and nothing on the terminal. We don't just call \tracingall here, +% since that produces some useless output on the terminal. +% +\def\gloggingall{\begingroup \globaldefs = 1 \loggingall \endgroup}% +\def\loggingall{\tracingcommands2 \tracingstats2 + \tracingpages1 \tracingoutput1 \tracinglostchars1 + \tracingmacros2 \tracingparagraphs1 \tracingrestores1 + \showboxbreadth\maxdimen\showboxdepth\maxdimen +}% + +%---------------------Begin change----------------------- +% +%%%% For @cropmarks command. +% Dimensions to add cropmarks at corners Added by P. A. MacKay, 12 Nov. 1986 +% +\newdimen\cornerlong \newdimen\cornerthick +\newdimen \topandbottommargin +\newdimen \outerhsize \newdimen \outervsize +\cornerlong=1pc\cornerthick=.3pt % These set size of cropmarks +\outerhsize=7in +%\outervsize=9.5in +% Alternative @smallbook page size is 9.25in +\outervsize=9.25in +\topandbottommargin=.75in +% +%---------------------End change----------------------- + +% \onepageout takes a vbox as an argument. Note that \pagecontents +% does insertions itself, but you have to call it yourself. +\chardef\PAGE=255 \output={\onepageout{\pagecontents\PAGE}} +\def\onepageout#1{\hoffset=\normaloffset +\ifodd\pageno \advance\hoffset by \bindingoffset +\else \advance\hoffset by -\bindingoffset\fi +{\escapechar=`\\\relax % makes sure backslash is used in output files. +\shipout\vbox{{\let\hsize=\pagewidth \makeheadline} \pagebody{#1}% +{\let\hsize=\pagewidth \makefootline}}}% +\advancepageno \ifnum\outputpenalty>-20000 \else\dosupereject\fi} + +%%%% For @cropmarks command %%%% + +% Here is a modification of the main output routine for Near East Publications +% This provides right-angle cropmarks at all four corners. +% The contents of the page are centerlined into the cropmarks, +% and any desired binding offset is added as an \hskip on either +% site of the centerlined box. (P. A. MacKay, 12 November, 1986) +% +\def\croppageout#1{\hoffset=0pt % make sure this doesn't mess things up + \shipout + \vbox to \outervsize{\hsize=\outerhsize + \vbox{\line{\ewtop\hfill\ewtop}} + \nointerlineskip + \line{\vbox{\moveleft\cornerthick\nstop} + \hfill + \vbox{\moveright\cornerthick\nstop}} + \vskip \topandbottommargin + \centerline{\ifodd\pageno\hskip\bindingoffset\fi + \vbox{ + {\let\hsize=\pagewidth \makeheadline} + \pagebody{#1} + {\let\hsize=\pagewidth \makefootline}} + \ifodd\pageno\else\hskip\bindingoffset\fi} + \vskip \topandbottommargin plus1fill minus1fill + \boxmaxdepth\cornerthick + \line{\vbox{\moveleft\cornerthick\nsbot} + \hfill + \vbox{\moveright\cornerthick\nsbot}} + \nointerlineskip + \vbox{\line{\ewbot\hfill\ewbot}} + } + \advancepageno + \ifnum\outputpenalty>-20000 \else\dosupereject\fi} +% +% Do @cropmarks to get crop marks +\def\cropmarks{\let\onepageout=\croppageout } + +\def\pagebody#1{\vbox to\pageheight{\boxmaxdepth=\maxdepth #1}} +{\catcode`\@ =11 +\gdef\pagecontents#1{\ifvoid\topins\else\unvbox\topins\fi +\dimen@=\dp#1 \unvbox#1 +\ifvoid\footins\else\vskip\skip\footins\footnoterule \unvbox\footins\fi +\ifr@ggedbottom \kern-\dimen@ \vfil \fi} +} + +% +% Here are the rules for the cropmarks. Note that they are +% offset so that the space between them is truly \outerhsize or \outervsize +% (P. A. MacKay, 12 November, 1986) +% +\def\ewtop{\vrule height\cornerthick depth0pt width\cornerlong} +\def\nstop{\vbox + {\hrule height\cornerthick depth\cornerlong width\cornerthick}} +\def\ewbot{\vrule height0pt depth\cornerthick width\cornerlong} +\def\nsbot{\vbox + {\hrule height\cornerlong depth\cornerthick width\cornerthick}} + +% Parse an argument, then pass it to #1. +% The argument can be delimited with [...] or with "..." or braces +% or it can be a whole line. +% #1 should be a macro which expects +% an ordinary undelimited TeX argument. + +\def\parsearg #1{\let\next=#1\begingroup\obeylines\futurelet\temp\parseargx} + +\def\parseargx{% +\ifx \obeyedspace\temp \aftergroup\parseargdiscardspace \else% +\aftergroup \parseargline % +\fi \endgroup} + +{\obeyspaces % +\gdef\parseargdiscardspace {\begingroup\obeylines\futurelet\temp\parseargx}} + +\gdef\obeyedspace{\ } + +\def\parseargline{\begingroup \obeylines \parsearglinex} +{\obeylines % +\gdef\parsearglinex #1^^M{\endgroup \next {#1}}} + +\def\flushcr{\ifx\par\lisppar \def\next##1{}\else \let\next=\relax \fi \next} + +%% These are used to keep @begin/@end levels from running away +%% Call \inENV within environments (after a \begingroup) +\newif\ifENV \ENVfalse \def\inENV{\ifENV\relax\else\ENVtrue\fi} +\def\ENVcheck{% +\ifENV\errmessage{Still within an environment. Type Return to continue.} +\endgroup\fi} % This is not perfect, but it should reduce lossage + +% @begin foo is the same as @foo, for now. +\newhelp\EMsimple{Type <Return> to continue} + +\outer\def\begin{\parsearg\beginxxx} + +\def\beginxxx #1{% +\expandafter\ifx\csname #1\endcsname\relax +{\errhelp=\EMsimple \errmessage{Undefined command @begin #1}}\else +\csname #1\endcsname\fi} + +%% @end foo executes the definition of \Efoo. +%% foo can be delimited by doublequotes or brackets. + +\def\end{\parsearg\endxxx} + +\def\endxxx #1{% +\expandafter\ifx\csname E#1\endcsname\relax +\expandafter\ifx\csname #1\endcsname\relax +\errmessage{Undefined command @end #1}\else +\errorE{#1}\fi\fi +\csname E#1\endcsname} +\def\errorE#1{ +{\errhelp=\EMsimple \errmessage{@end #1 not within #1 environment}}} + +% Single-spacing is done by various environments. + +\newskip\singlespaceskip \singlespaceskip = \baselineskip +\def\singlespace{% +{\advance \baselineskip by -\singlespaceskip +\kern \baselineskip}% +\baselineskip=\singlespaceskip +} + +%% Simple single-character @ commands + +% @@ prints an @ +% Kludge this until the fonts are right (grr). +\def\@{{\tt \char '100}} + +% Define @` and @' to be the same as ` and ' +% but suppressing ligatures. +\def\`{{`}} +\def\'{{'}} + +% Used to generate quoted braces. + +\def\mylbrace {{\tt \char '173}} +\def\myrbrace {{\tt \char '175}} +\let\{=\mylbrace +\let\}=\myrbrace + +% @: forces normal size whitespace following. +\def\:{\spacefactor=1000 } + +% @* forces a line break. +\def\*{\hfil\break\hbox{}\ignorespaces} + +% @. is an end-of-sentence period. +\def\.{.\spacefactor=3000 } + +% @w prevents a word break. Without the \leavevmode, @w at the +% beginning of a paragraph, when TeX is still in vertical mode, would +% produce a whole line of output instead of starting the paragraph. +\def\w#1{\leavevmode\hbox{#1}} + +% @group ... @end group forces ... to be all on one page, by enclosing +% it in a TeX vbox. We use \vtop instead of \vbox to construct the box +% to keep its height that of a normal line. According to the rules for +% \topskip (p.114 of the TeXbook), the glue inserted is +% max (\topskip - \ht (first item), 0). If that height is large, +% therefore, no glue is inserted, and the space between the headline and +% the text is small, which looks bad. +% +\def\group{\begingroup + \ifnum\catcode13=\active \else + \errhelp = \groupinvalidhelp + \errmessage{@group invalid in context where filling is enabled}% + \fi + \def\Egroup{\egroup\endgroup}% + \vtop\bgroup +} +% +% TeX puts in an \escapechar (i.e., `@') at the beginning of the help +% message, so this ends up printing `@group can only ...'. +% +\newhelp\groupinvalidhelp{% +group can only be used in environments such as @example,^^J% +where each line of input produces a line of output.} + +% @need space-in-mils +% forces a page break if there is not space-in-mils remaining. + +\newdimen\mil \mil=0.001in + +\def\need{\parsearg\needx} + +% Old definition--didn't work. +%\def\needx #1{\par % +%% This method tries to make TeX break the page naturally +%% if the depth of the box does not fit. +%{\baselineskip=0pt% +%\vtop to #1\mil{\vfil}\kern -#1\mil\penalty 10000 +%\prevdepth=-1000pt +%}} + +\def\needx#1{% + % Go into vertical mode, so we don't make a big box in the middle of a + % paragraph. + \par + % + % Don't add any leading before our big empty box, but allow a page + % break, since the best break might be right here. + \allowbreak + \nointerlineskip + \vtop to #1\mil{\vfil}% + % + % TeX does not even consider page breaks if a penalty added to the + % main vertical list is 10000 or more. But in order to see if the + % empty box we just added fits on the page, we must make it consider + % page breaks. On the other hand, we don't want to actually break the + % page after the empty box. So we use a penalty of 9999. + % + % There is an extremely small chance that TeX will actually break the + % page at this \penalty, if there are no other feasible breakpoints in + % sight. (If the user is using lots of big @group commands, which + % almost-but-not-quite fill up a page, TeX will have a hard time doing + % good page breaking, for example.) However, I could not construct an + % example where a page broke at this \penalty; if it happens in a real + % document, then we can reconsider our strategy. + \penalty9999 + % + % Back up by the size of the box, whether we did a page break or not. + \kern -#1\mil + % + % Do not allow a page break right after this kern. + \nobreak +} + +% @br forces paragraph break + +\let\br = \par + +% @dots{} output some dots + +\def\dots{$\ldots$} + +% @page forces the start of a new page + +\def\page{\par\vfill\supereject} + +% @exdent text.... +% outputs text on separate line in roman font, starting at standard page margin + +% This records the amount of indent in the innermost environment. +% That's how much \exdent should take out. +\newskip\exdentamount + +% This defn is used inside fill environments such as @defun. +\def\exdent{\parsearg\exdentyyy} +\def\exdentyyy #1{{\hfil\break\hbox{\kern -\exdentamount{\rm#1}}\hfil\break}} + +% This defn is used inside nofill environments such as @example. +\def\nofillexdent{\parsearg\nofillexdentyyy} +\def\nofillexdentyyy #1{{\advance \leftskip by -\exdentamount +\leftline{\hskip\leftskip{\rm#1}}}} + +%\hbox{{\rm#1}}\hfil\break}} + +% @include file insert text of that file as input. + +\def\include{\parsearg\includezzz} +\def\includezzz #1{{\def\thisfile{#1}\input #1 +}} + +\def\thisfile{} + +% @center line outputs that line, centered + +\def\center{\parsearg\centerzzz} +\def\centerzzz #1{{\advance\hsize by -\leftskip +\advance\hsize by -\rightskip +\centerline{#1}}} + +% @sp n outputs n lines of vertical space + +\def\sp{\parsearg\spxxx} +\def\spxxx #1{\par \vskip #1\baselineskip} + +% @comment ...line which is ignored... +% @c is the same as @comment +% @ignore ... @end ignore is another way to write a comment + +\def\comment{\catcode 64=\other \catcode 123=\other \catcode 125=\other% +\parsearg \commentxxx} + +\def\commentxxx #1{\catcode 64=0 \catcode 123=1 \catcode 125=2 } + +\let\c=\comment + +% Prevent errors for section commands. +% Used in @ignore and in failing conditionals. +\def\ignoresections{% +\let\chapter=\relax +\let\unnumbered=\relax +\let\top=\relax +\let\unnumberedsec=\relax +\let\unnumberedsection=\relax +\let\unnumberedsubsec=\relax +\let\unnumberedsubsection=\relax +\let\unnumberedsubsubsec=\relax +\let\unnumberedsubsubsection=\relax +\let\section=\relax +\let\subsec=\relax +\let\subsubsec=\relax +\let\subsection=\relax +\let\subsubsection=\relax +\let\appendix=\relax +\let\appendixsec=\relax +\let\appendixsection=\relax +\let\appendixsubsec=\relax +\let\appendixsubsection=\relax +\let\appendixsubsubsec=\relax +\let\appendixsubsubsection=\relax +\let\contents=\relax +\let\smallbook=\relax +\let\titlepage=\relax +} + +\def\ignore{\begingroup\ignoresections +% Make sure that spaces turn into tokens that match what \ignorexxx wants. +\catcode32=10 +\ignorexxx} +\long\def\ignorexxx #1\end ignore{\endgroup\ignorespaces} + +\def\direntry{\begingroup\direntryxxx} +\long\def\direntryxxx #1\end direntry{\endgroup\ignorespaces} + +% Conditionals to test whether a flag is set. + +\def\ifset{\begingroup\ignoresections\parsearg\ifsetxxx} + +\def\ifsetxxx #1{\endgroup +\expandafter\ifx\csname IF#1\endcsname\relax \let\temp=\ifsetfail +\else \let\temp=\relax \fi +\temp} +\def\Eifset{} +\def\ifsetfail{\begingroup\ignoresections\ifsetfailxxx} +\long\def\ifsetfailxxx #1\end ifset{\endgroup\ignorespaces} + +\def\ifclear{\begingroup\ignoresections\parsearg\ifclearxxx} + +\def\ifclearxxx #1{\endgroup +\expandafter\ifx\csname IF#1\endcsname\relax \let\temp=\relax +\else \let\temp=\ifclearfail \fi +\temp} +\def\Eifclear{} +\def\ifclearfail{\begingroup\ignoresections\ifclearfailxxx} +\long\def\ifclearfailxxx #1\end ifclear{\endgroup\ignorespaces} + +% @set foo to set the flag named foo. +% @clear foo to clear the flag named foo. +\def\set{\parsearg\setxxx} +\def\setxxx #1{ +\expandafter\let\csname IF#1\endcsname=\set} + +\def\clear{\parsearg\clearxxx} +\def\clearxxx #1{ +\expandafter\let\csname IF#1\endcsname=\relax} + +% Some texinfo constructs that are trivial in tex + +\def\iftex{} +\def\Eiftex{} +\def\ifinfo{\begingroup\ignoresections\ifinfoxxx} +\long\def\ifinfoxxx #1\end ifinfo{\endgroup\ignorespaces} + +\long\def\menu #1\end menu{} +\def\asis#1{#1} + +% @math means output in math mode. +% We don't use $'s directly in the definition of \math because control +% sequences like \math are expanded when the toc file is written. Then, +% we read the toc file back, the $'s will be normal characters (as they +% should be, according to the definition of Texinfo). So we must use a +% control sequence to switch into and out of math mode. +% +% This isn't quite enough for @math to work properly in indices, but it +% seems unlikely it will ever be needed there. +% +\let\implicitmath = $ +\def\math#1{\implicitmath #1\implicitmath} + +\def\node{\ENVcheck\parsearg\nodezzz} +\def\nodezzz#1{\nodexxx [#1,]} +\def\nodexxx[#1,#2]{\gdef\lastnode{#1}} +\let\lastnode=\relax + +\def\donoderef{\ifx\lastnode\relax\else +\expandafter\expandafter\expandafter\setref{\lastnode}\fi +\let\lastnode=\relax} + +\def\unnumbnoderef{\ifx\lastnode\relax\else +\expandafter\expandafter\expandafter\unnumbsetref{\lastnode}\fi +\let\lastnode=\relax} + +\def\appendixnoderef{\ifx\lastnode\relax\else +\expandafter\expandafter\expandafter\appendixsetref{\lastnode}\fi +\let\lastnode=\relax} + +\let\refill=\relax + +% @setfilename is done at the beginning of every texinfo file. +% So open here the files we need to have open while reading the input. +% This makes it possible to make a .fmt file for texinfo. +\def\setfilename{% + \readauxfile + \opencontents + \openindices + \fixbackslash % Turn off hack to swallow `\input texinfo'. + \global\let\setfilename=\comment % Ignore extra @setfilename cmds. + \comment % Ignore the actual filename. +} + +\outer\def\bye{\pagealignmacro\tracingstats=1\ptexend} + +\def\inforef #1{\inforefzzz #1,,,,**} +\def\inforefzzz #1,#2,#3,#4**{See Info file \file{\losespace#3{}}, + node \samp{\losespace#1{}}} +\def\losespace #1{#1} + +\message{fonts,} + +% Font-change commands. + +% Texinfo supports the sans serif font style, which plain TeX does not. +% So we set up a \sf analogous to plain's \rm, etc. +\newfam\sffam +\def\sf{\fam=\sffam \tensf} +\let\li = \sf % Sometimes we call it \li, not \sf. + +%% Try out Computer Modern fonts at \magstephalf +\let\mainmagstep=\magstephalf + +\ifx\bigger\relax +\let\mainmagstep=\magstep1 +\font\textrm=cmr12 +\font\texttt=cmtt12 +\else +\font\textrm=cmr10 scaled \mainmagstep +\font\texttt=cmtt10 scaled \mainmagstep +\fi +% Instead of cmb10, you many want to use cmbx10. +% cmbx10 is a prettier font on its own, but cmb10 +% looks better when embedded in a line with cmr10. +\font\textbf=cmb10 scaled \mainmagstep +\font\textit=cmti10 scaled \mainmagstep +\font\textsl=cmsl10 scaled \mainmagstep +\font\textsf=cmss10 scaled \mainmagstep +\font\textsc=cmcsc10 scaled \mainmagstep +\font\texti=cmmi10 scaled \mainmagstep +\font\textsy=cmsy10 scaled \mainmagstep + +% A few fonts for @defun, etc. +\font\defbf=cmbx10 scaled \magstep1 %was 1314 +\font\deftt=cmtt10 scaled \magstep1 +\def\df{\let\tentt=\deftt \let\tenbf = \defbf \bf} + +% Fonts for indices and small examples. +% We actually use the slanted font rather than the italic, +% because texinfo normally uses the slanted fonts for that. +% Do not make many font distinctions in general in the index, since they +% aren't very useful. +\font\ninett=cmtt9 +\font\indrm=cmr9 +\font\indit=cmsl9 +\let\indsl=\indit +\let\indtt=\ninett +\let\indsf=\indrm +\let\indbf=\indrm +\let\indsc=\indrm +\font\indi=cmmi9 +\font\indsy=cmsy9 + +% Fonts for headings +\font\chaprm=cmbx12 scaled \magstep2 +\font\chapit=cmti12 scaled \magstep2 +\font\chapsl=cmsl12 scaled \magstep2 +\font\chaptt=cmtt12 scaled \magstep2 +\font\chapsf=cmss12 scaled \magstep2 +\let\chapbf=\chaprm +\font\chapsc=cmcsc10 scaled\magstep3 +\font\chapi=cmmi12 scaled \magstep2 +\font\chapsy=cmsy10 scaled \magstep3 + +\font\secrm=cmbx12 scaled \magstep1 +\font\secit=cmti12 scaled \magstep1 +\font\secsl=cmsl12 scaled \magstep1 +\font\sectt=cmtt12 scaled \magstep1 +\font\secsf=cmss12 scaled \magstep1 +\font\secbf=cmbx12 scaled \magstep1 +\font\secsc=cmcsc10 scaled\magstep2 +\font\seci=cmmi12 scaled \magstep1 +\font\secsy=cmsy10 scaled \magstep2 + +% \font\ssecrm=cmbx10 scaled \magstep1 % This size an font looked bad. +% \font\ssecit=cmti10 scaled \magstep1 % The letters were too crowded. +% \font\ssecsl=cmsl10 scaled \magstep1 +% \font\ssectt=cmtt10 scaled \magstep1 +% \font\ssecsf=cmss10 scaled \magstep1 + +%\font\ssecrm=cmb10 scaled 1315 % Note the use of cmb rather than cmbx. +%\font\ssecit=cmti10 scaled 1315 % Also, the size is a little larger than +%\font\ssecsl=cmsl10 scaled 1315 % being scaled magstep1. +%\font\ssectt=cmtt10 scaled 1315 +%\font\ssecsf=cmss10 scaled 1315 + +%\let\ssecbf=\ssecrm + +\font\ssecrm=cmbx12 scaled \magstephalf +\font\ssecit=cmti12 scaled \magstephalf +\font\ssecsl=cmsl12 scaled \magstephalf +\font\ssectt=cmtt12 scaled \magstephalf +\font\ssecsf=cmss12 scaled \magstephalf +\font\ssecbf=cmbx12 scaled \magstephalf +\font\ssecsc=cmcsc10 scaled \magstep1 +\font\sseci=cmmi12 scaled \magstephalf +\font\ssecsy=cmsy10 scaled \magstep1 +% The smallcaps and symbol fonts should actually be scaled \magstep1.5, +% but that is not a standard magnification. + +% Fonts for title page: +\font\titlerm = cmbx12 scaled \magstep3 +\let\authorrm = \secrm + +% In order for the font changes to affect most math symbols and letters, +% we have to define the \textfont of the standard families. Since +% texinfo doesn't allow for producing subscripts and superscripts, we +% don't bother to reset \scriptfont and \scriptscriptfont (which would +% also require loading a lot more fonts). +% +\def\resetmathfonts{% + \textfont0 = \tenrm \textfont1 = \teni \textfont2 = \tensy + \textfont\itfam = \tenit \textfont\slfam = \tensl \textfont\bffam = \tenbf + \textfont\ttfam = \tentt \textfont\sffam = \tensf +} + + +% The font-changing commands redefine the meanings of \tenSTYLE, instead +% of just \STYLE. We do this so that font changes will continue to work +% in math mode, where it is the current \fam that is relevant in most +% cases, not the current. Plain TeX does, for example, +% \def\bf{\fam=\bffam \tenbf} By redefining \tenbf, we obviate the need +% to redefine \bf itself. +\def\textfonts{% + \let\tenrm=\textrm \let\tenit=\textit \let\tensl=\textsl + \let\tenbf=\textbf \let\tentt=\texttt \let\smallcaps=\textsc + \let\tensf=\textsf \let\teni=\texti \let\tensy=\textsy + \resetmathfonts} +\def\chapfonts{% + \let\tenrm=\chaprm \let\tenit=\chapit \let\tensl=\chapsl + \let\tenbf=\chapbf \let\tentt=\chaptt \let\smallcaps=\chapsc + \let\tensf=\chapsf \let\teni=\chapi \let\tensy=\chapsy + \resetmathfonts} +\def\secfonts{% + \let\tenrm=\secrm \let\tenit=\secit \let\tensl=\secsl + \let\tenbf=\secbf \let\tentt=\sectt \let\smallcaps=\secsc + \let\tensf=\secsf \let\teni=\seci \let\tensy=\secsy + \resetmathfonts} +\def\subsecfonts{% + \let\tenrm=\ssecrm \let\tenit=\ssecit \let\tensl=\ssecsl + \let\tenbf=\ssecbf \let\tentt=\ssectt \let\smallcaps=\ssecsc + \let\tensf=\ssecsf \let\teni=\sseci \let\tensy=\ssecsy + \resetmathfonts} +\def\indexfonts{% + \let\tenrm=\indrm \let\tenit=\indit \let\tensl=\indsl + \let\tenbf=\indbf \let\tentt=\indtt \let\smallcaps=\indsc + \let\tensf=\indsf \let\teni=\indi \let\tensy=\indsy + \resetmathfonts} + +% Set up the default fonts, so we can use them for creating boxes. +% +\textfonts + +% Count depth in font-changes, for error checks +\newcount\fontdepth \fontdepth=0 + +% Fonts for short table of contents. +\font\shortcontrm=cmr12 +\font\shortcontbf=cmbx12 +\font\shortcontsl=cmsl12 + +%% Add scribe-like font environments, plus @l for inline lisp (usually sans +%% serif) and @ii for TeX italic + +% \smartitalic{ARG} outputs arg in italics, followed by an italic correction +% unless the following character is such as not to need one. +\def\smartitalicx{\ifx\next,\else\ifx\next-\else\ifx\next.\else\/\fi\fi\fi} +\def\smartitalic#1{{\sl #1}\futurelet\next\smartitalicx} + +\let\i=\smartitalic +\let\var=\smartitalic +\let\dfn=\smartitalic +\let\emph=\smartitalic +\let\cite=\smartitalic + +\def\b#1{{\bf #1}} +\let\strong=\b + +\def\t#1{{\tt \exhyphenpenalty=10000\rawbackslash \frenchspacing #1}\null} +\let\ttfont = \t +%\def\samp #1{`{\tt \rawbackslash \frenchspacing #1}'\null} +\def\samp #1{`\tclose{#1}'\null} +\def\key #1{{\tt \exhyphenpenalty=10000\uppercase{#1}}\null} +\def\ctrl #1{{\tt \rawbackslash \hat}#1} + +\let\file=\samp + +% @code is a modification of @t, +% which makes spaces the same size as normal in the surrounding text. +\newdimen\tclosesave +\newdimen\tcloserm +\def\tclose#1{{\rm \tcloserm=\fontdimen2\font \tt \tclosesave=\fontdimen2\font +\fontdimen2\font=\tcloserm +% prevent breaking lines at hyphens. +\exhyphenpenalty=10000 +\def\ {{\fontdimen2\font=\tclosesave{} }}% + \rawbackslash \frenchspacing #1\fontdimen2\font=\tclosesave}\null} +\let\code=\tclose +%\let\exp=\tclose %Was temporary + +% @kbd is like @code, except that if the argument is just one @key command, +% then @kbd has no effect. + +\def\xkey{\key} +\def\kbdfoo#1#2#3\par{\def\one{#1}\def\three{#3}\def\threex{??}% +\ifx\one\xkey\ifx\threex\three \key{#2}% +\else\tclose{\look}\fi +\else\tclose{\look}\fi} + +% Typeset a dimension, e.g., `in' or `pt'. The only reason for the +% argument is to make the input look right: @dmn{pt} instead of +% @dmn{}pt. +% +\def\dmn#1{\thinspace #1} + +\def\kbd#1{\def\look{#1}\expandafter\kbdfoo\look??\par} + +\def\l#1{{\li #1}\null} % + +\def\r#1{{\rm #1}} % roman font +% Use of \lowercase was suggested. +\def\sc#1{{\smallcaps#1}} % smallcaps font +\def\ii#1{{\it #1}} % italic font + +\message{page headings,} + +\newskip\titlepagetopglue \titlepagetopglue = 1.5in +\newskip\titlepagebottomglue \titlepagebottomglue = 2pc + +% First the title page. Must do @settitle before @titlepage. +\def\titlefont#1{{\titlerm #1}} + +\newtoks\realeverypar +\newif\ifseenauthor +\newif\iffinishedtitlepage + +\def\titlepage{\begingroup \parindent=0pt \textfonts + \let\subtitlerm=\tenrm +% I deinstalled the following change because \cmr12 is undefined. +% This change was not in the ChangeLog anyway. --rms. +% \let\subtitlerm=\cmr12 + \def\subtitlefont{\subtitlerm \normalbaselineskip = 13pt \normalbaselines}% + % + \def\authorfont{\authorrm \normalbaselineskip = 16pt \normalbaselines}% + % + % Leave some space at the very top of the page. + \vglue\titlepagetopglue + % + % Now you can print the title using @title. + \def\title{\parsearg\titlezzz}% + \def\titlezzz##1{\leftline{\titlefont{##1}} + % print a rule at the page bottom also. + \finishedtitlepagefalse + \vskip4pt \hrule height 4pt \vskip4pt}% + % No rule at page bottom unless we print one at the top with @title. + \finishedtitlepagetrue + % + % Now you can put text using @subtitle. + \def\subtitle{\parsearg\subtitlezzz}% + \def\subtitlezzz##1{{\subtitlefont \rightline{##1}}}% + % + % @author should come last, but may come many times. + \def\author{\parsearg\authorzzz}% + \def\authorzzz##1{\ifseenauthor\else\vskip 0pt plus 1filll\seenauthortrue\fi + {\authorfont \leftline{##1}}}% + % + % Most title ``pages'' are actually two pages long, with space + % at the top of the second. We don't want the ragged left on the second. + \let\oldpage = \page + \def\page{% + \iffinishedtitlepage\else + \finishtitlepage + \fi + \oldpage + \let\page = \oldpage + \hbox{}}% +% \def\page{\oldpage \hbox{}} +} + +\def\Etitlepage{% + \iffinishedtitlepage\else + \finishtitlepage + \fi + % It is important to do the page break before ending the group, + % because the headline and footline are only empty inside the group. + % If we use the new definition of \page, we always get a blank page + % after the title page, which we certainly don't want. + \oldpage + \endgroup + \HEADINGSon +} + +\def\finishtitlepage{% + \vskip4pt \hrule height 2pt + \vskip\titlepagebottomglue + \finishedtitlepagetrue +} + +%%% Set up page headings and footings. + +\let\thispage=\folio + +\newtoks \evenheadline % Token sequence for heading line of even pages +\newtoks \oddheadline % Token sequence for heading line of odd pages +\newtoks \evenfootline % Token sequence for footing line of even pages +\newtoks \oddfootline % Token sequence for footing line of odd pages + +% Now make Tex use those variables +\headline={{\textfonts\rm \ifodd\pageno \the\oddheadline + \else \the\evenheadline \fi}} +\footline={{\textfonts\rm \ifodd\pageno \the\oddfootline + \else \the\evenfootline \fi}\HEADINGShook} +\let\HEADINGShook=\relax + +% Commands to set those variables. +% For example, this is what @headings on does +% @evenheading @thistitle|@thispage|@thischapter +% @oddheading @thischapter|@thispage|@thistitle +% @evenfooting @thisfile|| +% @oddfooting ||@thisfile + +\def\evenheading{\parsearg\evenheadingxxx} +\def\oddheading{\parsearg\oddheadingxxx} +\def\everyheading{\parsearg\everyheadingxxx} + +\def\evenfooting{\parsearg\evenfootingxxx} +\def\oddfooting{\parsearg\oddfootingxxx} +\def\everyfooting{\parsearg\everyfootingxxx} + +{\catcode`\@=0 % + +\gdef\evenheadingxxx #1{\evenheadingyyy #1@|@|@|@|\finish} +\gdef\evenheadingyyy #1@|#2@|#3@|#4\finish{% +\global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + +\gdef\oddheadingxxx #1{\oddheadingyyy #1@|@|@|@|\finish} +\gdef\oddheadingyyy #1@|#2@|#3@|#4\finish{% +\global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + +\gdef\everyheadingxxx #1{\everyheadingyyy #1@|@|@|@|\finish} +\gdef\everyheadingyyy #1@|#2@|#3@|#4\finish{% +\global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}} +\global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + +\gdef\evenfootingxxx #1{\evenfootingyyy #1@|@|@|@|\finish} +\gdef\evenfootingyyy #1@|#2@|#3@|#4\finish{% +\global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + +\gdef\oddfootingxxx #1{\oddfootingyyy #1@|@|@|@|\finish} +\gdef\oddfootingyyy #1@|#2@|#3@|#4\finish{% +\global\oddfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + +\gdef\everyfootingxxx #1{\everyfootingyyy #1@|@|@|@|\finish} +\gdef\everyfootingyyy #1@|#2@|#3@|#4\finish{% +\global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}} +\global\oddfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} +% +}% unbind the catcode of @. + +% @headings double turns headings on for double-sided printing. +% @headings single turns headings on for single-sided printing. +% @headings off turns them off. +% @headings on same as @headings double, retained for compatibility. +% @headings after turns on double-sided headings after this page. +% @headings doubleafter turns on double-sided headings after this page. +% @headings singleafter turns on single-sided headings after this page. +% By default, they are off. + +\def\headings #1 {\csname HEADINGS#1\endcsname} + +\def\HEADINGSoff{ +\global\evenheadline={\hfil} \global\evenfootline={\hfil} +\global\oddheadline={\hfil} \global\oddfootline={\hfil}} +\HEADINGSoff +% When we turn headings on, set the page number to 1. +% For double-sided printing, put current file name in lower left corner, +% chapter name on inside top of right hand pages, document +% title on inside top of left hand pages, and page numbers on outside top +% edge of all pages. +\def\HEADINGSdouble{ +%\pagealignmacro +\global\pageno=1 +\global\evenfootline={\hfil} +\global\oddfootline={\hfil} +\global\evenheadline={\line{\folio\hfil\thistitle}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +} +% For single-sided printing, chapter title goes across top left of page, +% page number on top right. +\def\HEADINGSsingle{ +%\pagealignmacro +\global\pageno=1 +\global\evenfootline={\hfil} +\global\oddfootline={\hfil} +\global\evenheadline={\line{\thischapter\hfil\folio}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +} +\def\HEADINGSon{\HEADINGSdouble} + +\def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdoublex} +\let\HEADINGSdoubleafter=\HEADINGSafter +\def\HEADINGSdoublex{% +\global\evenfootline={\hfil} +\global\oddfootline={\hfil} +\global\evenheadline={\line{\folio\hfil\thistitle}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +} + +\def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsinglex} +\def\HEADINGSsinglex{% +\global\evenfootline={\hfil} +\global\oddfootline={\hfil} +\global\evenheadline={\line{\thischapter\hfil\folio}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +} + +% Subroutines used in generating headings +% Produces Day Month Year style of output. +\def\today{\number\day\space +\ifcase\month\or +January\or February\or March\or April\or May\or June\or +July\or August\or September\or October\or November\or December\fi +\space\number\year} + +% Use this if you want the Month Day, Year style of output. +%\def\today{\ifcase\month\or +%January\or February\or March\or April\or May\or June\or +%July\or August\or September\or October\or November\or December\fi +%\space\number\day, \number\year} + +% @settitle line... specifies the title of the document, for headings +% It generates no output of its own + +\def\thistitle{No Title} +\def\settitle{\parsearg\settitlezzz} +\def\settitlezzz #1{\gdef\thistitle{#1}} + +\message{tables,} + +% @tabs -- simple alignment + +% These don't work. For one thing, \+ is defined as outer. +% So these macros cannot even be defined. + +%\def\tabs{\parsearg\tabszzz} +%\def\tabszzz #1{\settabs\+#1\cr} +%\def\tabline{\parsearg\tablinezzz} +%\def\tablinezzz #1{\+#1\cr} +%\def\&{&} + +% Tables -- @table, @ftable, @vtable, @item(x), @kitem(x), @xitem(x). + +% default indentation of table text +\newdimen\tableindent \tableindent=.8in +% default indentation of @itemize and @enumerate text +\newdimen\itemindent \itemindent=.3in +% margin between end of table item and start of table text. +\newdimen\itemmargin \itemmargin=.1in + +% used internally for \itemindent minus \itemmargin +\newdimen\itemmax + +% Note @table, @vtable, and @vtable define @item, @itemx, etc., with +% these defs. +% They also define \itemindex +% to index the item name in whatever manner is desired (perhaps none). + +\def\internalBitem{\smallbreak \parsearg\itemzzz} +\def\internalBitemx{\par \parsearg\itemzzz} + +\def\internalBxitem "#1"{\def\xitemsubtopix{#1} \smallbreak \parsearg\xitemzzz} +\def\internalBxitemx "#1"{\def\xitemsubtopix{#1} \par \parsearg\xitemzzz} + +\def\internalBkitem{\smallbreak \parsearg\kitemzzz} +\def\internalBkitemx{\par \parsearg\kitemzzz} + +\def\kitemzzz #1{\dosubind {kw}{\code{#1}}{for {\bf \lastfunction}}% + \itemzzz {#1}} + +\def\xitemzzz #1{\dosubind {kw}{\code{#1}}{for {\bf \xitemsubtopic}}% + \itemzzz {#1}} + +\def\itemzzz #1{\begingroup % + \advance\hsize by -\rightskip + \advance\hsize by -\tableindent + \setbox0=\hbox{\itemfont{#1}}% + \itemindex{#1}% + \nobreak % This prevents a break before @itemx. + % + % Be sure we are not still in the middle of a paragraph. + \parskip=0in + \par + % + % If the item text does not fit in the space we have, put it on a line + % by itself, and do not allow a page break either before or after that + % line. We do not start a paragraph here because then if the next + % command is, e.g., @kindex, the whatsit would get put into the + % horizontal list on a line by itself, resulting in extra blank space. + \ifdim \wd0>\itemmax + \setbox0=\hbox{\hskip \leftskip \hskip -\tableindent \unhbox0}\box0 + \nobreak + \else + % The item text fits into the space. Start a paragraph, so that the + % following text (if any) will end up on the same line. Since that + % text will be indented by \tableindent, we make the item text be in + % a zero-width box. + \noindent + \rlap{\hskip -\tableindent\box0}% + \fi + \endgroup +} + +\def\item{\errmessage{@item while not in a table}} +\def\itemx{\errmessage{@itemx while not in a table}} +\def\kitem{\errmessage{@kitem while not in a table}} +\def\kitemx{\errmessage{@kitemx while not in a table}} +\def\xitem{\errmessage{@xitem while not in a table}} +\def\xitemx{\errmessage{@xitemx while not in a table}} + +%% Contains a kludge to get @end[description] to work +\def\description{\tablez{\dontindex}{1}{}{}{}{}} + +\def\table{\begingroup\inENV\obeylines\obeyspaces\tablex} +{\obeylines\obeyspaces% +\gdef\tablex #1^^M{% +\tabley\dontindex#1 \endtabley}} + +\def\ftable{\begingroup\inENV\obeylines\obeyspaces\ftablex} +{\obeylines\obeyspaces% +\gdef\ftablex #1^^M{% +\tabley\fnitemindex#1 \endtabley +\def\Eftable{\endgraf\endgroup\afterenvbreak}% +\let\Etable=\relax}} + +\def\vtable{\begingroup\inENV\obeylines\obeyspaces\vtablex} +{\obeylines\obeyspaces% +\gdef\vtablex #1^^M{% +\tabley\vritemindex#1 \endtabley +\def\Evtable{\endgraf\endgroup\afterenvbreak}% +\let\Etable=\relax}} + +\def\dontindex #1{} +\def\fnitemindex #1{\doind {fn}{\code{#1}}}% +\def\vritemindex #1{\doind {vr}{\code{#1}}}% + +{\obeyspaces % +\gdef\tabley#1#2 #3 #4 #5 #6 #7\endtabley{\endgroup% +\tablez{#1}{#2}{#3}{#4}{#5}{#6}}} + +\def\tablez #1#2#3#4#5#6{% +\aboveenvbreak % +\begingroup % +\def\Edescription{\Etable}% Neccessary kludge. +\let\itemindex=#1% +\ifnum 0#3>0 \advance \leftskip by #3\mil \fi % +\ifnum 0#4>0 \tableindent=#4\mil \fi % +\ifnum 0#5>0 \advance \rightskip by #5\mil \fi % +\def\itemfont{#2}% +\itemmax=\tableindent % +\advance \itemmax by -\itemmargin % +\advance \leftskip by \tableindent % +\exdentamount=\tableindent +\parindent = 0pt +\parskip = \smallskipamount +\ifdim \parskip=0pt \parskip=2pt \fi% +\def\Etable{\endgraf\endgroup\afterenvbreak}% +\let\item = \internalBitem % +\let\itemx = \internalBitemx % +\let\kitem = \internalBkitem % +\let\kitemx = \internalBkitemx % +\let\xitem = \internalBxitem % +\let\xitemx = \internalBxitemx % +} + +% This is the counter used by @enumerate, which is really @itemize + +\newcount \itemno + +\def\itemize{\parsearg\itemizezzz} + +\def\itemizezzz #1{% + \begingroup % ended by the @end itemsize + \itemizey {#1}{\Eitemize} +} + +\def\itemizey #1#2{% +\aboveenvbreak % +\itemmax=\itemindent % +\advance \itemmax by -\itemmargin % +\advance \leftskip by \itemindent % +\exdentamount=\itemindent +\parindent = 0pt % +\parskip = \smallskipamount % +\ifdim \parskip=0pt \parskip=2pt \fi% +\def#2{\endgraf\endgroup\afterenvbreak}% +\def\itemcontents{#1}% +\let\item=\itemizeitem} + +\def\bullet{$\ptexbullet$} +\def\minus{$-$} + +% Set sfcode to normal for the chars that usually have another value. +% These are `.?!:;,' +\def\frenchspacing{\sfcode46=1000 \sfcode63=1000 \sfcode33=1000 + \sfcode58=1000 \sfcode59=1000 \sfcode44=1000 } + +% \splitoff TOKENS\endmark defines \first to be the first token in +% TOKENS, and \rest to be the remainder. +% +\def\splitoff#1#2\endmark{\def\first{#1}\def\rest{#2}}% + +% Allow an optional argument of an uppercase letter, lowercase letter, +% or number, to specify the first label in the enumerated list. No +% argument is the same as `1'. +% +\def\enumerate{\parsearg\enumeratezzz} +\def\enumeratezzz #1{\enumeratey #1 \endenumeratey} +\def\enumeratey #1 #2\endenumeratey{% + \begingroup % ended by the @end enumerate + % + % If we were given no argument, pretend we were given `1'. + \def\thearg{#1}% + \ifx\thearg\empty \def\thearg{1}\fi + % + % Detect if the argument is a single token. If so, it might be a + % letter. Otherwise, the only valid thing it can be is a number. + % (We will always have one token, because of the test we just made. + % This is a good thing, since \splitoff doesn't work given nothing at + % all -- the first parameter is undelimited.) + \expandafter\splitoff\thearg\endmark + \ifx\rest\empty + % Only one token in the argument. It could still be anything. + % A ``lowercase letter'' is one whose \lccode is nonzero. + % An ``uppercase letter'' is one whose \lccode is both nonzero, and + % not equal to itself. + % Otherwise, we assume it's a number. + % + % We need the \relax at the end of the \ifnum lines to stop TeX from + % continuing to look for a <number>. + % + \ifnum\lccode\expandafter`\thearg=0\relax + \numericenumerate % a number (we hope) + \else + % It's a letter. + \ifnum\lccode\expandafter`\thearg=\expandafter`\thearg\relax + \lowercaseenumerate % lowercase letter + \else + \uppercaseenumerate % uppercase letter + \fi + \fi + \else + % Multiple tokens in the argument. We hope it's a number. + \numericenumerate + \fi +} + +% An @enumerate whose labels are integers. The starting integer is +% given in \thearg. +% +\def\numericenumerate{% + \itemno = \thearg + \startenumeration{\the\itemno}% +} + +% The starting (lowercase) letter is in \thearg. +\def\lowercaseenumerate{% + \itemno = \expandafter`\thearg + \startenumeration{% + % Be sure we're not beyond the end of the alphabet. + \ifnum\itemno=0 + \errmessage{No more lowercase letters in @enumerate; get a bigger + alphabet}% + \fi + \char\lccode\itemno + }% +} + +% The starting (uppercase) letter is in \thearg. +\def\uppercaseenumerate{% + \itemno = \expandafter`\thearg + \startenumeration{% + % Be sure we're not beyond the end of the alphabet. + \ifnum\itemno=0 + \errmessage{No more uppercase letters in @enumerate; get a bigger + alphabet} + \fi + \char\uccode\itemno + }% +} + +% Call itemizey, adding a period to the first argument and supplying the +% common last two arguments. Also subtract one from the initial value in +% \itemno, since @item increments \itemno. +% +\def\startenumeration#1{% + \advance\itemno by -1 + \itemizey{#1.}\Eenumerate\flushcr +} + +% @alphaenumerate and @capsenumerate are abbreviations for giving an arg +% to @enumerate. +% +\def\alphaenumerate{\enumerate{a}} +\def\capsenumerate{\enumerate{A}} +\def\Ealphaenumerate{\Eenumerate} +\def\Ecapsenumerate{\Eenumerate} + +% Definition of @item while inside @itemize. + +\def\itemizeitem{% +\advance\itemno by 1 +{\let\par=\endgraf \smallbreak}% +\ifhmode \errmessage{\in hmode at itemizeitem}\fi +{\parskip=0in \hskip 0pt +\hbox to 0pt{\hss \itemcontents\hskip \itemmargin}% +\vadjust{\penalty 1200}}% +\flushcr} + +\message{indexing,} +% Index generation facilities + +% Define \newwrite to be identical to plain tex's \newwrite +% except not \outer, so it can be used within \newindex. +{\catcode`\@=11 +\gdef\newwrite{\alloc@7\write\chardef\sixt@@n}} + +% \newindex {foo} defines an index named foo. +% It automatically defines \fooindex such that +% \fooindex ...rest of line... puts an entry in the index foo. +% It also defines \fooindfile to be the number of the output channel for +% the file that accumulates this index. The file's extension is foo. +% The name of an index should be no more than 2 characters long +% for the sake of vms. + +\def\newindex #1{ +\expandafter\newwrite \csname#1indfile\endcsname% Define number for output file +\openout \csname#1indfile\endcsname \jobname.#1 % Open the file +\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex +\noexpand\doindex {#1}} +} + +% @defindex foo == \newindex{foo} + +\def\defindex{\parsearg\newindex} + +% Define @defcodeindex, like @defindex except put all entries in @code. + +\def\newcodeindex #1{ +\expandafter\newwrite \csname#1indfile\endcsname% Define number for output file +\openout \csname#1indfile\endcsname \jobname.#1 % Open the file +\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex +\noexpand\docodeindex {#1}} +} + +\def\defcodeindex{\parsearg\newcodeindex} + +% @synindex foo bar makes index foo feed into index bar. +% Do this instead of @defindex foo if you don't want it as a separate index. +\def\synindex #1 #2 {% +\expandafter\let\expandafter\synindexfoo\expandafter=\csname#2indfile\endcsname +\expandafter\let\csname#1indfile\endcsname=\synindexfoo +\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex +\noexpand\doindex {#2}}% +} + +% @syncodeindex foo bar similar, but put all entries made for index foo +% inside @code. +\def\syncodeindex #1 #2 {% +\expandafter\let\expandafter\synindexfoo\expandafter=\csname#2indfile\endcsname +\expandafter\let\csname#1indfile\endcsname=\synindexfoo +\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex +\noexpand\docodeindex {#2}}% +} + +% Define \doindex, the driver for all \fooindex macros. +% Argument #1 is generated by the calling \fooindex macro, +% and it is "foo", the name of the index. + +% \doindex just uses \parsearg; it calls \doind for the actual work. +% This is because \doind is more useful to call from other macros. + +% There is also \dosubind {index}{topic}{subtopic} +% which makes an entry in a two-level index such as the operation index. + +\def\doindex#1{\edef\indexname{#1}\parsearg\singleindexer} +\def\singleindexer #1{\doind{\indexname}{#1}} + +% like the previous two, but they put @code around the argument. +\def\docodeindex#1{\edef\indexname{#1}\parsearg\singlecodeindexer} +\def\singlecodeindexer #1{\doind{\indexname}{\code{#1}}} + +\def\indexdummies{% +\def\_{{\realbackslash _}}% +\def\w{\realbackslash w }% +\def\bf{\realbackslash bf }% +\def\rm{\realbackslash rm }% +\def\sl{\realbackslash sl }% +\def\sf{\realbackslash sf}% +\def\tt{\realbackslash tt}% +\def\gtr{\realbackslash gtr}% +\def\less{\realbackslash less}% +\def\hat{\realbackslash hat}% +\def\char{\realbackslash char}% +\def\TeX{\realbackslash TeX}% +\def\dots{\realbackslash dots }% +\def\copyright{\realbackslash copyright }% +\def\tclose##1{\realbackslash tclose {##1}}% +\def\code##1{\realbackslash code {##1}}% +\def\samp##1{\realbackslash samp {##1}}% +\def\t##1{\realbackslash r {##1}}% +\def\r##1{\realbackslash r {##1}}% +\def\i##1{\realbackslash i {##1}}% +\def\b##1{\realbackslash b {##1}}% +\def\cite##1{\realbackslash cite {##1}}% +\def\key##1{\realbackslash key {##1}}% +\def\file##1{\realbackslash file {##1}}% +\def\var##1{\realbackslash var {##1}}% +\def\kbd##1{\realbackslash kbd {##1}}% +} + +% \indexnofonts no-ops all font-change commands. +% This is used when outputting the strings to sort the index by. +\def\indexdummyfont#1{#1} +\def\indexdummytex{TeX} +\def\indexdummydots{...} + +\def\indexnofonts{% +\let\w=\indexdummyfont +\let\t=\indexdummyfont +\let\r=\indexdummyfont +\let\i=\indexdummyfont +\let\b=\indexdummyfont +\let\emph=\indexdummyfont +\let\strong=\indexdummyfont +\let\cite=\indexdummyfont +\let\sc=\indexdummyfont +%Don't no-op \tt, since it isn't a user-level command +% and is used in the definitions of the active chars like <, >, |... +%\let\tt=\indexdummyfont +\let\tclose=\indexdummyfont +\let\code=\indexdummyfont +\let\file=\indexdummyfont +\let\samp=\indexdummyfont +\let\kbd=\indexdummyfont +\let\key=\indexdummyfont +\let\var=\indexdummyfont +\let\TeX=\indexdummytex +\let\dots=\indexdummydots +} + +% To define \realbackslash, we must make \ not be an escape. +% We must first make another character (@) an escape +% so we do not become unable to do a definition. + +{\catcode`\@=0 \catcode`\\=\other +@gdef@realbackslash{\}} + +\let\indexbackslash=0 %overridden during \printindex. + +\def\doind #1#2{% +{\count10=\lastpenalty % +{\indexdummies % Must do this here, since \bf, etc expand at this stage +\escapechar=`\\% +{\let\folio=0% Expand all macros now EXCEPT \folio +\def\rawbackslashxx{\indexbackslash}% \indexbackslash isn't defined now +% so it will be output as is; and it will print as backslash in the indx. +% +% Now process the index-string once, with all font commands turned off, +% to get the string to sort the index by. +{\indexnofonts +\xdef\temp1{#2}% +}% +% Now produce the complete index entry. We process the index-string again, +% this time with font commands expanded, to get what to print in the index. +\edef\temp{% +\write \csname#1indfile\endcsname{% +\realbackslash entry {\temp1}{\folio}{#2}}}% +\temp }% +}\penalty\count10}} + +\def\dosubind #1#2#3{% +{\count10=\lastpenalty % +{\indexdummies % Must do this here, since \bf, etc expand at this stage +\escapechar=`\\% +{\let\folio=0% +\def\rawbackslashxx{\indexbackslash}% +% +% Now process the index-string once, with all font commands turned off, +% to get the string to sort the index by. +{\indexnofonts +\xdef\temp1{#2 #3}% +}% +% Now produce the complete index entry. We process the index-string again, +% this time with font commands expanded, to get what to print in the index. +\edef\temp{% +\write \csname#1indfile\endcsname{% +\realbackslash entry {\temp1}{\folio}{#2}{#3}}}% +\temp }% +}\penalty\count10}} + +% The index entry written in the file actually looks like +% \entry {sortstring}{page}{topic} +% or +% \entry {sortstring}{page}{topic}{subtopic} +% The texindex program reads in these files and writes files +% containing these kinds of lines: +% \initial {c} +% before the first topic whose initial is c +% \entry {topic}{pagelist} +% for a topic that is used without subtopics +% \primary {topic} +% for the beginning of a topic that is used with subtopics +% \secondary {subtopic}{pagelist} +% for each subtopic. + +% Define the user-accessible indexing commands +% @findex, @vindex, @kindex, @cindex. + +\def\findex {\fnindex} +\def\kindex {\kyindex} +\def\cindex {\cpindex} +\def\vindex {\vrindex} +\def\tindex {\tpindex} +\def\pindex {\pgindex} + +\def\cindexsub {\begingroup\obeylines\cindexsub} +{\obeylines % +\gdef\cindexsub "#1" #2^^M{\endgroup % +\dosubind{cp}{#2}{#1}}} + +% Define the macros used in formatting output of the sorted index material. + +% This is what you call to cause a particular index to get printed. +% Write +% @unnumbered Function Index +% @printindex fn + +\def\printindex{\parsearg\doprintindex} + +\def\doprintindex#1{% + \tex + \dobreak \chapheadingskip {10000} + \catcode`\%=\other\catcode`\&=\other\catcode`\#=\other + \catcode`\$=\other\catcode`\_=\other + \catcode`\~=\other + % + % The following don't help, since the chars were translated + % when the raw index was written, and their fonts were discarded + % due to \indexnofonts. + %\catcode`\"=\active + %\catcode`\^=\active + %\catcode`\_=\active + %\catcode`\|=\active + %\catcode`\<=\active + %\catcode`\>=\active + % % + \def\indexbackslash{\rawbackslashxx} + \indexfonts\rm \tolerance=9500 \advance\baselineskip -1pt + \begindoublecolumns + % + % See if the index file exists and is nonempty. + \openin 1 \jobname.#1s + \ifeof 1 + % \enddoublecolumns gets confused if there is no text in the index, + % and it loses the chapter title and the aux file entries for the + % index. The easiest way to prevent this problem is to make sure + % there is some text. + (Index is nonexistent) + \else + % + % If the index file exists but is empty, then \openin leaves \ifeof + % false. We have to make TeX try to read something from the file, so + % it can discover if there is anything in it. + \read 1 to \temp + \ifeof 1 + (Index is empty) + \else + \input \jobname.#1s + \fi + \fi + \closein 1 + \enddoublecolumns + \Etex +} + +% These macros are used by the sorted index file itself. +% Change them to control the appearance of the index. + +% Same as \bigskipamount except no shrink. +% \balancecolumns gets confused if there is any shrink. +\newskip\initialskipamount \initialskipamount 12pt plus4pt + +\def\initial #1{% +{\let\tentt=\sectt \let\tt=\sectt \let\sf=\sectt +\ifdim\lastskip<\initialskipamount +\removelastskip \penalty-200 \vskip \initialskipamount\fi +\line{\secbf#1\hfill}\kern 2pt\penalty10000}} + +\def\entry #1#2{\begingroup + \parfillskip=0in \parskip=0in \parindent=0in + % + % \hangindent is only relevant when the page number and the entry text + % don't fit on one line. In that case, bob suggests starting the dots + % pretty far over on the line. + % \hangafter is reset to 1 at the start of each paragraph. + \hangindent=.75\hsize + \noindent + % + % Don't break the text of the index entry. + \hbox{#1}% + % + % If we must, put the page number on a line of its own, and fill out + % this line with blank space. (The \hfil is overwhelmed with the + % fill leaders glue in \indexdotfill if the page number does fit.) + \hfil\penalty50 + \null\nobreak\indexdotfill % Have leaders before the page number. + % + % The `\ ' here is removed by the implicit \unskip that TeX does as + % part of (the primitive) \par. Without, a spurious underfull \hbox ensues. + \ #2% The page number ends the paragraph. + \par +\endgroup} + +% Like \dotfill except takes at least 1 em. +\def\indexdotfill{\cleaders + \hbox{$\mathsurround=0pt \mkern1.5mu . \mkern1.5mu$}\hskip 1em plus 1fill} + +\def\primary #1{\line{#1\hfil}} + +\newskip\secondaryindent \secondaryindent=0.5cm + +\def\secondary #1#2{ +{\parfillskip=0in \parskip=0in +\hangindent =1in \hangafter=1 +\noindent\hskip\secondaryindent\hbox{#1}\indexdotfill #2\par +}} + +%% Define two-column mode, which is used in indexes. +%% Adapted from the TeXBook, page 416 +\catcode `\@=11 + +\newbox\partialpage + +\newdimen\doublecolumnhsize \doublecolumnhsize = 3.11in +\newdimen\doublecolumnvsize \doublecolumnvsize = 19.1in +\newdimen\availdimen@ + +\def\begindoublecolumns{\begingroup + \output={\global\setbox\partialpage= + \vbox{\unvbox255\kern -\topskip \kern \baselineskip}}\eject + \output={\doublecolumnout}% + \hsize=\doublecolumnhsize \vsize=\doublecolumnvsize} +\def\enddoublecolumns{\output={\balancecolumns}\eject + \endgroup \pagegoal=\vsize} + +\def\doublecolumnout{\splittopskip=\topskip \splitmaxdepth=\maxdepth + \dimen@=\pageheight \advance\dimen@ by-\ht\partialpage + \setbox0=\vsplit255 to\dimen@ \setbox2=\vsplit255 to\dimen@ + \onepageout\pagesofar \unvbox255 \penalty\outputpenalty} +\def\pagesofar{\unvbox\partialpage % + \hsize=\doublecolumnhsize % have to restore this since output routine +% changes it to set cropmarks (P. A. MacKay, 12 Nov. 1986) + \wd0=\hsize \wd2=\hsize \hbox to\pagewidth{\box0\hfil\box2}} +\def\balancecolumns{% +% Unset the glue. + \setbox255=\vbox{\unvbox255} + \dimen@=\ht255 + \advance\dimen@ by\topskip \advance\dimen@ by-\baselineskip + \divide\dimen@ by2 + \availdimen@=\pageheight \advance\availdimen@ by-\ht\partialpage +% If the remaining data is too big for one page, +% output one page normally, then work with what remains. + \ifdim \dimen@>\availdimen@ + { + \splittopskip=\topskip \splitmaxdepth=\maxdepth + \dimen@=\pageheight \advance\dimen@ by-\ht\partialpage + \setbox0=\vsplit255 to\dimen@ \setbox2=\vsplit255 to\dimen@ + \onepageout\pagesofar + } +% Recompute size of what remains, in case we just output some of it. + \dimen@=\ht255 + \advance\dimen@ by\topskip \advance\dimen@ by-\baselineskip + \divide\dimen@ by2 + \fi + \setbox0=\vbox{\unvbox255} + \splittopskip=\topskip + {\vbadness=10000 \loop \global\setbox3=\copy0 + \global\setbox1=\vsplit3 to\dimen@ + \ifdim\ht3>\dimen@ \global\advance\dimen@ by1pt \repeat} + \setbox0=\vbox to\dimen@{\unvbox1} \setbox2=\vbox to\dimen@{\unvbox3} + \pagesofar} + +\catcode `\@=\other +\message{sectioning,} +% Define chapters, sections, etc. + +\newcount \chapno +\newcount \secno \secno=0 +\newcount \subsecno \subsecno=0 +\newcount \subsubsecno \subsubsecno=0 + +% This counter is funny since it counts through charcodes of letters A, B, ... +\newcount \appendixno \appendixno = `\@ +\def\appendixletter{\char\the\appendixno} + +\newwrite \contentsfile +% This is called from \setfilename. +\def\opencontents{\openout \contentsfile = \jobname.toc} + +% Each @chapter defines this as the name of the chapter. +% page headings and footings can use it. @section does likewise + +\def\thischapter{} \def\thissection{} +\def\seccheck#1{\if \pageno<0 % +\errmessage{@#1 not allowed after generating table of contents}\fi +% +} + +\def\chapternofonts{% +\let\rawbackslash=\relax% +\let\frenchspacing=\relax% +\def\result{\realbackslash result} +\def\equiv{\realbackslash equiv} +\def\expansion{\realbackslash expansion} +\def\print{\realbackslash print} +\def\TeX{\realbackslash TeX} +\def\dots{\realbackslash dots} +\def\copyright{\realbackslash copyright} +\def\tt{\realbackslash tt} +\def\bf{\realbackslash bf } +\def\w{\realbackslash w} +\def\less{\realbackslash less} +\def\gtr{\realbackslash gtr} +\def\hat{\realbackslash hat} +\def\char{\realbackslash char} +\def\tclose##1{\realbackslash tclose {##1}} +\def\code##1{\realbackslash code {##1}} +\def\samp##1{\realbackslash samp {##1}} +\def\r##1{\realbackslash r {##1}} +\def\b##1{\realbackslash b {##1}} +\def\key##1{\realbackslash key {##1}} +\def\file##1{\realbackslash file {##1}} +\def\kbd##1{\realbackslash kbd {##1}} +% These are redefined because @smartitalic wouldn't work inside xdef. +\def\i##1{\realbackslash i {##1}} +\def\cite##1{\realbackslash cite {##1}} +\def\var##1{\realbackslash var {##1}} +\def\emph##1{\realbackslash emph {##1}} +\def\dfn##1{\realbackslash dfn {##1}} +} + +\def\thischaptername{No Chapter Title} +\outer\def\chapter{\parsearg\chapterzzz} +\def\chapterzzz #1{\seccheck{chapter}% +\secno=0 \subsecno=0 \subsubsecno=0 +\global\advance \chapno by 1 \message{Chapter \the\chapno}% +\chapmacro {#1}{\the\chapno}% +\gdef\thissection{#1}% +\gdef\thischaptername{#1}% +% We don't substitute the actual chapter name into \thischapter +% because we don't want its macros evaluated now. +\xdef\thischapter{Chapter \the\chapno: \noexpand\thischaptername}% +{\chapternofonts% +\edef\temp{{\realbackslash chapentry {#1}{\the\chapno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\donoderef % +\global\let\section = \numberedsec +\global\let\subsection = \numberedsubsec +\global\let\subsubsection = \numberedsubsubsec +}} + +\outer\def\appendix{\parsearg\appendixzzz} +\def\appendixzzz #1{\seccheck{appendix}% +\secno=0 \subsecno=0 \subsubsecno=0 +\global\advance \appendixno by 1 \message{Appendix \appendixletter}% +\chapmacro {#1}{Appendix \appendixletter}% +\gdef\thissection{#1}% +\gdef\thischaptername{#1}% +\xdef\thischapter{Appendix \appendixletter: \noexpand\thischaptername}% +{\chapternofonts% +\edef\temp{{\realbackslash chapentry + {#1}{Appendix \appendixletter}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\appendixnoderef % +\global\let\section = \appendixsec +\global\let\subsection = \appendixsubsec +\global\let\subsubsection = \appendixsubsubsec +}} + +\outer\def\top{\parsearg\unnumberedzzz} +\outer\def\unnumbered{\parsearg\unnumberedzzz} +\def\unnumberedzzz #1{\seccheck{unnumbered}% +\secno=0 \subsecno=0 \subsubsecno=0 \message{(#1)} +\unnumbchapmacro {#1}% +\gdef\thischapter{#1}\gdef\thissection{#1}% +{\chapternofonts% +\edef\temp{{\realbackslash unnumbchapentry {#1}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\unnumbnoderef % +\global\let\section = \unnumberedsec +\global\let\subsection = \unnumberedsubsec +\global\let\subsubsection = \unnumberedsubsubsec +}} + +\outer\def\numberedsec{\parsearg\seczzz} +\def\seczzz #1{\seccheck{section}% +\subsecno=0 \subsubsecno=0 \global\advance \secno by 1 % +\gdef\thissection{#1}\secheading {#1}{\the\chapno}{\the\secno}% +{\chapternofonts% +\edef\temp{{\realbackslash secentry % +{#1}{\the\chapno}{\the\secno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\donoderef % +\penalty 10000 % +}} + +\outer\def\appendixsection{\parsearg\appendixsectionzzz} +\outer\def\appendixsec{\parsearg\appendixsectionzzz} +\def\appendixsectionzzz #1{\seccheck{appendixsection}% +\subsecno=0 \subsubsecno=0 \global\advance \secno by 1 % +\gdef\thissection{#1}\secheading {#1}{\appendixletter}{\the\secno}% +{\chapternofonts% +\edef\temp{{\realbackslash secentry % +{#1}{\appendixletter}{\the\secno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\appendixnoderef % +\penalty 10000 % +}} + +\outer\def\unnumberedsec{\parsearg\unnumberedseczzz} +\def\unnumberedseczzz #1{\seccheck{unnumberedsec}% +\plainsecheading {#1}\gdef\thissection{#1}% +{\chapternofonts% +\edef\temp{{\realbackslash unnumbsecentry{#1}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\unnumbnoderef % +\penalty 10000 % +}} + +\outer\def\numberedsubsec{\parsearg\numberedsubseczzz} +\def\numberedsubseczzz #1{\seccheck{subsection}% +\gdef\thissection{#1}\subsubsecno=0 \global\advance \subsecno by 1 % +\subsecheading {#1}{\the\chapno}{\the\secno}{\the\subsecno}% +{\chapternofonts% +\edef\temp{{\realbackslash subsecentry % +{#1}{\the\chapno}{\the\secno}{\the\subsecno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\donoderef % +\penalty 10000 % +}} + +\outer\def\appendixsubsec{\parsearg\appendixsubseczzz} +\def\appendixsubseczzz #1{\seccheck{appendixsubsec}% +\gdef\thissection{#1}\subsubsecno=0 \global\advance \subsecno by 1 % +\subsecheading {#1}{\appendixletter}{\the\secno}{\the\subsecno}% +{\chapternofonts% +\edef\temp{{\realbackslash subsecentry % +{#1}{\appendixletter}{\the\secno}{\the\subsecno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\appendixnoderef % +\penalty 10000 % +}} + +\outer\def\unnumberedsubsec{\parsearg\unnumberedsubseczzz} +\def\unnumberedsubseczzz #1{\seccheck{unnumberedsubsec}% +\plainsecheading {#1}\gdef\thissection{#1}% +{\chapternofonts% +\edef\temp{{\realbackslash unnumbsubsecentry{#1}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\unnumbnoderef % +\penalty 10000 % +}} + +\outer\def\numberedsubsubsec{\parsearg\numberedsubsubseczzz} +\def\numberedsubsubseczzz #1{\seccheck{subsubsection}% +\gdef\thissection{#1}\global\advance \subsubsecno by 1 % +\subsubsecheading {#1} + {\the\chapno}{\the\secno}{\the\subsecno}{\the\subsubsecno}% +{\chapternofonts% +\edef\temp{{\realbackslash subsubsecentry % + {#1} + {\the\chapno}{\the\secno}{\the\subsecno}{\the\subsubsecno} + {\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\donoderef % +\penalty 10000 % +}} + +\outer\def\appendixsubsubsec{\parsearg\appendixsubsubseczzz} +\def\appendixsubsubseczzz #1{\seccheck{appendixsubsubsec}% +\gdef\thissection{#1}\global\advance \subsubsecno by 1 % +\subsubsecheading {#1} + {\appendixletter}{\the\secno}{\the\subsecno}{\the\subsubsecno}% +{\chapternofonts% +\edef\temp{{\realbackslash subsubsecentry{#1}% + {\appendixletter} + {\the\secno}{\the\subsecno}{\the\subsubsecno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\appendixnoderef % +\penalty 10000 % +}} + +\outer\def\unnumberedsubsubsec{\parsearg\unnumberedsubsubseczzz} +\def\unnumberedsubsubseczzz #1{\seccheck{unnumberedsubsubsec}% +\plainsecheading {#1}\gdef\thissection{#1}% +{\chapternofonts% +\edef\temp{{\realbackslash unnumbsubsubsecentry{#1}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\unnumbnoderef % +\penalty 10000 % +}} + +% These are variants which are not "outer", so they can appear in @ifinfo. +% Actually, they should now be obsolete; ordinary section commands should work. +\def\infotop{\parsearg\unnumberedzzz} +\def\infounnumbered{\parsearg\unnumberedzzz} +\def\infounnumberedsec{\parsearg\unnumberedseczzz} +\def\infounnumberedsubsec{\parsearg\unnumberedsubseczzz} +\def\infounnumberedsubsubsec{\parsearg\unnumberedsubsubseczzz} + +\def\infoappendix{\parsearg\appendixzzz} +\def\infoappendixsec{\parsearg\appendixseczzz} +\def\infoappendixsubsec{\parsearg\appendixsubseczzz} +\def\infoappendixsubsubsec{\parsearg\appendixsubsubseczzz} + +\def\infochapter{\parsearg\chapterzzz} +\def\infosection{\parsearg\sectionzzz} +\def\infosubsection{\parsearg\subsectionzzz} +\def\infosubsubsection{\parsearg\subsubsectionzzz} + +% These macros control what the section commands do, according +% to what kind of chapter we are in (ordinary, appendix, or unnumbered). +% Define them by default for a numbered chapter. +\global\let\section = \numberedsec +\global\let\subsection = \numberedsubsec +\global\let\subsubsection = \numberedsubsubsec + +% Define @majorheading, @heading and @subheading + +% NOTE on use of \vbox for chapter headings, section headings, and +% such: +% 1) We use \vbox rather than the earlier \line to permit +% overlong headings to fold. +% 2) \hyphenpenalty is set to 10000 because hyphenation in a +% heading is obnoxious; this forbids it. +% 3) Likewise, headings look best if no \parindent is used, and +% if justification is not attempted. Hence \raggedright. + + +\def\majorheading{\parsearg\majorheadingzzz} +\def\majorheadingzzz #1{% +{\advance\chapheadingskip by 10pt \chapbreak }% +{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}\bigskip \par\penalty 200} + +\def\chapheading{\parsearg\chapheadingzzz} +\def\chapheadingzzz #1{\chapbreak % +{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}\bigskip \par\penalty 200} + +\def\heading{\parsearg\secheadingi} + +\def\subheading{\parsearg\subsecheadingi} + +\def\subsubheading{\parsearg\subsubsecheadingi} + +% These macros generate a chapter, section, etc. heading only +% (including whitespace, linebreaking, etc. around it), +% given all the information in convenient, parsed form. + +%%% Args are the skip and penalty (usually negative) +\def\dobreak#1#2{\par\ifdim\lastskip<#1\removelastskip\penalty#2\vskip#1\fi} + +\def\setchapterstyle #1 {\csname CHAPF#1\endcsname} + +%%% Define plain chapter starts, and page on/off switching for it +% Parameter controlling skip before chapter headings (if needed) + +\newskip \chapheadingskip \chapheadingskip = 30pt plus 8pt minus 4pt + +\def\chapbreak{\dobreak \chapheadingskip {-4000}} +\def\chappager{\par\vfill\supereject} +\def\chapoddpage{\chappager \ifodd\pageno \else \hbox to 0pt{} \chappager\fi} + +\def\setchapternewpage #1 {\csname CHAPPAG#1\endcsname} + +\def\CHAPPAGoff{ +\global\let\pchapsepmacro=\chapbreak +\global\let\pagealignmacro=\chappager} + +\def\CHAPPAGon{ +\global\let\pchapsepmacro=\chappager +\global\let\pagealignmacro=\chappager +\global\def\HEADINGSon{\HEADINGSsingle}} + +\def\CHAPPAGodd{ +\global\let\pchapsepmacro=\chapoddpage +\global\let\pagealignmacro=\chapoddpage +\global\def\HEADINGSon{\HEADINGSdouble}} + +\CHAPPAGon + +\def\CHAPFplain{ +\global\let\chapmacro=\chfplain +\global\let\unnumbchapmacro=\unnchfplain} + +\def\chfplain #1#2{% + \pchapsepmacro + {% + \chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #2\enspace #1}% + }% + \bigskip + \penalty5000 +} + +\def\unnchfplain #1{% +\pchapsepmacro % +{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}\bigskip \par\penalty 10000 % +} +\CHAPFplain % The default + +\def\unnchfopen #1{% +\chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}\bigskip \par\penalty 10000 % +} + +\def\chfopen #1#2{\chapoddpage {\chapfonts +\vbox to 3in{\vfil \hbox to\hsize{\hfil #2} \hbox to\hsize{\hfil #1} \vfil}}% +\par\penalty 5000 % +} + +\def\CHAPFopen{ +\global\let\chapmacro=\chfopen +\global\let\unnumbchapmacro=\unnchfopen} + +% Parameter controlling skip before section headings. + +\newskip \subsecheadingskip \subsecheadingskip = 17pt plus 8pt minus 4pt +\def\subsecheadingbreak{\dobreak \subsecheadingskip {-500}} + +\newskip \secheadingskip \secheadingskip = 21pt plus 8pt minus 4pt +\def\secheadingbreak{\dobreak \secheadingskip {-1000}} + +% @paragraphindent is defined for the Info formatting commands only. +\let\paragraphindent=\comment + +% Section fonts are the base font at magstep2, which produces +% a size a bit more than 14 points in the default situation. + +\def\secheading #1#2#3{\secheadingi {#2.#3\enspace #1}} +\def\plainsecheading #1{\secheadingi {#1}} +\def\secheadingi #1{{\advance \secheadingskip by \parskip % +\secheadingbreak}% +{\secfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}% +\ifdim \parskip<10pt \kern 10pt\kern -\parskip\fi \penalty 10000 } + + +% Subsection fonts are the base font at magstep1, +% which produces a size of 12 points. + +\def\subsecheading #1#2#3#4{\subsecheadingi {#2.#3.#4\enspace #1}} +\def\subsecheadingi #1{{\advance \subsecheadingskip by \parskip % +\subsecheadingbreak}% +{\subsecfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}% +\ifdim \parskip<10pt \kern 10pt\kern -\parskip\fi \penalty 10000 } + +\def\subsubsecfonts{\subsecfonts} % Maybe this should change: + % Perhaps make sssec fonts scaled + % magstep half +\def\subsubsecheading #1#2#3#4#5{\subsubsecheadingi {#2.#3.#4.#5\enspace #1}} +\def\subsubsecheadingi #1{{\advance \subsecheadingskip by \parskip % +\subsecheadingbreak}% +{\subsubsecfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}% +\ifdim \parskip<10pt \kern 10pt\kern -\parskip\fi \penalty 10000} + + +\message{toc printing,} + +% Finish up the main text and prepare to read what we've written +% to \contentsfile. + +\newskip\contentsrightmargin \contentsrightmargin=1in +\def\startcontents#1{% + \pagealignmacro + \immediate\closeout \contentsfile + \ifnum \pageno>0 + \pageno = -1 % Request roman numbered pages. + \fi + % Don't need to put `Contents' or `Short Contents' in the headline. + % It is abundantly clear what they are. + \unnumbchapmacro{#1}\def\thischapter{}% + \begingroup % Set up to handle contents files properly. + \catcode`\\=0 \catcode`\{=1 \catcode`\}=2 \catcode`\@=11 + \raggedbottom % Worry more about breakpoints than the bottom. + \advance\hsize by -\contentsrightmargin % Don't use the full line length. +} + + +% Normal (long) toc. +\outer\def\contents{% + \startcontents{Table of Contents}% + \input \jobname.toc + \endgroup + \vfill \eject +} + +% And just the chapters. +\outer\def\summarycontents{% + \startcontents{Short Contents}% + % + \let\chapentry = \shortchapentry + \let\unnumbchapentry = \shortunnumberedentry + % We want a true roman here for the page numbers. + \secfonts + \let\rm=\shortcontrm \let\bf=\shortcontbf \let\sl=\shortcontsl + \rm + \advance\baselineskip by 1pt % Open it up a little. + \def\secentry ##1##2##3##4{} + \def\unnumbsecentry ##1##2{} + \def\subsecentry ##1##2##3##4##5{} + \def\unnumbsubsecentry ##1##2{} + \def\subsubsecentry ##1##2##3##4##5##6{} + \def\unnumbsubsubsecentry ##1##2{} + \input \jobname.toc + \endgroup + \vfill \eject +} +\let\shortcontents = \summarycontents + +% These macros generate individual entries in the table of contents. +% The first argument is the chapter or section name. +% The last argument is the page number. +% The arguments in between are the chapter number, section number, ... + +% Chapter-level things, for both the long and short contents. +\def\chapentry#1#2#3{\dochapentry{#2\labelspace#1}{#3}} + +% See comments in \dochapentry re vbox and related settings +\def\shortchapentry#1#2#3{% + \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\strut\raggedright + {#2\labelspace #1}\dotfill\doshortpageno{#3}}% +} + +\def\unnumbchapentry#1#2{\dochapentry{#1}{#2}} +\def\shortunnumberedentry#1#2{% + \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\strut\raggedright + #1\dotfill\doshortpageno{#2}}% +} + +% Sections. +\def\secentry#1#2#3#4{\dosecentry{#2.#3\labelspace#1}{#4}} +\def\unnumbsecentry#1#2{\dosecentry{#1}{#2}} + +% Subsections. +\def\subsecentry#1#2#3#4#5{\dosubsecentry{#2.#3.#4\labelspace#1}{#5}} +\def\unnumbsubsecentry#1#2{\dosubsecentry{#1}{#2}} + +% And subsubsections. +\def\subsubsecentry#1#2#3#4#5#6{% + \dosubsubsecentry{#2.#3.#4.#5\labelspace#1}{#6}} +\def\unnumbsubsubsecentry#1#2{\dosubsubsecentry{#1}{#2}} + + +% This parameter controls the indentation of the various levels. +\newdimen\tocindent \tocindent = 3pc + +% Now for the actual typesetting. In all these, #1 is the text and #2 is the +% page number. +% +% If the toc has to be broken over pages, we would want to be at chapters +% if at all possible; hence the \penalty. +\def\dochapentry#1#2{% + \penalty-300 \vskip\baselineskip + % This \vbox (and similar ones in dosecentry etc.) used to be a + % \line; changed to permit linebreaks for long headings. See + % comments above \majorheading. Here we also use \strut to + % keep the top end of the vbox from jamming up against the previous + % entry in the table of contents. + \vbox{\chapentryfonts + \hyphenpenalty=10000\tolerance=5000 % this line and next introduced + \parindent=0pt\strut\raggedright % with \line -> \vbox change + #1\dotfill + \dopageno{#2}}% + \nobreak\vskip .25\baselineskip +} + +\def\dosecentry#1#2{% + \vbox{\secentryfonts \leftskip=\tocindent + \hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\strut\raggedright #1\dotfill + \dopageno{#2}}% +} + +\def\dosubsecentry#1#2{% + \vbox{\subsecentryfonts \leftskip=2\tocindent + \hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\strut\raggedright #1\dotfill + \dopageno{#2}}% +} + +\def\dosubsubsecentry#1#2{% + \vbox{\subsubsecentryfonts \leftskip=3\tocindent + \hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\strut\raggedright #1\dotfill + \dopageno{#2}}% +} + +% Space between chapter (or whatever) number and the title. +\def\labelspace{\hskip1em \relax} + +\def\dopageno#1{{\rm #1}} +\def\doshortpageno#1{{\rm #1}} + +\def\chapentryfonts{\secfonts \rm} +\def\secentryfonts{\textfonts} +\let\subsecentryfonts = \textfonts +\let\subsubsecentryfonts = \textfonts + + +\message{environments,} + +% Since these characters are used in examples, it should be an even number of +% \tt widths. Each \tt character is 1en, so two makes it 1em. +% Furthermore, these definitions must come after we define our fonts. +\newbox\dblarrowbox \newbox\longdblarrowbox +\newbox\pushcharbox \newbox\bullbox +\newbox\equivbox \newbox\errorbox + +\let\ptexequiv = \equiv + +%{\tentt +%\global\setbox\dblarrowbox = \hbox to 1em{\hfil$\Rightarrow$\hfil} +%\global\setbox\longdblarrowbox = \hbox to 1em{\hfil$\mapsto$\hfil} +%\global\setbox\pushcharbox = \hbox to 1em{\hfil$\dashv$\hfil} +%\global\setbox\equivbox = \hbox to 1em{\hfil$\ptexequiv$\hfil} +% Adapted from the manmac format (p.420 of TeXbook) +%\global\setbox\bullbox = \hbox to 1em{\kern.15em\vrule height .75ex width .85ex +% depth .1ex\hfil} +%} + +\def\point{$\star$} + +\def\result{\leavevmode\raise.15ex\hbox to 1em{\hfil$\Rightarrow$\hfil}} +\def\expansion{\leavevmode\raise.1ex\hbox to 1em{\hfil$\mapsto$\hfil}} +\def\print{\leavevmode\lower.1ex\hbox to 1em{\hfil$\dashv$\hfil}} + +\def\equiv{\leavevmode\lower.1ex\hbox to 1em{\hfil$\ptexequiv$\hfil}} + +% Adapted from the TeXbook's \boxit. +{\tentt \global\dimen0 = 3em}% Width of the box. +\dimen2 = .55pt % Thickness of rules +% The text. (`r' is open on the right, `e' somewhat less so on the left.) +\setbox0 = \hbox{\kern-.75pt \tensf error\kern-1.5pt} + +\global\setbox\errorbox=\hbox to \dimen0{\hfil + \hsize = \dimen0 \advance\hsize by -5.8pt % Space to left+right. + \advance\hsize by -2\dimen2 % Rules. + \vbox{ + \hrule height\dimen2 + \hbox{\vrule width\dimen2 \kern3pt % Space to left of text. + \vtop{\kern2.4pt \box0 \kern2.4pt}% Space above/below. + \kern3pt\vrule width\dimen2}% Space to right. + \hrule height\dimen2} + \hfil} + +% The @error{} command. +\def\error{\leavevmode\lower.7ex\copy\errorbox} + +% @tex ... @end tex escapes into raw Tex temporarily. +% One exception: @ is still an escape character, so that @end tex works. +% But \@ or @@ will get a plain tex @ character. + +\def\tex{\begingroup +\catcode `\\=0 \catcode `\{=1 \catcode `\}=2 +\catcode `\$=3 \catcode `\&=4 \catcode `\#=6 +\catcode `\^=7 \catcode `\_=8 \catcode `\~=13 \let~=\tie +\catcode `\%=14 +\catcode 43=12 +\catcode`\"=12 +\catcode`\==12 +\catcode`\|=12 +\catcode`\<=12 +\catcode`\>=12 +\escapechar=`\\ +% +\let\{=\ptexlbrace +\let\}=\ptexrbrace +\let\.=\ptexdot +\let\*=\ptexstar +\let\dots=\ptexdots +\def\@{@}% +\let\bullet=\ptexbullet +\let\b=\ptexb \let\c=\ptexc \let\i=\ptexi \let\t=\ptext \let\l=\ptexl +\let\L=\ptexL +% +\let\Etex=\endgroup} + +% Define @lisp ... @endlisp. +% @lisp does a \begingroup so it can rebind things, +% including the definition of @endlisp (which normally is erroneous). + +% Amount to narrow the margins by for @lisp. +\newskip\lispnarrowing \lispnarrowing=0.4in + +% This is the definition that ^M gets inside @lisp +% phr: changed space to \null, to avoid overfull hbox problems. +{\obeyspaces% +\gdef\lisppar{\null\endgraf}} + +% Cause \obeyspaces to make each Space cause a word-separation +% rather than the default which is that it acts punctuation. +% This is because space in tt font looks funny. +{\obeyspaces % +\gdef\sepspaces{\def {\ }}} + +\newskip\aboveenvskipamount \aboveenvskipamount= 0pt +\def\aboveenvbreak{{\advance\aboveenvskipamount by \parskip +\endgraf \ifdim\lastskip<\aboveenvskipamount +\removelastskip \penalty-50 \vskip\aboveenvskipamount \fi}} + +\def\afterenvbreak{\endgraf \ifdim\lastskip<\aboveenvskipamount +\removelastskip \penalty-50 \vskip\aboveenvskipamount \fi} + +% \nonarrowing is a flag. If "set", @lisp etc don't narrow margins. +\let\nonarrowing=\relax + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% \cartouche: draw rectangle w/rounded corners around argument +\font\circle=lcircle10 +\newdimen\circthick +\newdimen\cartouter\newdimen\cartinner +\newskip\normbskip\newskip\normpskip\newskip\normlskip +\circthick=\fontdimen8\circle +% +\def\ctl{{\circle\char'013\hskip -6pt}}% 6pt from pl file: 1/2charwidth +\def\ctr{{\hskip 6pt\circle\char'010}} +\def\cbl{{\circle\char'012\hskip -6pt}} +\def\cbr{{\hskip 6pt\circle\char'011}} +\def\carttop{\hbox to \cartouter{\hskip\lskip + \ctl\leaders\hrule height\circthick\hfil\ctr + \hskip\rskip}} +\def\cartbot{\hbox to \cartouter{\hskip\lskip + \cbl\leaders\hrule height\circthick\hfil\cbr + \hskip\rskip}} +% +\newskip\lskip\newskip\rskip + +\long\def\cartouche{% +\begingroup + \lskip=\leftskip \rskip=\rightskip + \leftskip=0pt\rightskip=0pt %we want these *outside*. + \cartinner=\hsize \advance\cartinner by-\lskip + \advance\cartinner by-\rskip + \cartouter=\hsize + \advance\cartouter by 18pt % allow for 3pt kerns on either +% side, and for 6pt waste from +% each corner char + \normbskip=\baselineskip \normpskip=\parskip \normlskip=\lineskip + % Flag to tell @lisp, etc., not to narrow margin. + \let\nonarrowing=\comment + \vbox\bgroup + \baselineskip=0pt\parskip=0pt\lineskip=0pt + \carttop + \hbox\bgroup + \hskip\lskip + \vrule\kern3pt + \vbox\bgroup + \hsize=\cartinner + \kern3pt + \begingroup + \baselineskip=\normbskip + \lineskip=\normlskip + \parskip=\normpskip + \vskip -\parskip +\def\Ecartouche{% + \endgroup + \kern3pt + \egroup + \kern3pt\vrule + \hskip\rskip + \egroup + \cartbot + \egroup +\endgroup +}} + +\def\lisp{\aboveenvbreak +\begingroup\inENV % This group ends at the end of the @lisp body +\hfuzz=12truept % Don't be fussy +% Make spaces be word-separators rather than space tokens. +\sepspaces % +% Single space lines +\singlespace % +% The following causes blank lines not to be ignored +% by adding a space to the end of each line. +\let\par=\lisppar +\def\Elisp{\endgroup\afterenvbreak}% +\parskip=0pt +% @cartouche defines \nonarrowing to inhibit narrowing +% at next level down. +\ifx\nonarrowing\relax +\advance \leftskip by \lispnarrowing +\exdentamount=\lispnarrowing +\let\exdent=\nofillexdent +\let\nonarrowing=\relax +\fi +\parindent=0pt +\obeyspaces \obeylines \tt \rawbackslash +\def\next##1{}\next} + + +\let\example=\lisp +\def\Eexample{\Elisp} + +\let\smallexample=\lisp +\def\Esmallexample{\Elisp} + +% Macro for 9 pt. examples, necessary to print with 5" lines. +% From Pavel@xerox. This is not really used unless the +% @smallbook command is given. + +\def\smalllispx{\aboveenvbreak\begingroup\inENV +% This group ends at the end of the @lisp body +\hfuzz=12truept % Don't be fussy +% Make spaces be word-separators rather than space tokens. +\sepspaces % +% Single space lines +\singlespace % +% The following causes blank lines not to be ignored +% by adding a space to the end of each line. +\let\par=\lisppar +\def\Esmalllisp{\endgroup\afterenvbreak}% +%%%% Smaller baseline skip for small examples. +\baselineskip 10pt +\parskip=0pt +% @cartouche defines \nonarrowing to inhibit narrowing +% at next level down. +\ifx\nonarrowing\relax +\advance \leftskip by \lispnarrowing +\exdentamount=\lispnarrowing +\let\exdent=\nofillexdent +\let\nonarrowing=\relax +\fi +\parindent=0pt +\obeyspaces \obeylines \ninett \indexfonts \rawbackslash +\def\next##1{}\next} + +% This is @display; same as @lisp except use roman font. + +\def\display{\begingroup\inENV %This group ends at the end of the @display body +\aboveenvbreak +% Make spaces be word-separators rather than space tokens. +\sepspaces % +% Single space lines +\singlespace % +% The following causes blank lines not to be ignored +% by adding a space to the end of each line. +\let\par=\lisppar +\def\Edisplay{\endgroup\afterenvbreak}% +\parskip=0pt +% @cartouche defines \nonarrowing to inhibit narrowing +% at next level down. +\ifx\nonarrowing\relax +\advance \leftskip by \lispnarrowing +\exdentamount=\lispnarrowing +\let\exdent=\nofillexdent +\let\nonarrowing=\relax +\fi +\parindent=0pt +\obeyspaces \obeylines +\def\next##1{}\next} + +% This is @format; same as @lisp except use roman font and don't narrow margins + +\def\format{\begingroup\inENV %This group ends at the end of the @format body +\aboveenvbreak +% Make spaces be word-separators rather than space tokens. +\sepspaces % +\singlespace % +% The following causes blank lines not to be ignored +% by adding a space to the end of each line. +\let\par=\lisppar +\def\Eformat{\endgroup\afterenvbreak} +\parskip=0pt \parindent=0pt +\obeyspaces \obeylines +\def\next##1{}\next} + +% @flushleft and @flushright + +\def\flushleft{% +\begingroup\inENV %This group ends at the end of the @format body +\aboveenvbreak +% Make spaces be word-separators rather than space tokens. +\sepspaces % +% The following causes blank lines not to be ignored +% by adding a space to the end of each line. +% This also causes @ to work when the directive name +% is terminated by end of line. +\let\par=\lisppar +\def\Eflushleft{\endgroup\afterenvbreak}% +\parskip=0pt \parindent=0pt +\obeyspaces \obeylines +\def\next##1{}\next} + +\def\flushright{% +\begingroup\inENV %This group ends at the end of the @format body +\aboveenvbreak +% Make spaces be word-separators rather than space tokens. +\sepspaces % +% The following causes blank lines not to be ignored +% by adding a space to the end of each line. +% This also causes @ to work when the directive name +% is terminated by end of line. +\let\par=\lisppar +\def\Eflushright{\endgroup\afterenvbreak}% +\parskip=0pt \parindent=0pt +\advance \leftskip by 0pt plus 1fill +\obeyspaces \obeylines +\def\next##1{}\next} + +% @quotation - narrow the margins. + +\def\quotation{% +\begingroup\inENV %This group ends at the end of the @quotation body +{\parskip=0pt % because we will skip by \parskip too, later +\aboveenvbreak}% +\singlespace +\parindent=0pt +\def\Equotation{\par\endgroup\afterenvbreak}% +% @cartouche defines \nonarrowing to inhibit narrowing +% at next level down. +\ifx\nonarrowing\relax +\advance \leftskip by \lispnarrowing +\advance \rightskip by \lispnarrowing +\exdentamount=\lispnarrowing +\let\nonarrowing=\relax +\fi} + +\message{defuns,} +% Define formatter for defuns +% First, allow user to change definition object font (\df) internally +\def\setdeffont #1 {\csname DEF#1\endcsname} + +\newskip\defbodyindent \defbodyindent=.4in +\newskip\defargsindent \defargsindent=50pt +\newskip\deftypemargin \deftypemargin=12pt +\newskip\deflastargmargin \deflastargmargin=18pt + +\newcount\parencount +% define \functionparens, which makes ( and ) and & do special things. +% \functionparens affects the group it is contained in. +\def\activeparens{% +\catcode`\(=\active \catcode`\)=\active \catcode`\&=\active +\catcode`\[=\active \catcode`\]=\active} +{\activeparens % Now, smart parens don't turn on until &foo (see \amprm) +\gdef\functionparens{\boldbrax\let&=\amprm\parencount=0 } +\gdef\boldbrax{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb} + +% Definitions of (, ) and & used in args for functions. +% This is the definition of ( outside of all parentheses. +\gdef\oprm#1 {{\rm\char`\(}#1 \bf \let(=\opnested % +\global\advance\parencount by 1 } +% +% This is the definition of ( when already inside a level of parens. +\gdef\opnested{\char`\(\global\advance\parencount by 1 } +% +\gdef\clrm{% Print a paren in roman if it is taking us back to depth of 0. +% also in that case restore the outer-level definition of (. +\ifnum \parencount=1 {\rm \char `\)}\sl \let(=\oprm \else \char `\) \fi +\global\advance \parencount by -1 } +% If we encounter &foo, then turn on ()-hacking afterwards +\gdef\amprm#1 {{\rm\}\let(=\oprm \let)=\clrm\ } +% +\gdef\normalparens{\boldbrax\let&=\ampnr} +} % End of definition inside \activeparens +%% These parens (in \boldbrax) actually are a little bolder than the +%% contained text. This is especially needed for [ and ] +\def\opnr{{\sf\char`\(}} \def\clnr{{\sf\char`\)}} \def\ampnr{\&} +\def\lbrb{{\bf\char`\[}} \def\rbrb{{\bf\char`\]}} + +% First, defname, which formats the header line itself. +% #1 should be the function name. +% #2 should be the type of definition, such as "Function". + +\def\defname #1#2{% +% Get the values of \leftskip and \rightskip as they were +% outside the @def... +\dimen2=\leftskip +\advance\dimen2 by -\defbodyindent +\dimen3=\rightskip +\advance\dimen3 by -\defbodyindent +\noindent % +\setbox0=\hbox{\hskip \deflastargmargin{\rm #2}\hskip \deftypemargin}% +\dimen0=\hsize \advance \dimen0 by -\wd0 % compute size for first line +\dimen1=\hsize \advance \dimen1 by -\defargsindent %size for continuations +\parshape 2 0in \dimen0 \defargsindent \dimen1 % +% Now output arg 2 ("Function" or some such) +% ending at \deftypemargin from the right margin, +% but stuck inside a box of width 0 so it does not interfere with linebreaking +{% Adjust \hsize to exclude the ambient margins, +% so that \rightline will obey them. +\advance \hsize by -\dimen2 \advance \hsize by -\dimen3 +\rlap{\rightline{{\rm #2}\hskip \deftypemargin}}}% +% Make all lines underfull and no complaints: +\tolerance=10000 \hbadness=10000 +\advance\leftskip by -\defbodyindent +\exdentamount=\defbodyindent +{\df #1}\enskip % Generate function name +} + +% Actually process the body of a definition +% #1 should be the terminating control sequence, such as \Edefun. +% #2 should be the "another name" control sequence, such as \defunx. +% #3 should be the control sequence that actually processes the header, +% such as \defunheader. + +\def\defparsebody #1#2#3{\begingroup\inENV% Environment for definitionbody +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2{\begingroup\obeylines\activeparens\spacesplit#3}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup % +\catcode 61=\active % +\obeylines\activeparens\spacesplit#3} + +\def\defmethparsebody #1#2#3#4 {\begingroup\inENV % +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2##1 {\begingroup\obeylines\activeparens\spacesplit{#3{##1}}}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup\obeylines\activeparens\spacesplit{#3{#4}}} + +\def\defopparsebody #1#2#3#4#5 {\begingroup\inENV % +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2##1 ##2 {\def#4{##1}% +\begingroup\obeylines\activeparens\spacesplit{#3{##2}}}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup\obeylines\activeparens\spacesplit{#3{#5}}} + +% These parsing functions are similar to the preceding ones +% except that they do not make parens into active characters. +% These are used for "variables" since they have no arguments. + +\def\defvarparsebody #1#2#3{\begingroup\inENV% Environment for definitionbody +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2{\begingroup\obeylines\spacesplit#3}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup % +\catcode 61=\active % +\obeylines\spacesplit#3} + +\def\defvrparsebody #1#2#3#4 {\begingroup\inENV % +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2##1 {\begingroup\obeylines\spacesplit{#3{##1}}}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup\obeylines\spacesplit{#3{#4}}} + +\def\defopvarparsebody #1#2#3#4#5 {\begingroup\inENV % +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2##1 ##2 {\def#4{##1}% +\begingroup\obeylines\spacesplit{#3{##2}}}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup\obeylines\spacesplit{#3{#5}}} + +% Split up #2 at the first space token. +% call #1 with two arguments: +% the first is all of #2 before the space token, +% the second is all of #2 after that space token. +% If #2 contains no space token, all of it is passed as the first arg +% and the second is passed as empty. + +{\obeylines +\gdef\spacesplit#1#2^^M{\endgroup\spacesplitfoo{#1}#2 \relax\spacesplitfoo}% +\long\gdef\spacesplitfoo#1#2 #3#4\spacesplitfoo{% +\ifx\relax #3% +#1{#2}{}\else #1{#2}{#3#4}\fi}} + +% So much for the things common to all kinds of definitions. + +% Define @defun. + +% First, define the processing that is wanted for arguments of \defun +% Use this to expand the args and terminate the paragraph they make up + +\def\defunargs #1{\functionparens \sl +% Expand, preventing hyphenation at `-' chars. +% Note that groups don't affect changes in \hyphenchar. +\hyphenchar\tensl=0 +#1% +\hyphenchar\tensl=45 +\ifnum\parencount=0 \else \errmessage{unbalanced parens in @def arguments}\fi% +\interlinepenalty=10000 +\advance\rightskip by 0pt plus 1fil +\endgraf\penalty 10000\vskip -\parskip\penalty 10000% +} + +\def\deftypefunargs #1{% +% Expand, preventing hyphenation at `-' chars. +% Note that groups don't affect changes in \hyphenchar. +\functionparens +\code{#1}% +\interlinepenalty=10000 +\advance\rightskip by 0pt plus 1fil +\endgraf\penalty 10000\vskip -\parskip\penalty 10000% +} + +% Do complete processing of one @defun or @defunx line already parsed. + +% @deffn Command forward-char nchars + +\def\deffn{\defmethparsebody\Edeffn\deffnx\deffnheader} + +\def\deffnheader #1#2#3{\doind {fn}{\code{#2}}% +\begingroup\defname {#2}{#1}\defunargs{#3}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% @defun == @deffn Function + +\def\defun{\defparsebody\Edefun\defunx\defunheader} + +\def\defunheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index +\begingroup\defname {#1}{Function}% +\defunargs {#2}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% @deftypefun int foobar (int @var{foo}, float @var{bar}) + +\def\deftypefun{\defparsebody\Edeftypefun\deftypefunx\deftypefunheader} + +% #1 is the data type. #2 is the name and args. +\def\deftypefunheader #1#2{\deftypefunheaderx{#1}#2 \relax} +% #1 is the data type, #2 the name, #3 the args. +\def\deftypefunheaderx #1#2 #3\relax{% +\doind {fn}{\code{#2}}% Make entry in function index +\begingroup\defname {\code{#1} #2}{Function}% +\deftypefunargs {#3}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% @deftypefn {Library Function} int foobar (int @var{foo}, float @var{bar}) + +\def\deftypefn{\defmethparsebody\Edeftypefn\deftypefnx\deftypefnheader} + +% #1 is the classification. #2 is the data type. #3 is the name and args. +\def\deftypefnheader #1#2#3{\deftypefnheaderx{#1}{#2}#3 \relax} +% #1 is the classification, #2 the data type, #3 the name, #4 the args. +\def\deftypefnheaderx #1#2#3 #4\relax{% +\doind {fn}{\code{#3}}% Make entry in function index +\begingroup\defname {\code{#2} #3}{#1}% +\deftypefunargs {#4}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% @defmac == @deffn Macro + +\def\defmac{\defparsebody\Edefmac\defmacx\defmacheader} + +\def\defmacheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index +\begingroup\defname {#1}{Macro}% +\defunargs {#2}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% @defspec == @deffn Special Form + +\def\defspec{\defparsebody\Edefspec\defspecx\defspecheader} + +\def\defspecheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index +\begingroup\defname {#1}{Special Form}% +\defunargs {#2}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% This definition is run if you use @defunx +% anywhere other than immediately after a @defun or @defunx. + +\def\deffnx #1 {\errmessage{@deffnx in invalid context}} +\def\defunx #1 {\errmessage{@defunx in invalid context}} +\def\defmacx #1 {\errmessage{@defmacx in invalid context}} +\def\defspecx #1 {\errmessage{@defspecx in invalid context}} +\def\deftypefnx #1 {\errmessage{@deftypefnx in invalid context}} +\def\deftypeunx #1 {\errmessage{@deftypeunx in invalid context}} + +% @defmethod, and so on + +% @defop {Funny Method} foo-class frobnicate argument + +\def\defop #1 {\def\defoptype{#1}% +\defopparsebody\Edefop\defopx\defopheader\defoptype} + +\def\defopheader #1#2#3{% +\dosubind {fn}{\code{#2}}{on #1}% Make entry in function index +\begingroup\defname {#2}{\defoptype{} on #1}% +\defunargs {#3}\endgroup % +} + +% @defmethod == @defop Method + +\def\defmethod{\defmethparsebody\Edefmethod\defmethodx\defmethodheader} + +\def\defmethodheader #1#2#3{% +\dosubind {fn}{\code{#2}}{on #1}% entry in function index +\begingroup\defname {#2}{Method on #1}% +\defunargs {#3}\endgroup % +} + +% @defcv {Class Option} foo-class foo-flag + +\def\defcv #1 {\def\defcvtype{#1}% +\defopvarparsebody\Edefcv\defcvx\defcvarheader\defcvtype} + +\def\defcvarheader #1#2#3{% +\dosubind {vr}{\code{#2}}{of #1}% Make entry in var index +\begingroup\defname {#2}{\defcvtype{} of #1}% +\defvarargs {#3}\endgroup % +} + +% @defivar == @defcv {Instance Variable} + +\def\defivar{\defvrparsebody\Edefivar\defivarx\defivarheader} + +\def\defivarheader #1#2#3{% +\dosubind {vr}{\code{#2}}{of #1}% Make entry in var index +\begingroup\defname {#2}{Instance Variable of #1}% +\defvarargs {#3}\endgroup % +} + +% These definitions are run if you use @defmethodx, etc., +% anywhere other than immediately after a @defmethod, etc. + +\def\defopx #1 {\errmessage{@defopx in invalid context}} +\def\defmethodx #1 {\errmessage{@defmethodx in invalid context}} +\def\defcvx #1 {\errmessage{@defcvx in invalid context}} +\def\defivarx #1 {\errmessage{@defivarx in invalid context}} + +% Now @defvar + +% First, define the processing that is wanted for arguments of @defvar. +% This is actually simple: just print them in roman. +% This must expand the args and terminate the paragraph they make up +\def\defvarargs #1{\normalparens #1% +\interlinepenalty=10000 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000} + +% @defvr Counter foo-count + +\def\defvr{\defvrparsebody\Edefvr\defvrx\defvrheader} + +\def\defvrheader #1#2#3{\doind {vr}{\code{#2}}% +\begingroup\defname {#2}{#1}\defvarargs{#3}\endgroup} + +% @defvar == @defvr Variable + +\def\defvar{\defvarparsebody\Edefvar\defvarx\defvarheader} + +\def\defvarheader #1#2{\doind {vr}{\code{#1}}% Make entry in var index +\begingroup\defname {#1}{Variable}% +\defvarargs {#2}\endgroup % +} + +% @defopt == @defvr {User Option} + +\def\defopt{\defvarparsebody\Edefopt\defoptx\defoptheader} + +\def\defoptheader #1#2{\doind {vr}{\code{#1}}% Make entry in var index +\begingroup\defname {#1}{User Option}% +\defvarargs {#2}\endgroup % +} + +% @deftypevar int foobar + +\def\deftypevar{\defvarparsebody\Edeftypevar\deftypevarx\deftypevarheader} + +% #1 is the data type. #2 is the name. +\def\deftypevarheader #1#2{% +\doind {vr}{\code{#2}}% Make entry in variables index +\begingroup\defname {\code{#1} #2}{Variable}% +\interlinepenalty=10000 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000 +\endgroup} + +% @deftypevr {Global Flag} int enable + +\def\deftypevr{\defvrparsebody\Edeftypevr\deftypevrx\deftypevrheader} + +\def\deftypevrheader #1#2#3{\doind {vr}{\code{#3}}% +\begingroup\defname {\code{#2} #3}{#1} +\interlinepenalty=10000 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000 +\endgroup} + +% This definition is run if you use @defvarx +% anywhere other than immediately after a @defvar or @defvarx. + +\def\defvrx #1 {\errmessage{@defvrx in invalid context}} +\def\defvarx #1 {\errmessage{@defvarx in invalid context}} +\def\defoptx #1 {\errmessage{@defoptx in invalid context}} +\def\deftypevarx #1 {\errmessage{@deftypevarx in invalid context}} +\def\deftypevrx #1 {\errmessage{@deftypevrx in invalid context}} + +% Now define @deftp +% Args are printed in bold, a slight difference from @defvar. + +\def\deftpargs #1{\bf \defvarargs{#1}} + +% @deftp Class window height width ... + +\def\deftp{\defvrparsebody\Edeftp\deftpx\deftpheader} + +\def\deftpheader #1#2#3{\doind {tp}{\code{#2}}% +\begingroup\defname {#2}{#1}\deftpargs{#3}\endgroup} + +% This definition is run if you use @deftpx, etc +% anywhere other than immediately after a @deftp, etc. + +\def\deftpx #1 {\errmessage{@deftpx in invalid context}} + +\message{cross reference,} +% Define cross-reference macros +\newwrite \auxfile + +\newif\ifhavexrefs % True if xref values are known. +\newif\ifwarnedxrefs % True if we warned once that they aren't known. + +% \setref{foo} defines a cross-reference point named foo. + +\def\setref#1{% +%\dosetq{#1-title}{Ytitle}% +\dosetq{#1-pg}{Ypagenumber}% +\dosetq{#1-snt}{Ysectionnumberandtype}} + +\def\unnumbsetref#1{% +%\dosetq{#1-title}{Ytitle}% +\dosetq{#1-pg}{Ypagenumber}% +\dosetq{#1-snt}{Ynothing}} + +\def\appendixsetref#1{% +%\dosetq{#1-title}{Ytitle}% +\dosetq{#1-pg}{Ypagenumber}% +\dosetq{#1-snt}{Yappendixletterandtype}} + +% \xref, \pxref, and \ref generate cross-references to specified points. +% For \xrefX, #1 is the node name, #2 the name of the Info +% cross-reference, #3 the printed node name, #4 the name of the Info +% file, #5 the name of the printed manual. All but the node name can be +% omitted. +% +\def\pxref#1{see \xrefX[#1,,,,,,,]} +\def\xref#1{See \xrefX[#1,,,,,,,]} +\def\ref#1{\xrefX[#1,,,,,,,]} +\def\xrefX[#1,#2,#3,#4,#5,#6]{\begingroup% +\def\printedmanual{\ignorespaces #5}% +\def\printednodename{\ignorespaces #3}% +% +\setbox1=\hbox{\printedmanual}% +\setbox0=\hbox{\printednodename}% +\ifdim \wd0=0pt% +\def\printednodename{\ignorespaces #1}% +%%% Uncommment the following line to make the actual chapter or section title +%%% appear inside the square brackets. +%\def\printednodename{#1-title}% +\fi% +% +% +% If we use \unhbox0 and \unhbox1 to print the node names, TeX does +% not insert empty discretionaries after hyphens, which means that it +% will not find a line break at a hyphen in a node names. Since some +% manuals are best written with fairly long node names, containing +% hyphens, this is a loss. Therefore, we simply give the text of +% the node name again, so it is as if TeX is seeing it for the first +% time. +\ifdim \wd1>0pt +section ``\printednodename'' in \cite{\printedmanual}% +\else% +\turnoffactive% +\refx{#1-snt}{} [\printednodename], page\tie\refx{#1-pg}{}% +\fi +\endgroup} + +% \dosetq is the interface for calls from other macros + +% Use \turnoffactive so that punctuation chars such as underscore +% work in node names. +\def\dosetq #1#2{{\let\folio=0 \turnoffactive% +\edef\next{\write\auxfile{\internalsetq {#1}{#2}}}% +\next}} + +% \internalsetq {foo}{page} expands into +% CHARACTERS 'xrdef {foo}{...expansion of \Ypage...} +% When the aux file is read, ' is the escape character + +\def\internalsetq #1#2{'xrdef {#1}{\csname #2\endcsname}} + +% Things to be expanded by \internalsetq + +\def\Ypagenumber{\folio} + +\def\Ytitle{\thischapter} + +\def\Ynothing{} + +\def\Ysectionnumberandtype{% +\ifnum\secno=0 Chapter\xreftie\the\chapno % +\else \ifnum \subsecno=0 Section\xreftie\the\chapno.\the\secno % +\else \ifnum \subsubsecno=0 % +Section\xreftie\the\chapno.\the\secno.\the\subsecno % +\else % +Section\xreftie\the\chapno.\the\secno.\the\subsecno.\the\subsubsecno % +\fi \fi \fi } + +\def\Yappendixletterandtype{% +\ifnum\secno=0 Appendix\xreftie'char\the\appendixno{}% +\else \ifnum \subsecno=0 Section\xreftie'char\the\appendixno.\the\secno % +\else \ifnum \subsubsecno=0 % +Section\xreftie'char\the\appendixno.\the\secno.\the\subsecno % +\else % +Section\xreftie'char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno % +\fi \fi \fi } + +\gdef\xreftie{'tie} + +% Use TeX 3.0's \inputlineno to get the line number, for better error +% messages, but if we're using an old version of TeX, don't do anything. +% +\ifx\inputlineno\thisisundefined + \let\linenumber = \empty % Non-3.0. +\else + \def\linenumber{\the\inputlineno:\space} +\fi + +% Define \refx{NAME}{SUFFIX} to reference a cross-reference string named NAME. +% If its value is nonempty, SUFFIX is output afterward. + +\def\refx#1#2{% + \expandafter\ifx\csname X#1\endcsname\relax + % If not defined, say something at least. + $\langle$un\-de\-fined$\rangle$% + \ifhavexrefs + \message{\linenumber Undefined cross reference `#1'.}% + \else + \ifwarnedxrefs\else + \global\warnedxrefstrue + \message{Cross reference values unknown; you must run TeX again.}% + \fi + \fi + \else + % It's defined, so just use it. + \csname X#1\endcsname + \fi + #2% Output the suffix in any case. +} + +% Read the last existing aux file, if any. No error if none exists. + +% This is the macro invoked by entries in the aux file. +\def\xrdef #1#2{ +{\catcode`\'=\other\expandafter \gdef \csname X#1\endcsname {#2}}} + +\def\readauxfile{% +\begingroup +\catcode `\^^@=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\^^C=\other +\catcode `\^^D=\other +\catcode `\^^E=\other +\catcode `\^^F=\other +\catcode `\^^G=\other +\catcode `\^^H=\other +\catcode `\ =\other +\catcode `\^^L=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode 26=\other +\catcode `\^^[=\other +\catcode `\^^\=\other +\catcode `\^^]=\other +\catcode `\^^^=\other +\catcode `\^^_=\other +\catcode `\@=\other +\catcode `\^=\other +\catcode `\~=\other +\catcode `\[=\other +\catcode `\]=\other +\catcode`\"=\other +\catcode`\_=\other +\catcode`\|=\other +\catcode`\<=\other +\catcode`\>=\other +\catcode `\$=\other +\catcode `\#=\other +\catcode `\&=\other +% the aux file uses ' as the escape. +% Turn off \ as an escape so we do not lose on +% entries which were dumped with control sequences in their names. +% For example, 'xrdef {$\leq $-fun}{page ...} made by @defun ^^ +% Reference to such entries still does not work the way one would wish, +% but at least they do not bomb out when the aux file is read in. +\catcode `\{=1 \catcode `\}=2 +\catcode `\%=\other +\catcode `\'=0 +\catcode `\\=\other +\openin 1 \jobname.aux +\ifeof 1 \else \closein 1 \input \jobname.aux \global\havexrefstrue +\fi +% Open the new aux file. Tex will close it automatically at exit. +\openout \auxfile=\jobname.aux +\endgroup} + + +% Footnotes. + +\newcount \footnoteno + +% The trailing space in the following definition for supereject is +% vital for proper filling; pages come out unaligned when you do a +% pagealignmacro call if that space before the closing brace is +% removed. +\def\supereject{\par\penalty -20000\footnoteno =0 } + +% @footnotestyle is meaningful for info output only.. +\let\footnotestyle=\comment + +\let\ptexfootnote=\footnote + +{\catcode `\@=11 +\long\gdef\footnote #1{\global\advance \footnoteno by \@ne +\unskip +\edef\thisfootno{$^{\the\footnoteno}$}% +\let\@sf\empty +\ifhmode\edef\@sf{\spacefactor\the\spacefactor}\/\fi +\thisfootno\@sf \footnotezzz{#1}} +% \parsearg\footnotezzz} + +\long\gdef\footnotezzz #1{\insert\footins{ +\interlinepenalty\interfootnotelinepenalty +\splittopskip\ht\strutbox % top baseline for broken footnotes +\splitmaxdepth\dp\strutbox \floatingpenalty\@MM +\leftskip\z@skip \rightskip\z@skip \spaceskip\z@skip \xspaceskip\z@skip +\footstrut\parindent=\defaultparindent\hang\textindent{\thisfootno}#1\strut}} + +}%end \catcode `\@=11 + +% End of control word definitions. + +\message{and turning on texinfo input format.} + +\def\openindices{% + \newindex{cp}% + \newcodeindex{fn}% + \newcodeindex{vr}% + \newcodeindex{tp}% + \newcodeindex{ky}% + \newcodeindex{pg}% +} + +% Set some numeric style parameters, for 8.5 x 11 format. + +%\hsize = 6.5in +\newdimen\defaultparindent \defaultparindent = 15pt +\parindent = \defaultparindent +\parskip 18pt plus 1pt +\baselineskip 15pt +\advance\topskip by 1.2cm + +% Prevent underfull vbox error messages. +\vbadness=10000 + +% Following George Bush, just get rid of widows and orphans. +\widowpenalty=10000 +\clubpenalty=10000 + +% Use TeX 3.0's \emergencystretch to help line breaking, but if we're +% using an old version of TeX, don't do anything. We want the amount of +% stretch added to depend on the line length, hence the dependence on +% \hsize. This makes it come to about 9pt for the 8.5x11 format. +% +\ifx\emergencystretch\thisisundefined \else + \emergencystretch = \hsize + \divide\emergencystretch by 45 +\fi + +% Use @smallbook to reset parameters for 7x9.5 format (or else 7x9.25) +\def\smallbook{ +\global\lispnarrowing = 0.3in +\global\baselineskip 12pt +\advance\topskip by -1cm +\global\parskip 3pt plus 1pt +\global\hsize = 5in +\global\doublecolumnhsize=2.4in \global\doublecolumnvsize=15.0in +\global\vsize=7.5in +\global\tolerance=700 +\global\hfuzz=1pt +\global\contentsrightmargin=0pt + +\global\pagewidth=\hsize +\global\pageheight=\vsize + +\global\let\smalllisp=\smalllispx +\global\let\smallexample=\smalllispx +\global\def\Esmallexample{\Esmalllisp} +} + +% Use @afourpaper to print on European A4 paper. +\def\afourpaper{ +\global\tolerance=700 +\global\hfuzz=1pt +\global\baselineskip=12pt +\global\parskip 15pt plus 1pt + +\global\vsize= 53\baselineskip +\advance\vsize by \topskip +%\global\hsize= 5.85in % A4 wide 10pt +\global\hsize= 6.5in +\global\outerhsize=\hsize +\global\advance\outerhsize by 0.5in +\global\outervsize=\vsize +\global\advance\outervsize by 0.6in +\global\doublecolumnhsize=\hsize +\global\divide\doublecolumnhsize by 2 +\global\advance\doublecolumnhsize by -0.1in +\global\doublecolumnvsize=\vsize +\global\multiply\doublecolumnvsize by 2 +\global\advance\doublecolumnvsize by 0.1in + +\global\pagewidth=\hsize +\global\pageheight=\vsize +} + +%% For a final copy, take out the rectangles +%% that mark overfull boxes (in case you have decided +%% that the text looks ok even though it passes the margin). +\def\finalout{\overfullrule=0pt} + +% Define macros to output various characters with catcode for normal text. +\catcode`\"=\other +\catcode`\~=\other +\catcode`\^=\other +\catcode`\_=\other +\catcode`\|=\other +\catcode`\<=\other +\catcode`\>=\other +\catcode`\+=\other +\def\normaldoublequote{"} +\def\normaltilde{~} +\def\normalcaret{^} +\def\normalunderscore{_} +\def\normalverticalbar{|} +\def\normalless{<} +\def\normalgreater{>} +\def\normalplus{+} + +% This macro is used to make a character print one way in ttfont +% where it can probably just be output, and another way in other fonts, +% where something hairier probably needs to be done. +% +% #1 is what to print if we are indeed using \tt; #2 is what to print +% otherwise. Since all the Computer Modern typewriter fonts have zero +% interword stretch (and shrink), and it is reasonable to expect all +% typewriter fonts to have this, we can check that font parameter. +% +\def\ifusingtt#1#2{\ifdim \fontdimen3\the\font=0pt #1\else #2\fi} + +% Turn off all special characters except @ +% (and those which the user can use as if they were ordinary). +% Most of these we simply print from the \tt font, but for some, we can +% use math or other variants that look better in normal text. + +\catcode`\"=\active +\def\activedoublequote{{\tt \char '042}} +\let"=\activedoublequote +\catcode`\~=\active +\def~{{\tt \char '176}} +\chardef\hat=`\^ +\catcode`\^=\active +\def^{{\tt \hat}} + +\catcode`\_=\active +\def_{\ifusingtt\normalunderscore\_} +% Subroutine for the previous macro. +\def\_{\lvvmode \kern.06em \vbox{\hrule width.3em height.1ex}} + +% \lvvmode is equivalent in function to \leavevmode. +% Using \leavevmode runs into trouble when written out to +% an index file due to the expansion of \leavevmode into ``\unhbox +% \voidb@x'' ---which looks to TeX like ``\unhbox \voidb\x'' due to our +% magic tricks with @. +\def\lvvmode{\vbox to 0pt{}} + +\catcode`\|=\active +\def|{{\tt \char '174}} +\chardef \less=`\< +\catcode`\<=\active +\def<{{\tt \less}} +\chardef \gtr=`\> +\catcode`\>=\active +\def>{{\tt \gtr}} +\catcode`\+=\active +\def+{{\tt \char 43}} +%\catcode 27=\active +%\def^^[{$\diamondsuit$} + +% Used sometimes to turn off (effectively) the active characters +% even after parsing them. +\def\turnoffactive{\let"=\normaldoublequote +\let~=\normaltilde +\let^=\normalcaret +\let_=\normalunderscore +\let|=\normalverticalbar +\let<=\normalless +\let>=\normalgreater +\let+=\normalplus} + +% Set up an active definition for =, but don't enable it most of the time. +{\catcode`\==\active +\global\def={{\tt \char 61}}} + +\catcode`\@=0 + +% \rawbackslashxx output one backslash character in current font +\global\chardef\rawbackslashxx=`\\ +%{\catcode`\\=\other +%@gdef@rawbackslashxx{\}} + +% \rawbackslash redefines \ as input to do \rawbackslashxx. +{\catcode`\\=\active +@gdef@rawbackslash{@let\=@rawbackslashxx }} + +% \normalbackslash outputs one backslash in fixed width font. +\def\normalbackslash{{\tt\rawbackslashxx}} + +% Say @foo, not \foo, in error messages. +\escapechar=`\@ + +% \catcode 17=0 % Define control-q +\catcode`\\=\active + +% If a .fmt file is being used, we don't want the `\input texinfo' to show up. +% That is what \eatinput is for; after that, the `\' should revert to printing +% a backslash. +% +@gdef@eatinput input texinfo{@fixbackslash} +@global@let\ = @eatinput + +% On the other hand, perhaps the file did not have a `\input texinfo'. Then +% the first `\{ in the file would cause an error. This macro tries to fix +% that, assuming it is called before the first `\' could plausibly occur. +% +@gdef@fixbackslash{@ifx\@eatinput @let\ = @normalbackslash @fi} + +%% These look ok in all fonts, so just make them not special. The @rm below +%% makes sure that the current font starts out as the newly loaded cmr10 +@catcode`@$=@other @catcode`@%=@other @catcode`@&=@other @catcode`@#=@other + +@textfonts +@rm + +@c Local variables: +@c page-delimiter: "^\\\\message" +@c End: diff --cc test/manual/etags/y-src/cccp.c index 6996705d7cb,00000000000..776e3dad4b0 mode 100644,000000..100644 --- a/test/manual/etags/y-src/cccp.c +++ b/test/manual/etags/y-src/cccp.c @@@ -1,2202 -1,0 +1,2203 @@@ +/* A Bison parser, made from cccp.y + by GNU bison 1.32. */ + +#define YYBISON 1 /* Identify Bison output. */ + +# define INT 257 +# define CHAR 258 +# define NAME 259 +# define ERROR 260 +# define OR 261 +# define AND 262 +# define EQUAL 263 +# define NOTEQUAL 264 +# define LEQ 265 +# define GEQ 266 +# define LSH 267 +# define RSH 268 +# define UNARY 269 + +#line 26 "cccp.y" + +#include "config.h" +#include <setjmp.h> +/* #define YYDEBUG 1 */ + +#ifdef MULTIBYTE_CHARS +#include <stdlib.h> +#include <locale.h> +#endif + +#include <stdio.h> + +typedef unsigned char U_CHAR; + +/* This is used for communicating lists of keywords with cccp.c. */ +struct arglist { + struct arglist *next; + U_CHAR *name; + int length; + int argno; +}; + +/* Define a generic NULL if one hasn't already been defined. */ + +#ifndef NULL +#define NULL 0 +#endif + +#ifndef GENERIC_PTR +#if defined (USE_PROTOTYPES) ? USE_PROTOTYPES : defined (__STDC__) +#define GENERIC_PTR void * +#else +#define GENERIC_PTR char * +#endif +#endif + +#ifndef NULL_PTR +#define NULL_PTR ((GENERIC_PTR)0) +#endif + +int yylex (); +void yyerror (); +int expression_value; + +static jmp_buf parse_return_error; + +/* Nonzero means count most punctuation as part of a name. */ +static int keyword_parsing = 0; + +/* some external tables of character types */ +extern unsigned char is_idstart[], is_idchar[], is_hor_space[]; + +extern char *xmalloc (); + +/* Flag for -pedantic. */ +extern int pedantic; + +/* Flag for -traditional. */ +extern int traditional; + +#ifndef CHAR_TYPE_SIZE +#define CHAR_TYPE_SIZE BITS_PER_UNIT +#endif + +#ifndef INT_TYPE_SIZE +#define INT_TYPE_SIZE BITS_PER_WORD +#endif + +#ifndef LONG_TYPE_SIZE +#define LONG_TYPE_SIZE BITS_PER_WORD +#endif + +#ifndef WCHAR_TYPE_SIZE +#define WCHAR_TYPE_SIZE INT_TYPE_SIZE +#endif + +/* Yield nonzero if adding two numbers with A's and B's signs can yield a + number with SUM's sign, where A, B, and SUM are all C integers. */ +#define possible_sum_sign(a, b, sum) ((((a) ^ (b)) | ~ ((a) ^ (sum))) < 0) + +static void integer_overflow (); +static long left_shift (); +static long right_shift (); + +#line 111 "cccp.y" +#ifndef YYSTYPE +typedef union { + struct constant {long value; int unsignedp;} integer; + struct name {U_CHAR *address; int length;} name; + struct arglist *keywords; + int voidval; + char *sval; +} yystype; +# define YYSTYPE yystype +#endif +#ifndef YYDEBUG +# define YYDEBUG 0 +#endif + + + +#define YYFINAL 73 +#define YYFLAG -32768 +#define YYNTBASE 34 + +/* YYTRANSLATE(YYLEX) -- Bison token number corresponding to YYLEX. */ +#define YYTRANSLATE(x) ((unsigned)(x) <= 269 ? yytranslate[x] : 39) + +/* YYTRANSLATE[YYLEX] -- Bison token number corresponding to YYLEX. */ +static const char yytranslate[] = +{ + 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 29, 2, 31, 2, 27, 14, 2, + 32, 33, 25, 23, 9, 24, 2, 26, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 8, 2, + 17, 2, 18, 7, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 13, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 12, 2, 30, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 1, 3, 4, 5, + 6, 10, 11, 15, 16, 19, 20, 21, 22, 28 +}; + +#if YYDEBUG +static const short yyprhs[] = +{ + 0, 0, 2, 4, 8, 11, 14, 17, 20, 23, + 24, 31, 35, 39, 43, 47, 51, 55, 59, 63, + 67, 71, 75, 79, 83, 87, 91, 95, 99, 103, + 107, 113, 115, 117, 119, 120, 125 +}; +static const short yyrhs[] = +{ + 35, 0, 36, 0, 35, 9, 36, 0, 24, 36, + 0, 29, 36, 0, 23, 36, 0, 30, 36, 0, + 31, 5, 0, 0, 31, 5, 37, 32, 38, 33, + 0, 32, 35, 33, 0, 36, 25, 36, 0, 36, + 26, 36, 0, 36, 27, 36, 0, 36, 23, 36, + 0, 36, 24, 36, 0, 36, 21, 36, 0, 36, + 22, 36, 0, 36, 15, 36, 0, 36, 16, 36, + 0, 36, 19, 36, 0, 36, 20, 36, 0, 36, + 17, 36, 0, 36, 18, 36, 0, 36, 14, 36, + 0, 36, 13, 36, 0, 36, 12, 36, 0, 36, + 11, 36, 0, 36, 10, 36, 0, 36, 7, 36, + 8, 36, 0, 3, 0, 4, 0, 5, 0, 0, + 32, 38, 33, 38, 0, 5, 38, 0 +}; + +#endif + +#if YYDEBUG +/* YYRLINE[YYN] -- source line where rule number YYN was defined. */ +static const short yyrline[] = +{ + 0, 143, 148, 149, 156, 161, 164, 166, 169, 173, + 173, 180, 185, 197, 212, 223, 230, 237, 243, 249, + 252, 255, 261, 267, 273, 279, 282, 285, 288, 291, + 294, 297, 299, 301, 306, 308, 321 +}; +#endif + + +#if (YYDEBUG) || defined YYERROR_VERBOSE + +/* YYTNAME[TOKEN_NUM] -- String name of the token TOKEN_NUM. */ +static const char *const yytname[] = +{ + "$", "error", "$undefined.", "INT", "CHAR", "NAME", "ERROR", "'?'", "':'", + "','", "OR", "AND", "'|'", "'^'", "'&'", "EQUAL", "NOTEQUAL", "'<'", + "'>'", "LEQ", "GEQ", "LSH", "RSH", "'+'", "'-'", "'*'", "'/'", "'%'", + "UNARY", "'!'", "'~'", "'#'", "'('", "')'", "start", "exp1", "exp", + "@1", "keywords", NULL +}; +#endif + +/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ +static const short yyr1[] = +{ + 0, 34, 35, 35, 36, 36, 36, 36, 36, 37, + 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, + 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, + 36, 36, 36, 36, 38, 38, 38 +}; + +/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ +static const short yyr2[] = +{ + 0, 1, 1, 3, 2, 2, 2, 2, 2, 0, + 6, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 5, 1, 1, 1, 0, 4, 2 +}; + +/* YYDEFACT[S] -- default rule to reduce with in state S when YYTABLE + doesn't specify something else to do. Zero means the default is an + error. */ +static const short yydefact[] = +{ + 0, 31, 32, 33, 0, 0, 0, 0, 0, 0, + 1, 2, 6, 4, 5, 7, 8, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 11, + 3, 0, 29, 28, 27, 26, 25, 19, 20, 23, + 24, 21, 22, 17, 18, 15, 16, 12, 13, 14, + 34, 0, 34, 34, 0, 30, 36, 0, 10, 34, + 35, 0, 0, 0 +}; + +static const short yydefgoto[] = +{ + 71, 10, 11, 38, 64 +}; + +static const short yypact[] = +{ + 31,-32768,-32768,-32768, 31, 31, 31, 31, 4, 31, + 3, 80,-32768,-32768,-32768,-32768, 6, 32, 31, 31, + 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, + 31, 31, 31, 31, 31, 31, 31, 31, 7,-32768, + 80, 59, 97, 113, 128, 142, 155, 25, 25, 162, + 162, 162, 162, 167, 167, -19, -19,-32768,-32768,-32768, + 5, 31, 5, 5, -20, 80,-32768, 20,-32768, 5, + -32768, 40, 56,-32768 +}; + +static const short yypgoto[] = +{ + -32768, 49, -4,-32768, -58 +}; + + +#define YYLAST 194 + + +static const short yytable[] = +{ + 12, 13, 14, 15, 66, 67, 35, 36, 37, 16, + 62, 70, 18, 68, 40, 41, 42, 43, 44, 45, + 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 1, 2, 3, 63, -9, 60, + 72, 18, 27, 28, 29, 30, 31, 32, 33, 34, + 35, 36, 37, 69, 4, 5, 73, 65, 17, 0, + 6, 7, 8, 9, 0, 39, 19, 61, 0, 20, + 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, + 31, 32, 33, 34, 35, 36, 37, 19, 0, 0, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, + 30, 31, 32, 33, 34, 35, 36, 37, 21, 22, + 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, + 33, 34, 35, 36, 37, 22, 23, 24, 25, 26, + 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, + 37, 23, 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 24, 25, 26, 27, + 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, + 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, + 35, 36, 37, 31, 32, 33, 34, 35, 36, 37, + 33, 34, 35, 36, 37 +}; + +static const short yycheck[] = +{ + 4, 5, 6, 7, 62, 63, 25, 26, 27, 5, + 5, 69, 9, 33, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, + 34, 35, 36, 37, 3, 4, 5, 32, 32, 32, + 0, 9, 17, 18, 19, 20, 21, 22, 23, 24, + 25, 26, 27, 33, 23, 24, 0, 61, 9, -1, + 29, 30, 31, 32, -1, 33, 7, 8, -1, 10, + 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, + 21, 22, 23, 24, 25, 26, 27, 7, -1, -1, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, + 20, 21, 22, 23, 24, 25, 26, 27, 11, 12, + 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, + 23, 24, 25, 26, 27, 12, 13, 14, 15, 16, + 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, + 27, 13, 14, 15, 16, 17, 18, 19, 20, 21, + 22, 23, 24, 25, 26, 27, 14, 15, 16, 17, + 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, + 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, + 25, 26, 27, 21, 22, 23, 24, 25, 26, 27, + 23, 24, 25, 26, 27 +}; +/* -*-C-*- Note some compilers choke on comments on `#line' lines. */ +#line 3 "/usr/share/bison/bison.simple" + +/* Skeleton output parser for bison, - Copyright (C) 1984, 1989, 1990, 2000, 2001 Free Software Foundation, Inc. ++ Copyright (C) 1984, 1989-1990, 2000-2001, 2016 Free Software ++ Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + +/* As a special exception, when this file is copied by Bison into a + Bison output file, you may use that output file without restriction. + This special exception was added by the Free Software Foundation + in version 1.24 of Bison. */ + +/* This is the parser code that is written into each bison parser when + the %semantic_parser declaration is not specified in the grammar. + It was written by Richard Stallman by simplifying the hairy parser + used when %semantic_parser is specified. */ + +/* All symbols defined below should begin with yy or YY, to avoid + infringing on user name space. This should be done even for local + variables, as they might otherwise be expanded by user macros. + There are some unavoidable exceptions within include files to + define necessary library symbols; they are noted "INFRINGES ON + USER NAME SPACE" below. */ + +#ifdef __cplusplus +# define YYSTD(x) std::x +#else +# define YYSTD(x) x +#endif + +#if ! defined (yyoverflow) || defined (YYERROR_VERBOSE) + +/* The parser invokes alloca or malloc; define the necessary symbols. */ + +# if YYSTACK_USE_ALLOCA +# define YYSTACK_ALLOC alloca +# define YYSIZE_T YYSTD (size_t) +# else +# ifndef YYSTACK_USE_ALLOCA +# if defined (alloca) || defined (_ALLOCA_H) +# define YYSTACK_ALLOC alloca +# define YYSIZE_T YYSTD (size_t) +# else +# ifdef __GNUC__ +# define YYSTACK_ALLOC __builtin_alloca +# endif +# endif +# endif +# endif + +# ifdef YYSTACK_ALLOC + /* Pacify GCC's `empty if-body' warning. */ +# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0) +# else +# ifdef __cplusplus +# include <cstdlib> /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T std::size_t +# else +# ifdef __STDC__ +# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T size_t +# endif +# endif +# define YYSTACK_ALLOC YYSTD (malloc) +# define YYSTACK_FREE YYSTD (free) +# endif + +/* A type that is properly aligned for any stack member. */ +union yyalloc +{ + short yyss; + YYSTYPE yyvs; +# if YYLSP_NEEDED + YYLTYPE yyls; +# endif +}; + +/* The size of the maximum gap between one aligned stack and the next. */ +# define YYSTACK_GAP_MAX (sizeof (union yyalloc) - 1) + +/* The size of an array large to enough to hold all stacks, each with + N elements. */ +# if YYLSP_NEEDED +# define YYSTACK_BYTES(N) \ + ((N) * (sizeof (short) + sizeof (YYSTYPE) + sizeof (YYLTYPE)) \ + + 2 * YYSTACK_GAP_MAX) +# else +# define YYSTACK_BYTES(N) \ + ((N) * (sizeof (short) + sizeof (YYSTYPE)) \ + + YYSTACK_GAP_MAX) +# endif + +/* Relocate the TYPE STACK from its old location to the new one. The + local variables YYSIZE and YYSTACKSIZE give the old and new number of + elements in the stack, and YYPTR gives the new location of the + stack. Advance YYPTR to a properly aligned location for the next + stack. */ +# define YYSTACK_RELOCATE(Type, Stack) \ + do \ + { \ + YYSIZE_T yynewbytes; \ + yymemcpy ((char *) yyptr, (char *) (Stack), \ + yysize * (YYSIZE_T) sizeof (Type)); \ + Stack = &yyptr->Stack; \ + yynewbytes = yystacksize * sizeof (Type) + YYSTACK_GAP_MAX; \ + yyptr += yynewbytes / sizeof (*yyptr); \ + } \ + while (0) + +#endif /* ! defined (yyoverflow) || defined (YYERROR_VERBOSE) */ + + +#if ! defined (YYSIZE_T) && defined (__SIZE_TYPE__) +# define YYSIZE_T __SIZE_TYPE__ +#endif +#if ! defined (YYSIZE_T) && defined (size_t) +# define YYSIZE_T size_t +#endif +#if ! defined (YYSIZE_T) +# ifdef __cplusplus +# include <cstddef> /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T std::size_t +# else +# ifdef __STDC__ +# include <stddef.h> /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T size_t +# endif +# endif +#endif +#if ! defined (YYSIZE_T) +# define YYSIZE_T unsigned int +#endif + +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY -2 +#define YYEOF 0 +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrlab1 +/* Like YYERROR except do call yyerror. This remains here temporarily + to ease the transition to the new meaning of YYERROR, for GCC. + Once GCC version 2 has supplanted version 1, this can go. */ +#define YYFAIL goto yyerrlab +#define YYRECOVERING() (!!yyerrstatus) +#define YYBACKUP(Token, Value) \ +do \ + if (yychar == YYEMPTY && yylen == 1) \ + { \ + yychar = (Token); \ + yylval = (Value); \ + yychar1 = YYTRANSLATE (yychar); \ + YYPOPSTACK; \ + goto yybackup; \ + } \ + else \ + { \ + yyerror ("syntax error: cannot back up"); \ + YYERROR; \ + } \ +while (0) + +#define YYTERROR 1 +#define YYERRCODE 256 + + +/* YYLLOC_DEFAULT -- Compute the default location (before the actions + are run). + + When YYLLOC_DEFAULT is run, CURRENT is set the location of the + first token. By default, to implement support for ranges, extend + its range to the last symbol. */ + +#ifndef YYLLOC_DEFAULT +# define YYLLOC_DEFAULT(Current, Rhs, N) \ + Current.last_line = Rhs[N].last_line; \ + Current.last_column = Rhs[N].last_column; +#endif + + +/* YYLEX -- calling `yylex' with the right arguments. */ + +#if YYPURE +# if YYLSP_NEEDED +# ifdef YYLEX_PARAM +# define YYLEX yylex (&yylval, &yylloc, YYLEX_PARAM) +# else +# define YYLEX yylex (&yylval, &yylloc) +# endif +# else /* !YYLSP_NEEDED */ +# ifdef YYLEX_PARAM +# define YYLEX yylex (&yylval, YYLEX_PARAM) +# else +# define YYLEX yylex (&yylval) +# endif +# endif /* !YYLSP_NEEDED */ +#else /* !YYPURE */ +# define YYLEX yylex () +#endif /* !YYPURE */ + + +/* Enable debugging if requested. */ +#if YYDEBUG + +# ifndef YYFPRINTF +# ifdef __cplusplus +# include <cstdio> /* INFRINGES ON USER NAME SPACE */ +# else +# include <stdio.h> /* INFRINGES ON USER NAME SPACE */ +# endif +# define YYFPRINTF YYSTD (fprintf) +# endif + +# define YYDPRINTF(Args) \ +do { \ + if (yydebug) \ + YYFPRINTF Args; \ +} while (0) +/* Nonzero means print parse trace. [The following comment makes no + sense to me. Could someone clarify it? --akim] Since this is + uninitialized, it does not stop multiple parsers from coexisting. + */ +int yydebug; +#else /* !YYDEBUG */ +# define YYDPRINTF(Args) +#endif /* !YYDEBUG */ + +/* YYINITDEPTH -- initial size of the parser's stacks. */ +#ifndef YYINITDEPTH +# define YYINITDEPTH 200 +#endif + +/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only + if the built-in stack extension method is used). + + Do not make this value too large; the results are undefined if + SIZE_MAX < YYSTACK_BYTES (YYMAXDEPTH) + evaluated with infinite-precision integer arithmetic. */ + +#if YYMAXDEPTH == 0 +# undef YYMAXDEPTH +#endif + +#ifndef YYMAXDEPTH +# define YYMAXDEPTH 10000 +#endif + +#if ! defined (yyoverflow) && ! defined (yymemcpy) +# if __GNUC__ > 1 /* GNU C and GNU C++ define this. */ +# define yymemcpy __builtin_memcpy +# else /* not GNU C or C++ */ + +/* This is the most reliable way to avoid incompatibilities + in available built-in functions on various systems. */ +static void +# if defined (__STDC__) || defined (__cplusplus) +yymemcpy (char *yyto, const char *yyfrom, YYSIZE_T yycount) +# else +yymemcpy (yyto, yyfrom, yycount) + char *yyto; + const char *yyfrom; + YYSIZE_T yycount; +# endif +{ + register const char *yyf = yyfrom; + register char *yyt = yyto; + register YYSIZE_T yyi = yycount; + + while (yyi-- != 0) + *yyt++ = *yyf++; +} +# endif +#endif + +#ifdef YYERROR_VERBOSE + +# ifndef yystrlen +# if defined (__GLIBC__) && defined (_STRING_H) +# define yystrlen strlen +# else +/* Return the length of YYSTR. */ +static YYSIZE_T +# if defined (__STDC__) || defined (__cplusplus) +yystrlen (const char *yystr) +# else +yystrlen (yystr) + const char *yystr; +# endif +{ + register const char *yys = yystr; + + while (*yys++ != '\0') + continue; + + return yys - yystr - 1; +} +# endif +# endif + +# ifndef yystpcpy +# if defined (__GLIBC__) && defined (_STRING_H) && defined (_GNU_SOURCE) +# define yystpcpy stpcpy +# else +/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in + YYDEST. */ +static char * +# if defined (__STDC__) || defined (__cplusplus) +yystpcpy (char *yydest, const char *yysrc) +# else +yystpcpy (yydest, yysrc) + char *yydest; + const char *yysrc; +# endif +{ + register char *yyd = yydest; + register const char *yys = yysrc; + + while ((*yyd++ = *yys++) != '\0') + continue; + + return yyd - 1; +} +# endif +# endif +#endif + +#line 341 "/usr/share/bison/bison.simple" + + +/* The user can define YYPARSE_PARAM as the name of an argument to be passed + into yyparse. The argument should have type void *. + It should actually point to an object. + Grammar actions can access the variable by casting it + to the proper pointer type. */ + +#ifdef YYPARSE_PARAM +# ifdef __cplusplus +# define YYPARSE_PARAM_ARG void *YYPARSE_PARAM +# define YYPARSE_PARAM_DECL +# else /* !__cplusplus */ +# define YYPARSE_PARAM_ARG YYPARSE_PARAM +# define YYPARSE_PARAM_DECL void *YYPARSE_PARAM; +# endif /* !__cplusplus */ +#else /* !YYPARSE_PARAM */ +# define YYPARSE_PARAM_ARG +# define YYPARSE_PARAM_DECL +#endif /* !YYPARSE_PARAM */ + +/* Prevent warning if -Wstrict-prototypes. */ +#ifdef __GNUC__ +# ifdef YYPARSE_PARAM +int yyparse (void *); +# else +int yyparse (void); +# endif +#endif + +/* YY_DECL_VARIABLES -- depending whether we use a pure parser, + variables are global, or local to YYPARSE. */ + +#define YY_DECL_NON_LSP_VARIABLES \ +/* The lookahead symbol. */ \ +int yychar; \ + \ +/* The semantic value of the lookahead symbol. */ \ +YYSTYPE yylval; \ + \ +/* Number of parse errors so far. */ \ +int yynerrs; + +#if YYLSP_NEEDED +# define YY_DECL_VARIABLES \ +YY_DECL_NON_LSP_VARIABLES \ + \ +/* Location data for the lookahead symbol. */ \ +YYLTYPE yylloc; +#else +# define YY_DECL_VARIABLES \ +YY_DECL_NON_LSP_VARIABLES +#endif + + +/* If nonreentrant, generate the variables here. */ + +#if !YYPURE +YY_DECL_VARIABLES +#endif /* !YYPURE */ + +int +yyparse (YYPARSE_PARAM_ARG) + YYPARSE_PARAM_DECL +{ + /* If reentrant, generate the variables here. */ +#if YYPURE + YY_DECL_VARIABLES +#endif /* !YYPURE */ + + register int yystate; + register int yyn; + int yyresult; + /* Number of tokens to shift before error messages enabled. */ + int yyerrstatus; + /* Lookahead token as an internal (translated) token number. */ + int yychar1 = 0; + + /* Three stacks and their tools: + `yyss': related to states, + `yyvs': related to semantic values, + `yyls': related to locations. + + Refer to the stacks thru separate pointers, to allow yyoverflow + to reallocate them elsewhere. */ + + /* The state stack. */ + short yyssa[YYINITDEPTH]; + short *yyss = yyssa; + register short *yyssp; + + /* The semantic value stack. */ + YYSTYPE yyvsa[YYINITDEPTH]; + YYSTYPE *yyvs = yyvsa; + register YYSTYPE *yyvsp; + +#if YYLSP_NEEDED + /* The location stack. */ + YYLTYPE yylsa[YYINITDEPTH]; + YYLTYPE *yyls = yylsa; + YYLTYPE *yylsp; +#endif + +#if YYLSP_NEEDED +# define YYPOPSTACK (yyvsp--, yyssp--, yylsp--) +#else +# define YYPOPSTACK (yyvsp--, yyssp--) +#endif + + YYSIZE_T yystacksize = YYINITDEPTH; + + + /* The variables used to return semantic value and location from the + action routines. */ + YYSTYPE yyval; +#if YYLSP_NEEDED + YYLTYPE yyloc; +#endif + + /* When reducing, the number of symbols on the RHS of the reduced + rule. */ + int yylen; + + YYDPRINTF ((stderr, "Starting parse\n")); + + yystate = 0; + yyerrstatus = 0; + yynerrs = 0; + yychar = YYEMPTY; /* Cause a token to be read. */ + + /* Initialize stack pointers. + Waste one element of value and location stack + so that they stay on the same level as the state stack. + The wasted elements are never initialized. */ + + yyssp = yyss; + yyvsp = yyvs; +#if YYLSP_NEEDED + yylsp = yyls; +#endif + goto yysetstate; + +/*------------------------------------------------------------. +| yynewstate -- Push a new state, which is found in yystate. | +`------------------------------------------------------------*/ + yynewstate: + /* In all cases, when you get here, the value and location stacks + have just been pushed. so pushing a state here evens the stacks. + */ + yyssp++; + + yysetstate: + *yyssp = yystate; + + if (yyssp >= yyss + yystacksize - 1) + { + /* Get the current used size of the three stacks, in elements. */ + YYSIZE_T yysize = yyssp - yyss + 1; + +#ifdef yyoverflow + { + /* Give user a chance to reallocate the stack. Use copies of + these so that the &'s don't force the real ones into + memory. */ + YYSTYPE *yyvs1 = yyvs; + short *yyss1 = yyss; + + /* Each stack pointer address is followed by the size of the + data in use in that stack, in bytes. */ +# if YYLSP_NEEDED + YYLTYPE *yyls1 = yyls; + /* This used to be a conditional around just the two extra args, + but that might be undefined if yyoverflow is a macro. */ + yyoverflow ("parser stack overflow", + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + &yyls1, yysize * sizeof (*yylsp), + &yystacksize); + yyls = yyls1; +# else + yyoverflow ("parser stack overflow", + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + &yystacksize); +# endif + yyss = yyss1; + yyvs = yyvs1; + } +#else /* no yyoverflow */ + /* Extend the stack our own way. */ + if (yystacksize >= YYMAXDEPTH) + goto yyoverflowlab; + yystacksize *= 2; + if (yystacksize > YYMAXDEPTH) + yystacksize = YYMAXDEPTH; + + { + short *yyss1 = yyss; + union yyalloc *yyptr = + (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); + if (! yyptr) + goto yyoverflowlab; + YYSTACK_RELOCATE (short, yyss); + YYSTACK_RELOCATE (YYSTYPE, yyvs); +# if YYLSP_NEEDED + YYSTACK_RELOCATE (YYLTYPE, yyls); +# endif +# undef YYSTACK_RELOCATE + if (yyss1 != yyssa) + YYSTACK_FREE (yyss1); + } +#endif /* no yyoverflow */ + + yyssp = yyss + yysize - 1; + yyvsp = yyvs + yysize - 1; +#if YYLSP_NEEDED + yylsp = yyls + yysize - 1; +#endif + + YYDPRINTF ((stderr, "Stack size increased to %lu\n", + (unsigned long int) yystacksize)); + + if (yyssp >= yyss + yystacksize - 1) + YYABORT; + } + + YYDPRINTF ((stderr, "Entering state %d\n", yystate)); + + goto yybackup; + + +/*-----------. +| yybackup. | +`-----------*/ +yybackup: + +/* Do appropriate processing given the current state. */ +/* Read a lookahead token if we need one and don't already have one. */ +/* yyresume: */ + + /* First try to decide what to do without reference to lookahead token. */ + + yyn = yypact[yystate]; + if (yyn == YYFLAG) + goto yydefault; + + /* Not known => get a lookahead token if don't already have one. */ + + /* yychar is either YYEMPTY or YYEOF + or a valid token in external form. */ + + if (yychar == YYEMPTY) + { + YYDPRINTF ((stderr, "Reading a token: ")); + yychar = YYLEX; + } + + /* Convert token to internal form (in yychar1) for indexing tables with */ + + if (yychar <= 0) /* This means end of input. */ + { + yychar1 = 0; + yychar = YYEOF; /* Don't call YYLEX any more */ + + YYDPRINTF ((stderr, "Now at end of input.\n")); + } + else + { + yychar1 = YYTRANSLATE (yychar); + +#if YYDEBUG + /* We have to keep this `#if YYDEBUG', since we use variables + which are defined only if `YYDEBUG' is set. */ + if (yydebug) + { + YYFPRINTF (stderr, "Next token is %d (%s", + yychar, yytname[yychar1]); + /* Give the individual parser a way to print the precise + meaning of a token, for further debugging info. */ +# ifdef YYPRINT + YYPRINT (stderr, yychar, yylval); +# endif + YYFPRINTF (stderr, ")\n"); + } +#endif + } + + yyn += yychar1; + if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != yychar1) + goto yydefault; + + yyn = yytable[yyn]; + + /* yyn is what to do for this token type in this state. + Negative => reduce, -yyn is rule number. + Positive => shift, yyn is new state. + New state is final state => don't bother to shift, + just return success. + 0, or most negative number => error. */ + + if (yyn < 0) + { + if (yyn == YYFLAG) + goto yyerrlab; + yyn = -yyn; + goto yyreduce; + } + else if (yyn == 0) + goto yyerrlab; + + if (yyn == YYFINAL) + YYACCEPT; + + /* Shift the lookahead token. */ + YYDPRINTF ((stderr, "Shifting token %d (%s), ", + yychar, yytname[yychar1])); + + /* Discard the token being shifted unless it is eof. */ + if (yychar != YYEOF) + yychar = YYEMPTY; + + *++yyvsp = yylval; +#if YYLSP_NEEDED + *++yylsp = yylloc; +#endif + + /* Count tokens shifted since error; after three, turn off error + status. */ + if (yyerrstatus) + yyerrstatus--; + + yystate = yyn; + goto yynewstate; + + +/*-----------------------------------------------------------. +| yydefault -- do the default action for the current state. | +`-----------------------------------------------------------*/ +yydefault: + yyn = yydefact[yystate]; + if (yyn == 0) + goto yyerrlab; + goto yyreduce; + + +/*-----------------------------. +| yyreduce -- Do a reduction. | +`-----------------------------*/ +yyreduce: + /* yyn is the number of a rule to reduce with. */ + yylen = yyr2[yyn]; + + /* If YYLEN is nonzero, implement the default value of the action: + `$$ = $1'. + + Otherwise, the following line sets YYVAL to the semantic value of + the lookahead token. This behavior is undocumented and Bison + users should not rely upon it. Assigning to YYVAL + unconditionally makes the parser a bit smaller, and it avoids a + GCC warning that YYVAL may be used uninitialized. */ + yyval = yyvsp[1-yylen]; + +#if YYLSP_NEEDED + /* Similarly for the default location. Let the user run additional + commands if for instance locations are ranges. */ + yyloc = yylsp[1-yylen]; + YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen); +#endif + +#if YYDEBUG + /* We have to keep this `#if YYDEBUG', since we use variables which + are defined only if `YYDEBUG' is set. */ + if (yydebug) + { + int yyi; + + YYFPRINTF (stderr, "Reducing via rule %d (line %d), ", + yyn, yyrline[yyn]); + + /* Print the symbols being reduced, and their result. */ + for (yyi = yyprhs[yyn]; yyrhs[yyi] > 0; yyi++) + YYFPRINTF (stderr, "%s ", yytname[yyrhs[yyi]]); + YYFPRINTF (stderr, " -> %s\n", yytname[yyr1[yyn]]); + } +#endif + + switch (yyn) { + +case 1: +#line 144 "cccp.y" +{ expression_value = yyvsp[0].integer.value; } + break; +case 3: +#line 150 "cccp.y" +{ if (pedantic) + pedwarn ("comma operator in operand of `#if'"); + yyval.integer = yyvsp[0].integer; } + break; +case 4: +#line 157 "cccp.y" +{ yyval.integer.value = - yyvsp[0].integer.value; + if ((yyval.integer.value & yyvsp[0].integer.value) < 0 && ! yyvsp[0].integer.unsignedp) + integer_overflow (); + yyval.integer.unsignedp = yyvsp[0].integer.unsignedp; } + break; +case 5: +#line 162 "cccp.y" +{ yyval.integer.value = ! yyvsp[0].integer.value; + yyval.integer.unsignedp = 0; } + break; +case 6: +#line 165 "cccp.y" +{ yyval.integer = yyvsp[0].integer; } + break; +case 7: +#line 167 "cccp.y" +{ yyval.integer.value = ~ yyvsp[0].integer.value; + yyval.integer.unsignedp = yyvsp[0].integer.unsignedp; } + break; +case 8: +#line 170 "cccp.y" +{ yyval.integer.value = check_assertion (yyvsp[0].name.address, yyvsp[0].name.length, + 0, NULL_PTR); + yyval.integer.unsignedp = 0; } + break; +case 9: +#line 174 "cccp.y" +{ keyword_parsing = 1; } + break; +case 10: +#line 176 "cccp.y" +{ yyval.integer.value = check_assertion (yyvsp[-4].name.address, yyvsp[-4].name.length, + 1, yyvsp[-1].keywords); + keyword_parsing = 0; + yyval.integer.unsignedp = 0; } + break; +case 11: +#line 181 "cccp.y" +{ yyval.integer = yyvsp[-1].integer; } + break; +case 12: +#line 186 "cccp.y" +{ yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; + if (yyval.integer.unsignedp) + yyval.integer.value = (unsigned long) yyvsp[-2].integer.value * yyvsp[0].integer.value; + else + { + yyval.integer.value = yyvsp[-2].integer.value * yyvsp[0].integer.value; + if (yyvsp[-2].integer.value + && (yyval.integer.value / yyvsp[-2].integer.value != yyvsp[0].integer.value + || (yyval.integer.value & yyvsp[-2].integer.value & yyvsp[0].integer.value) < 0)) + integer_overflow (); + } } + break; +case 13: +#line 198 "cccp.y" +{ if (yyvsp[0].integer.value == 0) + { + error ("division by zero in #if"); + yyvsp[0].integer.value = 1; + } + yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; + if (yyval.integer.unsignedp) + yyval.integer.value = (unsigned long) yyvsp[-2].integer.value / yyvsp[0].integer.value; + else + { + yyval.integer.value = yyvsp[-2].integer.value / yyvsp[0].integer.value; + if ((yyval.integer.value & yyvsp[-2].integer.value & yyvsp[0].integer.value) < 0) + integer_overflow (); + } } + break; +case 14: +#line 213 "cccp.y" +{ if (yyvsp[0].integer.value == 0) + { + error ("division by zero in #if"); + yyvsp[0].integer.value = 1; + } + yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; + if (yyval.integer.unsignedp) + yyval.integer.value = (unsigned long) yyvsp[-2].integer.value % yyvsp[0].integer.value; + else + yyval.integer.value = yyvsp[-2].integer.value % yyvsp[0].integer.value; } + break; +case 15: +#line 224 "cccp.y" +{ yyval.integer.value = yyvsp[-2].integer.value + yyvsp[0].integer.value; + yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; + if (! yyval.integer.unsignedp + && ! possible_sum_sign (yyvsp[-2].integer.value, yyvsp[0].integer.value, + yyval.integer.value)) + integer_overflow (); } + break; +case 16: +#line 231 "cccp.y" +{ yyval.integer.value = yyvsp[-2].integer.value - yyvsp[0].integer.value; + yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; + if (! yyval.integer.unsignedp + && ! possible_sum_sign (yyval.integer.value, yyvsp[0].integer.value, + yyvsp[-2].integer.value)) + integer_overflow (); } + break; +case 17: +#line 238 "cccp.y" +{ yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp; + if (yyvsp[0].integer.value < 0 && ! yyvsp[0].integer.unsignedp) + yyval.integer.value = right_shift (&yyvsp[-2].integer, -yyvsp[0].integer.value); + else + yyval.integer.value = left_shift (&yyvsp[-2].integer, yyvsp[0].integer.value); } + break; +case 18: +#line 244 "cccp.y" +{ yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp; + if (yyvsp[0].integer.value < 0 && ! yyvsp[0].integer.unsignedp) + yyval.integer.value = left_shift (&yyvsp[-2].integer, -yyvsp[0].integer.value); + else + yyval.integer.value = right_shift (&yyvsp[-2].integer, yyvsp[0].integer.value); } + break; +case 19: +#line 250 "cccp.y" +{ yyval.integer.value = (yyvsp[-2].integer.value == yyvsp[0].integer.value); + yyval.integer.unsignedp = 0; } + break; +case 20: +#line 253 "cccp.y" +{ yyval.integer.value = (yyvsp[-2].integer.value != yyvsp[0].integer.value); + yyval.integer.unsignedp = 0; } + break; +case 21: +#line 256 "cccp.y" +{ yyval.integer.unsignedp = 0; + if (yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp) + yyval.integer.value = (unsigned long) yyvsp[-2].integer.value <= yyvsp[0].integer.value; + else + yyval.integer.value = yyvsp[-2].integer.value <= yyvsp[0].integer.value; } + break; +case 22: +#line 262 "cccp.y" +{ yyval.integer.unsignedp = 0; + if (yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp) + yyval.integer.value = (unsigned long) yyvsp[-2].integer.value >= yyvsp[0].integer.value; + else + yyval.integer.value = yyvsp[-2].integer.value >= yyvsp[0].integer.value; } + break; +case 23: +#line 268 "cccp.y" +{ yyval.integer.unsignedp = 0; + if (yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp) + yyval.integer.value = (unsigned long) yyvsp[-2].integer.value < yyvsp[0].integer.value; + else + yyval.integer.value = yyvsp[-2].integer.value < yyvsp[0].integer.value; } + break; +case 24: +#line 274 "cccp.y" +{ yyval.integer.unsignedp = 0; + if (yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp) + yyval.integer.value = (unsigned long) yyvsp[-2].integer.value > yyvsp[0].integer.value; + else + yyval.integer.value = yyvsp[-2].integer.value > yyvsp[0].integer.value; } + break; +case 25: +#line 280 "cccp.y" +{ yyval.integer.value = yyvsp[-2].integer.value & yyvsp[0].integer.value; + yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; } + break; +case 26: +#line 283 "cccp.y" +{ yyval.integer.value = yyvsp[-2].integer.value ^ yyvsp[0].integer.value; + yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; } + break; +case 27: +#line 286 "cccp.y" +{ yyval.integer.value = yyvsp[-2].integer.value | yyvsp[0].integer.value; + yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; } + break; +case 28: +#line 289 "cccp.y" +{ yyval.integer.value = (yyvsp[-2].integer.value && yyvsp[0].integer.value); + yyval.integer.unsignedp = 0; } + break; +case 29: +#line 292 "cccp.y" +{ yyval.integer.value = (yyvsp[-2].integer.value || yyvsp[0].integer.value); + yyval.integer.unsignedp = 0; } + break; +case 30: +#line 295 "cccp.y" +{ yyval.integer.value = yyvsp[-4].integer.value ? yyvsp[-2].integer.value : yyvsp[0].integer.value; + yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; } + break; +case 31: +#line 298 "cccp.y" +{ yyval.integer = yylval.integer; } + break; +case 32: +#line 300 "cccp.y" +{ yyval.integer = yylval.integer; } + break; +case 33: +#line 302 "cccp.y" +{ yyval.integer.value = 0; + yyval.integer.unsignedp = 0; } + break; +case 34: +#line 307 "cccp.y" +{ yyval.keywords = 0; } + break; +case 35: +#line 309 "cccp.y" +{ struct arglist *temp; + yyval.keywords = (struct arglist *) xmalloc (sizeof (struct arglist)); + yyval.keywords->next = yyvsp[-2].keywords; + yyval.keywords->name = (U_CHAR *) "("; + yyval.keywords->length = 1; + temp = yyval.keywords; + while (temp != 0 && temp->next != 0) + temp = temp->next; + temp->next = (struct arglist *) xmalloc (sizeof (struct arglist)); + temp->next->next = yyvsp[0].keywords; + temp->next->name = (U_CHAR *) ")"; + temp->next->length = 1; } + break; +case 36: +#line 322 "cccp.y" +{ yyval.keywords = (struct arglist *) xmalloc (sizeof (struct arglist)); + yyval.keywords->name = yyvsp[-1].name.address; + yyval.keywords->length = yyvsp[-1].name.length; + yyval.keywords->next = yyvsp[0].keywords; } + break; +} + +#line 727 "/usr/share/bison/bison.simple" + + + yyvsp -= yylen; + yyssp -= yylen; +#if YYLSP_NEEDED + yylsp -= yylen; +#endif + +#if YYDEBUG + if (yydebug) + { + short *yyssp1 = yyss - 1; + YYFPRINTF (stderr, "state stack now"); + while (yyssp1 != yyssp) + YYFPRINTF (stderr, " %d", *++yyssp1); + YYFPRINTF (stderr, "\n"); + } +#endif + + *++yyvsp = yyval; +#if YYLSP_NEEDED + *++yylsp = yyloc; +#endif + + /* Now `shift' the result of the reduction. Determine what state + that goes to, based on the state we popped back to and the rule + number reduced by. */ + + yyn = yyr1[yyn]; + + yystate = yypgoto[yyn - YYNTBASE] + *yyssp; + if (yystate >= 0 && yystate <= YYLAST && yycheck[yystate] == *yyssp) + yystate = yytable[yystate]; + else + yystate = yydefgoto[yyn - YYNTBASE]; + + goto yynewstate; + + +/*------------------------------------. +| yyerrlab -- here on detecting error | +`------------------------------------*/ +yyerrlab: + /* If not already recovering from an error, report this error. */ + if (!yyerrstatus) + { + ++yynerrs; + +#ifdef YYERROR_VERBOSE + yyn = yypact[yystate]; + + if (yyn > YYFLAG && yyn < YYLAST) + { + YYSIZE_T yysize = 0; + char *yymsg; + int yyx, yycount; + + yycount = 0; + /* Start YYX at -YYN if negative to avoid negative indexes in + YYCHECK. */ + for (yyx = yyn < 0 ? -yyn : 0; + yyx < (int) (sizeof (yytname) / sizeof (char *)); yyx++) + if (yycheck[yyx + yyn] == yyx) + yysize += yystrlen (yytname[yyx]) + 15, yycount++; + yysize += yystrlen ("parse error, unexpected ") + 1; + yysize += yystrlen (yytname[YYTRANSLATE (yychar)]); + yymsg = (char *) YYSTACK_ALLOC (yysize); + if (yymsg != 0) + { + char *yyp = yystpcpy (yymsg, "parse error, unexpected "); + yyp = yystpcpy (yyp, yytname[YYTRANSLATE (yychar)]); + + if (yycount < 5) + { + yycount = 0; + for (yyx = yyn < 0 ? -yyn : 0; + yyx < (int) (sizeof (yytname) / sizeof (char *)); + yyx++) + if (yycheck[yyx + yyn] == yyx) + { + const char *yyq = ! yycount ? ", expecting " : " or "; + yyp = yystpcpy (yyp, yyq); + yyp = yystpcpy (yyp, yytname[yyx]); + yycount++; + } + } + yyerror (yymsg); + YYSTACK_FREE (yymsg); + } + else + yyerror ("parse error; also virtual memory exhausted"); + } + else +#endif /* defined (YYERROR_VERBOSE) */ + yyerror ("parse error"); + } + goto yyerrlab1; + + +/*--------------------------------------------------. +| yyerrlab1 -- error raised explicitly by an action | +`--------------------------------------------------*/ +yyerrlab1: + if (yyerrstatus == 3) + { + /* If just tried and failed to reuse lookahead token after an + error, discard it. */ + + /* return failure if at end of input */ + if (yychar == YYEOF) + YYABORT; + YYDPRINTF ((stderr, "Discarding token %d (%s).\n", + yychar, yytname[yychar1])); + yychar = YYEMPTY; + } + + /* Else will try to reuse lookahead token after shifting the error + token. */ + + yyerrstatus = 3; /* Each real token shifted decrements this */ + + goto yyerrhandle; + + +/*-------------------------------------------------------------------. +| yyerrdefault -- current state does not do anything special for the | +| error token. | +`-------------------------------------------------------------------*/ +yyerrdefault: +#if 0 + /* This is wrong; only states that explicitly want error tokens + should shift them. */ + + /* If its default is to accept any token, ok. Otherwise pop it. */ + yyn = yydefact[yystate]; + if (yyn) + goto yydefault; +#endif + + +/*---------------------------------------------------------------. +| yyerrpop -- pop the current state because it cannot handle the | +| error token | +`---------------------------------------------------------------*/ +yyerrpop: + if (yyssp == yyss) + YYABORT; + yyvsp--; + yystate = *--yyssp; +#if YYLSP_NEEDED + yylsp--; +#endif + +#if YYDEBUG + if (yydebug) + { + short *yyssp1 = yyss - 1; + YYFPRINTF (stderr, "Error: state stack now"); + while (yyssp1 != yyssp) + YYFPRINTF (stderr, " %d", *++yyssp1); + YYFPRINTF (stderr, "\n"); + } +#endif + +/*--------------. +| yyerrhandle. | +`--------------*/ +yyerrhandle: + yyn = yypact[yystate]; + if (yyn == YYFLAG) + goto yyerrdefault; + + yyn += YYTERROR; + if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != YYTERROR) + goto yyerrdefault; + + yyn = yytable[yyn]; + if (yyn < 0) + { + if (yyn == YYFLAG) + goto yyerrpop; + yyn = -yyn; + goto yyreduce; + } + else if (yyn == 0) + goto yyerrpop; + + if (yyn == YYFINAL) + YYACCEPT; + + YYDPRINTF ((stderr, "Shifting error token, ")); + + *++yyvsp = yylval; +#if YYLSP_NEEDED + *++yylsp = yylloc; +#endif + + yystate = yyn; + goto yynewstate; + + +/*-------------------------------------. +| yyacceptlab -- YYACCEPT comes here. | +`-------------------------------------*/ +yyacceptlab: + yyresult = 0; + goto yyreturn; + +/*-----------------------------------. +| yyabortlab -- YYABORT comes here. | +`-----------------------------------*/ +yyabortlab: + yyresult = 1; + goto yyreturn; + +/*---------------------------------------------. +| yyoverflowab -- parser overflow comes here. | +`---------------------------------------------*/ +yyoverflowlab: + yyerror ("parser stack overflow"); + yyresult = 2; + /* Fall through. */ + +yyreturn: +#ifndef yyoverflow + if (yyss != yyssa) + YYSTACK_FREE (yyss); +#endif + return yyresult; +} +#line 327 "cccp.y" + + +/* During parsing of a C expression, the pointer to the next character + is in this variable. */ + +static char *lexptr; + +/* Take care of parsing a number (anything that starts with a digit). + Set yylval and return the token type; update lexptr. + LEN is the number of characters in it. */ + +/* maybe needs to actually deal with floating point numbers */ + +int +parse_number (olen) + int olen; +{ + register char *p = lexptr; + register int c; + register unsigned long n = 0, nd, ULONG_MAX_over_base; + register int base = 10; + register int len = olen; + register int overflow = 0; + register int digit, largest_digit = 0; + int spec_long = 0; + + for (c = 0; c < len; c++) + if (p[c] == '.') { + /* It's a float since it contains a point. */ + yyerror ("floating point numbers not allowed in #if expressions"); + return ERROR; + } + + yylval.integer.unsignedp = 0; + + if (len >= 3 && (!strncmp (p, "0x", 2) || !strncmp (p, "0X", 2))) { + p += 2; + base = 16; + len -= 2; + } + else if (*p == '0') + base = 8; + + ULONG_MAX_over_base = (unsigned long) -1 / base; + + for (; len > 0; len--) { + c = *p++; + + if (c >= '0' && c <= '9') + digit = c - '0'; + else if (base == 16 && c >= 'a' && c <= 'f') + digit = c - 'a' + 10; + else if (base == 16 && c >= 'A' && c <= 'F') + digit = c - 'A' + 10; + else { + /* `l' means long, and `u' means unsigned. */ + while (1) { + if (c == 'l' || c == 'L') + { + if (spec_long) + yyerror ("two `l's in integer constant"); + spec_long = 1; + } + else if (c == 'u' || c == 'U') + { + if (yylval.integer.unsignedp) + yyerror ("two `u's in integer constant"); + yylval.integer.unsignedp = 1; + } + else + break; + + if (--len == 0) + break; + c = *p++; + } + /* Don't look for any more digits after the suffixes. */ + break; + } + if (largest_digit < digit) + largest_digit = digit; + nd = n * base + digit; + overflow |= ULONG_MAX_over_base < n | nd < n; + n = nd; + } + + if (len != 0) { + yyerror ("Invalid number in #if expression"); + return ERROR; + } + + if (base <= largest_digit) + warning ("integer constant contains digits beyond the radix"); + + if (overflow) + warning ("integer constant out of range"); + + /* If too big to be signed, consider it unsigned. */ + if ((long) n < 0 && ! yylval.integer.unsignedp) + { + if (base == 10) + warning ("integer constant is so large that it is unsigned"); + yylval.integer.unsignedp = 1; + } + + lexptr = p; + yylval.integer.value = n; + return INT; +} + +struct token { + char *operator; + int token; +}; + +static struct token tokentab2[] = { + {"&&", AND}, + {"||", OR}, + {"<<", LSH}, + {">>", RSH}, + {"==", EQUAL}, + {"!=", NOTEQUAL}, + {"<=", LEQ}, + {">=", GEQ}, + {"++", ERROR}, + {"--", ERROR}, + {NULL, ERROR} +}; + +/* Read one token, getting characters through lexptr. */ + +int +yylex () +{ + register int c; + register int namelen; + register unsigned char *tokstart; + register struct token *toktab; + int wide_flag; + + retry: + + tokstart = (unsigned char *) lexptr; + c = *tokstart; + /* See if it is a special token of length 2. */ + if (! keyword_parsing) + for (toktab = tokentab2; toktab->operator != NULL; toktab++) + if (c == *toktab->operator && tokstart[1] == toktab->operator[1]) { + lexptr += 2; + if (toktab->token == ERROR) + { + char *buf = (char *) alloca (40); + sprintf (buf, "`%s' not allowed in operand of `#if'", toktab->operator); + yyerror (buf); + } + return toktab->token; + } + + switch (c) { + case 0: + return 0; + + case ' ': + case '\t': + case '\r': + case '\n': + lexptr++; + goto retry; + + case 'L': + /* Capital L may start a wide-string or wide-character constant. */ + if (lexptr[1] == '\'') + { + lexptr++; + wide_flag = 1; + goto char_constant; + } + if (lexptr[1] == '"') + { + lexptr++; + wide_flag = 1; + goto string_constant; + } + break; + + case '\'': + wide_flag = 0; + char_constant: + lexptr++; + if (keyword_parsing) { + char *start_ptr = lexptr - 1; + while (1) { + c = *lexptr++; + if (c == '\\') + c = parse_escape (&lexptr); + else if (c == '\'') + break; + } + yylval.name.address = tokstart; + yylval.name.length = lexptr - start_ptr; + return NAME; + } + + /* This code for reading a character constant + handles multicharacter constants and wide characters. + It is mostly copied from c-lex.c. */ + { + register int result = 0; + register num_chars = 0; + unsigned width = CHAR_TYPE_SIZE; + int max_chars; + char *token_buffer; + + if (wide_flag) + { + width = WCHAR_TYPE_SIZE; +#ifdef MULTIBYTE_CHARS + max_chars = MB_CUR_MAX; +#else + max_chars = 1; +#endif + } + else + max_chars = LONG_TYPE_SIZE / width; + + token_buffer = (char *) alloca (max_chars + 1); + + while (1) + { + c = *lexptr++; + + if (c == '\'' || c == EOF) + break; + + if (c == '\\') + { + c = parse_escape (&lexptr); + if (width < HOST_BITS_PER_INT + && (unsigned) c >= (1 << width)) + pedwarn ("escape sequence out of range for character"); + } + + num_chars++; + + /* Merge character into result; ignore excess chars. */ + if (num_chars < max_chars + 1) + { + if (width < HOST_BITS_PER_INT) + result = (result << width) | (c & ((1 << width) - 1)); + else + result = c; + token_buffer[num_chars - 1] = c; + } + } + + token_buffer[num_chars] = 0; + + if (c != '\'') + error ("malformatted character constant"); + else if (num_chars == 0) + error ("empty character constant"); + else if (num_chars > max_chars) + { + num_chars = max_chars; + error ("character constant too long"); + } + else if (num_chars != 1 && ! traditional) + warning ("multi-character character constant"); + + /* If char type is signed, sign-extend the constant. */ + if (! wide_flag) + { + int num_bits = num_chars * width; + + if (lookup ("__CHAR_UNSIGNED__", sizeof ("__CHAR_UNSIGNED__")-1, -1) + || ((result >> (num_bits - 1)) & 1) == 0) + yylval.integer.value + = result & ((unsigned long) ~0 >> (HOST_BITS_PER_LONG - num_bits)); + else + yylval.integer.value + = result | ~((unsigned long) ~0 >> (HOST_BITS_PER_LONG - num_bits)); + } + else + { +#ifdef MULTIBYTE_CHARS + /* Set the initial shift state and convert the next sequence. */ + result = 0; + /* In all locales L'\0' is zero and mbtowc will return zero, + so don't use it. */ + if (num_chars > 1 + || (num_chars == 1 && token_buffer[0] != '\0')) + { + wchar_t wc; + (void) mbtowc (NULL_PTR, NULL_PTR, 0); + if (mbtowc (& wc, token_buffer, num_chars) == num_chars) + result = wc; + else + warning ("Ignoring invalid multibyte character"); + } +#endif + yylval.integer.value = result; + } + } + + /* This is always a signed type. */ + yylval.integer.unsignedp = 0; + + return CHAR; + + /* some of these chars are invalid in constant expressions; + maybe do something about them later */ + case '/': + case '+': + case '-': + case '*': + case '%': + case '|': + case '&': + case '^': + case '~': + case '!': + case '@': + case '<': + case '>': + case '[': + case ']': + case '.': + case '?': + case ':': + case '=': + case '{': + case '}': + case ',': + case '#': + if (keyword_parsing) + break; + case '(': + case ')': + lexptr++; + return c; + + case '"': + string_constant: + if (keyword_parsing) { + char *start_ptr = lexptr; + lexptr++; + while (1) { + c = *lexptr++; + if (c == '\\') + c = parse_escape (&lexptr); + else if (c == '"') + break; + } + yylval.name.address = tokstart; + yylval.name.length = lexptr - start_ptr; + return NAME; + } + yyerror ("string constants not allowed in #if expressions"); + return ERROR; + } + + if (c >= '0' && c <= '9' && !keyword_parsing) { + /* It's a number */ + for (namelen = 0; + c = tokstart[namelen], is_idchar[c] || c == '.'; + namelen++) + ; + return parse_number (namelen); + } + + /* It is a name. See how long it is. */ + + if (keyword_parsing) { + for (namelen = 0;; namelen++) { + if (is_hor_space[tokstart[namelen]]) + break; + if (tokstart[namelen] == '(' || tokstart[namelen] == ')') + break; + if (tokstart[namelen] == '"' || tokstart[namelen] == '\'') + break; + } + } else { + if (!is_idstart[c]) { + yyerror ("Invalid token in expression"); + return ERROR; + } + + for (namelen = 0; is_idchar[tokstart[namelen]]; namelen++) + ; + } + + lexptr += namelen; + yylval.name.address = tokstart; + yylval.name.length = namelen; + return NAME; +} + + +/* Parse a C escape sequence. STRING_PTR points to a variable + containing a pointer to the string to parse. That pointer + is updated past the characters we use. The value of the + escape sequence is returned. + + A negative value means the sequence \ newline was seen, + which is supposed to be equivalent to nothing at all. + + If \ is followed by a null character, we return a negative + value and leave the string pointer pointing at the null character. + + If \ is followed by 000, we return 0 and leave the string pointer + after the zeros. A value of 0 does not mean end of string. */ + +int +parse_escape (string_ptr) + char **string_ptr; +{ + register int c = *(*string_ptr)++; + switch (c) + { + case 'a': + return TARGET_BELL; + case 'b': + return TARGET_BS; + case 'e': + case 'E': + if (pedantic) + pedwarn ("non-ANSI-standard escape sequence, `\\%c'", c); + return 033; + case 'f': + return TARGET_FF; + case 'n': + return TARGET_NEWLINE; + case 'r': + return TARGET_CR; + case 't': + return TARGET_TAB; + case 'v': + return TARGET_VT; + case '\n': + return -2; + case 0: + (*string_ptr)--; + return 0; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + { + register int i = c - '0'; + register int count = 0; + while (++count < 3) + { + c = *(*string_ptr)++; + if (c >= '0' && c <= '7') + i = (i << 3) + c - '0'; + else + { + (*string_ptr)--; + break; + } + } + if ((i & ~((1 << CHAR_TYPE_SIZE) - 1)) != 0) + { + i &= (1 << CHAR_TYPE_SIZE) - 1; + warning ("octal character constant does not fit in a byte"); + } + return i; + } + case 'x': + { + register unsigned i = 0, overflow = 0, digits_found = 0, digit; + for (;;) + { + c = *(*string_ptr)++; + if (c >= '0' && c <= '9') + digit = c - '0'; + else if (c >= 'a' && c <= 'f') + digit = c - 'a' + 10; + else if (c >= 'A' && c <= 'F') + digit = c - 'A' + 10; + else + { + (*string_ptr)--; + break; + } + overflow |= i ^ (i << 4 >> 4); + i = (i << 4) + digit; + digits_found = 1; + } + if (!digits_found) + yyerror ("\\x used with no following hex digits"); + if (overflow | (i & ~((1 << BITS_PER_UNIT) - 1))) + { + i &= (1 << BITS_PER_UNIT) - 1; + warning ("hex character constant does not fit in a byte"); + } + return i; + } + default: + return c; + } +} + +void +yyerror (s) + char *s; +{ + error (s); + longjmp (parse_return_error, 1); +} + +static void +integer_overflow () +{ + if (pedantic) + pedwarn ("integer overflow in preprocessor expression"); +} + +static long +left_shift (a, b) + struct constant *a; + unsigned long b; +{ + if (b >= HOST_BITS_PER_LONG) + { + if (! a->unsignedp && a->value != 0) + integer_overflow (); + return 0; + } + else if (a->unsignedp) + return (unsigned long) a->value << b; + else + { + long l = a->value << b; + if (l >> b != a->value) + integer_overflow (); + return l; + } +} + +static long +right_shift (a, b) + struct constant *a; + unsigned long b; +{ + if (b >= HOST_BITS_PER_LONG) + return a->unsignedp ? 0 : a->value >> (HOST_BITS_PER_LONG - 1); + else if (a->unsignedp) + return (unsigned long) a->value >> b; + else + return a->value >> b; +} + +/* This page contains the entry point to this file. */ + +/* Parse STRING as an expression, and complain if this fails + to use up all of the contents of STRING. */ +/* We do not support C comments. They should be removed before + this function is called. */ + +int +parse_c_expression (string) + char *string; +{ + lexptr = string; + + if (lexptr == 0 || *lexptr == 0) { + error ("empty #if expression"); + return 0; /* don't include the #if group */ + } + + /* if there is some sort of scanning error, just return 0 and assume + the parsing routine has printed an error message somewhere. + there is surely a better thing to do than this. */ + if (setjmp (parse_return_error)) + return 0; + + if (yyparse ()) + return 0; /* actually this is never reached + the way things stand. */ + if (*lexptr) + error ("Junk after end of expression."); + + return expression_value; /* set by yyparse () */ +} + +#ifdef TEST_EXP_READER +extern int yydebug; + +/* Main program for testing purposes. */ +int +main () +{ + int n, c; + char buf[1024]; + +/* + yydebug = 1; +*/ + initialize_random_junk (); + + for (;;) { + printf ("enter expression: "); + n = 0; + while ((buf[n] = getchar ()) != '\n' && buf[n] != EOF) + n++; + if (buf[n] == EOF) + break; + buf[n] = '\0'; + printf ("parser returned %d\n", parse_c_expression (buf)); + } + + return 0; +} + +/* table to tell if char can be part of a C identifier. */ +unsigned char is_idchar[256]; +/* table to tell if char can be first char of a c identifier. */ +unsigned char is_idstart[256]; +/* table to tell if c is horizontal space. isspace () thinks that + newline is space; this is not a good idea for this program. */ +char is_hor_space[256]; + +/* + * initialize random junk in the hash table and maybe other places + */ +initialize_random_junk () +{ + register int i; + + /* + * Set up is_idchar and is_idstart tables. These should be + * faster than saying (is_alpha (c) || c == '_'), etc. + * Must do set up these things before calling any routines tthat + * refer to them. + */ + for (i = 'a'; i <= 'z'; i++) { + ++is_idchar[i - 'a' + 'A']; + ++is_idchar[i]; + ++is_idstart[i - 'a' + 'A']; + ++is_idstart[i]; + } + for (i = '0'; i <= '9'; i++) + ++is_idchar[i]; + ++is_idchar['_']; + ++is_idstart['_']; +#if DOLLARS_IN_IDENTIFIERS + ++is_idchar['$']; + ++is_idstart['$']; +#endif + + /* horizontal space table */ + ++is_hor_space[' ']; + ++is_hor_space['\t']; +} + +error (msg) +{ + printf ("error: %s\n", msg); +} + +warning (msg) +{ + printf ("warning: %s\n", msg); +} + +struct hashnode * +lookup (name, len, hash) + char *name; + int len; + int hash; +{ + return (DEFAULT_SIGNED_CHAR) ? 0 : ((struct hashnode *) -1); +} +#endif diff --cc test/manual/etags/y-src/parse.c index 7b1eedc85db,00000000000..95098674279 mode 100644,000000..100644 --- a/test/manual/etags/y-src/parse.c +++ b/test/manual/etags/y-src/parse.c @@@ -1,2236 -1,0 +1,2236 @@@ +/* A Bison parser, made from parse.y + by GNU bison 1.32. */ + +#define YYBISON 1 /* Identify Bison output. */ + +# define NE 257 +# define LE 258 +# define GE 259 +# define NEG 260 +# define L_CELL 261 +# define L_RANGE 262 +# define L_VAR 263 +# define L_CONST 264 +# define L_FN0 265 +# define L_FN1 266 +# define L_FN2 267 +# define L_FN3 268 +# define L_FN4 269 +# define L_FNN 270 +# define L_FN1R 271 +# define L_FN2R 272 +# define L_FN3R 273 +# define L_FN4R 274 +# define L_FNNR 275 +# define L_LE 276 +# define L_NE 277 +# define L_GE 278 + +#line 1 "parse.y" + - /* Copyright (C) 1990, 1992, 1993 Free Software Foundation, Inc. ++/* Copyright (C) 1990, 1992-1993, 2016 Free Software Foundation, Inc. + +This file is part of Oleo, the GNU Spreadsheet. + +Oleo is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +Oleo is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with Oleo; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ +#line 41 "parse.y" + +#include "funcdef.h" + +#include <ctype.h> + +#define obstack_chunk_alloc ck_malloc +#define obstack_chunk_free free +#include "obstack.h" +#include "sysdef.h" + +#include "global.h" +#include "errors.h" +#include "node.h" +#include "eval.h" +#include "ref.h" + +int yylex (); +#ifdef __STDC__ +void yyerror (char *); +#else +void yyerror (); +#endif +VOIDSTAR parse_hash; +extern VOIDSTAR hash_find(); + +/* This table contains a list of the infix single-char functions */ +unsigned char fnin[] = { + SUM, DIFF, DIV, PROD, MOD, /* AND, OR, */ POW, EQUAL, IF, CONCAT, 0 +}; + +#define YYSTYPE _y_y_s_t_y_p_e +typedef struct node *YYSTYPE; +YYSTYPE parse_return; +#ifdef __STDC__ +YYSTYPE make_list (YYSTYPE, YYSTYPE); +#else +YYSTYPE make_list (); +#endif + +char *instr; +int parse_error = 0; +extern struct obstack tmp_mem; + +#ifndef YYSTYPE +#define YYSTYPE int +#endif +#ifndef YYDEBUG +# define YYDEBUG 0 +#endif + + + +#define YYFINAL 131 +#define YYFLAG -32768 +#define YYNTBASE 41 + +/* YYTRANSLATE(YYLEX) -- Bison token number corresponding to YYLEX. */ +#define YYTRANSLATE(x) ((unsigned)(x) <= 278 ? yytranslate[x] : 47) + +/* YYTRANSLATE[YYLEX] -- Bison token number corresponding to YYLEX. */ +static const char yytranslate[] = +{ + 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 19, 2, 2, 2, 16, 5, 2, + 38, 39, 14, 12, 40, 13, 2, 15, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 4, 2, + 8, 6, 10, 3, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 17, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 1, 7, 9, 11, + 18, 20, 21, 22, 23, 24, 25, 26, 27, 28, + 29, 30, 31, 32, 33, 34, 35, 36, 37 +}; + +#if YYDEBUG +static const short yyprhs[] = +{ + 0, 0, 2, 4, 6, 8, 12, 17, 24, 33, + 44, 49, 54, 59, 66, 73, 82, 91, 100, 109, + 114, 120, 124, 128, 132, 136, 140, 144, 148, 152, + 156, 160, 164, 168, 172, 175, 178, 182, 186, 189, + 191, 195, 197, 199, 201, 205, 207 +}; +static const short yyrhs[] = +{ + 42, 0, 1, 0, 23, 0, 46, 0, 24, 38, + 39, 0, 25, 38, 42, 39, 0, 26, 38, 42, + 40, 42, 39, 0, 27, 38, 42, 40, 42, 40, + 42, 39, 0, 28, 38, 42, 40, 42, 40, 42, + 40, 42, 39, 0, 29, 38, 43, 39, 0, 30, + 38, 21, 39, 0, 30, 38, 22, 39, 0, 31, + 38, 21, 40, 42, 39, 0, 31, 38, 22, 40, + 42, 39, 0, 31, 38, 21, 40, 42, 40, 42, + 39, 0, 31, 38, 22, 40, 42, 40, 42, 39, + 0, 32, 38, 21, 40, 42, 40, 42, 39, 0, + 32, 38, 22, 40, 42, 40, 42, 39, 0, 34, + 38, 45, 39, 0, 42, 3, 42, 4, 42, 0, + 42, 5, 42, 0, 42, 8, 42, 0, 42, 9, + 42, 0, 42, 6, 42, 0, 42, 7, 42, 0, + 42, 10, 42, 0, 42, 11, 42, 0, 42, 12, + 42, 0, 42, 13, 42, 0, 42, 14, 42, 0, + 42, 15, 42, 0, 42, 16, 42, 0, 42, 17, + 42, 0, 13, 42, 0, 19, 42, 0, 38, 42, + 39, 0, 38, 42, 1, 0, 38, 1, 0, 42, + 0, 43, 40, 42, 0, 21, 0, 42, 0, 44, + 0, 45, 40, 44, 0, 20, 0, 22, 0 +}; + +#endif + +#if YYDEBUG +/* YYRLINE[YYN] -- source line where rule number YYN was defined. */ +static const short yyrline[] = +{ + 0, 86, 88, 94, 95, 96, 98, 102, 106, 110, + 114, 118, 121, 125, 129, 135, 142, 150, 154, 159, + 163, 174, 178, 182, 186, 190, 194, 198, 202, 206, + 210, 214, 218, 222, 226, 241, 245, 247, 255, 262, + 264, 268, 269, 272, 274, 278, 280 +}; +#endif + + +#if (YYDEBUG) || defined YYERROR_VERBOSE + +/* YYTNAME[TOKEN_NUM] -- String name of the token TOKEN_NUM. */ +static const char *const yytname[] = +{ + "$", "error", "$undefined.", "'?'", "':'", "'&'", "'='", "NE", "'<'", + "LE", "'>'", "GE", "'+'", "'-'", "'*'", "'/'", "'%'", "'^'", "NEG", + "'!'", "L_CELL", "L_RANGE", "L_VAR", "L_CONST", "L_FN0", "L_FN1", + "L_FN2", "L_FN3", "L_FN4", "L_FNN", "L_FN1R", "L_FN2R", "L_FN3R", + "L_FN4R", "L_FNNR", "L_LE", "L_NE", "L_GE", "'('", "')'", "','", "line", + "exp", "exp_list", "range_exp", "range_exp_list", "cell", NULL +}; +#endif + +/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ +static const short yyr1[] = +{ + 0, 41, 41, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 43, + 43, 44, 44, 45, 45, 46, 46 +}; + +/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ +static const short yyr2[] = +{ + 0, 1, 1, 1, 1, 3, 4, 6, 8, 10, + 4, 4, 4, 6, 6, 8, 8, 8, 8, 4, + 5, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 2, 2, 3, 3, 2, 1, + 3, 1, 1, 1, 3, 1, 1 +}; + +/* YYDEFACT[S] -- default rule to reduce with in state S when YYTABLE + doesn't specify something else to do. Zero means the default is an + error. */ +static const short yydefact[] = +{ + 0, 2, 0, 0, 45, 46, 3, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 4, + 34, 35, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 38, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 5, 0, + 0, 0, 0, 39, 0, 0, 0, 0, 0, 0, + 0, 41, 42, 43, 0, 37, 36, 0, 21, 24, + 25, 22, 23, 26, 27, 28, 29, 30, 31, 32, + 33, 6, 0, 0, 0, 10, 0, 11, 12, 0, + 0, 0, 0, 19, 0, 0, 0, 0, 0, 40, + 0, 0, 0, 0, 44, 20, 7, 0, 0, 13, + 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 8, 0, 15, 16, 17, 18, 0, 9, 0, + 0, 0 +}; + +static const short yydefgoto[] = +{ + 129, 62, 54, 63, 64, 19 +}; + +static const short yypact[] = +{ + 104,-32768, 486, 486,-32768,-32768,-32768, -37, -22, -16, + 10, 12, 14, 29, 43, 47, 50, 124, 537,-32768, + -32768,-32768, 59, 486, 486, 486, 486, 486, 7, 9, + 11, 464,-32768, 48, 486, 486, 486, 486, 486, 486, + 486, 486, 486, 486, 486, 486, 486, 486,-32768, 332, + 173, 209, 224, 537, 54, 60, 61, 64, 66, 69, + 71,-32768, 537,-32768, 57,-32768,-32768, 522, -2, 193, + 193, 547, 547, 547, 547, 4, 4, 84, 84, 84, + 84,-32768, 486, 486, 486,-32768, 486,-32768,-32768, 486, + 486, 486, 486,-32768, 464, 486, 353, 245, 260, 537, + 63, 158, 281, 296,-32768, 537,-32768, 486, 486,-32768, + 486,-32768, 486, 486, 486, 369, 317, 388, 404, 423, + 439,-32768, 486,-32768,-32768,-32768,-32768, 458,-32768, 115, + 116,-32768 +}; + +static const short yypgoto[] = +{ + -32768, 0,-32768, 24,-32768,-32768 +}; + + +#define YYLAST 564 + + +static const short yytable[] = +{ + 18, 22, 20, 21, 36, 37, 38, 39, 40, 41, + 42, 43, 44, 45, 46, 47, 23, 33, 44, 45, + 46, 47, 24, 49, 50, 51, 52, 53, 55, 56, + 57, 58, 59, 60, 67, 68, 69, 70, 71, 72, + 73, 74, 75, 76, 77, 78, 79, 80, 25, 65, + 26, 34, 27, 35, 36, 37, 38, 39, 40, 41, + 42, 43, 44, 45, 46, 47, 34, 28, 35, 36, + 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, + 47, 29, 96, 97, 98, 30, 99, 66, 31, 100, + 101, 102, 103, 85, 86, 105, 93, 94, 48, 87, + 88, 47, 109, 110, 89, 1, 90, 115, 116, 91, + 117, 92, 118, 119, 120, 130, 131, 2, 104, 0, + 0, 0, 127, 3, 4, 32, 5, 6, 7, 8, + 9, 10, 11, 12, 13, 14, 15, 2, 16, 0, + 0, 0, 17, 3, 4, 0, 5, 6, 7, 8, + 9, 10, 11, 12, 13, 14, 15, 0, 16, 0, + 0, 34, 17, 35, 36, 37, 38, 39, 40, 41, + 42, 43, 44, 45, 46, 47, 34, 0, 35, 36, + 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, + 47, 0, 0, 0, 0, 0, 0, 111, 112,-32768, + -32768, 38, 39, 40, 41, 42, 43, 44, 45, 46, + 47, 0, 34, 82, 35, 36, 37, 38, 39, 40, + 41, 42, 43, 44, 45, 46, 47, 34, 0, 35, + 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, + 46, 47, 0, 0, 0, 0, 0, 0, 34, 83, + 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, + 45, 46, 47, 34, 84, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, 0, 0, + 0, 0, 0, 0, 34, 107, 35, 36, 37, 38, + 39, 40, 41, 42, 43, 44, 45, 46, 47, 34, + 108, 35, 36, 37, 38, 39, 40, 41, 42, 43, + 44, 45, 46, 47, 0, 0, 0, 0, 0, 0, + 34, 113, 35, 36, 37, 38, 39, 40, 41, 42, + 43, 44, 45, 46, 47, 34, 114, 35, 36, 37, + 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, + 0, 0, 0, 0, 0, 0, 34, 122, 35, 36, + 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, + 47, 81, 34, 0, 35, 36, 37, 38, 39, 40, + 41, 42, 43, 44, 45, 46, 47, 0, 0, 0, + 0, 34, 106, 35, 36, 37, 38, 39, 40, 41, + 42, 43, 44, 45, 46, 47, 0, 34, 121, 35, + 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, + 46, 47, 0, 0, 0, 0, 34, 123, 35, 36, + 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, + 47, 0, 34, 124, 35, 36, 37, 38, 39, 40, + 41, 42, 43, 44, 45, 46, 47, 0, 0, 0, + 0, 34, 125, 35, 36, 37, 38, 39, 40, 41, + 42, 43, 44, 45, 46, 47, 0, 2, 126, 0, + 0, 0, 0, 3, 4, 61, 5, 6, 7, 8, + 9, 10, 11, 12, 13, 14, 15, 128, 16, 2, + 0, 0, 17, 0, 0, 3, 4, 0, 5, 6, + 7, 8, 9, 10, 11, 12, 13, 14, 15, 0, + 16, 0, 0, 0, 17, 34, 95, 35, 36, 37, + 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, + 34, 0, 35, 36, 37, 38, 39, 40, 41, 42, + 43, 44, 45, 46, 47,-32768,-32768,-32768,-32768, 42, + 43, 44, 45, 46, 47 +}; + +static const short yycheck[] = +{ + 0, 38, 2, 3, 6, 7, 8, 9, 10, 11, + 12, 13, 14, 15, 16, 17, 38, 17, 14, 15, + 16, 17, 38, 23, 24, 25, 26, 27, 21, 22, + 21, 22, 21, 22, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, 38, 1, + 38, 3, 38, 5, 6, 7, 8, 9, 10, 11, + 12, 13, 14, 15, 16, 17, 3, 38, 5, 6, + 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, + 17, 38, 82, 83, 84, 38, 86, 39, 38, 89, + 90, 91, 92, 39, 40, 95, 39, 40, 39, 39, + 39, 17, 39, 40, 40, 1, 40, 107, 108, 40, + 110, 40, 112, 113, 114, 0, 0, 13, 94, -1, + -1, -1, 122, 19, 20, 1, 22, 23, 24, 25, + 26, 27, 28, 29, 30, 31, 32, 13, 34, -1, + -1, -1, 38, 19, 20, -1, 22, 23, 24, 25, + 26, 27, 28, 29, 30, 31, 32, -1, 34, -1, + -1, 3, 38, 5, 6, 7, 8, 9, 10, 11, + 12, 13, 14, 15, 16, 17, 3, -1, 5, 6, + 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, + 17, -1, -1, -1, -1, -1, -1, 39, 40, 6, + 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, + 17, -1, 3, 40, 5, 6, 7, 8, 9, 10, + 11, 12, 13, 14, 15, 16, 17, 3, -1, 5, + 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, -1, -1, -1, -1, -1, -1, 3, 40, + 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, 3, 40, 5, 6, 7, 8, 9, + 10, 11, 12, 13, 14, 15, 16, 17, -1, -1, + -1, -1, -1, -1, 3, 40, 5, 6, 7, 8, + 9, 10, 11, 12, 13, 14, 15, 16, 17, 3, + 40, 5, 6, 7, 8, 9, 10, 11, 12, 13, + 14, 15, 16, 17, -1, -1, -1, -1, -1, -1, + 3, 40, 5, 6, 7, 8, 9, 10, 11, 12, + 13, 14, 15, 16, 17, 3, 40, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, + -1, -1, -1, -1, -1, -1, 3, 40, 5, 6, + 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, + 17, 39, 3, -1, 5, 6, 7, 8, 9, 10, + 11, 12, 13, 14, 15, 16, 17, -1, -1, -1, + -1, 3, 39, 5, 6, 7, 8, 9, 10, 11, + 12, 13, 14, 15, 16, 17, -1, 3, 39, 5, + 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, -1, -1, -1, -1, 3, 39, 5, 6, + 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, + 17, -1, 3, 39, 5, 6, 7, 8, 9, 10, + 11, 12, 13, 14, 15, 16, 17, -1, -1, -1, + -1, 3, 39, 5, 6, 7, 8, 9, 10, 11, + 12, 13, 14, 15, 16, 17, -1, 13, 39, -1, + -1, -1, -1, 19, 20, 21, 22, 23, 24, 25, + 26, 27, 28, 29, 30, 31, 32, 39, 34, 13, + -1, -1, 38, -1, -1, 19, 20, -1, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, 32, -1, + 34, -1, -1, -1, 38, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, + 3, -1, 5, 6, 7, 8, 9, 10, 11, 12, + 13, 14, 15, 16, 17, 8, 9, 10, 11, 12, + 13, 14, 15, 16, 17 +}; +/* -*-C-*- Note some compilers choke on comments on `#line' lines. */ +#line 3 "/usr/share/bison/bison.simple" + +/* Skeleton output parser for bison, + Copyright (C) 1984, 1989, 1990, 2000, 2001 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + +/* As a special exception, when this file is copied by Bison into a + Bison output file, you may use that output file without restriction. + This special exception was added by the Free Software Foundation + in version 1.24 of Bison. */ + +/* This is the parser code that is written into each bison parser when + the %semantic_parser declaration is not specified in the grammar. + It was written by Richard Stallman by simplifying the hairy parser + used when %semantic_parser is specified. */ + +/* All symbols defined below should begin with yy or YY, to avoid + infringing on user name space. This should be done even for local + variables, as they might otherwise be expanded by user macros. + There are some unavoidable exceptions within include files to + define necessary library symbols; they are noted "INFRINGES ON + USER NAME SPACE" below. */ + +#ifdef __cplusplus +# define YYSTD(x) std::x +#else +# define YYSTD(x) x +#endif + +#if ! defined (yyoverflow) || defined (YYERROR_VERBOSE) + +/* The parser invokes alloca or malloc; define the necessary symbols. */ + +# if YYSTACK_USE_ALLOCA +# define YYSTACK_ALLOC alloca +# define YYSIZE_T YYSTD (size_t) +# else +# ifndef YYSTACK_USE_ALLOCA +# if defined (alloca) || defined (_ALLOCA_H) +# define YYSTACK_ALLOC alloca +# define YYSIZE_T YYSTD (size_t) +# else +# ifdef __GNUC__ +# define YYSTACK_ALLOC __builtin_alloca +# endif +# endif +# endif +# endif + +# ifdef YYSTACK_ALLOC + /* Pacify GCC's `empty if-body' warning. */ +# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0) +# else +# ifdef __cplusplus +# include <cstdlib> /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T std::size_t +# else +# ifdef __STDC__ +# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T size_t +# endif +# endif +# define YYSTACK_ALLOC YYSTD (malloc) +# define YYSTACK_FREE YYSTD (free) +# endif + +/* A type that is properly aligned for any stack member. */ +union yyalloc +{ + short yyss; + YYSTYPE yyvs; +# if YYLSP_NEEDED + YYLTYPE yyls; +# endif +}; + +/* The size of the maximum gap between one aligned stack and the next. */ +# define YYSTACK_GAP_MAX (sizeof (union yyalloc) - 1) + +/* The size of an array large to enough to hold all stacks, each with + N elements. */ +# if YYLSP_NEEDED +# define YYSTACK_BYTES(N) \ + ((N) * (sizeof (short) + sizeof (YYSTYPE) + sizeof (YYLTYPE)) \ + + 2 * YYSTACK_GAP_MAX) +# else +# define YYSTACK_BYTES(N) \ + ((N) * (sizeof (short) + sizeof (YYSTYPE)) \ + + YYSTACK_GAP_MAX) +# endif + +/* Relocate the TYPE STACK from its old location to the new one. The + local variables YYSIZE and YYSTACKSIZE give the old and new number of + elements in the stack, and YYPTR gives the new location of the + stack. Advance YYPTR to a properly aligned location for the next + stack. */ +# define YYSTACK_RELOCATE(Type, Stack) \ + do \ + { \ + YYSIZE_T yynewbytes; \ + yymemcpy ((char *) yyptr, (char *) (Stack), \ + yysize * (YYSIZE_T) sizeof (Type)); \ + Stack = &yyptr->Stack; \ + yynewbytes = yystacksize * sizeof (Type) + YYSTACK_GAP_MAX; \ + yyptr += yynewbytes / sizeof (*yyptr); \ + } \ + while (0) + +#endif /* ! defined (yyoverflow) || defined (YYERROR_VERBOSE) */ + + +#if ! defined (YYSIZE_T) && defined (__SIZE_TYPE__) +# define YYSIZE_T __SIZE_TYPE__ +#endif +#if ! defined (YYSIZE_T) && defined (size_t) +# define YYSIZE_T size_t +#endif +#if ! defined (YYSIZE_T) +# ifdef __cplusplus +# include <cstddef> /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T std::size_t +# else +# ifdef __STDC__ +# include <stddef.h> /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T size_t +# endif +# endif +#endif +#if ! defined (YYSIZE_T) +# define YYSIZE_T unsigned int +#endif + +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY -2 +#define YYEOF 0 +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrlab1 +/* Like YYERROR except do call yyerror. This remains here temporarily + to ease the transition to the new meaning of YYERROR, for GCC. + Once GCC version 2 has supplanted version 1, this can go. */ +#define YYFAIL goto yyerrlab +#define YYRECOVERING() (!!yyerrstatus) +#define YYBACKUP(Token, Value) \ +do \ + if (yychar == YYEMPTY && yylen == 1) \ + { \ + yychar = (Token); \ + yylval = (Value); \ + yychar1 = YYTRANSLATE (yychar); \ + YYPOPSTACK; \ + goto yybackup; \ + } \ + else \ + { \ + yyerror ("syntax error: cannot back up"); \ + YYERROR; \ + } \ +while (0) + +#define YYTERROR 1 +#define YYERRCODE 256 + + +/* YYLLOC_DEFAULT -- Compute the default location (before the actions + are run). + + When YYLLOC_DEFAULT is run, CURRENT is set the location of the + first token. By default, to implement support for ranges, extend + its range to the last symbol. */ + +#ifndef YYLLOC_DEFAULT +# define YYLLOC_DEFAULT(Current, Rhs, N) \ + Current.last_line = Rhs[N].last_line; \ + Current.last_column = Rhs[N].last_column; +#endif + + +/* YYLEX -- calling `yylex' with the right arguments. */ + +#if YYPURE +# if YYLSP_NEEDED +# ifdef YYLEX_PARAM +# define YYLEX yylex (&yylval, &yylloc, YYLEX_PARAM) +# else +# define YYLEX yylex (&yylval, &yylloc) +# endif +# else /* !YYLSP_NEEDED */ +# ifdef YYLEX_PARAM +# define YYLEX yylex (&yylval, YYLEX_PARAM) +# else +# define YYLEX yylex (&yylval) +# endif +# endif /* !YYLSP_NEEDED */ +#else /* !YYPURE */ +# define YYLEX yylex () +#endif /* !YYPURE */ + + +/* Enable debugging if requested. */ +#if YYDEBUG + +# ifndef YYFPRINTF +# ifdef __cplusplus +# include <cstdio> /* INFRINGES ON USER NAME SPACE */ +# else +# include <stdio.h> /* INFRINGES ON USER NAME SPACE */ +# endif +# define YYFPRINTF YYSTD (fprintf) +# endif + +# define YYDPRINTF(Args) \ +do { \ + if (yydebug) \ + YYFPRINTF Args; \ +} while (0) +/* Nonzero means print parse trace. [The following comment makes no + sense to me. Could someone clarify it? --akim] Since this is + uninitialized, it does not stop multiple parsers from coexisting. + */ +int yydebug; +#else /* !YYDEBUG */ +# define YYDPRINTF(Args) +#endif /* !YYDEBUG */ + +/* YYINITDEPTH -- initial size of the parser's stacks. */ +#ifndef YYINITDEPTH +# define YYINITDEPTH 200 +#endif + +/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only + if the built-in stack extension method is used). + + Do not make this value too large; the results are undefined if + SIZE_MAX < YYSTACK_BYTES (YYMAXDEPTH) + evaluated with infinite-precision integer arithmetic. */ + +#if YYMAXDEPTH == 0 +# undef YYMAXDEPTH +#endif + +#ifndef YYMAXDEPTH +# define YYMAXDEPTH 10000 +#endif + +#if ! defined (yyoverflow) && ! defined (yymemcpy) +# if __GNUC__ > 1 /* GNU C and GNU C++ define this. */ +# define yymemcpy __builtin_memcpy +# else /* not GNU C or C++ */ + +/* This is the most reliable way to avoid incompatibilities + in available built-in functions on various systems. */ +static void +# if defined (__STDC__) || defined (__cplusplus) +yymemcpy (char *yyto, const char *yyfrom, YYSIZE_T yycount) +# else +yymemcpy (yyto, yyfrom, yycount) + char *yyto; + const char *yyfrom; + YYSIZE_T yycount; +# endif +{ + register const char *yyf = yyfrom; + register char *yyt = yyto; + register YYSIZE_T yyi = yycount; + + while (yyi-- != 0) + *yyt++ = *yyf++; +} +# endif +#endif + +#ifdef YYERROR_VERBOSE + +# ifndef yystrlen +# if defined (__GLIBC__) && defined (_STRING_H) +# define yystrlen strlen +# else +/* Return the length of YYSTR. */ +static YYSIZE_T +# if defined (__STDC__) || defined (__cplusplus) +yystrlen (const char *yystr) +# else +yystrlen (yystr) + const char *yystr; +# endif +{ + register const char *yys = yystr; + + while (*yys++ != '\0') + continue; + + return yys - yystr - 1; +} +# endif +# endif + +# ifndef yystpcpy +# if defined (__GLIBC__) && defined (_STRING_H) && defined (_GNU_SOURCE) +# define yystpcpy stpcpy +# else +/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in + YYDEST. */ +static char * +# if defined (__STDC__) || defined (__cplusplus) +yystpcpy (char *yydest, const char *yysrc) +# else +yystpcpy (yydest, yysrc) + char *yydest; + const char *yysrc; +# endif +{ + register char *yyd = yydest; + register const char *yys = yysrc; + + while ((*yyd++ = *yys++) != '\0') + continue; + + return yyd - 1; +} +# endif +# endif +#endif + +#line 341 "/usr/share/bison/bison.simple" + + +/* The user can define YYPARSE_PARAM as the name of an argument to be passed + into yyparse. The argument should have type void *. + It should actually point to an object. + Grammar actions can access the variable by casting it + to the proper pointer type. */ + +#ifdef YYPARSE_PARAM +# ifdef __cplusplus +# define YYPARSE_PARAM_ARG void *YYPARSE_PARAM +# define YYPARSE_PARAM_DECL +# else /* !__cplusplus */ +# define YYPARSE_PARAM_ARG YYPARSE_PARAM +# define YYPARSE_PARAM_DECL void *YYPARSE_PARAM; +# endif /* !__cplusplus */ +#else /* !YYPARSE_PARAM */ +# define YYPARSE_PARAM_ARG +# define YYPARSE_PARAM_DECL +#endif /* !YYPARSE_PARAM */ + +/* Prevent warning if -Wstrict-prototypes. */ +#ifdef __GNUC__ +# ifdef YYPARSE_PARAM +int yyparse (void *); +# else +int yyparse (void); +# endif +#endif + +/* YY_DECL_VARIABLES -- depending whether we use a pure parser, + variables are global, or local to YYPARSE. */ + +#define YY_DECL_NON_LSP_VARIABLES \ +/* The lookahead symbol. */ \ +int yychar; \ + \ +/* The semantic value of the lookahead symbol. */ \ +YYSTYPE yylval; \ + \ +/* Number of parse errors so far. */ \ +int yynerrs; + +#if YYLSP_NEEDED +# define YY_DECL_VARIABLES \ +YY_DECL_NON_LSP_VARIABLES \ + \ +/* Location data for the lookahead symbol. */ \ +YYLTYPE yylloc; +#else +# define YY_DECL_VARIABLES \ +YY_DECL_NON_LSP_VARIABLES +#endif + + +/* If nonreentrant, generate the variables here. */ + +#if !YYPURE +YY_DECL_VARIABLES +#endif /* !YYPURE */ + +int +yyparse (YYPARSE_PARAM_ARG) + YYPARSE_PARAM_DECL +{ + /* If reentrant, generate the variables here. */ +#if YYPURE + YY_DECL_VARIABLES +#endif /* !YYPURE */ + + register int yystate; + register int yyn; + int yyresult; + /* Number of tokens to shift before error messages enabled. */ + int yyerrstatus; + /* Lookahead token as an internal (translated) token number. */ + int yychar1 = 0; + + /* Three stacks and their tools: + `yyss': related to states, + `yyvs': related to semantic values, + `yyls': related to locations. + + Refer to the stacks thru separate pointers, to allow yyoverflow + to reallocate them elsewhere. */ + + /* The state stack. */ + short yyssa[YYINITDEPTH]; + short *yyss = yyssa; + register short *yyssp; + + /* The semantic value stack. */ + YYSTYPE yyvsa[YYINITDEPTH]; + YYSTYPE *yyvs = yyvsa; + register YYSTYPE *yyvsp; + +#if YYLSP_NEEDED + /* The location stack. */ + YYLTYPE yylsa[YYINITDEPTH]; + YYLTYPE *yyls = yylsa; + YYLTYPE *yylsp; +#endif + +#if YYLSP_NEEDED +# define YYPOPSTACK (yyvsp--, yyssp--, yylsp--) +#else +# define YYPOPSTACK (yyvsp--, yyssp--) +#endif + + YYSIZE_T yystacksize = YYINITDEPTH; + + + /* The variables used to return semantic value and location from the + action routines. */ + YYSTYPE yyval; +#if YYLSP_NEEDED + YYLTYPE yyloc; +#endif + + /* When reducing, the number of symbols on the RHS of the reduced + rule. */ + int yylen; + + YYDPRINTF ((stderr, "Starting parse\n")); + + yystate = 0; + yyerrstatus = 0; + yynerrs = 0; + yychar = YYEMPTY; /* Cause a token to be read. */ + + /* Initialize stack pointers. + Waste one element of value and location stack + so that they stay on the same level as the state stack. + The wasted elements are never initialized. */ + + yyssp = yyss; + yyvsp = yyvs; +#if YYLSP_NEEDED + yylsp = yyls; +#endif + goto yysetstate; + +/*------------------------------------------------------------. +| yynewstate -- Push a new state, which is found in yystate. | +`------------------------------------------------------------*/ + yynewstate: + /* In all cases, when you get here, the value and location stacks + have just been pushed. so pushing a state here evens the stacks. + */ + yyssp++; + + yysetstate: + *yyssp = yystate; + + if (yyssp >= yyss + yystacksize - 1) + { + /* Get the current used size of the three stacks, in elements. */ + YYSIZE_T yysize = yyssp - yyss + 1; + +#ifdef yyoverflow + { + /* Give user a chance to reallocate the stack. Use copies of + these so that the &'s don't force the real ones into + memory. */ + YYSTYPE *yyvs1 = yyvs; + short *yyss1 = yyss; + + /* Each stack pointer address is followed by the size of the + data in use in that stack, in bytes. */ +# if YYLSP_NEEDED + YYLTYPE *yyls1 = yyls; + /* This used to be a conditional around just the two extra args, + but that might be undefined if yyoverflow is a macro. */ + yyoverflow ("parser stack overflow", + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + &yyls1, yysize * sizeof (*yylsp), + &yystacksize); + yyls = yyls1; +# else + yyoverflow ("parser stack overflow", + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + &yystacksize); +# endif + yyss = yyss1; + yyvs = yyvs1; + } +#else /* no yyoverflow */ + /* Extend the stack our own way. */ + if (yystacksize >= YYMAXDEPTH) + goto yyoverflowlab; + yystacksize *= 2; + if (yystacksize > YYMAXDEPTH) + yystacksize = YYMAXDEPTH; + + { + short *yyss1 = yyss; + union yyalloc *yyptr = + (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); + if (! yyptr) + goto yyoverflowlab; + YYSTACK_RELOCATE (short, yyss); + YYSTACK_RELOCATE (YYSTYPE, yyvs); +# if YYLSP_NEEDED + YYSTACK_RELOCATE (YYLTYPE, yyls); +# endif +# undef YYSTACK_RELOCATE + if (yyss1 != yyssa) + YYSTACK_FREE (yyss1); + } +#endif /* no yyoverflow */ + + yyssp = yyss + yysize - 1; + yyvsp = yyvs + yysize - 1; +#if YYLSP_NEEDED + yylsp = yyls + yysize - 1; +#endif + + YYDPRINTF ((stderr, "Stack size increased to %lu\n", + (unsigned long int) yystacksize)); + + if (yyssp >= yyss + yystacksize - 1) + YYABORT; + } + + YYDPRINTF ((stderr, "Entering state %d\n", yystate)); + + goto yybackup; + + +/*-----------. +| yybackup. | +`-----------*/ +yybackup: + +/* Do appropriate processing given the current state. */ +/* Read a lookahead token if we need one and don't already have one. */ +/* yyresume: */ + + /* First try to decide what to do without reference to lookahead token. */ + + yyn = yypact[yystate]; + if (yyn == YYFLAG) + goto yydefault; + + /* Not known => get a lookahead token if don't already have one. */ + + /* yychar is either YYEMPTY or YYEOF + or a valid token in external form. */ + + if (yychar == YYEMPTY) + { + YYDPRINTF ((stderr, "Reading a token: ")); + yychar = YYLEX; + } + + /* Convert token to internal form (in yychar1) for indexing tables with */ + + if (yychar <= 0) /* This means end of input. */ + { + yychar1 = 0; + yychar = YYEOF; /* Don't call YYLEX any more */ + + YYDPRINTF ((stderr, "Now at end of input.\n")); + } + else + { + yychar1 = YYTRANSLATE (yychar); + +#if YYDEBUG + /* We have to keep this `#if YYDEBUG', since we use variables + which are defined only if `YYDEBUG' is set. */ + if (yydebug) + { + YYFPRINTF (stderr, "Next token is %d (%s", + yychar, yytname[yychar1]); + /* Give the individual parser a way to print the precise + meaning of a token, for further debugging info. */ +# ifdef YYPRINT + YYPRINT (stderr, yychar, yylval); +# endif + YYFPRINTF (stderr, ")\n"); + } +#endif + } + + yyn += yychar1; + if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != yychar1) + goto yydefault; + + yyn = yytable[yyn]; + + /* yyn is what to do for this token type in this state. + Negative => reduce, -yyn is rule number. + Positive => shift, yyn is new state. + New state is final state => don't bother to shift, + just return success. + 0, or most negative number => error. */ + + if (yyn < 0) + { + if (yyn == YYFLAG) + goto yyerrlab; + yyn = -yyn; + goto yyreduce; + } + else if (yyn == 0) + goto yyerrlab; + + if (yyn == YYFINAL) + YYACCEPT; + + /* Shift the lookahead token. */ + YYDPRINTF ((stderr, "Shifting token %d (%s), ", + yychar, yytname[yychar1])); + + /* Discard the token being shifted unless it is eof. */ + if (yychar != YYEOF) + yychar = YYEMPTY; + + *++yyvsp = yylval; +#if YYLSP_NEEDED + *++yylsp = yylloc; +#endif + + /* Count tokens shifted since error; after three, turn off error + status. */ + if (yyerrstatus) + yyerrstatus--; + + yystate = yyn; + goto yynewstate; + + +/*-----------------------------------------------------------. +| yydefault -- do the default action for the current state. | +`-----------------------------------------------------------*/ +yydefault: + yyn = yydefact[yystate]; + if (yyn == 0) + goto yyerrlab; + goto yyreduce; + + +/*-----------------------------. +| yyreduce -- Do a reduction. | +`-----------------------------*/ +yyreduce: + /* yyn is the number of a rule to reduce with. */ + yylen = yyr2[yyn]; + + /* If YYLEN is nonzero, implement the default value of the action: + `$$ = $1'. + + Otherwise, the following line sets YYVAL to the semantic value of + the lookahead token. This behavior is undocumented and Bison + users should not rely upon it. Assigning to YYVAL + unconditionally makes the parser a bit smaller, and it avoids a + GCC warning that YYVAL may be used uninitialized. */ + yyval = yyvsp[1-yylen]; + +#if YYLSP_NEEDED + /* Similarly for the default location. Let the user run additional + commands if for instance locations are ranges. */ + yyloc = yylsp[1-yylen]; + YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen); +#endif + +#if YYDEBUG + /* We have to keep this `#if YYDEBUG', since we use variables which + are defined only if `YYDEBUG' is set. */ + if (yydebug) + { + int yyi; + + YYFPRINTF (stderr, "Reducing via rule %d (line %d), ", + yyn, yyrline[yyn]); + + /* Print the symbols being reduced, and their result. */ + for (yyi = yyprhs[yyn]; yyrhs[yyi] > 0; yyi++) + YYFPRINTF (stderr, "%s ", yytname[yyrhs[yyi]]); + YYFPRINTF (stderr, " -> %s\n", yytname[yyr1[yyn]]); + } +#endif + + switch (yyn) { + +case 1: +#line 87 "parse.y" +{ parse_return=yyvsp[0]; } + break; +case 2: +#line 88 "parse.y" +{ + if(!parse_error) + parse_error=PARSE_ERR; + parse_return=0; } + break; +case 5: +#line 96 "parse.y" +{ + yyval=yyvsp[-2]; } + break; +case 6: +#line 98 "parse.y" +{ + (yyvsp[-3])->n_x.v_subs[0]=yyvsp[-1]; + (yyvsp[-3])->n_x.v_subs[1]=(struct node *)0; + yyval=yyvsp[-3]; } + break; +case 7: +#line 102 "parse.y" +{ + (yyvsp[-5])->n_x.v_subs[0]=yyvsp[-3]; + (yyvsp[-5])->n_x.v_subs[1]=yyvsp[-1]; + yyval=yyvsp[-5]; } + break; +case 8: +#line 106 "parse.y" +{ + (yyvsp[-7])->n_x.v_subs[0]=make_list(yyvsp[-5],yyvsp[-3]); + (yyvsp[-7])->n_x.v_subs[1]=yyvsp[-1]; + yyval=yyvsp[-7];} + break; +case 9: +#line 110 "parse.y" +{ + (yyvsp[-9])->n_x.v_subs[0]=make_list(yyvsp[-7],yyvsp[-5]); + (yyvsp[-9])->n_x.v_subs[1]=make_list(yyvsp[-3],yyvsp[-1]); + yyval=yyvsp[-9];} + break; +case 10: +#line 114 "parse.y" +{ + (yyvsp[-3])->n_x.v_subs[0]=(struct node *)0; + (yyvsp[-3])->n_x.v_subs[1]=yyvsp[-1]; + yyval=yyvsp[-3]; } + break; +case 11: +#line 118 "parse.y" +{ + yyvsp[-3]->n_x.v_subs[0]=yyvsp[-1]; + yyval=yyvsp[-3]; } + break; +case 12: +#line 121 "parse.y" +{ + yyvsp[-3]->n_x.v_subs[0]=yyvsp[-1]; + yyval=yyvsp[-3]; } + break; +case 13: +#line 125 "parse.y" +{ + yyvsp[-5]->n_x.v_subs[0]=yyvsp[-3]; + yyvsp[-5]->n_x.v_subs[1]=yyvsp[-1]; + yyval=yyvsp[-5]; } + break; +case 14: +#line 129 "parse.y" +{ + yyvsp[-5]->n_x.v_subs[0]=yyvsp[-3]; + yyvsp[-5]->n_x.v_subs[1]=yyvsp[-1]; + yyval=yyvsp[-5]; } + break; +case 15: +#line 135 "parse.y" +{ + if(yyvsp[-7]->comp_value!=F_INDEX) + parse_error=PARSE_ERR; + yyvsp[-7]->comp_value=F_INDEX2; + yyvsp[-7]->n_x.v_subs[0]=make_list(yyvsp[-5],yyvsp[-3]); + yyvsp[-7]->n_x.v_subs[1]=yyvsp[-1]; + yyval=yyvsp[-7]; } + break; +case 16: +#line 142 "parse.y" +{ + if(yyvsp[-7]->comp_value!=F_INDEX) + parse_error=PARSE_ERR; + yyvsp[-7]->comp_value=F_INDEX2; + yyvsp[-7]->n_x.v_subs[0]=make_list(yyvsp[-5],yyvsp[-3]); + yyvsp[-7]->n_x.v_subs[1]=yyvsp[-1]; + yyval=yyvsp[-7]; } + break; +case 17: +#line 150 "parse.y" +{ + (yyvsp[-7])->n_x.v_subs[0]=make_list(yyvsp[-5],yyvsp[-3]); + (yyvsp[-7])->n_x.v_subs[1]=yyvsp[-1]; + yyval=yyvsp[-7];} + break; +case 18: +#line 154 "parse.y" +{ + (yyvsp[-7])->n_x.v_subs[0]=make_list(yyvsp[-5],yyvsp[-3]); + (yyvsp[-7])->n_x.v_subs[1]=yyvsp[-1]; + yyval=yyvsp[-7];} + break; +case 19: +#line 159 "parse.y" +{ + (yyvsp[-3])->n_x.v_subs[0]=(struct node *)0; + (yyvsp[-3])->n_x.v_subs[1]=yyvsp[-1]; + yyval=yyvsp[-3]; } + break; +case 20: +#line 163 "parse.y" +{ + yyvsp[-3]->comp_value=IF; + yyvsp[-3]->n_x.v_subs[0]=yyvsp[-1]; + yyvsp[-3]->n_x.v_subs[1]=yyvsp[0]; + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-4]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[-2]; + yyval=yyvsp[-3]; } + break; +case 21: +#line 174 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 22: +#line 178 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 23: +#line 182 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 24: +#line 186 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 25: +#line 190 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 26: +#line 194 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 27: +#line 198 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 28: +#line 202 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 29: +#line 206 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 30: +#line 210 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 31: +#line 214 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 32: +#line 218 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 33: +#line 222 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2]; + yyvsp[-1]->n_x.v_subs[1]=yyvsp[0]; + yyval = yyvsp[-1]; } + break; +case 34: +#line 226 "parse.y" +{ + if(yyvsp[0]->comp_value==CONST_FLT) { + yyvsp[0]->n_x.v_float= -(yyvsp[0]->n_x.v_float); + /* free($1); */ + yyval=yyvsp[0]; + } else if(yyvsp[0]->comp_value==CONST_INT) { + yyvsp[0]->n_x.v_int= -(yyvsp[0]->n_x.v_int); + /* free($1); */ + yyval=yyvsp[0]; + } else { + yyvsp[-1]->comp_value = NEGATE; + yyvsp[-1]->n_x.v_subs[0]=yyvsp[0]; + yyvsp[-1]->n_x.v_subs[1]=(struct node *)0; + yyval = yyvsp[-1]; + } } + break; +case 35: +#line 241 "parse.y" +{ + yyvsp[-1]->n_x.v_subs[0]=yyvsp[0]; + yyvsp[-1]->n_x.v_subs[1]=(struct node *)0; + yyval = yyvsp[-1]; } + break; +case 36: +#line 246 "parse.y" +{ yyval = yyvsp[-1]; } + break; +case 37: +#line 247 "parse.y" +{ + if(!parse_error) + parse_error=NO_CLOSE; + } + break; +case 38: +#line 255 "parse.y" +{ + if(!parse_error) + parse_error=NO_CLOSE; + } + break; +case 39: +#line 263 "parse.y" +{ yyval = make_list(yyvsp[0], 0); } + break; +case 40: +#line 265 "parse.y" +{ yyval = make_list(yyvsp[0], yyvsp[-2]); } + break; +case 43: +#line 273 "parse.y" +{ yyval=make_list(yyvsp[0], 0); } + break; +case 44: +#line 275 "parse.y" +{ yyval=make_list(yyvsp[0],yyvsp[-2]); } + break; +case 45: +#line 279 "parse.y" +{ yyval=yyvsp[0]; } + break; +} + +#line 727 "/usr/share/bison/bison.simple" + + + yyvsp -= yylen; + yyssp -= yylen; +#if YYLSP_NEEDED + yylsp -= yylen; +#endif + +#if YYDEBUG + if (yydebug) + { + short *yyssp1 = yyss - 1; + YYFPRINTF (stderr, "state stack now"); + while (yyssp1 != yyssp) + YYFPRINTF (stderr, " %d", *++yyssp1); + YYFPRINTF (stderr, "\n"); + } +#endif + + *++yyvsp = yyval; +#if YYLSP_NEEDED + *++yylsp = yyloc; +#endif + + /* Now `shift' the result of the reduction. Determine what state + that goes to, based on the state we popped back to and the rule + number reduced by. */ + + yyn = yyr1[yyn]; + + yystate = yypgoto[yyn - YYNTBASE] + *yyssp; + if (yystate >= 0 && yystate <= YYLAST && yycheck[yystate] == *yyssp) + yystate = yytable[yystate]; + else + yystate = yydefgoto[yyn - YYNTBASE]; + + goto yynewstate; + + +/*------------------------------------. +| yyerrlab -- here on detecting error | +`------------------------------------*/ +yyerrlab: + /* If not already recovering from an error, report this error. */ + if (!yyerrstatus) + { + ++yynerrs; + +#ifdef YYERROR_VERBOSE + yyn = yypact[yystate]; + + if (yyn > YYFLAG && yyn < YYLAST) + { + YYSIZE_T yysize = 0; + char *yymsg; + int yyx, yycount; + + yycount = 0; + /* Start YYX at -YYN if negative to avoid negative indexes in + YYCHECK. */ + for (yyx = yyn < 0 ? -yyn : 0; + yyx < (int) (sizeof (yytname) / sizeof (char *)); yyx++) + if (yycheck[yyx + yyn] == yyx) + yysize += yystrlen (yytname[yyx]) + 15, yycount++; + yysize += yystrlen ("parse error, unexpected ") + 1; + yysize += yystrlen (yytname[YYTRANSLATE (yychar)]); + yymsg = (char *) YYSTACK_ALLOC (yysize); + if (yymsg != 0) + { + char *yyp = yystpcpy (yymsg, "parse error, unexpected "); + yyp = yystpcpy (yyp, yytname[YYTRANSLATE (yychar)]); + + if (yycount < 5) + { + yycount = 0; + for (yyx = yyn < 0 ? -yyn : 0; + yyx < (int) (sizeof (yytname) / sizeof (char *)); + yyx++) + if (yycheck[yyx + yyn] == yyx) + { + const char *yyq = ! yycount ? ", expecting " : " or "; + yyp = yystpcpy (yyp, yyq); + yyp = yystpcpy (yyp, yytname[yyx]); + yycount++; + } + } + yyerror (yymsg); + YYSTACK_FREE (yymsg); + } + else + yyerror ("parse error; also virtual memory exhausted"); + } + else +#endif /* defined (YYERROR_VERBOSE) */ + yyerror ("parse error"); + } + goto yyerrlab1; + + +/*--------------------------------------------------. +| yyerrlab1 -- error raised explicitly by an action | +`--------------------------------------------------*/ +yyerrlab1: + if (yyerrstatus == 3) + { + /* If just tried and failed to reuse lookahead token after an + error, discard it. */ + + /* return failure if at end of input */ + if (yychar == YYEOF) + YYABORT; + YYDPRINTF ((stderr, "Discarding token %d (%s).\n", + yychar, yytname[yychar1])); + yychar = YYEMPTY; + } + + /* Else will try to reuse lookahead token after shifting the error + token. */ + + yyerrstatus = 3; /* Each real token shifted decrements this */ + + goto yyerrhandle; + + +/*-------------------------------------------------------------------. +| yyerrdefault -- current state does not do anything special for the | +| error token. | +`-------------------------------------------------------------------*/ +yyerrdefault: +#if 0 + /* This is wrong; only states that explicitly want error tokens + should shift them. */ + + /* If its default is to accept any token, ok. Otherwise pop it. */ + yyn = yydefact[yystate]; + if (yyn) + goto yydefault; +#endif + + +/*---------------------------------------------------------------. +| yyerrpop -- pop the current state because it cannot handle the | +| error token | +`---------------------------------------------------------------*/ +yyerrpop: + if (yyssp == yyss) + YYABORT; + yyvsp--; + yystate = *--yyssp; +#if YYLSP_NEEDED + yylsp--; +#endif + +#if YYDEBUG + if (yydebug) + { + short *yyssp1 = yyss - 1; + YYFPRINTF (stderr, "Error: state stack now"); + while (yyssp1 != yyssp) + YYFPRINTF (stderr, " %d", *++yyssp1); + YYFPRINTF (stderr, "\n"); + } +#endif + +/*--------------. +| yyerrhandle. | +`--------------*/ +yyerrhandle: + yyn = yypact[yystate]; + if (yyn == YYFLAG) + goto yyerrdefault; + + yyn += YYTERROR; + if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != YYTERROR) + goto yyerrdefault; + + yyn = yytable[yyn]; + if (yyn < 0) + { + if (yyn == YYFLAG) + goto yyerrpop; + yyn = -yyn; + goto yyreduce; + } + else if (yyn == 0) + goto yyerrpop; + + if (yyn == YYFINAL) + YYACCEPT; + + YYDPRINTF ((stderr, "Shifting error token, ")); + + *++yyvsp = yylval; +#if YYLSP_NEEDED + *++yylsp = yylloc; +#endif + + yystate = yyn; + goto yynewstate; + + +/*-------------------------------------. +| yyacceptlab -- YYACCEPT comes here. | +`-------------------------------------*/ +yyacceptlab: + yyresult = 0; + goto yyreturn; + +/*-----------------------------------. +| yyabortlab -- YYABORT comes here. | +`-----------------------------------*/ +yyabortlab: + yyresult = 1; + goto yyreturn; + +/*---------------------------------------------. +| yyoverflowab -- parser overflow comes here. | +`---------------------------------------------*/ +yyoverflowlab: + yyerror ("parser stack overflow"); + yyresult = 2; + /* Fall through. */ + +yyreturn: +#ifndef yyoverflow + if (yyss != yyssa) + YYSTACK_FREE (yyss); +#endif + return yyresult; +} +#line 282 "parse.y" + + +void +yyerror FUN1(char *, s) +{ + if(!parse_error) + parse_error=PARSE_ERR; +} + +YYSTYPE +make_list FUN2(YYSTYPE, car, YYSTYPE, cdr) +{ + YYSTYPE ret; + + ret=(YYSTYPE)obstack_alloc(&tmp_mem,sizeof(*ret)); + ret->comp_value = 0; + ret->n_x.v_subs[0]=car; + ret->n_x.v_subs[1]=cdr; + return ret; +} + +#define ERROR -1 + +extern struct node *yylval; + +#ifdef __STDC__ +unsigned char parse_cell_or_range (char **,struct rng *); +#else +unsigned char parse_cell_or_range (); +#endif + +int +yylex FUN0() +{ + int ch; + struct node *new; + int isflt; + char *begin; + char *tmp_str; + unsigned char byte_value; + int n; + + /* unsigned char *ptr; */ + int nn; + struct function *fp; + int tmp_ch; + +#ifdef TEST + if(!instr) + return ERROR; +#endif + while(isspace(*instr)) + instr++; + ch = *instr++; + if(ch=='(' || ch==',' || ch==')') + return ch; + + new=(struct node *)obstack_alloc(&tmp_mem,sizeof(struct node)); + new->add_byte=0; + new->sub_value=0; + switch(ch) { + case 0: + return 0; + + case '0': case '1': case '2': case '3': case '4': case '5': case '6': + case '7': case '8': case '9': case '.': + isflt = (ch=='.'); + + begin=instr-1; + tmp_str=instr; + + while(isdigit(*tmp_str) || (!isflt && *tmp_str=='.' && ++isflt)) + tmp_str++; + if(*tmp_str=='e' || *tmp_str=='E') { + isflt=1; + tmp_str++; + if(*tmp_str=='-' || *tmp_str=='+') + tmp_str++; + while(isdigit(*tmp_str)) + tmp_str++; + } + if(isflt) { + new->n_x.v_float=astof((char **)(&begin)); + byte_value=CONST_FLT; + } else { + new->n_x.v_int=astol((char **)(&begin)); + if(begin!=tmp_str) { + begin=instr-1; + new->n_x.v_float=astof((char **)(&begin)); + byte_value=CONST_FLT; + } else + byte_value=CONST_INT; + } + ch=L_CONST; + instr=begin; + break; + + case '"': + begin=instr; + while(*instr && *instr!='"') { + if(*instr=='\\' && instr[1]) + instr++; + instr++; + } + if(!*instr) { + parse_error=NO_QUOTE; + return ERROR; + } + tmp_str=new->n_x.v_string=(char *)ck_malloc(1+instr-begin); + while(begin!=instr) { + unsigned char n; + + if(*begin=='\\') { + begin++; + if(begin[0]>='0' && begin[0]<='7') { + if(begin[1]>='0' && begin[1]<='7') { + if(begin[2]>='0' && begin[2]<='7') { + n=(begin[2]-'0') + (010 * (begin[1]-'0')) + ( 0100 * (begin[0]-'0')); + begin+=3; + } else { + n=(begin[1]-'0') + (010 * (begin[0]-'0')); + begin+=2; + } + } else { + n=begin[0]-'0'; + begin++; + } + } else + n= *begin++; + *tmp_str++= n; + } else + *tmp_str++= *begin++; + } + *tmp_str='\0'; + instr++; + byte_value=CONST_STR; + ch=L_CONST; + break; + + case '+': case '-': + + case '*': case '/': case '%': case '&': + /* case '|': */ case '^': case '=': + + case '?': + { + unsigned char *ptr; + + for(ptr= fnin;*ptr;ptr++) + if(the_funs[*ptr].fn_str[0]==ch) + break; +#ifdef TEST + if(!*ptr) + panic("Can't find fnin[] entry for '%c'",ch); +#endif + byte_value= *ptr; + } + break; + + case ':': + byte_value=IF; + break; + + case '!': + case '<': + case '>': + if(*instr!='=') { + byte_value = (ch=='<') ? LESS : (ch=='>') ? GREATER : NOT; + break; + } + instr++; + byte_value = (ch=='<') ? LESSEQ : (ch=='>') ? GREATEQ : NOTEQUAL; + ch = (ch=='<') ? LE : (ch=='>') ? GE : NE; + break; + + case '\'': + case ';': + case '[': + case '\\': + case ']': + case '`': + case '{': + case '}': + case '~': + bad_chr: + parse_error=BAD_CHAR; + return ERROR; + + case '#': + begin=instr-1; + while(*instr && (isalnum(*instr) || *instr=='_')) + instr++; + ch= *instr; + *instr=0; + if(!stricmp(begin,tname)) + byte_value=F_TRUE; + else if(!stricmp(begin,fname)) + byte_value=F_FALSE; + else if(!stricmp(begin,iname) && (begin[4]==0 || !stricmp(begin+4,"inity"))) + byte_value=CONST_INF; + else if(!stricmp(begin,mname) || + !stricmp(begin,"#ninf")) + byte_value=CONST_NINF; + else if(!stricmp(begin,nname) || + !stricmp(begin,"#nan")) + byte_value=CONST_NAN; + else { + for(n=1;n<=ERR_MAX;n++) + if(!stricmp(begin,ename[n])) + break; + if(n>ERR_MAX) + n=BAD_CHAR; + new->n_x.v_int=n; + byte_value=CONST_ERR; + } + *instr=ch; + ch=L_CONST; + break; + + default: + if(!a0 && (ch=='@' || ch=='$')) + goto bad_chr; + + if(a0 && ch=='@') { + begin=instr; + while(*instr && (isalpha(*instr) || isdigit(*instr) || *instr=='_')) + instr++; + n=instr-begin; + } else { + begin=instr-1; + byte_value=parse_cell_or_range(&begin,&(new->n_x.v_rng)); + if(byte_value) { + if((byte_value& ~0x3)==R_CELL) + ch=L_CELL; + else + ch=L_RANGE; + instr=begin; + break; + } + + while(*instr && (isalpha(*instr) || isdigit(*instr) || *instr=='_')) + instr++; + + n=instr-begin; + while(isspace(*instr)) + instr++; + + if(*instr!='(') { + ch=L_VAR; + byte_value=VAR; + new->n_x.v_var=find_or_make_var(begin,n); + break; + } + } + tmp_ch=begin[n]; + begin[n]='\0'; + fp=hash_find(parse_hash,begin); + begin[n]=tmp_ch; + byte_value= ERROR; + if(!fp) { + parse_error=BAD_FUNC; + return ERROR; + } + + if(fp>=the_funs && fp<=&the_funs[USR1]) + byte_value=fp-the_funs; + else { + for(nn=0;nn<n_usr_funs;nn++) { + if(fp>=&usr_funs[nn][0] && fp<=&usr_funs[nn][usr_n_funs[nn]]) { + byte_value=USR1+nn; + new->sub_value=fp-&usr_funs[nn][0]; + break; + } + } +#ifdef TEST + if(nn==n_usr_funs) { + io_error_msg("Couln't turn fp into a ##"); + parse_error=BAD_FUNC; + return ERROR; + } +#endif + } + + if(fp->fn_argn&X_J) + ch= byte_value==F_IF ? L_FN3 : L_FN2; + else if(fp->fn_argt[0]=='R' || fp->fn_argt[0]=='E') + ch=L_FN1R-1+fp->fn_argn-X_A0; + else + ch=L_FN0 + fp->fn_argn-X_A0; + + break; + } + /* new->node_type=ch; */ + new->comp_value=byte_value; + yylval=new; + return ch; +} + +/* Return value is + 0 if it doesn't look like a cell or a range, + R_CELL if it is a cell (ptr now points past the characters, lr and lc hold the row and col of the cell) + RANGE if it is a range (ptr points past the chars) + */ +unsigned char +parse_cell_or_range FUN2(char **,ptr, struct rng *,retp) +{ + if(a0) { + unsigned tmpc,tmpr; + char *p; + int abz = ROWREL|COLREL; + + p= *ptr; + tmpc=0; + if(*p=='$') { + abz-=COLREL; + p++; + } + if(!isalpha(*p)) + return 0; + tmpc=str_to_col(&p); + if(tmpc<MIN_COL || tmpc>MAX_COL) + return 0; + if(*p=='$') { + abz-=ROWREL; + p++; + } + if(!isdigit(*p)) + return 0; + for(tmpr=0;isdigit(*p);p++) + tmpr=tmpr*10 + *p - '0'; + + if(tmpr<MIN_ROW || tmpr>MAX_ROW) + return 0; + + if(*p==':' || *p=='.') { + unsigned tmpc1,tmpr1; + + abz = ((abz&COLREL) ? LCREL : 0)|((abz&ROWREL) ? LRREL : 0)|HRREL|HCREL; + p++; + if(*p=='$') { + abz-=HCREL; + p++; + } + if(!isalpha(*p)) + return 0; + tmpc1=str_to_col(&p); + if(tmpc1<MIN_COL || tmpc1>MAX_COL) + return 0; + if(*p=='$') { + abz-=HRREL; + p++; + } + if(!isdigit(*p)) + return 0; + for(tmpr1=0;isdigit(*p);p++) + tmpr1=tmpr1*10 + *p - '0'; + if(tmpr1<MIN_ROW || tmpr1>MAX_ROW) + return 0; + + if(tmpr<tmpr1) { + retp->lr=tmpr; + retp->hr=tmpr1; + } else { + retp->lr=tmpr1; + retp->hr=tmpr; + } + if(tmpc<tmpc1) { + retp->lc=tmpc; + retp->hc=tmpc1; + } else { + retp->lc=tmpc1; + retp->hc=tmpc; + } + *ptr= p; + return RANGE | abz; + } + retp->lr = retp->hr = tmpr; + retp->lc = retp->hc = tmpc; + *ptr=p; + return R_CELL | abz; + } else { + char *p; + unsigned char retr; + unsigned char retc; + int ended; + long num; + CELLREF tmp; + +#define CK_ABS_R(x) if((x)<MIN_ROW || (x)>MAX_ROW) \ + return 0; \ + else + +#define CK_REL_R(x) if( ((x)>0 && MAX_ROW-(x)<cur_row) \ + || ((x)<0 && MIN_ROW-(x)>cur_row)) \ + return 0; \ + else + +#define CK_ABS_C(x) if((x)<MIN_COL || (x)>MAX_COL) \ + return 0; \ + else + +#define CK_REL_C(x) if( ((x)>0 && MAX_COL-(x)<cur_col) \ + || ((x)<0 && MIN_COL-(x)>cur_col)) \ + return 0; \ + else + +#define MAYBEREL(p) (*(p)=='[' && (isdigit((p)[1]) || (((p)[1]=='+' || (p)[1]=='-') && isdigit((p)[2])))) + + p= *ptr; + retr=0; + retc=0; + ended=0; + while(ended==0) { + switch(*p) { + case 'r': + case 'R': + if(retr) { + ended++; + break; + } + p++; + retr=R_CELL; + if(isdigit(*p)) { + num=astol(&p); + CK_ABS_R(num); + retp->lr= retp->hr=num; + } else if(MAYBEREL(p)) { + p++; + num=astol(&p); + CK_REL_R(num); + retp->lr= retp->hr=num+cur_row; + retr|=ROWREL; + if(*p==':') { + retr=RANGE|LRREL|HRREL; + p++; + num=astol(&p); + CK_REL_R(num); + retp->hr=num+cur_row; + } + if(*p++!=']') + return 0; + } else if(retc || *p=='c' || *p=='C') { + retr|=ROWREL; + retp->lr= retp->hr=cur_row; + } else + return 0; + if(*p==':' && retr!=(RANGE|LRREL|HRREL)) { + retr= (retr&ROWREL) ? RANGE|LRREL : RANGE; + p++; + if(isdigit(*p)) { + num=astol(&p); + CK_ABS_R(num); + retp->hr=num; + } else if(MAYBEREL(p)) { + p++; + num=astol(&p); + CK_REL_R(num); + retp->hr=num+cur_row; + retr|=HRREL; + if(*p++!=']') + return 0; + } else + return 0; + } + + if(retc) + ended++; + break; + + case 'c': + case 'C': + if(retc) { + ended++; + break; + } + p++; + retc=R_CELL; + if(isdigit(*p)) { + num=astol(&p); + CK_ABS_C(num); + retp->lc= retp->hc=num; + } else if(MAYBEREL(p)) { + p++; + num=astol(&p); + CK_REL_C(num); + retp->lc= retp->hc=num+cur_col; + retc|=COLREL; + if(*p==':') { + retc=RANGE|LCREL|HCREL; + p++; + num=astol(&p); + CK_REL_C(num); + retp->hc=num+cur_col; + } + if(*p++!=']') + return 0; + } else if(retr || *p=='r' || *p=='R') { + retc|=COLREL; + retp->lc= retp->hc=cur_col; + } else + return 0; + if(*p==':' && retc!=(RANGE|LCREL|HCREL)) { + retc= (retc&COLREL) ? RANGE|LCREL : RANGE; + p++; + if(isdigit(*p)) { + num=astol(&p); + CK_ABS_C(num); + retp->hc=num; + } else if(MAYBEREL(p)) { + p++; + num=astol(&p); + CK_REL_C(num); + retp->hc=num+cur_col; + retc|=HCREL; + if(*p++!=']') + return 0; + } else + return 0; + } + + if(retr) + ended++; + break; + default: + if(retr) { + *ptr=p; + retp->lc=MIN_COL; + retp->hc=MAX_COL; + if((retr|ROWREL)==(R_CELL|ROWREL)) + return (retr&ROWREL) ? (RANGE|LRREL|HRREL) : RANGE; + else + return retr; + } else if(retc) { + *ptr=p; + retp->lr=MIN_ROW; + retp->hr=MAX_COL; + if((retc|COLREL)==(R_CELL|COLREL)) + return (retc&COLREL) ? (RANGE|LCREL|HCREL) : RANGE; + else + return retc; + } + return 0; + } + } + if(!retr || !retc) + return 0; + *ptr=p; + if(retp->lr>retp->hr) + tmp=retp->lr,retp->lr=retp->hr,retp->hr=tmp; + if(retp->lc>retp->hc) + tmp=retp->lc,retp->lc=retp->hc,retp->hc=tmp; + + if((retr|ROWREL)==(R_CELL|ROWREL)) { + if((retc|COLREL)==(R_CELL|COLREL)) + return retr|retc; + return (retr&ROWREL) ? (retc|LRREL|HRREL) : retc; + } + if((retc|COLREL)==(R_CELL|COLREL)) + return (retc&COLREL) ? (retr|LCREL|HCREL) : retr; + return retr|retc; + } +} + +int +str_to_col FUN1(char **,str) +{ + int ret; + char c,cc,ccc; +#if MAX_COL>702 + char cccc; +#endif + + ret=0; + c=str[0][0]; + if(!isalpha((cc=str[0][1]))) { + (*str)++; + return MIN_COL + (isupper(c) ? c-'A' : c-'a'); + } + if(!isalpha((ccc=str[0][2]))) { + (*str)+=2; + return MIN_COL+26 + (isupper(c) ? c-'A' : c-'a')*26 + (isupper(cc) ? cc-'A' : cc-'a'); + } +#if MAX_COL>702 + if(!isalpha((cccc=str[0][3]))) { + (*str)+=3; + return MIN_COL+702 + (isupper(c) ? c-'A' : c-'a')*26*26 + (isupper(cc) ? cc-'A' : cc-'a')*26 + (isupper(ccc) ? ccc-'A' : ccc-'a'); + } + if(!isalpha(str[0][4])) { + (*str)+=4; + return MIN_COL+18278 + (isupper(c) ? c-'A' : c-'a')*26*26*26 + (isupper(cc) ? cc-'A' : cc-'a')*26*26 + (isupper(ccc) ? ccc-'A' : ccc-'a')*26 + (isupper(cccc) ? cccc-'A' : cccc-'a'); + } +#endif + return 0; +} diff --cc test/manual/etags/y-src/parse.y index 75fd7870ff8,00000000000..824c98d6245 mode 100644,000000..100644 --- a/test/manual/etags/y-src/parse.y +++ b/test/manual/etags/y-src/parse.y @@@ -1,875 -1,0 +1,875 @@@ +%{ - /* Copyright (C) 1990, 1992, 1993 Free Software Foundation, Inc. ++/* Copyright (C) 1990, 1992-1993, 2016 Free Software Foundation, Inc. + +This file is part of Oleo, the GNU Spreadsheet. + +Oleo is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +Oleo is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with Oleo; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ +%} + + +%right '?' ':' +/* %left '|' */ +%left '&' +%nonassoc '=' NE +%nonassoc '<' LE '>' GE +%left '+' '-' +%left '*' '/' '%' +%right '^' +%left NEG '!' + +%token L_CELL L_RANGE +%token L_VAR + +%token L_CONST +%token L_FN0 L_FN1 L_FN2 L_FN3 L_FN4 L_FNN +%token L_FN1R L_FN2R L_FN3R L_FN4R L_FNNR + +%token L_LE L_NE L_GE + +%{ +#include "funcdef.h" + +#include <ctype.h> + +#define obstack_chunk_alloc ck_malloc +#define obstack_chunk_free free +#include "obstack.h" +#include "sysdef.h" + +#include "global.h" +#include "errors.h" +#include "node.h" +#include "eval.h" +#include "ref.h" + +int yylex (); +#ifdef __STDC__ +void yyerror (char *); +#else +void yyerror (); +#endif +VOIDSTAR parse_hash; +extern VOIDSTAR hash_find(); + +/* This table contains a list of the infix single-char functions */ +unsigned char fnin[] = { + SUM, DIFF, DIV, PROD, MOD, /* AND, OR, */ POW, EQUAL, IF, CONCAT, 0 +}; + +#define YYSTYPE _y_y_s_t_y_p_e +typedef struct node *YYSTYPE; +YYSTYPE parse_return; +#ifdef __STDC__ +YYSTYPE make_list (YYSTYPE, YYSTYPE); +#else +YYSTYPE make_list (); +#endif + +char *instr; +int parse_error = 0; +extern struct obstack tmp_mem; + +%} +%% +line: exp + { parse_return=$1; } + | error { + if(!parse_error) + parse_error=PARSE_ERR; + parse_return=0; } + ; + +exp: L_CONST + | cell + | L_FN0 '(' ')' { + $$=$1; } + | L_FN1 '(' exp ')' { + ($1)->n_x.v_subs[0]=$3; + ($1)->n_x.v_subs[1]=(struct node *)0; + $$=$1; } + | L_FN2 '(' exp ',' exp ')' { + ($1)->n_x.v_subs[0]=$3; + ($1)->n_x.v_subs[1]=$5; + $$=$1; } + | L_FN3 '(' exp ',' exp ',' exp ')' { + ($1)->n_x.v_subs[0]=make_list($3,$5); + ($1)->n_x.v_subs[1]=$7; + $$=$1;} + | L_FN4 '(' exp ',' exp ',' exp ',' exp ')' { + ($1)->n_x.v_subs[0]=make_list($3,$5); + ($1)->n_x.v_subs[1]=make_list($7,$9); + $$=$1;} + | L_FNN '(' exp_list ')' { + ($1)->n_x.v_subs[0]=(struct node *)0; + ($1)->n_x.v_subs[1]=$3; + $$=$1; } + | L_FN1R '(' L_RANGE ')' { + $1->n_x.v_subs[0]=$3; + $$=$1; } + | L_FN1R '(' L_VAR ')' { + $1->n_x.v_subs[0]=$3; + $$=$1; } + + | L_FN2R '(' L_RANGE ',' exp ')' { + $1->n_x.v_subs[0]=$3; + $1->n_x.v_subs[1]=$5; + $$=$1; } + | L_FN2R '(' L_VAR ',' exp ')' { + $1->n_x.v_subs[0]=$3; + $1->n_x.v_subs[1]=$5; + $$=$1; } + + /* JF: These should be FN2R, but I'm hacking this for SYLNK */ + | L_FN2R '(' L_RANGE ',' exp ',' exp ')' { + if($1->comp_value!=F_INDEX) + parse_error=PARSE_ERR; + $1->comp_value=F_INDEX2; + $1->n_x.v_subs[0]=make_list($3,$5); + $1->n_x.v_subs[1]=$7; + $$=$1; } + | L_FN2R '(' L_VAR ',' exp ',' exp ')' { + if($1->comp_value!=F_INDEX) + parse_error=PARSE_ERR; + $1->comp_value=F_INDEX2; + $1->n_x.v_subs[0]=make_list($3,$5); + $1->n_x.v_subs[1]=$7; + $$=$1; } + + | L_FN3R '(' L_RANGE ',' exp ',' exp ')' { + ($1)->n_x.v_subs[0]=make_list($3,$5); + ($1)->n_x.v_subs[1]=$7; + $$=$1;} + | L_FN3R '(' L_VAR ',' exp ',' exp ')' { + ($1)->n_x.v_subs[0]=make_list($3,$5); + ($1)->n_x.v_subs[1]=$7; + $$=$1;} + + | L_FNNR '(' range_exp_list ')' { + ($1)->n_x.v_subs[0]=(struct node *)0; + ($1)->n_x.v_subs[1]=$3; + $$=$1; } + | exp '?' exp ':' exp { + $2->comp_value=IF; + $2->n_x.v_subs[0]=$4; + $2->n_x.v_subs[1]=$5; + $4->n_x.v_subs[0]=$1; + $4->n_x.v_subs[1]=$3; + $$=$2; } + /* | exp '|' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } */ + | exp '&' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp '<' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp LE exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp '=' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp NE exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp '>' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp GE exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp '+' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp '-' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp '*' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp '/' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp '%' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | exp '^' exp { + $2->n_x.v_subs[0]=$1; + $2->n_x.v_subs[1]=$3; + $$ = $2; } + | '-' exp %prec NEG { + if($2->comp_value==CONST_FLT) { + $2->n_x.v_float= -($2->n_x.v_float); + /* free($1); */ + $$=$2; + } else if($2->comp_value==CONST_INT) { + $2->n_x.v_int= -($2->n_x.v_int); + /* free($1); */ + $$=$2; + } else { + $1->comp_value = NEGATE; + $1->n_x.v_subs[0]=$2; + $1->n_x.v_subs[1]=(struct node *)0; + $$ = $1; + } } + | '!' exp { + $1->n_x.v_subs[0]=$2; + $1->n_x.v_subs[1]=(struct node *)0; + $$ = $1; } + | '(' exp ')' + { $$ = $2; } + | '(' exp error { + if(!parse_error) + parse_error=NO_CLOSE; + } + /* | exp ')' error { + if(!parse_error) + parse_error=NO_OPEN; + } */ + | '(' error { + if(!parse_error) + parse_error=NO_CLOSE; + } + ; + + +exp_list: exp + { $$ = make_list($1, 0); } + | exp_list ',' exp + { $$ = make_list($3, $1); } + ; + +range_exp: L_RANGE + | exp + ; + +range_exp_list: range_exp + { $$=make_list($1, 0); } + | range_exp_list ',' range_exp + { $$=make_list($3,$1); } + ; + +cell: L_CELL + { $$=$1; } + | L_VAR + ; +%% + +void +yyerror FUN1(char *, s) +{ + if(!parse_error) + parse_error=PARSE_ERR; +} + +YYSTYPE +make_list FUN2(YYSTYPE, car, YYSTYPE, cdr) +{ + YYSTYPE ret; + + ret=(YYSTYPE)obstack_alloc(&tmp_mem,sizeof(*ret)); + ret->comp_value = 0; + ret->n_x.v_subs[0]=car; + ret->n_x.v_subs[1]=cdr; + return ret; +} + +#define ERROR -1 + +extern struct node *yylval; + +#ifdef __STDC__ +unsigned char parse_cell_or_range (char **,struct rng *); +#else +unsigned char parse_cell_or_range (); +#endif + +int +yylex FUN0() +{ + int ch; + struct node *new; + int isflt; + char *begin; + char *tmp_str; + unsigned char byte_value; + int n; + + /* unsigned char *ptr; */ + int nn; + struct function *fp; + int tmp_ch; + +#ifdef TEST + if(!instr) + return ERROR; +#endif + while(isspace(*instr)) + instr++; + ch = *instr++; + if(ch=='(' || ch==',' || ch==')') + return ch; + + new=(struct node *)obstack_alloc(&tmp_mem,sizeof(struct node)); + new->add_byte=0; + new->sub_value=0; + switch(ch) { + case 0: + return 0; + + case '0': case '1': case '2': case '3': case '4': case '5': case '6': + case '7': case '8': case '9': case '.': + isflt = (ch=='.'); + + begin=instr-1; + tmp_str=instr; + + while(isdigit(*tmp_str) || (!isflt && *tmp_str=='.' && ++isflt)) + tmp_str++; + if(*tmp_str=='e' || *tmp_str=='E') { + isflt=1; + tmp_str++; + if(*tmp_str=='-' || *tmp_str=='+') + tmp_str++; + while(isdigit(*tmp_str)) + tmp_str++; + } + if(isflt) { + new->n_x.v_float=astof((char **)(&begin)); + byte_value=CONST_FLT; + } else { + new->n_x.v_int=astol((char **)(&begin)); + if(begin!=tmp_str) { + begin=instr-1; + new->n_x.v_float=astof((char **)(&begin)); + byte_value=CONST_FLT; + } else + byte_value=CONST_INT; + } + ch=L_CONST; + instr=begin; + break; + + case '"': + begin=instr; + while(*instr && *instr!='"') { + if(*instr=='\\' && instr[1]) + instr++; + instr++; + } + if(!*instr) { + parse_error=NO_QUOTE; + return ERROR; + } + tmp_str=new->n_x.v_string=(char *)ck_malloc(1+instr-begin); + while(begin!=instr) { + unsigned char n; + + if(*begin=='\\') { + begin++; + if(begin[0]>='0' && begin[0]<='7') { + if(begin[1]>='0' && begin[1]<='7') { + if(begin[2]>='0' && begin[2]<='7') { + n=(begin[2]-'0') + (010 * (begin[1]-'0')) + ( 0100 * (begin[0]-'0')); + begin+=3; + } else { + n=(begin[1]-'0') + (010 * (begin[0]-'0')); + begin+=2; + } + } else { + n=begin[0]-'0'; + begin++; + } + } else + n= *begin++; + *tmp_str++= n; + } else + *tmp_str++= *begin++; + } + *tmp_str='\0'; + instr++; + byte_value=CONST_STR; + ch=L_CONST; + break; + + case '+': case '-': + + case '*': case '/': case '%': case '&': + /* case '|': */ case '^': case '=': + + case '?': + { + unsigned char *ptr; + + for(ptr= fnin;*ptr;ptr++) + if(the_funs[*ptr].fn_str[0]==ch) + break; +#ifdef TEST + if(!*ptr) + panic("Can't find fnin[] entry for '%c'",ch); +#endif + byte_value= *ptr; + } + break; + + case ':': + byte_value=IF; + break; + + case '!': + case '<': + case '>': + if(*instr!='=') { + byte_value = (ch=='<') ? LESS : (ch=='>') ? GREATER : NOT; + break; + } + instr++; + byte_value = (ch=='<') ? LESSEQ : (ch=='>') ? GREATEQ : NOTEQUAL; + ch = (ch=='<') ? LE : (ch=='>') ? GE : NE; + break; + + case '\'': + case ';': + case '[': + case '\\': + case ']': + case '`': + case '{': + case '}': + case '~': + bad_chr: + parse_error=BAD_CHAR; + return ERROR; + + case '#': + begin=instr-1; + while(*instr && (isalnum(*instr) || *instr=='_')) + instr++; + ch= *instr; + *instr=0; + if(!stricmp(begin,tname)) + byte_value=F_TRUE; + else if(!stricmp(begin,fname)) + byte_value=F_FALSE; + else if(!stricmp(begin,iname) && (begin[4]==0 || !stricmp(begin+4,"inity"))) + byte_value=CONST_INF; + else if(!stricmp(begin,mname) || + !stricmp(begin,"#ninf")) + byte_value=CONST_NINF; + else if(!stricmp(begin,nname) || + !stricmp(begin,"#nan")) + byte_value=CONST_NAN; + else { + for(n=1;n<=ERR_MAX;n++) + if(!stricmp(begin,ename[n])) + break; + if(n>ERR_MAX) + n=BAD_CHAR; + new->n_x.v_int=n; + byte_value=CONST_ERR; + } + *instr=ch; + ch=L_CONST; + break; + + default: + if(!a0 && (ch=='@' || ch=='$')) + goto bad_chr; + + if(a0 && ch=='@') { + begin=instr; + while(*instr && (isalpha(*instr) || isdigit(*instr) || *instr=='_')) + instr++; + n=instr-begin; + } else { + begin=instr-1; + byte_value=parse_cell_or_range(&begin,&(new->n_x.v_rng)); + if(byte_value) { + if((byte_value& ~0x3)==R_CELL) + ch=L_CELL; + else + ch=L_RANGE; + instr=begin; + break; + } + + while(*instr && (isalpha(*instr) || isdigit(*instr) || *instr=='_')) + instr++; + + n=instr-begin; + while(isspace(*instr)) + instr++; + + if(*instr!='(') { + ch=L_VAR; + byte_value=VAR; + new->n_x.v_var=find_or_make_var(begin,n); + break; + } + } + tmp_ch=begin[n]; + begin[n]='\0'; + fp=hash_find(parse_hash,begin); + begin[n]=tmp_ch; + byte_value= ERROR; + if(!fp) { + parse_error=BAD_FUNC; + return ERROR; + } + + if(fp>=the_funs && fp<=&the_funs[USR1]) + byte_value=fp-the_funs; + else { + for(nn=0;nn<n_usr_funs;nn++) { + if(fp>=&usr_funs[nn][0] && fp<=&usr_funs[nn][usr_n_funs[nn]]) { + byte_value=USR1+nn; + new->sub_value=fp-&usr_funs[nn][0]; + break; + } + } +#ifdef TEST + if(nn==n_usr_funs) { + io_error_msg("Couln't turn fp into a ##"); + parse_error=BAD_FUNC; + return ERROR; + } +#endif + } + + if(fp->fn_argn&X_J) + ch= byte_value==F_IF ? L_FN3 : L_FN2; + else if(fp->fn_argt[0]=='R' || fp->fn_argt[0]=='E') + ch=L_FN1R-1+fp->fn_argn-X_A0; + else + ch=L_FN0 + fp->fn_argn-X_A0; + + break; + } + /* new->node_type=ch; */ + new->comp_value=byte_value; + yylval=new; + return ch; +} + +/* Return value is + 0 if it doesn't look like a cell or a range, + R_CELL if it is a cell (ptr now points past the characters, lr and lc hold the row and col of the cell) + RANGE if it is a range (ptr points past the chars) + */ +unsigned char +parse_cell_or_range FUN2(char **,ptr, struct rng *,retp) +{ + if(a0) { + unsigned tmpc,tmpr; + char *p; + int abz = ROWREL|COLREL; + + p= *ptr; + tmpc=0; + if(*p=='$') { + abz-=COLREL; + p++; + } + if(!isalpha(*p)) + return 0; + tmpc=str_to_col(&p); + if(tmpc<MIN_COL || tmpc>MAX_COL) + return 0; + if(*p=='$') { + abz-=ROWREL; + p++; + } + if(!isdigit(*p)) + return 0; + for(tmpr=0;isdigit(*p);p++) + tmpr=tmpr*10 + *p - '0'; + + if(tmpr<MIN_ROW || tmpr>MAX_ROW) + return 0; + + if(*p==':' || *p=='.') { + unsigned tmpc1,tmpr1; + + abz = ((abz&COLREL) ? LCREL : 0)|((abz&ROWREL) ? LRREL : 0)|HRREL|HCREL; + p++; + if(*p=='$') { + abz-=HCREL; + p++; + } + if(!isalpha(*p)) + return 0; + tmpc1=str_to_col(&p); + if(tmpc1<MIN_COL || tmpc1>MAX_COL) + return 0; + if(*p=='$') { + abz-=HRREL; + p++; + } + if(!isdigit(*p)) + return 0; + for(tmpr1=0;isdigit(*p);p++) + tmpr1=tmpr1*10 + *p - '0'; + if(tmpr1<MIN_ROW || tmpr1>MAX_ROW) + return 0; + + if(tmpr<tmpr1) { + retp->lr=tmpr; + retp->hr=tmpr1; + } else { + retp->lr=tmpr1; + retp->hr=tmpr; + } + if(tmpc<tmpc1) { + retp->lc=tmpc; + retp->hc=tmpc1; + } else { + retp->lc=tmpc1; + retp->hc=tmpc; + } + *ptr= p; + return RANGE | abz; + } + retp->lr = retp->hr = tmpr; + retp->lc = retp->hc = tmpc; + *ptr=p; + return R_CELL | abz; + } else { + char *p; + unsigned char retr; + unsigned char retc; + int ended; + long num; + CELLREF tmp; + +#define CK_ABS_R(x) if((x)<MIN_ROW || (x)>MAX_ROW) \ + return 0; \ + else + +#define CK_REL_R(x) if( ((x)>0 && MAX_ROW-(x)<cur_row) \ + || ((x)<0 && MIN_ROW-(x)>cur_row)) \ + return 0; \ + else + +#define CK_ABS_C(x) if((x)<MIN_COL || (x)>MAX_COL) \ + return 0; \ + else + +#define CK_REL_C(x) if( ((x)>0 && MAX_COL-(x)<cur_col) \ + || ((x)<0 && MIN_COL-(x)>cur_col)) \ + return 0; \ + else + +#define MAYBEREL(p) (*(p)=='[' && (isdigit((p)[1]) || (((p)[1]=='+' || (p)[1]=='-') && isdigit((p)[2])))) + + p= *ptr; + retr=0; + retc=0; + ended=0; + while(ended==0) { + switch(*p) { + case 'r': + case 'R': + if(retr) { + ended++; + break; + } + p++; + retr=R_CELL; + if(isdigit(*p)) { + num=astol(&p); + CK_ABS_R(num); + retp->lr= retp->hr=num; + } else if(MAYBEREL(p)) { + p++; + num=astol(&p); + CK_REL_R(num); + retp->lr= retp->hr=num+cur_row; + retr|=ROWREL; + if(*p==':') { + retr=RANGE|LRREL|HRREL; + p++; + num=astol(&p); + CK_REL_R(num); + retp->hr=num+cur_row; + } + if(*p++!=']') + return 0; + } else if(retc || *p=='c' || *p=='C') { + retr|=ROWREL; + retp->lr= retp->hr=cur_row; + } else + return 0; + if(*p==':' && retr!=(RANGE|LRREL|HRREL)) { + retr= (retr&ROWREL) ? RANGE|LRREL : RANGE; + p++; + if(isdigit(*p)) { + num=astol(&p); + CK_ABS_R(num); + retp->hr=num; + } else if(MAYBEREL(p)) { + p++; + num=astol(&p); + CK_REL_R(num); + retp->hr=num+cur_row; + retr|=HRREL; + if(*p++!=']') + return 0; + } else + return 0; + } + + if(retc) + ended++; + break; + + case 'c': + case 'C': + if(retc) { + ended++; + break; + } + p++; + retc=R_CELL; + if(isdigit(*p)) { + num=astol(&p); + CK_ABS_C(num); + retp->lc= retp->hc=num; + } else if(MAYBEREL(p)) { + p++; + num=astol(&p); + CK_REL_C(num); + retp->lc= retp->hc=num+cur_col; + retc|=COLREL; + if(*p==':') { + retc=RANGE|LCREL|HCREL; + p++; + num=astol(&p); + CK_REL_C(num); + retp->hc=num+cur_col; + } + if(*p++!=']') + return 0; + } else if(retr || *p=='r' || *p=='R') { + retc|=COLREL; + retp->lc= retp->hc=cur_col; + } else + return 0; + if(*p==':' && retc!=(RANGE|LCREL|HCREL)) { + retc= (retc&COLREL) ? RANGE|LCREL : RANGE; + p++; + if(isdigit(*p)) { + num=astol(&p); + CK_ABS_C(num); + retp->hc=num; + } else if(MAYBEREL(p)) { + p++; + num=astol(&p); + CK_REL_C(num); + retp->hc=num+cur_col; + retc|=HCREL; + if(*p++!=']') + return 0; + } else + return 0; + } + + if(retr) + ended++; + break; + default: + if(retr) { + *ptr=p; + retp->lc=MIN_COL; + retp->hc=MAX_COL; + if((retr|ROWREL)==(R_CELL|ROWREL)) + return (retr&ROWREL) ? (RANGE|LRREL|HRREL) : RANGE; + else + return retr; + } else if(retc) { + *ptr=p; + retp->lr=MIN_ROW; + retp->hr=MAX_COL; + if((retc|COLREL)==(R_CELL|COLREL)) + return (retc&COLREL) ? (RANGE|LCREL|HCREL) : RANGE; + else + return retc; + } + return 0; + } + } + if(!retr || !retc) + return 0; + *ptr=p; + if(retp->lr>retp->hr) + tmp=retp->lr,retp->lr=retp->hr,retp->hr=tmp; + if(retp->lc>retp->hc) + tmp=retp->lc,retp->lc=retp->hc,retp->hc=tmp; + + if((retr|ROWREL)==(R_CELL|ROWREL)) { + if((retc|COLREL)==(R_CELL|COLREL)) + return retr|retc; + return (retr&ROWREL) ? (retc|LRREL|HRREL) : retc; + } + if((retc|COLREL)==(R_CELL|COLREL)) + return (retc&COLREL) ? (retr|LCREL|HCREL) : retr; + return retr|retc; + } +} + +int +str_to_col FUN1(char **,str) +{ + int ret; + char c,cc,ccc; +#if MAX_COL>702 + char cccc; +#endif + + ret=0; + c=str[0][0]; + if(!isalpha((cc=str[0][1]))) { + (*str)++; + return MIN_COL + (isupper(c) ? c-'A' : c-'a'); + } + if(!isalpha((ccc=str[0][2]))) { + (*str)+=2; + return MIN_COL+26 + (isupper(c) ? c-'A' : c-'a')*26 + (isupper(cc) ? cc-'A' : cc-'a'); + } +#if MAX_COL>702 + if(!isalpha((cccc=str[0][3]))) { + (*str)+=3; + return MIN_COL+702 + (isupper(c) ? c-'A' : c-'a')*26*26 + (isupper(cc) ? cc-'A' : cc-'a')*26 + (isupper(ccc) ? ccc-'A' : ccc-'a'); + } + if(!isalpha(str[0][4])) { + (*str)+=4; + return MIN_COL+18278 + (isupper(c) ? c-'A' : c-'a')*26*26*26 + (isupper(cc) ? cc-'A' : cc-'a')*26*26 + (isupper(ccc) ? ccc-'A' : ccc-'a')*26 + (isupper(cccc) ? cccc-'A' : cccc-'a'); + } +#endif + return 0; +} diff --cc test/manual/indent/pascal.pas index bb2e7002b6b,00000000000..2d09eb775a4 mode 100644,000000..100644 --- a/test/manual/indent/pascal.pas +++ b/test/manual/indent/pascal.pas @@@ -1,1092 -1,0 +1,1092 @@@ +{ GPC demo program for the CRT unit. + - Copyright (C) 1999-2006, 2013-2015 Free Software Foundation, Inc. ++Copyright (C) 1999-2006, 2013-2016 Free Software Foundation, Inc. + +Author: Frank Heckenbach <frank@pascal.gnu.de> + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation, version 3. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see <http://www.gnu.org/licenses/>. + +As a special exception, if you incorporate even large parts of the +code of this demo program into another program with substantially +different functionality, this does not cause the other program to +be covered by the GNU General Public License. This exception does +not however invalidate any other reasons why it might be covered +by the GNU General Public License. } + +{$gnu-pascal,I+} + +(* second style of comment *) +// Free-pascal style comment. +var x:Char = 12 /* 45; // This /* does not start a comment. +var x:Char = (/ 4); // This (/ does not start a comment. +var a_to_b : integer; // 'to' should not be highlighted + +program CRTDemo; + +uses GPC, CRT; + +type + TFrameChars = array [1 .. 8] of Char; + TSimulateBlockCursorKind = (bc_None, bc_Blink, bc_Static); + +const + SingleFrame: TFrameChars = (chCornerTLS, chLineHS, chCornerTRS, chLineVS, chLineVS, chCornerBLS, chLineHS, chCornerBRS); + DoubleFrame: TFrameChars = (chCornerTLD, chLineHD, chCornerTRD, chLineVD, chLineVD, chCornerBLD, chLineHD, chCornerBRD); + +var + ScrollState: Boolean = True; + SimulateBlockCursorKind: TSimulateBlockCursorKind = bc_None; + CursorShape: TCursorShape = CursorNormal; + MainPanel: TPanel; + OrigScreenSize: TPoint; + +procedure FrameWin (const Title: String; const Frame: TFrameChars; TitleInverse: Boolean); +var + w, h, y, Color: Integer; + Attr: TTextAttr; +begin + HideCursor; + SetPCCharSet (True); + ClrScr; + w := GetXMax; + h := GetYMax; + WriteCharAt (1, 1, 1, Frame[1], TextAttr); + WriteCharAt (2, 1, w - 2, Frame[2], TextAttr); + WriteCharAt (w, 1, 1, Frame[3], TextAttr); + for y := 2 to h - 1 do + begin + WriteCharAt (1, y, 1, Frame[4], TextAttr); + WriteCharAt (w, y, 1, Frame[5], TextAttr) + end; + WriteCharAt (1, h, 1, Frame[6], TextAttr); + WriteCharAt (2, h, w - 2, Frame[7], TextAttr); + WriteCharAt (w, h, 1, Frame[8], TextAttr); + SetPCCharSet (False); + Attr := TextAttr; + if TitleInverse then + begin + Color := GetTextColor; + TextColor (GetTextBackground); + TextBackground (Color) + end; + WriteStrAt ((w - Length (Title)) div 2 + 1, 1, Title, TextAttr); + TextAttr := Attr +end; + +function GetKey (TimeOut: Integer) = Key: TKey; forward; + +procedure ClosePopUpWindow; +begin + PanelDelete (GetActivePanel); + PanelDelete (GetActivePanel) +end; + +function PopUpConfirm (XSize, YSize: Integer; const Msg: String): Boolean; +var + ax, ay: Integer; + Key: TKey; + SSize: TPoint; +begin + repeat + SSize := ScreenSize; + ax := (SSize.x - XSize - 4) div 2 + 1; + ay := (SSize.y - YSize - 4) div 2 + 1; + PanelNew (ax, ay, ax + XSize + 3, ay + YSize + 1, False); + TextBackground (Black); + TextColor (Yellow); + SetControlChars (True); + FrameWin ('', DoubleFrame, False); + NormalCursor; + PanelNew (ax + 2, ay + 1, ax + XSize + 2, ay + YSize, False); + ClrScr; + Write (Msg); + Key := GetKey (-1); + if Key = kbScreenSizeChanged then ClosePopUpWindow + until Key <> kbScreenSizeChanged; + PopUpConfirm := not (Key in [kbEsc, kbAltEsc]) +end; + +procedure MainDraw; +begin + WriteLn ('3, F3 : Open a window'); + WriteLn ('4, F4 : Close window'); + WriteLn ('5, F5 : Previous window'); + WriteLn ('6, F6 : Next window'); + WriteLn ('7, F7 : Move window'); + WriteLn ('8, F8 : Resize window'); + Write ('q, Esc: Quit') +end; + +procedure StatusDraw; +const + YesNo: array [Boolean] of String [3] = ('No', 'Yes'); + SimulateBlockCursorIDs: array [TSimulateBlockCursorKind] of String [8] = ('Off', 'Blinking', 'Static'); + CursorShapeIDs: array [TCursorShape] of String [7] = ('Ignored', 'Hidden', 'Normal', 'Fat', 'Block'); +var + SSize: TPoint; +begin + WriteLn ('You can change some of the following'); + WriteLn ('settings by pressing the key shown'); + WriteLn ('in parentheses. Naturally, color and'); + WriteLn ('changing the cursor shape or screen'); + WriteLn ('size does not work on all terminals.'); + WriteLn; + WriteLn ('XCurses version: ', YesNo[XCRT]); + WriteLn ('CRTSavePreviousScreen: ', YesNo[CRTSavePreviousScreenWorks]); + WriteLn ('(M)onochrome: ', YesNo[IsMonochrome]); + SSize := ScreenSize; + WriteLn ('Screen (C)olumns: ', SSize.x); + WriteLn ('Screen (L)ines: ', SSize.y); + WriteLn ('(R)estore screen size'); + WriteLn ('(B)reak checking: ', YesNo[CheckBreak]); + WriteLn ('(S)crolling: ', YesNo[ScrollState]); + WriteLn ('S(i)mulated block cursor: ', SimulateBlockCursorIDs[SimulateBlockCursorKind]); + Write ('C(u)rsor shape: ', CursorShapeIDs[CursorShape]); + GotoXY (36, WhereY) +end; + +procedure RedrawAll; forward; +procedure CheckScreenSize; forward; + +procedure StatusKey (Key: TKey); +var SSize, NewSize: TPoint; +begin + case LoCase (Key2Char (Key)) of + 'm': begin + SetMonochrome (not IsMonochrome); + RedrawAll + end; + 'c': begin + SSize := ScreenSize; + if SSize.x > 40 then + NewSize.x := 40 + else + NewSize.x := 80; + if SSize.y > 25 then + NewSize.y := 50 + else + NewSize.y := 25; + SetScreenSize (NewSize.x, NewSize.y); + CheckScreenSize + end; + 'l': begin + SSize := ScreenSize; + if SSize.x > 40 then + NewSize.x := 80 + else + NewSize.x := 40; + if SSize.y > 25 then + NewSize.y := 25 + else + NewSize.y := 50; + SetScreenSize (NewSize.x, NewSize.y); + CheckScreenSize + end; + 'r': begin + SetScreenSize (OrigScreenSize.x, OrigScreenSize.y); + CheckScreenSize + end; + 'b': CheckBreak := not CheckBreak; + 's': ScrollState := not ScrollState; + 'i': if SimulateBlockCursorKind = High (SimulateBlockCursorKind) then + SimulateBlockCursorKind := Low (SimulateBlockCursorKind) + else + Inc (SimulateBlockCursorKind); + 'u': case CursorShape of + CursorNormal: CursorShape := CursorBlock; + CursorFat, + CursorBlock : CursorShape := CursorHidden; + else CursorShape := CursorNormal + end; + end; + ClrScr; + StatusDraw +end; + +procedure TextAttrDemo; +var f, b, y, x1, y1, x2, y2, Fill, n1, n2, n3: Integer; +begin + GetWindow (x1, y1, x2, y2); + Window (x1 - 1, y1, x2, y2); + TextColor (White); + TextBackground (Blue); + ClrScr; + SetScroll (False); + Fill := GetXMax - 32; + for y := 1 to GetYMax do + begin + GotoXY (1, y); + b := (y - 1) mod 16; + n1 := 0; + for f := 0 to 15 do + begin + TextAttr := f + 16 * b; + n2 := (Fill * (1 + 2 * f) + 16) div 32; + n3 := (Fill * (2 + 2 * f) + 16) div 32; + Write ('' : n2 - n1, NumericBaseDigitsUpper[b], NumericBaseDigitsUpper[f], '' : n3 - n2); + n1 := n3 + end + end +end; + +procedure CharSetDemo (UsePCCharSet: Boolean); +var h, l, y, x1, y1, x2, y2, Fill, n1, n2: Integer; +begin + GetWindow (x1, y1, x2, y2); + Window (x1 - 1, y1, x2, y2); + ClrScr; + SetScroll (False); + SetPCCharSet (UsePCCharSet); + SetControlChars (False); + Fill := GetXMax - 35; + for y := 1 to GetYMax do + begin + GotoXY (1, y); + h := (y - 2) mod 16; + n1 := (Fill + 9) div 18; + if y = 1 then + Write ('' : 3 + n1) + else + Write (16 * h : 3 + n1); + for l := 0 to 15 do + begin + n2 := (Fill * (2 + l) + 9) div 18; + if y = 1 then + Write ('' : n2 - n1, l : 2) + else + Write ('' : n2 - n1 + 1, Chr (16 * h + l)); + n1 := n2 + end + end +end; + +procedure NormalCharSetDemo; +begin + CharSetDemo (False) +end; + +procedure PCCharSetDemo; +begin + CharSetDemo (True) +end; + +procedure FKeyDemoDraw; +var x1, y1, x2, y2: Integer; +begin + GetWindow (x1, y1, x2, y2); + Window (x1, y1, x2 - 1, y2); + ClrScr; + SetScroll (False); + WriteLn ('You can type the following keys'); + WriteLn ('(function keys if present on the'); + WriteLn ('terminal, letters as alternatives):'); + GotoXY (1, 4); + WriteLn ('S, Left : left (wrap-around)'); + WriteLn ('D, Right : right (wrap-around)'); + WriteLn ('E, Up : up (wrap-around)'); + WriteLn ('X, Down : down (wrap-around)'); + WriteLn ('A, Home : go to first column'); + WriteLn ('F, End : go to last column'); + WriteLn ('R, Page Up : go to first line'); + WriteLn ('C, Page Down: go to last line'); + WriteLn ('Y, Ctrl-PgUp: first column and line'); + GotoXY (1, 13); + WriteLn ('B, Ctrl-PgDn: last column and line'); + WriteLn ('Z, Ctrl-Home: clear screen'); + WriteLn ('N, Ctrl-End : clear to end of line'); + WriteLn ('V, Insert : insert a line'); + WriteLn ('T, Delete : delete a line'); + WriteLn ('# : beep'); + WriteLn ('* : flash'); + WriteLn ('Tab, Enter, Backspace, other'); + WriteLn (' normal characters: write text') +end; + +procedure FKeyDemoKey (Key: TKey); +const TabSize = 8; +var + ch: Char; + NewX: Integer; +begin + case LoCaseKey (Key) of + Ord ('s'), kbLeft : if WhereX = 1 then GotoXY (GetXMax, WhereY) else GotoXY (WhereX - 1, WhereY); + Ord ('d'), kbRight : if WhereX = GetXMax then GotoXY (1, WhereY) else GotoXY (WhereX + 1, WhereY); + Ord ('e'), kbUp : if WhereY = 1 then GotoXY (WhereX, GetYMax) else GotoXY (WhereX, WhereY - 1); + Ord ('x'), kbDown : if WhereY = GetYMax then GotoXY (WhereX, 1) else GotoXY (WhereX, WhereY + 1); + Ord ('a'), kbHome : Write (chCR); + Ord ('f'), kbEnd : GotoXY (GetXMax, WhereY); + Ord ('r'), kbPgUp : GotoXY (WhereX, 1); + Ord ('c'), kbPgDn : GotoXY (WhereX, GetYMax); + Ord ('y'), kbCtrlPgUp: GotoXY (1, 1); + Ord ('b'), kbCtrlPgDn: GotoXY (GetXMax, GetYMax); + Ord ('z'), kbCtrlHome: ClrScr; + Ord ('n'), kbCtrlEnd : ClrEOL; + Ord ('v'), kbIns : InsLine; + Ord ('t'), kbDel : DelLine; + Ord ('#') : Beep; + Ord ('*') : Flash; + kbTab : begin + NewX := ((WhereX - 1) div TabSize + 1) * TabSize + 1; + if NewX <= GetXMax then GotoXY (NewX, WhereY) else WriteLn + end; + kbCR : WriteLn; + kbBkSp : Write (chBkSp, ' ', chBkSp); + else ch := Key2Char (Key); + if ch <> #0 then Write (ch) + end +end; + +procedure KeyDemoDraw; +begin + WriteLn ('Press some keys ...') +end; + +procedure KeyDemoKey (Key: TKey); +var ch: Char; +begin + ch := Key2Char (Key); + if ch <> #0 then + begin + Write ('Normal key'); + if IsPrintable (ch) then Write (' `', ch, ''''); + WriteLn (', ASCII #', Ord (ch)) + end + else + WriteLn ('Special key ', Ord (Key2Scan (Key))) +end; + +procedure IOSelectPeriodical; +var + CurrentTime: TimeStamp; + s: String (8); + i: Integer; +begin + GetTimeStamp (CurrentTime); + with CurrentTime do + WriteStr (s, Hour : 2, ':', Minute : 2, ':', Second : 2); + for i := 1 to Length (s) do + if s[i] = ' ' then s[i] := '0'; + GotoXY (1, 12); + Write ('The time is: ', s) +end; + +procedure IOSelectDraw; +begin + WriteLn ('IOSelect is a way to handle I/O from'); + WriteLn ('or to several places simultaneously,'); + WriteLn ('without having to use threads or'); + WriteLn ('signal/interrupt handlers or waste'); + WriteLn ('CPU time with busy waiting.'); + WriteLn; + WriteLn ('This demo shows how IOSelect works'); + WriteLn ('in connection with CRT. It displays'); + WriteLn ('a clock, but still reacts to user'); + WriteLn ('input immediately.'); + IOSelectPeriodical +end; + +procedure ModifierPeriodical; +const + Pressed: array [Boolean] of String [8] = ('Released', 'Pressed'); + ModifierNames: array [1 .. 7] of record + Modifier: Integer; + Name: String (17) + end = + ((shLeftShift, 'Left Shift'), + (shRightShift, 'Right Shift'), + (shLeftCtrl, 'Left Control'), + (shRightCtrl, 'Right Control'), + (shAlt, 'Alt (left)'), + (shAltGr, 'AltGr (right Alt)'), + (shExtra, 'Extra')); +var + ShiftState, i: Integer; +begin + ShiftState := GetShiftState; + for i := 1 to 7 do + with ModifierNames[i] do + begin + GotoXY (1, 4 + i); + ClrEOL; + Write (Name, ':'); + GotoXY (20, WhereY); + Write (Pressed[(ShiftState and Modifier) <> 0]) + end +end; + +procedure ModifierDraw; +begin + WriteLn ('Modifier keys (NOTE: only'); + WriteLn ('available on some systems;'); + WriteLn ('X11: only after key press):'); + ModifierPeriodical +end; + +procedure ChecksDraw; +begin + WriteLn ('(O)S shell'); + WriteLn ('OS shell with (C)learing'); + WriteLn ('(R)efresh check'); + Write ('(S)ound check') +end; + +procedure ChecksKey (Key: TKey); +var + i, j: Integer; + WasteTime: Real; attribute (volatile); + + procedure DoOSShell; + var + Result: Integer; + Shell: TString; + begin + Shell := GetShellPath (Null); + {$I-} + Result := Execute (Shell); + {$I+} + if (InOutRes <> 0) or (Result <> 0) then + begin + ClrScr; + if InOutRes <> 0 then + WriteLn (GetIOErrorMessage, ' while trying to execute `', Shell, '''.') + else + WriteLn ('`', Shell, ''' returned status ', Result, '.'); + Write ('Any key to continue.'); + BlockCursor; + Discard (GetKey (-1)) + end + end; + +begin + case LoCase (Key2Char (Key)) of + 'o': begin + if PopUpConfirm (36, 12, 'You will now get an OS shell. Unless' + NewLine + + 'CRTDemo is running in its own (GUI)' + NewLine + + 'window, the shell will run on the' + NewLine + + 'same screen as CRTDemo which is not' + NewLine + + 'cleared before the shell is started.' + NewLine + + 'If possible, the screen contents are' + NewLine + + 'restored to the state before CRTDemo' + NewLine + + 'was started. After leaving the shell' + NewLine + + 'in the usual way (usually by enter-' + NewLine + + 'ing `exit''), you will get back to' + NewLine + + 'the demo. <ESC> to abort, any other' + NewLine + + 'key to start.') then + begin + RestoreTerminal (True); + DoOSShell + end; + ClosePopUpWindow + end; + 'c': begin + if PopUpConfirm (36, 9, 'You will now get an OS shell. Unless' + NewLine + + 'CRTDemo is running in its own (GUI)' + NewLine + + 'window, the screen will be cleared,' + NewLine + + 'and the cursor will be moved to the' + NewLine + + 'top before the shell is started.' + NewLine + + 'After leaving the shell in the usual' + NewLine + + 'way (usually by entering `exit''),' + NewLine + + 'you will get back to the demo. <ESC>' + NewLine + + 'to abort, any other key to start.') then + begin + RestoreTerminalClearCRT; + DoOSShell + end; + ClosePopUpWindow + end; + 'r': begin + if PopUpConfirm (36, 11, 'The program will now get busy with' + NewLine + + 'some dummy computations. However,' + NewLine + + 'CRT output in the form of dots will' + NewLine + + 'still appear continuously one by one' + NewLine + + '(rather than the whole line at once' + NewLine + + 'in the end). While running, the test' + NewLine + + 'cannot be interrupted. <ESC> to' + NewLine + + 'abort, any other key to start.') then + begin + SetCRTUpdate (UpdateRegularly); + BlockCursor; + WriteLn; + WriteLn; + for i := 1 to GetXMax - 2 do + begin + Write ('.'); + for j := 1 to 400000 do WasteTime := Random + end; + SetCRTUpdate (UpdateInput); + WriteLn; + Write ('Press any key.'); + Discard (GetKey (-1)) + end; + ClosePopUpWindow + end; + 's': begin + if PopUpConfirm (32, 4, 'You will now hear some sounds if' + NewLine + + 'supported (otherwise there will' + NewLine + + 'just be a short pause). <ESC> to' + NewLine + + 'abort, any other key to start.') then + begin + BlockCursor; + for i := 0 to 7 do + begin + Sound (Round (440 * 2 ** (Round (i * 12 / 7 + 0.3) / 12))); + if GetKey (400000) in [kbEsc, kbAltEsc] then Break + end; + NoSound + end; + ClosePopUpWindow + end; + end +end; + +type + PWindowList = ^TWindowList; + TWindowList = record + Next, Prev: PWindowList; + Panel, FramePanel: TPanel; + WindowType: Integer; + x1, y1, xs, ys: Integer; + State: (ws_None, ws_Moving, ws_Resizing); + end; + +TKeyProc = procedure (Key: TKey); +TProcedure = procedure; + +const + MenuNameLength = 16; + WindowTypes: array [0 .. 9] of record + DrawProc, + PeriodicalProc: procedure; + KeyProc : TKeyProc; + Name : String (MenuNameLength); + Color, + Background, + MinSizeX, + MinSizeY, + PrefSizeX, + PrefSizeY : Integer; + RedrawAlways, + WantCursor : Boolean + end = +((MainDraw , nil , nil , 'CRT Demo' , LightGreen, Blue , 26, 7, 0, 0, False, False), + (StatusDraw , nil , StatusKey , 'Status' , White , Red , 38, 16, 0, 0, True, True), + (TextAttrDemo , nil , nil , 'Text Attributes' , White , Blue , 32, 16, 64, 16, False, False), + (NormalCharSetDemo, nil , nil , 'Character Set' , Black , Green , 35, 17, 53, 17, False, False), + (PCCharSetDemo , nil , nil , 'PC Character Set', Black , Brown , 35, 17, 53, 17, False, False), + (KeyDemoDraw , nil , KeyDemoKey , 'Keys' , Blue , LightGray, 29, 5, -1, -1, False, True), + (FKeyDemoDraw , nil , FKeyDemoKey, 'Function Keys' , Blue , LightGray, 37, 22, -1, -1, False, True), + (ModifierDraw , ModifierPeriodical, nil , 'Modifier Keys' , Black , Cyan , 29, 11, 0, 0, True, False), + (IOSelectDraw , IOSelectPeriodical, nil , 'IOSelect Demo' , White , Magenta , 38, 12, 0, 0, False, False), + (ChecksDraw , nil , ChecksKey , 'Various Checks' , Black , Red , 26, 4, 0, 0, False, False)); + +MenuMax = High (WindowTypes); +MenuXSize = MenuNameLength + 4; +MenuYSize = MenuMax + 2; + +var + WindowList: PWindowList = nil; + + procedure RedrawFrame (p: PWindowList); + begin + with p^, WindowTypes[WindowType] do + begin + PanelActivate (FramePanel); + Window (x1, y1, x1 + xs - 1, y1 + ys - 1); + ClrScr; + case State of + ws_None : if p = WindowList then + FrameWin (' ' + Name + ' ', DoubleFrame, True) + else + FrameWin (' ' + Name + ' ', SingleFrame, False); + ws_Moving : FrameWin (' Move Window ', SingleFrame, True); + ws_Resizing: FrameWin (' Resize Window ', SingleFrame, True); + end + end + end; + + procedure DrawWindow (p: PWindowList); + begin + with p^, WindowTypes[WindowType] do + begin + RedrawFrame (p); + PanelActivate (Panel); + Window (x1 + 2, y1 + 1, x1 + xs - 2, y1 + ys - 2); + ClrScr; + DrawProc + end + end; + + procedure RedrawAll; + var + LastPanel: TPanel; + p: PWindowList; + x2, y2: Integer; + begin + LastPanel := GetActivePanel; + PanelActivate (MainPanel); + TextBackground (Blue); + ClrScr; + p := WindowList; + if p <> nil then + repeat + with p^ do + begin + PanelActivate (FramePanel); + GetWindow (x1, y1, x2, y2); { updated automatically by CRT } + xs := x2 - x1 + 1; + ys := y2 - y1 + 1 + end; + DrawWindow (p); + p := p^.Next + until p = WindowList; + PanelActivate (LastPanel) + end; + + procedure CheckScreenSize; + var + LastPanel: TPanel; + MinScreenSizeX, MinScreenSizeY, i: Integer; + SSize: TPoint; + begin + LastPanel := GetActivePanel; + PanelActivate (MainPanel); + HideCursor; + MinScreenSizeX := MenuXSize; + MinScreenSizeY := MenuYSize; + for i := Low (WindowTypes) to High (WindowTypes) do + with WindowTypes[i] do + begin + MinScreenSizeX := Max (MinScreenSizeX, MinSizeX + 2); + MinScreenSizeY := Max (MinScreenSizeY, MinSizeY + 2) + end; + SSize := ScreenSize; + Window (1, 1, SSize.x, SSize.y); + if (SSize.x < MinScreenSizeX) or (SSize.y < MinScreenSizeY) then + begin + NormVideo; + ClrScr; + RestoreTerminal (True); + WriteLn (StdErr, 'Sorry, your screen is too small for this demo (', SSize.x, 'x', SSize.y, ').'); + WriteLn (StdErr, 'You need at least ', MinScreenSizeX, 'x', MinScreenSizeY, ' characters.'); + Halt (2) + end; + PanelActivate (LastPanel); + RedrawAll + end; + + procedure Die; attribute (noreturn); + begin + NoSound; + RestoreTerminalClearCRT; + WriteLn (StdErr, 'You''re trying to kill me. Since I have break checking turned off,'); + WriteLn (StdErr, 'I''m not dying, but I''ll do you a favor and terminate now.'); + Halt (3) + end; + + function GetKey (TimeOut: Integer) = Key: TKey; + var + NeedSelect, SelectValue: Integer; + SimulateBlockCursorCurrent: TSimulateBlockCursorKind; + SelectInput: array [1 .. 1] of PAnyFile = (@Input); + NextSelectTime: MicroSecondTimeType = 0; attribute (static); + TimeOutTime: MicroSecondTimeType; + LastPanel: TPanel; + p: PWindowList; + begin + LastPanel := GetActivePanel; + if TimeOut < 0 then + TimeOutTime := High (TimeOutTime) + else + TimeOutTime := GetMicroSecondTime + TimeOut; + NeedSelect := 0; + if TimeOut >= 0 then + Inc (NeedSelect); + SimulateBlockCursorCurrent := SimulateBlockCursorKind; + if SimulateBlockCursorCurrent <> bc_None then + Inc (NeedSelect); + p := WindowList; + repeat + if @WindowTypes[p^.WindowType].PeriodicalProc <> nil then + Inc (NeedSelect); + p := p^.Next + until p = WindowList; + p := WindowList; + repeat + with p^, WindowTypes[WindowType] do + if RedrawAlways then + begin + PanelActivate (Panel); + ClrScr; + DrawProc + end; + p := p^.Next + until p = WindowList; + if NeedSelect <> 0 then + repeat + CRTUpdate; + SelectValue := IOSelectRead (SelectInput, Max (0, Min (NextSelectTime, TimeOutTime) - GetMicroSecondTime)); + if SelectValue = 0 then + begin + case SimulateBlockCursorCurrent of + bc_None : ; + bc_Blink : SimulateBlockCursor; + bc_Static: begin + SimulateBlockCursor; + SimulateBlockCursorCurrent := bc_None; + Dec (NeedSelect) + end + end; + NextSelectTime := GetMicroSecondTime + 120000; + p := WindowList; + repeat + with p^, WindowTypes[WindowType] do + if @PeriodicalProc <> nil then + begin + PanelActivate (Panel); + PeriodicalProc + end; + p := p^.Next + until p = WindowList + end; + until (NeedSelect = 0) or (SelectValue <> 0) or ((TimeOut >= 0) and (GetMicroSecondTime >= TimeOutTime)); + if NeedSelect = 0 then + SelectValue := 1; + if SelectValue = 0 then + Key := 0 + else + Key := ReadKeyWord; + if SimulateBlockCursorKind <> bc_None then + SimulateBlockCursorOff; + if IsDeadlySignal (Key) then Die; + if Key = kbScreenSizeChanged then CheckScreenSize; + PanelActivate (LastPanel) + end; + + function Menu = n: Integer; + var + i, ax, ay: Integer; + Key: TKey; + Done: Boolean; + SSize: TPoint; + begin + n := 1; + repeat + SSize := ScreenSize; + ax := (SSize.x - MenuXSize) div 2 + 1; + ay := (SSize.y - MenuYSize) div 2 + 1; + PanelNew (ax, ay, ax + MenuXSize - 1, ay + MenuYSize - 1, False); + SetControlChars (True); + TextColor (Blue); + TextBackground (LightGray); + FrameWin (' Select Window ', DoubleFrame, True); + IgnoreCursor; + PanelNew (ax + 1, ay + 1, ax + MenuXSize - 2, ay + MenuYSize - 2, False); + ClrScr; + TextColor (Black); + SetScroll (False); + Done := False; + repeat + for i := 1 to MenuMax do + begin + GotoXY (1, i); + if i = n then + TextBackground (Green) + else + TextBackground (LightGray); + ClrEOL; + Write (' ', WindowTypes[i].Name); + ChangeTextAttr (2, i, 1, Red + $10 * GetTextBackground) + end; + Key := GetKey (-1); + case LoCaseKey (Key) of + kbUp : if n = 1 then n := MenuMax else Dec (n); + kbDown : if n = MenuMax then n := 1 else Inc (n); + kbHome, + kbPgUp, + kbCtrlPgUp, + kbCtrlHome : n := 1; + kbEnd, + kbPgDn, + kbCtrlPgDn, + kbCtrlEnd : n := MenuMax; + kbCR : Done := True; + kbEsc, kbAltEsc : begin + n := -1; + Done := True + end; + Ord ('a') .. Ord ('z'): begin + i := MenuMax; + while (i > 0) and (LoCase (Key2Char (Key)) <> LoCase (WindowTypes[i].Name[1])) do Dec (i); + if i > 0 then + begin + n := i; + Done := True + end + end; + end + until Done or (Key = kbScreenSizeChanged); + ClosePopUpWindow + until Key <> kbScreenSizeChanged + end; + + procedure NewWindow (WindowType, ax, ay: Integer); + var + p, LastWindow: PWindowList; + MaxX1, MaxY1: Integer; + SSize: TPoint; + begin + New (p); + if WindowList = nil then + begin + p^.Prev := p; + p^.Next := p + end + else + begin + p^.Prev := WindowList; + p^.Next := WindowList^.Next; + p^.Prev^.Next := p; + p^.Next^.Prev := p; + end; + p^.WindowType := WindowType; + with p^, WindowTypes[WindowType] do + begin + SSize := ScreenSize; + if PrefSizeX > 0 then xs := PrefSizeX else xs := MinSizeX; + if PrefSizeY > 0 then ys := PrefSizeY else ys := MinSizeY; + xs := Min (xs + 2, SSize.x); + ys := Min (ys + 2, SSize.y); + MaxX1 := SSize.x - xs + 1; + MaxY1 := SSize.y - ys + 1; + if ax = 0 then x1 := Random (MaxX1) + 1 else x1 := Min (ax, MaxX1); + if ay = 0 then y1 := Random (MaxY1) + 1 else y1 := Min (ay, MaxY1); + if (ax = 0) and (PrefSizeX < 0) then Inc (xs, Random (SSize.x - x1 - xs + 2)); + if (ax = 0) and (PrefSizeY < 0) then Inc (ys, Random (SSize.y - y1 - ys + 2)); + State := ws_None; + PanelNew (1, 1, 1, 1, False); + FramePanel := GetActivePanel; + SetControlChars (True); + TextColor (Color); + TextBackground (Background); + PanelNew (1, 1, 1, 1, False); + SetPCCharSet (False); + Panel := GetActivePanel; + end; + LastWindow := WindowList; + WindowList := p; + if LastWindow <> nil then RedrawFrame (LastWindow); + DrawWindow (p) + end; + + procedure OpenWindow; + var WindowType: Integer; + begin + WindowType := Menu; + if WindowType >= 0 then NewWindow (WindowType, 0, 0) + end; + + procedure NextWindow; + var LastWindow: PWindowList; + begin + LastWindow := WindowList; + WindowList := WindowList^.Next; + PanelTop (WindowList^.FramePanel); + PanelTop (WindowList^.Panel); + RedrawFrame (LastWindow); + RedrawFrame (WindowList) + end; + + procedure PreviousWindow; + var LastWindow: PWindowList; + begin + PanelMoveAbove (WindowList^.Panel, MainPanel); + PanelMoveAbove (WindowList^.FramePanel, MainPanel); + LastWindow := WindowList; + WindowList := WindowList^.Prev; + RedrawFrame (LastWindow); + RedrawFrame (WindowList) + end; + + procedure CloseWindow; + var p: PWindowList; + begin + if WindowList^.WindowType <> 0 then + begin + p := WindowList; + NextWindow; + PanelDelete (p^.FramePanel); + PanelDelete (p^.Panel); + p^.Next^.Prev := p^.Prev; + p^.Prev^.Next := p^.Next; + Dispose (p) + end + end; + + procedure MoveWindow; + var + Done, Changed: Boolean; + SSize: TPoint; + begin + with WindowList^ do + begin + Done := False; + Changed := True; + State := ws_Moving; + repeat + if Changed then DrawWindow (WindowList); + Changed := True; + case LoCaseKey (GetKey (-1)) of + Ord ('s'), kbLeft : if x1 > 1 then Dec (x1); + Ord ('d'), kbRight : if x1 + xs - 1 < ScreenSize.x then Inc (x1); + Ord ('e'), kbUp : if y1 > 1 then Dec (y1); + Ord ('x'), kbDown : if y1 + ys - 1 < ScreenSize.y then Inc (y1); + Ord ('a'), kbHome : x1 := 1; + Ord ('f'), kbEnd : x1 := ScreenSize.x - xs + 1; + Ord ('r'), kbPgUp : y1 := 1; + Ord ('c'), kbPgDn : y1 := ScreenSize.y - ys + 1; + Ord ('y'), kbCtrlPgUp: begin + x1 := 1; + y1 := 1 + end; + Ord ('b'), kbCtrlPgDn: begin + SSize := ScreenSize; + x1 := SSize.x - xs + 1; + y1 := SSize.y - ys + 1 + end; + kbCR, + kbEsc, kbAltEsc : Done := True; + else Changed := False + end + until Done; + State := ws_None; + DrawWindow (WindowList) + end + end; + + procedure ResizeWindow; + var + Done, Changed: Boolean; + SSize: TPoint; + begin + with WindowList^, WindowTypes[WindowType] do + begin + Done := False; + Changed := True; + State := ws_Resizing; + repeat + if Changed then DrawWindow (WindowList); + Changed := True; + case LoCaseKey (GetKey (-1)) of + Ord ('s'), kbLeft : if xs > MinSizeX + 2 then Dec (xs); + Ord ('d'), kbRight : if x1 + xs - 1 < ScreenSize.x then Inc (xs); + Ord ('e'), kbUp : if ys > MinSizeY + 2 then Dec (ys); + Ord ('x'), kbDown : if y1 + ys - 1 < ScreenSize.y then Inc (ys); + Ord ('a'), kbHome : xs := MinSizeX + 2; + Ord ('f'), kbEnd : xs := ScreenSize.x - x1 + 1; + Ord ('r'), kbPgUp : ys := MinSizeY + 2; + Ord ('c'), kbPgDn : ys := ScreenSize.y - y1 + 1; + Ord ('y'), kbCtrlPgUp: begin + xs := MinSizeX + 2; + ys := MinSizeY + 2 + end; + Ord ('b'), kbCtrlPgDn: begin + SSize := ScreenSize; + xs := SSize.x - x1 + 1; + ys := SSize.y - y1 + 1 + end; + kbCR, + kbEsc, kbAltEsc : Done := True; + else Changed := False + end + until Done; + State := ws_None; + DrawWindow (WindowList) + end + end; + + procedure ActivateCursor; + begin + with WindowList^, WindowTypes[WindowType] do + begin + PanelActivate (Panel); + if WantCursor then + SetCursorShape (CursorShape) + else + HideCursor + end; + SetScroll (ScrollState) + end; + +var + Key: TKey; + ScreenShot, Done: Boolean; + +begin + ScreenShot := ParamStr (1) = '--screenshot'; + if ParamCount <> Ord (ScreenShot) then + begin + RestoreTerminal (True); + WriteLn (StdErr, ParamStr (0), ': invalid argument `', ParamStr (Ord (ScreenShot) + 1), ''''); + Halt (1) + end; + CRTSavePreviousScreen (True); + SetCRTUpdate (UpdateInput); + MainPanel := GetActivePanel; + CheckScreenSize; + OrigScreenSize := ScreenSize; + if ScreenShot then + begin + CursorShape := CursorBlock; + NewWindow (6, 1, 1); + NewWindow (2, 1, MaxInt); + NewWindow (8, MaxInt, 1); + NewWindow (5, 1, 27); + KeyDemoKey (Ord ('f')); + KeyDemoKey (246); + KeyDemoKey (kbDown); + NewWindow (3, MaxInt, 13); + NewWindow (4, MaxInt, 31); + NewWindow (7, MaxInt, MaxInt); + NewWindow (9, MaxInt, 33); + NewWindow (0, 1, 2); + NewWindow (1, 1, 14); + ActivateCursor; + OpenWindow + end + else + NewWindow (0, 3, 2); + Done := False; + repeat + ActivateCursor; + Key := GetKey (-1); + case LoCaseKey (Key) of + Ord ('3'), kbF3 : OpenWindow; + Ord ('4'), kbF4 : CloseWindow; + Ord ('5'), kbF5 : PreviousWindow; + Ord ('6'), kbF6 : NextWindow; + Ord ('7'), kbF7 : MoveWindow; + Ord ('8'), kbF8 : ResizeWindow; + Ord ('q'), kbEsc, + kbAltEsc: Done := True; + else + if WindowList <> nil then + with WindowList^, WindowTypes[WindowType] do + if @KeyProc <> nil then + begin + TextColor (Color); + TextBackground (Background); + KeyProc (Key) + end + end + until Done +end. diff --cc test/manual/redisplay-testsuite.el index 332eeb1cc9f,00000000000..37a5649dc1b mode 100644,000000..100644 --- a/test/manual/redisplay-testsuite.el +++ b/test/manual/redisplay-testsuite.el @@@ -1,313 -1,0 +1,313 @@@ +;;; redisplay-testsuite.el --- Test suite for redisplay. + - ;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2009-2016 Free Software Foundation, Inc. + +;; Author: Chong Yidong <cyd@stupidchicken.com> +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Type M-x test-redisplay RET to generate the test buffer. + +;;; Code: + +(defun test-insert-overlay (text &rest props) + (let ((opoint (point)) + overlay) + (insert text) + (setq overlay (make-overlay opoint (point))) + (while props + (overlay-put overlay (car props) (cadr props)) + (setq props (cddr props))))) + +(defun test-redisplay-1 () + (insert "Test 1: Displaying adjacent and overlapping overlays:\n\n") + (insert " Expected: gnu emacs\n") + (insert " Results: ") + (test-insert-overlay "n" 'before-string "g" 'after-string "u ") + (test-insert-overlay "ma" 'before-string "e" 'after-string "cs") + (insert "\n\n") + (insert " Expected: gnu emacs\n") + (insert " Results: ") + (test-insert-overlay "u" 'before-string "gn") + (test-insert-overlay "ma" 'before-string " e" 'after-string "cs") + (insert "\n\n") + (insert " Expected: gnu emacs\n") + (insert " Results: ") + (test-insert-overlay "XXX" 'display "u " + 'before-string "gn" 'after-string "em") + (test-insert-overlay "a" 'after-string "cs") + (insert "\n\n") + (insert " Expected: gnu emacs\n") + (insert " Results: ") + (test-insert-overlay "u " 'before-string "gn" 'after-string "em") + (test-insert-overlay "XXX" 'display "a" 'after-string "cs") + (insert "\n\n")) + +(defun test-redisplay-2 () + (insert "Test 2: Mouse highlighting. Move your mouse over the letters XXX:\n\n") + (insert " Expected: " + (propertize "xxxXXXxxx" 'face 'highlight) + "...---...\n Test: ") + (test-insert-overlay "XXX" 'before-string "xxx" 'after-string "xxx" + 'mouse-face 'highlight ) + (test-insert-overlay "---" 'before-string "..." 'after-string "...") + (insert "\n\n Expected: " + (propertize "xxxXXX" 'face 'highlight) + "...---...\n Test: ") + (test-insert-overlay "XXX" 'before-string "xxx" 'mouse-face 'highlight) + (test-insert-overlay "---" 'before-string "..." 'after-string "...") + (insert "\n\n Expected: " + (propertize "XXX" 'face 'highlight) + "...---...\n Test: ") + (test-insert-overlay "..." 'display "XXX" 'mouse-face 'highlight) + (test-insert-overlay "---" 'before-string "..." 'after-string "...") + (insert "\n\n Expected: " + (propertize "XXXxxx" 'face 'highlight) + "...\n Test: ") + (test-insert-overlay "..." 'display "XXX" 'after-string "xxx" + 'mouse-face 'highlight) + (test-insert-overlay "error" 'display "...") + (insert "\n\n Expected: " + "---..." + (propertize "xxxXXX" 'face 'highlight) + "\n Test: ") + (test-insert-overlay "xxx" 'display "---" 'after-string "...") + (test-insert-overlay "error" 'before-string "xxx" 'display "XXX" + 'mouse-face 'highlight) + (insert "\n\n Expected: " + "...---..." + (propertize "xxxXXXxxx" 'face 'highlight) + "\n Test: ") + (test-insert-overlay "---" 'before-string "..." 'after-string "...") + (test-insert-overlay "XXX" 'before-string "xxx" 'after-string "xxx" + 'mouse-face 'highlight) + (insert "\n\n Expected: " + "..." + (propertize "XXX" 'face 'highlight) + "...\n Test: ") + (test-insert-overlay "---" + 'display (propertize "XXX" 'mouse-face 'highlight) + 'before-string "..." + 'after-string "...") + (insert "\n\n Expected: " + (propertize "XXX\n" 'face 'highlight) + "\n Test: ") + (test-insert-overlay "XXX\n" 'mouse-face 'highlight) + (insert "\n\n")) + +(defun test-redisplay-3 () + (insert "Test 3: Overlay with strings and images:\n\n") + (let ((img-data "#define x_width 8 +#define x_height 8 +static unsigned char x_bits[] = {0xff, 0x81, 0xbd, 0xa5, 0xa5, 0xbd, 0x81, 0xff };")) + ;; Control + (insert " Expected: AB" + (propertize "X" 'display `(image :data ,img-data :type xbm)) + "CD\n") + + ;; Overlay with before, after, and image display string. + (insert " Result 1: ") + (let ((opoint (point))) + (insert "AXD\n") + (let ((ov (make-overlay (1+ opoint) (+ 2 opoint)))) + (overlay-put ov 'before-string "B") + (overlay-put ov 'after-string "C") + (overlay-put ov 'display + `(image :data ,img-data :type xbm)))) + + ;; Overlay with before and after string, and image text prop. + (insert " Result 2: ") + (let ((opoint (point))) + (insert "AXD\n") + (let ((ov (make-overlay (1+ opoint) (+ 2 opoint)))) + (overlay-put ov 'before-string "B") + (overlay-put ov 'after-string "C") + (put-text-property (1+ opoint) (+ 2 opoint) 'display + `(image :data ,img-data :type xbm)))) + + ;; Overlays with adjacent before and after strings, and image text + ;; prop. + (insert " Result 3: ") + (let ((opoint (point))) + (insert "AXD\n") + (let ((ov1 (make-overlay opoint (1+ opoint))) + (ov2 (make-overlay (+ 2 opoint) (+ 3 opoint)))) + (overlay-put ov1 'after-string "B") + (overlay-put ov2 'before-string "C") + (put-text-property (1+ opoint) (+ 2 opoint) 'display + `(image :data ,img-data :type xbm)))) + + ;; Three overlays. + (insert " Result 4: ") + (let ((opoint (point))) + (insert "AXD\n\n") + (let ((ov1 (make-overlay opoint (1+ opoint))) + (ov2 (make-overlay (+ 2 opoint) (+ 3 opoint))) + (ov3 (make-overlay (1+ opoint) (+ 2 opoint)))) + (overlay-put ov1 'after-string "B") + (overlay-put ov2 'before-string "C") + (overlay-put ov3 'display `(image :data ,img-data :type xbm)))))) + +(defun test-redisplay-4 () + (insert "Test 4: Overlay strings and invisibility:\n\n") + ;; Before and after strings with non-nil `invisibility'. + (insert " Expected: ABC\n") + (insert " Result: ") + (let ((opoint (point))) + (insert "ABC\n") + (let ((ov (make-overlay (1+ opoint) (+ 2 opoint)))) + (overlay-put ov 'before-string + (propertize "XX" 'invisible + 'test-redisplay--simple-invis)) + (overlay-put ov 'after-string + (propertize "XX" 'invisible + 'test-redisplay--simple-invis)))) + + ;; Before and after strings bogus `invisibility' property (value is + ;; not listed in `buffer-invisibility-spec'). + (insert "\n Expected: ABC") + (insert "\n Result: ") + (let ((opoint (point))) + (insert "B\n") + (let ((ov (make-overlay opoint (1+ opoint)))) + (overlay-put ov 'before-string + (propertize "A" 'invisible 'bogus-invis-spec)) + (overlay-put ov 'after-string + (propertize "C" 'invisible 'bogus-invis-spec)))) + + ;; Before/after string with ellipsis `invisibility' property. + (insert "\n Expected: ...B...") + (insert "\n Result: ") + (let ((opoint (point))) + (insert "B\n") + (let ((ov (make-overlay opoint (1+ opoint)))) + (overlay-put ov 'before-string + (propertize "A" 'invisible 'test-redisplay--ellipsis-invis)) + (overlay-put ov 'after-string + (propertize "C" 'invisible 'test-redisplay--ellipsis-invis)))) + + ;; Before/after string with partial ellipsis `invisibility' property. + (insert "\n Expected: A...ABC...C") + (insert "\n Result: ") + (let ((opoint (point))) + (insert "B\n") + (let ((ov (make-overlay opoint (1+ opoint))) + (a "AAA") + (c "CCC")) + (put-text-property 1 2 'invisible 'test-redisplay--ellipsis-invis a) + (put-text-property 1 2 'invisible 'test-redisplay--ellipsis-invis c) + (overlay-put ov 'before-string a) + (overlay-put ov 'after-string c))) + + ;; Display string with `invisibility' property. + (insert "\n Expected: ABC") + (insert "\n Result: ") + (let ((opoint (point))) + (insert "AYBC\n") + (let ((ov (make-overlay (1+ opoint) (+ 2 opoint)))) + (overlay-put ov 'display + (propertize "XX" 'invisible + 'test-redisplay--simple-invis)))) + ;; Display string with bogus `invisibility' property. + (insert "\n Expected: ABC") + (insert "\n Result: ") + (let ((opoint (point))) + (insert "AXC\n") + (let ((ov (make-overlay (1+ opoint) (+ 2 opoint)))) + (overlay-put ov 'display + (propertize "B" 'invisible 'bogus-invis-spec)))) + ;; Display string with ellipsis `invisibility' property. + (insert "\n Expected: A...C") + (insert "\n Result: ") + (let ((opoint (point))) + (insert "AXC\n") + (let ((ov (make-overlay (1+ opoint) (+ 2 opoint)))) + (overlay-put ov 'display + (propertize "B" 'invisible + 'test-redisplay--ellipsis-invis)))) + ;; Display string with partial `invisibility' property. + (insert "\n Expected: A...C") + (insert "\n Result: ") + (let ((opoint (point))) + (insert "X\n") + (let ((ov (make-overlay opoint (1+ opoint))) + (str "ABC")) + (put-text-property 1 2 'invisible 'test-redisplay--ellipsis-invis str) + (overlay-put ov 'display str))) + ;; Overlay string over invisible text and non-default face. + (insert "\n Expected: ..." (propertize "ABC" 'face 'highlight) "XYZ") + (insert "\n Result: ") + (insert (propertize "foo" 'invisible 'test-redisplay--ellipsis-invis)) + (let ((ov (make-overlay (point) (point)))) + (overlay-put ov 'invisible t) + (overlay-put ov 'window (selected-window)) + (overlay-put ov 'after-string + (propertize "ABC" 'face 'highlight))) + (insert "XYZ\n") + ;; Overlay strings with partial `invisibility' property and with a + ;; display property on the before-string. + (insert "\n Expected: ..." + (propertize "DEF" 'display '(image :type xpm :file "close.xpm")) + (propertize "ABC" 'face 'highlight) "XYZ") + (insert "\n Result: ") + (insert (propertize "foo" 'invisible 'test-redisplay--ellipsis-invis)) + (let ((ov (make-overlay (point) (point)))) + (overlay-put ov 'invisible t) + (overlay-put ov 'window (selected-window)) + (overlay-put ov 'after-string + (propertize "ABC" 'face 'highlight)) + (overlay-put ov 'before-string + (propertize "DEF" + 'display '(image :type xpm :file "close.xpm")))) + (insert "XYZ\n") + + ;; Overlay string with 2 adjacent and different invisible + ;; properties. This caused an infloop before Emacs 25. + (insert "\n Expected: ABC") + (insert "\n Result: ") + (let ((opoint (point))) + (insert "ABC\n") + (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))) + (str (concat (propertize "X" + 'invisible 'test-redisplay--simple-invis) + (propertize "Y" + 'invisible 'test-redisplay--simple-invis2)))) + (overlay-put ov 'after-string str))) + + (insert "\n")) + + +(defun test-redisplay () + (interactive) + (let ((buf (get-buffer "*Redisplay Test*"))) + (if buf + (kill-buffer buf)) + (switch-to-buffer (get-buffer-create "*Redisplay Test*")) + (erase-buffer) + (setq buffer-invisibility-spec + '(test-redisplay--simple-invis + test-redisplay--simple-invis2 + (test-redisplay--ellipsis-invis . t))) + (test-redisplay-1) + (test-redisplay-2) + (test-redisplay-3) + (test-redisplay-4) + (goto-char (point-min)))) + diff --cc test/manual/rmailmm.el index a20ae40849f,00000000000..96acbc4735e mode 100644,000000..100644 --- a/test/manual/rmailmm.el +++ b/test/manual/rmailmm.el @@@ -1,93 -1,0 +1,93 @@@ +;;; rmailmm.el --- tests for mail/rmailmm.el + - ;; Copyright (C) 2006-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2006-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'rmailmm) + +(defun rmailmm-test-handler () + "Test of a mail using no MIME parts at all." + (let ((mail "To: alex@gnu.org +Content-Type: text/plain; charset=koi8-r +Content-Transfer-Encoding: 8bit +MIME-Version: 1.0 + +\372\304\322\301\327\323\324\327\325\312\324\305\41")) + (switch-to-buffer (get-buffer-create "*test*")) + (erase-buffer) + (set-buffer-multibyte nil) + (insert mail) + (rmail-mime-show t) + (set-buffer-multibyte t))) + +(defun rmailmm-test-bulk-handler () + "Test of a mail used as an example in RFC 2183." + (let ((mail "Content-Type: image/jpeg +Content-Disposition: attachment; filename=genome.jpeg; + modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\"; +Content-Description: a complete map of the human genome +Content-Transfer-Encoding: base64 + +iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ +TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy ++ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me +WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv +9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L +UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx +lgAAAABJRU5ErkJggg== +")) + (switch-to-buffer (get-buffer-create "*test*")) + (erase-buffer) + (insert mail) + (rmail-mime-show))) + +(defun rmailmm-test-multipart-handler () + "Test of a mail used as an example in RFC 2046." + (let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com> +To: Ned Freed <ned@innosoft.com> +Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST) +Subject: Sample message +MIME-Version: 1.0 +Content-type: multipart/mixed; boundary=\"simple boundary\" + +This is the preamble. It is to be ignored, though it +is a handy place for composition agents to include an +explanatory note to non-MIME conformant readers. + +--simple boundary + +This is implicitly typed plain US-ASCII text. +It does NOT end with a linebreak. +--simple boundary +Content-type: text/plain; charset=us-ascii + +This is explicitly typed plain US-ASCII text. +It DOES end with a linebreak. + +--simple boundary-- + +This is the epilogue. It is also to be ignored.")) + (switch-to-buffer (get-buffer-create "*test*")) + (erase-buffer) + (insert mail) + (rmail-mime-show t))) + +;;; rmailmm.el ends here diff --cc test/src/alloc-tests.el index c0fe0f33cb9,00000000000..97c6b4f8070 mode 100644,000000..100644 --- a/test/src/alloc-tests.el +++ b/test/src/alloc-tests.el @@@ -1,33 -1,0 +1,33 @@@ +;;; alloc-tests.el --- alloc tests -*- lexical-binding: t -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Daniel Colascione <dancol@dancol.org> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(ert-deftest finalizer-object-type () + (should (equal (type-of (make-finalizer nil)) 'finalizer))) diff --cc test/src/buffer-tests.el index bb3c92dd6de,00000000000..62875216a31 mode 100644,000000..100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@@ -1,48 -1,0 +1,48 @@@ +;;; buffer-tests.el --- tests for buffer.c functions -*- lexical-binding: t -*- + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(ert-deftest overlay-modification-hooks-message-other-buf () + "Test for bug#21824. +After a modification-hook has been run and there is an overlay in +the *Messages* buffer, the message coalescing [2 times] wrongly +runs the modification-hook of the overlay in the 1st buffer, but +with parameters from the *Messages* buffer modification." + (let ((buf nil) + (msg-ov nil)) + (with-temp-buffer + (insert "123") + (overlay-put (make-overlay 1 3) + 'modification-hooks + (list (lambda (&rest _) + (setq buf (current-buffer))))) + (goto-char 2) + (insert "x") + (unwind-protect + (progn + (setq msg-ov (make-overlay 1 1 (get-buffer-create "*Messages*"))) + (message "a message") + (message "a message") + (should (eq buf (current-buffer)))) + (when msg-ov (delete-overlay msg-ov)))))) + +;;; buffer-tests.el ends here diff --cc test/src/cmds-tests.el index 7e742a1fa8b,00000000000..4a30d9872a1 mode 100644,000000..100644 --- a/test/src/cmds-tests.el +++ b/test/src/cmds-tests.el @@@ -1,34 -1,0 +1,34 @@@ +;;; cmds-tests.el --- Testing some Emacs commands + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Nicolas Richard <youngfrog@members.fsf.org> +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + + +(ert-deftest self-insert-command-with-negative-argument () + "Test `self-insert-command' with a negative argument." + (let ((last-command-event ?a)) + (should-error (self-insert-command -1)))) + +(provide 'cmds-tests) +;;; cmds-tests.el ends here diff --cc test/src/data-tests.el index 252a1410206,00000000000..9ca5ac53333 mode 100644,000000..100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@@ -1,257 -1,0 +1,257 @@@ +;;; data-tests.el --- tests for src/data.c + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) +(eval-when-compile (require 'cl)) + +(ert-deftest data-tests-= () + (should-error (=)) + (should (= 1)) + (should (= 2 2)) + (should (= 9 9 9 9 9 9 9 9 9)) + (should-not (apply #'= '(3 8 3))) + (should-error (= 9 9 'foo)) + ;; Short circuits before getting to bad arg + (should-not (= 9 8 'foo))) + +(ert-deftest data-tests-< () + (should-error (<)) + (should (< 1)) + (should (< 2 3)) + (should (< -6 -1 0 2 3 4 8 9 999)) + (should-not (apply #'< '(3 8 3))) + (should-error (< 9 10 'foo)) + ;; Short circuits before getting to bad arg + (should-not (< 9 8 'foo))) + +(ert-deftest data-tests-> () + (should-error (>)) + (should (> 1)) + (should (> 3 2)) + (should (> 6 1 0 -2 -3 -4 -8 -9 -999)) + (should-not (apply #'> '(3 8 3))) + (should-error (> 9 8 'foo)) + ;; Short circuits before getting to bad arg + (should-not (> 8 9 'foo))) + +(ert-deftest data-tests-<= () + (should-error (<=)) + (should (<= 1)) + (should (<= 2 3)) + (should (<= -6 -1 -1 0 0 0 2 3 4 8 999)) + (should-not (apply #'<= '(3 8 3 3))) + (should-error (<= 9 10 'foo)) + ;; Short circuits before getting to bad arg + (should-not (<= 9 8 'foo))) + +(ert-deftest data-tests->= () + (should-error (>=)) + (should (>= 1)) + (should (>= 3 2)) + (should (>= 666 1 0 0 -2 -3 -3 -3 -4 -8 -8 -9 -999)) + (should-not (apply #'>= '(3 8 3))) + (should-error (>= 9 8 'foo)) + ;; Short circuits before getting to bad arg + (should-not (>= 8 9 'foo))) + +;; Bool vector tests. Compactly represent bool vectors as hex +;; strings. + +(ert-deftest bool-vector-count-population-all-0-nil () + (cl-loop for sz in '(0 45 1 64 9 344) + do (let* ((bv (make-bool-vector sz nil))) + (should + (zerop + (bool-vector-count-population bv)))))) + +(ert-deftest bool-vector-count-population-all-1-t () + (cl-loop for sz in '(0 45 1 64 9 344) + do (let* ((bv (make-bool-vector sz t))) + (should + (eql + (bool-vector-count-population bv) + sz))))) + +(ert-deftest bool-vector-count-population-1-nil () + (let* ((bv (make-bool-vector 45 nil))) + (aset bv 40 t) + (aset bv 0 t) + (should + (eql + (bool-vector-count-population bv) + 2)))) + +(ert-deftest bool-vector-count-population-1-t () + (let* ((bv (make-bool-vector 45 t))) + (aset bv 40 nil) + (aset bv 0 nil) + (should + (eql + (bool-vector-count-population bv) + 43)))) + +(defun mock-bool-vector-count-consecutive (a b i) + (loop for i from i below (length a) + while (eq (aref a i) b) + sum 1)) + +(defun test-bool-vector-bv-from-hex-string (desc) + (let (bv nchars nibbles) + (dolist (c (string-to-list desc)) + (push (string-to-number + (char-to-string c) + 16) + nibbles)) + (setf bv (make-bool-vector (* 4 (length nibbles)) nil)) + (let ((i 0)) + (dolist (n (nreverse nibbles)) + (dotimes (_ 4) + (aset bv i (> (logand 1 n) 0)) + (incf i) + (setf n (lsh n -1))))) + bv)) + +(defun test-bool-vector-to-hex-string (bv) + (let (nibbles (v (cl-coerce bv 'list))) + (while v + (push (logior + (lsh (if (nth 0 v) 1 0) 0) + (lsh (if (nth 1 v) 1 0) 1) + (lsh (if (nth 2 v) 1 0) 2) + (lsh (if (nth 3 v) 1 0) 3)) + nibbles) + (setf v (nthcdr 4 v))) + (mapconcat (lambda (n) (format "%X" n)) + (nreverse nibbles) + ""))) + +(defun test-bool-vector-count-consecutive-tc (desc) + "Run a test case for bool-vector-count-consecutive. +DESC is a string describing the test. It is a sequence of +hexadecimal digits describing the bool vector. We exhaustively +test all counts at all possible positions in the vector by +comparing the subr with a much slower lisp implementation." + (let ((bv (test-bool-vector-bv-from-hex-string desc))) + (loop + for lf in '(nil t) + do (loop + for pos from 0 upto (length bv) + for cnt = (mock-bool-vector-count-consecutive bv lf pos) + for rcnt = (bool-vector-count-consecutive bv lf pos) + unless (eql cnt rcnt) + do (error "FAILED testcase %S %3S %3S %3S" + pos lf cnt rcnt))))) + +(defconst bool-vector-test-vectors +'("" + "0" + "F" + "0F" + "F0" + "00000000000000000000000000000FFFFF0000000" + "44a50234053fba3340000023444a50234053fba33400000234" + "12341234123456123412346001234123412345612341234600" + "44a50234053fba33400000234" + "1234123412345612341234600" + "44a50234053fba33400000234" + "1234123412345612341234600" + "44a502340" + "123412341" + "0000000000000000000000000" + "FFFFFFFFFFFFFFFF1")) + +(ert-deftest bool-vector-count-consecutive () + (mapc #'test-bool-vector-count-consecutive-tc + bool-vector-test-vectors)) + +(defun test-bool-vector-apply-mock-op (mock a b c) + "Compute (slowly) the correct result of a bool-vector set operation." + (let (changed nv) + (assert (eql (length b) (length c))) + (if a (setf nv a) + (setf a (make-bool-vector (length b) nil)) + (setf changed t)) + + (loop for i below (length b) + for mockr = (funcall mock + (if (aref b i) 1 0) + (if (aref c i) 1 0)) + for r = (not (= 0 mockr)) + do (progn + (unless (eq (aref a i) r) + (setf changed t)) + (setf (aref a i) r))) + (if changed a))) + +(defun test-bool-vector-binop (mock real) + "Test a binary set operation." + (loop for s1 in bool-vector-test-vectors + for bv1 = (test-bool-vector-bv-from-hex-string s1) + for vecs2 = (cl-remove-if-not + (lambda (x) (eql (length x) (length s1))) + bool-vector-test-vectors) + do (loop for s2 in vecs2 + for bv2 = (test-bool-vector-bv-from-hex-string s2) + for mock-result = (test-bool-vector-apply-mock-op + mock nil bv1 bv2) + for real-result = (funcall real bv1 bv2) + do (progn + (should (equal mock-result real-result)))))) + +(ert-deftest bool-vector-intersection-op () + (test-bool-vector-binop + #'logand + #'bool-vector-intersection)) + +(ert-deftest bool-vector-union-op () + (test-bool-vector-binop + #'logior + #'bool-vector-union)) + +(ert-deftest bool-vector-xor-op () + (test-bool-vector-binop + #'logxor + #'bool-vector-exclusive-or)) + +(ert-deftest bool-vector-set-difference-op () + (test-bool-vector-binop + (lambda (a b) (logand a (lognot b))) + #'bool-vector-set-difference)) + +(ert-deftest bool-vector-change-detection () + (let* ((vc1 (test-bool-vector-bv-from-hex-string "abcdef")) + (vc2 (test-bool-vector-bv-from-hex-string "012345")) + (vc3 (make-bool-vector (length vc1) nil)) + (c1 (bool-vector-union vc1 vc2 vc3)) + (c2 (bool-vector-union vc1 vc2 vc3))) + (should (equal c1 (test-bool-vector-apply-mock-op + #'logior + nil + vc1 vc2))) + (should (not c2)))) + +(ert-deftest bool-vector-not () + (let* ((v1 (test-bool-vector-bv-from-hex-string "FFFF3")) + (v2 (test-bool-vector-bv-from-hex-string "0000C")) + (v3 (bool-vector-not v1))) + (should (equal v2 v3)))) diff --cc test/src/decompress-tests.el index 1eea673121c,00000000000..f0264ec548d mode 100644,000000..100644 --- a/test/src/decompress-tests.el +++ b/test/src/decompress-tests.el @@@ -1,45 -1,0 +1,45 @@@ +;;; decompress-tests.el --- Test suite for decompress. + - ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(defvar zlib-tests-data-directory + (expand-file-name "data/decompress" (getenv "EMACS_TEST_DIRECTORY")) + "Directory containing zlib test data.") + +(ert-deftest zlib--decompress () + "Test decompressing a gzipped file." + (when (and (fboundp 'zlib-available-p) + (zlib-available-p)) + (should (string= + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally + (expand-file-name "foo.gz" zlib-tests-data-directory)) + (zlib-decompress-region (point-min) (point-max)) + (buffer-string)) + "foo\n")))) + +(provide 'decompress-tests) + +;;; decompress-tests.el ends here. diff --cc test/src/fns-tests.el index b5222db3ca1,00000000000..762f7bdd94f mode 100644,000000..100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@@ -1,193 -1,0 +1,193 @@@ +;;; fns-tests.el --- tests for src/fns.c + - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) +(eval-when-compile (require 'cl)) + +(ert-deftest fns-tests-reverse () + (should-error (reverse)) + (should-error (reverse 1)) + (should-error (reverse (make-char-table 'foo))) + (should (equal [] (reverse []))) + (should (equal [0] (reverse [0]))) + (should (equal [1 2 3 4] (reverse (reverse [1 2 3 4])))) + (should (equal '(a b c d) (reverse (reverse '(a b c d))))) + (should (equal "xyzzy" (reverse (reverse "xyzzy")))) + (should (equal "こんにちは / コンニチハ" (reverse (reverse "こんにちは / コンニチハ"))))) + +(ert-deftest fns-tests-nreverse () + (should-error (nreverse)) + (should-error (nreverse 1)) + (should-error (nreverse (make-char-table 'foo))) + (should (equal (nreverse "xyzzy") "yzzyx")) + (let ((A [])) + (nreverse A) + (should (equal A []))) + (let ((A [0])) + (nreverse A) + (should (equal A [0]))) + (let ((A [1 2 3 4])) + (nreverse A) + (should (equal A [4 3 2 1]))) + (let ((A [1 2 3 4])) + (nreverse A) + (nreverse A) + (should (equal A [1 2 3 4]))) + (let* ((A [1 2 3 4]) + (B (nreverse (nreverse A)))) + (should (equal A B)))) + +(ert-deftest fns-tests-reverse-bool-vector () + (let ((A (make-bool-vector 10 nil))) + (dotimes (i 5) (aset A i t)) + (should (equal [nil nil nil nil nil t t t t t] (vconcat (reverse A)))) + (should (equal A (reverse (reverse A)))))) + +(ert-deftest fns-tests-nreverse-bool-vector () + (let ((A (make-bool-vector 10 nil))) + (dotimes (i 5) (aset A i t)) + (nreverse A) + (should (equal [nil nil nil nil nil t t t t t] (vconcat A))) + (should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A)))))) + +(ert-deftest fns-tests-compare-strings () + (should-error (compare-strings)) + (should-error (compare-strings "xyzzy" "xyzzy")) + (should (= (compare-strings "xyzzy" 0 10 "zyxxy" 0 5) -1)) + (should-error (compare-strings "xyzzy" 0 5 "zyxxy" -1 2)) + (should-error (compare-strings "xyzzy" 'foo nil "zyxxy" 0 1)) + (should-error (compare-strings "xyzzy" 0 'foo "zyxxy" 2 3)) + (should-error (compare-strings "xyzzy" 0 2 "zyxxy" 'foo 3)) + (should-error (compare-strings "xyzzy" nil 3 "zyxxy" 4 'foo)) + (should (eq (compare-strings "" nil nil "" nil nil) t)) + (should (eq (compare-strings "" 0 0 "" 0 0) t)) + (should (eq (compare-strings "test" nil nil "test" nil nil) t)) + (should (eq (compare-strings "test" nil nil "test" nil nil t) t)) + (should (eq (compare-strings "test" nil nil "test" nil nil nil) t)) + (should (eq (compare-strings "Test" nil nil "test" nil nil t) t)) + (should (= (compare-strings "Test" nil nil "test" nil nil) -1)) + (should (= (compare-strings "Test" nil nil "test" nil nil) -1)) + (should (= (compare-strings "test" nil nil "Test" nil nil) 1)) + (should (= (compare-strings "foobaz" nil nil "barbaz" nil nil) 1)) + (should (= (compare-strings "barbaz" nil nil "foobar" nil nil) -1)) + (should (= (compare-strings "foobaz" nil nil "farbaz" nil nil) 2)) + (should (= (compare-strings "farbaz" nil nil "foobar" nil nil) -2)) + (should (eq (compare-strings "abcxyz" 0 2 "abcprq" 0 2) t)) + (should (eq (compare-strings "abcxyz" 0 -3 "abcprq" 0 -3) t)) + (should (= (compare-strings "abcxyz" 0 6 "abcprq" 0 6) 4)) + (should (= (compare-strings "abcprq" 0 6 "abcxyz" 0 6) -4)) + (should (eq (compare-strings "xyzzy" -3 4 "azza" -3 3) t)) + (should (eq (compare-strings "こんにちはコンニチハ" nil nil "こんにちはコンニチハ" nil nil) t)) + (should (= (compare-strings "んにちはコンニチハこ" nil nil "こんにちはコンニチハ" nil nil) 1)) + (should (= (compare-strings "こんにちはコンニチハ" nil nil "んにちはコンニチハこ" nil nil) -1))) + +(defun fns-tests--collate-enabled-p () + "Check whether collation functions are enabled." + (and + ;; When there is no collation library, collation functions fall back + ;; to their lexicographic counterparts. We don't need to test then. + (not (ignore-errors (string-collate-equalp "" "" t))) + ;; We use a locale, which might not be installed. Check it. + (ignore-errors + (string-collate-equalp + "" "" (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8"))))) + +(ert-deftest fns-tests-collate-strings () + (skip-unless (fns-tests--collate-enabled-p)) + + (should (string-collate-equalp "xyzzy" "xyzzy")) + (should-not (string-collate-equalp "xyzzy" "XYZZY")) + + ;; In POSIX or C locales, collation order is lexicographic. + (should (string-collate-lessp "XYZZY" "xyzzy" "POSIX")) + ;; In a language specific locale, collation order is different. + (should (string-collate-lessp + "xyzzy" "XYZZY" + (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8"))) + + ;; Ignore case. + (should (string-collate-equalp "xyzzy" "XYZZY" nil t)) + + ;; Locale must be valid. + (should-error (string-collate-equalp "xyzzy" "xyzzy" "en_DE.UTF-8"))) + +;; There must be a check for valid codepoints. (Check not implemented yet) +; (should-error +; (string-collate-equalp (string ?\x00110000) (string ?\x00110000))) +;; Invalid UTF-8 sequences shall be indicated. How to create such strings? + +(ert-deftest fns-tests-sort () + (should (equal (sort '(9 5 2 -1 5 3 8 7 4) (lambda (x y) (< x y))) + '(-1 2 3 4 5 5 7 8 9))) + (should (equal (sort '(9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y))) + '(9 8 7 5 5 4 3 2 -1))) + (should (equal (sort '[9 5 2 -1 5 3 8 7 4] (lambda (x y) (< x y))) + [-1 2 3 4 5 5 7 8 9])) + (should (equal (sort '[9 5 2 -1 5 3 8 7 4] (lambda (x y) (> x y))) + [9 8 7 5 5 4 3 2 -1])) + (should (equal + (sort + (vector + '(8 . "xxx") '(9 . "aaa") '(8 . "bbb") '(9 . "zzz") + '(9 . "ppp") '(8 . "ttt") '(8 . "eee") '(9 . "fff")) + (lambda (x y) (< (car x) (car y)))) + [(8 . "xxx") (8 . "bbb") (8 . "ttt") (8 . "eee") + (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")]))) + +(ert-deftest fns-tests-collate-sort () + ;; See https://lists.gnu.org/archive/html/emacs-devel/2015-10/msg02505.html. + :expected-result (if (eq system-type 'cygwin) :failed :passed) + (skip-unless (fns-tests--collate-enabled-p)) + + ;; Punctuation and whitespace characters are relevant for POSIX. + (should + (equal + (sort '("11" "12" "1 1" "1 2" "1.1" "1.2") + (lambda (a b) (string-collate-lessp a b "POSIX"))) + '("1 1" "1 2" "1.1" "1.2" "11" "12"))) + ;; Punctuation and whitespace characters are not taken into account + ;; for collation in other locales. + (should + (equal + (sort '("11" "12" "1 1" "1 2" "1.1" "1.2") + (lambda (a b) + (let ((w32-collate-ignore-punctuation t)) + (string-collate-lessp + a b (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8"))))) + '("11" "1 1" "1.1" "12" "1 2" "1.2"))) + + ;; Diacritics are different letters for POSIX, they sort lexicographical. + (should + (equal + (sort '("Ævar" "Agustín" "Adrian" "Eli") + (lambda (a b) (string-collate-lessp a b "POSIX"))) + '("Adrian" "Agustín" "Eli" "Ævar"))) + ;; Diacritics are sorted between similar letters for other locales. + (should + (equal + (sort '("Ævar" "Agustín" "Adrian" "Eli") + (lambda (a b) + (let ((w32-collate-ignore-punctuation t)) + (string-collate-lessp + a b (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8"))))) + '("Adrian" "Ævar" "Agustín" "Eli")))) diff --cc test/src/inotify-tests.el index 187b59054cd,00000000000..54977925f86 mode 100644,000000..100644 --- a/test/src/inotify-tests.el +++ b/test/src/inotify-tests.el @@@ -1,64 -1,0 +1,64 @@@ +;;; inotify-tests.el --- Test suite for inotify. -*- lexical-binding: t -*- + - ;; Copyright (C) 2012-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; Author: Rüdiger Sonderfeld <ruediger@c-plusplus.de> +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(declare-function inotify-add-watch "inotify.c" (file-name aspect callback)) +(declare-function inotify-rm-watch "inotify.c" (watch-descriptor)) + +;; (ert-deftest filewatch-file-watch-aspects-check () +;; "Test whether `file-watch' properly checks the aspects." +;; (let ((temp-file (make-temp-file "filewatch-aspects"))) +;; (should (stringp temp-file)) +;; (should-error (file-watch temp-file 'wrong nil) +;; :type 'error) +;; (should-error (file-watch temp-file '(modify t) nil) +;; :type 'error) +;; (should-error (file-watch temp-file '(modify all-modify) nil) +;; :type 'error) +;; (should-error (file-watch temp-file '(access wrong modify) nil) +;; :type 'error))) + +(ert-deftest inotify-file-watch-simple () + "Test if watching a normal file works." + + (skip-unless (featurep 'inotify)) + (let ((temp-file (make-temp-file "inotify-simple")) + (events 0)) + (let ((wd + (inotify-add-watch temp-file t (lambda (_ev) + (setq events (1+ events)))))) + (unwind-protect + (progn + (with-temp-file temp-file + (insert "Foo\n")) + (read-event nil nil 5) + (should (> events 0))) + (inotify-rm-watch wd) + (delete-file temp-file))))) + +(provide 'inotify-tests) + +;;; inotify-tests.el ends here. diff --cc test/src/keymap-tests.el index 524563fea50,00000000000..b835fc7530b mode 100644,000000..100644 --- a/test/src/keymap-tests.el +++ b/test/src/keymap-tests.el @@@ -1,43 -1,0 +1,43 @@@ +;;; keymap-tests.el --- Test suite for src/keymap.c + - ;; Copyright (C) 2015 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Juanma Barranquero <lekktu@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(ert-deftest keymap-store_in_keymap-XFASTINT-on-non-characters () + "Check for bug fixed in \"Fix assertion violation in define-key\", +commit 86c19714b097aa477d339ed99ffb5136c755a046." + (let ((def (lookup-key Buffer-menu-mode-map [32]))) + (unwind-protect + (progn + (should-not (eq def 'undefined)) + ;; This will cause an assertion violation if the bug is present. + ;; We could run an inferior Emacs process and check for the return + ;; status, but in some environments an assertion failure triggers + ;; an abort dialog that requires user intervention anyway. + (define-key Buffer-menu-mode-map [(32 . 32)] 'undefined) + (should (eq (lookup-key Buffer-menu-mode-map [32]) 'undefined))) + (define-key Buffer-menu-mode-map [32] def)))) + +(provide 'keymap-tests) + +;;; keymap-tests.el ends here diff --cc test/src/print-tests.el index fe8c56553a8,00000000000..1abfa53581c mode 100644,000000..100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@@ -1,62 -1,0 +1,62 @@@ +;;; print-tests.el --- tests for src/print.c -*- lexical-binding: t; -*- + - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(ert-deftest print-hex-backslash () + (should (string= (let ((print-escape-multibyte t) + (print-escape-newlines t)) + (prin1-to-string "\u00A2\ff")) + "\"\\x00a2\\ff\""))) + +(ert-deftest terpri () + (should (string= (with-output-to-string + (princ 'abc) + (should (terpri nil t))) + "abc\n")) + (should (string= (with-output-to-string + (should-not (terpri nil t)) + (princ 'xyz)) + "xyz")) + (message nil) + (if noninteractive + (progn (should (terpri nil t)) + (should-not (terpri nil t)) + (princ 'abc) + (should (terpri nil t)) + (should-not (terpri nil t))) + (should (string= (progn (should-not (terpri nil t)) + (princ 'abc) + (should (terpri nil t)) + (current-message)) + "abc\n"))) + (let ((standard-output + (with-current-buffer (get-buffer-create "*terpri-test*") + (insert "--------") + (point-max-marker)))) + (should (terpri nil t)) + (should-not (terpri nil t)) + (should (string= (with-current-buffer (marker-buffer standard-output) + (buffer-string)) + "--------\n")))) + +(provide 'print-tests) +;;; print-tests.el ends here diff --cc test/src/xml-tests.el index aa97b30f73c,00000000000..dc60197b59e mode 100644,000000..100644 --- a/test/src/xml-tests.el +++ b/test/src/xml-tests.el @@@ -1,74 -1,0 +1,74 @@@ +;;; libxml-parse-tests.el --- Test suite for libxml parsing. + - ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Ulf Jasper <ulf.jasper@web.de> +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(defvar libxml-tests--data-comments-preserved + `(;; simple case + ("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>" + . (foo ((baz . "true")) "bar")) + ;; toplevel comments -- first document child must not get lost + (,(concat "<?xml version=\"1.0\"?><foo>bar</foo><!--comment-1-->" + "<!--comment-2-->") + . (top nil (foo nil "bar") (comment nil "comment-1") + (comment nil "comment-2"))) + (,(concat "<?xml version=\"1.0\"?><!--comment-a--><foo a=\"b\">" + "<bar>blub</bar></foo><!--comment-b--><!--comment-c-->") + . (top nil (comment nil "comment-a") (foo ((a . "b")) (bar nil "blub")) + (comment nil "comment-b") (comment nil "comment-c")))) + "Alist of XML strings and their expected parse trees for preserved comments.") + +(defvar libxml-tests--data-comments-discarded + `(;; simple case + ("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>" + . (foo ((baz . "true")) "bar")) + ;; toplevel comments -- first document child must not get lost + (,(concat "<?xml version=\"1.0\"?><foo>bar</foo><!--comment-1-->" + "<!--comment-2-->") + . (foo nil "bar")) + (,(concat "<?xml version=\"1.0\"?><!--comment-a--><foo a=\"b\">" + "<bar>blub</bar></foo><!--comment-b--><!--comment-c-->") + . (foo ((a . "b")) (bar nil "blub")))) + "Alist of XML strings and their expected parse trees for discarded comments.") + + +(ert-deftest libxml-tests () + "Test libxml." + (when (fboundp 'libxml-parse-xml-region) + (with-temp-buffer + (dolist (test libxml-tests--data-comments-preserved) + (erase-buffer) + (insert (car test)) + (should (equal (cdr test) + (libxml-parse-xml-region (point-min) (point-max))))) + (dolist (test libxml-tests--data-comments-discarded) + (erase-buffer) + (insert (car test)) + (should (equal (cdr test) + (libxml-parse-xml-region (point-min) (point-max) nil t))))))) + +;;; libxml-tests.el ends here