% 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
;;; 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 <bruce.connor.am@gmail.com>
-;; Maintainer: Artur Malabarba <bruce.connor.am@gmail.com>
+;; Author: Artur Malabarba <emacs@endlessparentheses.com>
+;; Package-Requires: ((emacs "24.1"))
;; Version: 1.0.4
;; Keywords: extensions lisp
;; Prefix: let-alist
-;;; 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 <alexr@msil.sps.mot.com>
--- /dev/null
- # Copyright (C) 2010-2015 Free Software Foundation, Inc.
+### @configure_input@
+
++# 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 <http://www.gnu.org/licenses/>.
+
+### 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=$<c; \
+ ${MAKE} $$loadfile; \
+ fi; \
+ echo Testing $$loadfile; \
+ stat=OK ; \
+ mkdir --parents $(dir $@) ; \
+ $(emacs) -l ert -l $$loadfile \
+ -f ert-run-tests-batch-and-exit ${WRITE_LOG}
+
+ELFILES = $(shell find ${srcdir} -path "${srcdir}/manual" -prune -o \
+ -path "*resources" -prune -o -name "*el" -print)
+## .elc files may be in a different directory for out of source builds
+ELCFILES = $(patsubst %.el,%.elc, \
+ $(patsubst $(srcdir)%,.%,$(ELFILES)))
+LOGFILES = $(patsubst %.elc,%.log,${ELCFILES})
+LOGSAVEFILES = $(patsubst %.elc,%.log~,${ELCFILES})
+TESTS = $(subst ${srcdir}/,,$(LOGFILES:.log=))
+
+## If we have to interrupt a hanging test, preserve the log so we can
+## see what the problem was.
+.PRECIOUS: %.log
+
+.PHONY: ${TESTS}
+
+## The short aliases that always re-run the tests, with no logging.
+## Define an alias both with and without the directory name for ease
+## of use.
+define test_template
+$(1):
+ @test ! -f ./$(1).log || mv ./$(1).log ./$(1).log~
+ @${MAKE} ./$(1).log WRITE_LOG=
+
+$(notdir $(1)): $(1)
+endef
+
+$(foreach test,${TESTS},$(eval $(call test_template,${test})))
+
+## Include dependencies between test files and the files they test.
+## We do this without the file and eval directly, but then we would
+## have to run Emacs for every make invocation, and it might not be
+## available during clean.
+-include make-test-deps.mk
+
+## Re-run all the tests every time.
+check:
+ -@for f in $(LOGFILES); do test ! -f $$f || mv $$f $$f~; done
+ @${MAKE} check-maybe
+
+## Only re-run tests whose .log is older than the test.
+.PHONY: check-maybe
+check-maybe: ${LOGFILES}
+ $(emacs) -l ert -f ert-summarize-tests-batch-and-exit $^
+
+.PHONY: mostlyclean clean bootstrap-clean distclean maintainer-clean
+
+clean mostlyclean:
+ -rm -f ${LOGFILES} ${LOGSAVEFILES}
+ -rm make-test-deps.mk
+
+bootstrap-clean: clean
+ -rm -f ${ELCFILES}
+
+distclean: clean
+ rm -f Makefile
+
+maintainer-clean: distclean bootstrap-clean
+
+make-test-deps.mk: $(ELFILES) make-test-deps.emacs-lisp
+ $(EMACS) --batch -l $(srcdir)/make-test-deps.emacs-lisp \
+ --eval "(make-test-deps \"$(srcdir)\")" \
+ 2> $@
+# Makefile ends here.
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; abbrev-tests.el --- Test suite for abbrevs -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Eli Zaretskii <eliz@gnu.org>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; auto-revert-tests.el --- Tests of auto-revert
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.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, 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
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; calc-tests.el --- tests for calc -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
+
+;; Author: Leo Liu <sdl.web@gmail.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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:
--- /dev/null
- ;; Copyright (C) 2005, 2008-2015 Free Software Foundation, Inc.
+;; icalendar-tests.el --- Test suite for icalendar.el
+
++;; Copyright (C) 2005, 2008-2016 Free Software Foundation, Inc.
+
+;; Author: Ulf Jasper <ulf.jasper@web.de>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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:<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2//EN\"><html><head><META NAME=\"Generator\" CONTENT=\"MS Exchange Server version 08.00.0681.000\"><title></title></head><body><b><font face=\"Calibri\" size=\"3\">Reisereferanse</p></body></html>
+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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; character-fold-tests.el --- Tests for character-fold.el -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
+
+;; 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 '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))))
+
+\f
+(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
--- /dev/null
- ;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
+;;; comint-testsuite.el
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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 <at> 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
--- /dev/null
- ;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; descr-text-test.el --- ERT tests for descr-text.el -*- lexical-binding: t -*-
+
++;; Copyright (C) 2014, 2016 Free Software Foundation, Inc.
+
+;; Author: Michal Nazarewicz <mina86@mina86.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/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; electric-tests.el --- tests for electric.el
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: João Távora <joaotavora@gmail.com>
+;; 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:
+
+;; 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))))))
+\f
+;;; 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-")
+
+\f
+;;; 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---")
+
+
+
+\f
+;;; 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")))
+
+\f
+;;; 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)
+
+\f
+;;; 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)
+
+\f
+;;; 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 . ((?\` . ?\')))))
+
+\f
+;;; `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)))
+
+\f
+;;; 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))))))
+
+\f
+;;; 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)))))))
+
+
+\f
+;;; 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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+
+;; 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:
+
+(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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el -*- lexical-binding:t -*-
+
++;; 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
--- /dev/null
- ;; Copyright (C) 2005, 2008, 2010, 2013-2015 Free Software Foundation,
+;;; eieio-testsinvoke.el -- eieio tests for method invocation
+
++;; Copyright (C) 2005, 2008, 2010, 2013-2016 Free Software Foundation,
+;; Inc.
+
+;; Author: Eric M. Ludlam <zappo@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 <http://www.gnu.org/licenses/>.
+
+;;; 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))))
--- /dev/null
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;;; eieio-persist.el --- Tests for eieio-persistent class
+
++;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software
+;;; eieio-tests.el -- eieio tests routines
+
++;; Copyright (C) 1999-2003, 2005-2010, 2012-2016 Free Software
+;; Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@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 <http://www.gnu.org/licenses/>.
+
+;;; 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)))
+
+\f
+;;; 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))))
+
+\f
+;;; 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
--- /dev/null
- ;; Copyright (C) 2007-2008, 2010-2015 Free Software Foundation, Inc.
+;;; ert-tests.el --- ERT's self-tests -*- lexical-binding: t -*-
+
++;; Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc.
+
+;; Author: Christian Ohler <ohler@gnu.org>
+
+;; 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 <passing-test> <failing-test> "
+ "<skipped-test>)\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:
--- /dev/null
- ;; Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc.
+;;; ert-x-tests.el --- Tests for ert-x.el
+
++;; Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc.
+
+;; Author: Phil Hagelberg
+;; Christian Ohler <ohler@gnu.org>
+
+;; 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 <passing-test> <failing-test> "
+ "<skipped-test>)\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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*-
+
++;; 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:
+
+(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)))
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; let-alist.el --- tests for file handling. -*- lexical-binding: t; -*-
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; map-tests.el --- Tests for map.el -*- lexical-binding:t -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Nicolas Petton <nicolas@petton.fr>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; advice-tests.el --- Test suite for the new advice thingy.
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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.
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; package-test.el --- Tests for the Emacs package system
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Daniel Hackney <dan@haxney.org>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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))))))
+
+
+\f
+;;; 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
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; pcase-tests.el --- Test suite for pcase macro.
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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.
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; regexp-tests.el --- Test suite for regular expression handling.
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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 '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.
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; seq-tests.el --- Tests for sequences.el
+
++;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
+
+;; Author: Nicolas Petton <nicolas@petton.fr>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; subr-x-tests.el --- Testing the extended lisp routines
+
++;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
+
+;; Author: Fabián E. Gallina <fgallina@gnu.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:
+
+(require 'ert)
+(require 'subr-x)
+
+\f
+;; 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)))))
+
+\f
+;; 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)))))
+
+\f
+;; 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"))))
+\f
+;; 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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; tabulated-list-test.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Artur Malabarba <bruce.connor.am@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 '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))
+
+\f
+;;; 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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; thunk-tests.el --- Tests for thunk.el -*- lexical-binding: t -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Nicolas Petton <nicolas@petton.fr>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; timer-tests.el --- tests for timers -*- lexical-binding:t -*-
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; epg-tests.el --- Test suite for epg.el -*- lexical-binding: t -*-
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 1999-2015 Free Software Foundation, Inc.
+;;; tests/eshell.el --- Eshell test suite
+
++;; Copyright (C) 1999-2016 Free Software Foundation, Inc.
+
+;; Author: John Wiegley <johnw@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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; faces-tests.el --- Tests for faces.el -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
+;; 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/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; file-notify-tests.el --- Tests of file notifications -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.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, 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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; auth-source-tests.el --- Tests for auth-source.el -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Damien Cassou <damien@cassou.me>,
+;; Nicolas Petton <nicolas@petton.fr>
+
+;; 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 '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
--- /dev/null
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;;; gnus-tests.el --- Wrapper for the Gnus tests
+
++;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Teodor Zlatanov <tzz@lifelogs.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/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; message-mode-tests.el --- Tests for message-mode -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: João Távora <joaotavora@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/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; help-fns.el --- tests for help-fns.el
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; imenu-tests.el --- Test suite for imenu.
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Masatake YAMATO <yamato@redhat.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; info-xref.el --- tests for info-xref.el
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2002-2015 Free Software Foundation, Inc.
+;;; mule-util --- tests for international/mule-util.el
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; isearch-tests.el --- Tests for isearch.el -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
+
+;; 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 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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; json-tests.el --- Test suite for json.el
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Dmitry Gutov <dgutov@yandex.ru>
+
+;; 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 '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
--- /dev/null
- ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
+;;; bytecomp-testsuite.el
+
++;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+;; Author: Shigeru Fukaya <shigeru.fukaya@gmail.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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)
+
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; coding-tests.el --- tests for text encoding and decoding
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Eli Zaretskii <eliz@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 <http://www.gnu.org/licenses/>.
+
+;;; 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)))
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; core-elisp-tests.el --- Testing some core Elisp rules
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; decoder-tests.el --- test for text decoder
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Kenichi Handa <handa@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 <http://www.gnu.org/licenses/>.
+
+;;; 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)))
+
+\f
+;;; 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)))
+
+\f
+;;; 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)))
+
+\f
+;;; 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)))))))
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; files.el --- tests for file handling.
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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.
+\f
+
+;;; files.el ends here
--- /dev/null
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;;; font-parse-tests.el --- Test suite for font parsing.
+
++;; Copyright (C) 2011-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-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.
--- /dev/null
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;;; lexbind-tests.el --- Testing the lexbind byte-compiler
+
++;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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:
+
+(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
--- /dev/null
- ;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
+;;; occur-tests.el --- Test suite for occur.
+
++;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
+
+;; Author: Juri Linkov <juri@jurta.org>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; process-tests.el --- Testing the process facilities
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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)
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; syntax-tests.el --- Testing syntax rules and basic movement -*- lexical-binding: t -*-
+
++;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
+
+;; Author: Daniel Colascione <dancol@dancol.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:
+(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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; textprop-tests.el --- Test suite for text properties.
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Wolfgang Jenkner <wjenkner@inode.at>
+;; 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)
+
+(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)))))
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; undo-tests.el --- Tests of primitive-undo
+
++;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
+
+;; Author: Aaron S. Hawley <aaron.s.hawley@gmail.com>
+
+;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; man-tests.el --- Test suite for man.
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Wolfgang Jenkner <wjenkner@inode.at>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; completion-tests.el --- Tests for completion functions -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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:
+
+(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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; dbus-tests.el --- Tests of D-Bus integration into Emacs
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.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, 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
--- /dev/null
- ;; Copyright (C) 2003-2015 Free Software Foundation, Inc.
+;;; newsticker-testsuite.el --- Test suite for newsticker.
+
++;; Copyright (C) 2003-2016 Free Software Foundation, Inc.
+
+;; Author: Ulf Jasper <ulf.jasper@web.de>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; sasl-scram-rfc-tests.el --- tests for SCRAM-SHA-1 -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
+
+;; Author: Magnus Henoch <magnus.henoch@gmail.com>
+
+;; 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:
+
+;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; tramp-tests.el --- Tests of remote file access
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.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, 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 <TAB>.
+ (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))
+ "<foo>bar<baz>")
+ "(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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; obarray-tests.el --- Tests for obarray -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Przemysław Wojnowski <esperanto@cumego.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/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;;; compile-tests.el --- Test suite for font parsing.
+
++;; Copyright (C) 2011-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/>.
+
+;;; 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 <panel.h> ..."
+ 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 </geroup>, got </group>\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 <fdjsk>"
+ 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.
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; elisp-mode-tests.el --- Tests for emacs-lisp-mode -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Dmitry Gutov <dgutov@yandex.ru>
+;; Author: Stephen Leake <stephen_leake@member.fsf.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)
+(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
--- /dev/null
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;;; f90.el --- tests for progmodes/f90.el
+
++;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Glenn Morris <rgm@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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;;; flymake-tests.el --- Test suite for flymake
+
++;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Eduard Wiebe <usenet@pusto.de>
+
+;; 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 'flymake)
+
+(defvar flymake-tests-data-directory
+ (expand-file-name "lisp/progmodes/flymake-resources" (getenv "EMACS_TEST_DIRECTORY"))
+ "Directory containing flymake test data.")
+
+\f
+;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; python-tests.el --- Test suite for python.el
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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)))))
+
+\f
+;;; 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)))))
+
+\f
+;;; Bindings
+
+\f
+;;; Python specialized rx
+
+\f
+;;; 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))))))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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")))))
+
+\f
+;;; 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')
+"))))
+
+
+\f
+;;; 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))))
+
+
+
+\f
+;;; PDB Track integration
+
+\f
+;;; Symbol completion
+
+\f
+;;; Fill paragraph
+
+\f
+;;; Skeletons
+
+\f
+;;; FFAP
+
+\f
+;;; Code check
+
+\f
+;;; 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"))))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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))))
+
+\f
+;;; 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 "\\("))))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; ruby-mode-tests.el --- Test suite for ruby-mode
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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 <<asd\n" 3 ?\n)
+ (ruby-assert-state "class <<asd\n" 3 nil))
+
+(ert-deftest ruby-heredoc-font-lock ()
+ (let ((s "foo <<eos.gsub('^ *', '')"))
+ (ruby-assert-face s 9 font-lock-string-face)
+ (ruby-assert-face s 10 nil)))
+
+(ert-deftest ruby-singleton-class-no-heredoc-font-lock ()
+ (ruby-assert-face "class<<a" 8 nil))
+
+(ert-deftest ruby-heredoc-highlights-interpolations ()
+ (ruby-assert-face "s = <<EOS\n #{foo}\nEOS" 15 font-lock-variable-name-face))
+
+(ert-deftest ruby-no-heredoc-inside-quotes ()
+ (ruby-assert-state "\"<<\", \"\",\nfoo" 3 nil))
+
+(ert-deftest ruby-exit!-font-lock ()
+ (ruby-assert-face "exit!" 5 font-lock-builtin-face))
+
+(ert-deftest ruby-deep-indent ()
+ (let ((ruby-deep-arglist nil)
+ (ruby-deep-indent-paren '(?\( ?\{ ?\[ ?\] t)))
+ (ruby-should-indent "foo = [1,\n2" 7)
+ (ruby-should-indent "foo = {a: b,\nc: d" 7)
+ (ruby-should-indent "foo(a,\nb" 4)))
+
+(ert-deftest ruby-deep-indent-disabled ()
+ (let ((ruby-deep-arglist nil)
+ (ruby-deep-indent-paren nil))
+ (ruby-should-indent "foo = [\n1" ruby-indent-level)
+ (ruby-should-indent "foo = {\na: b" ruby-indent-level)
+ (ruby-should-indent "foo(\na" ruby-indent-level)))
+
+(ert-deftest ruby-indent-after-keyword-in-a-string ()
+ (ruby-should-indent "a = \"abc\nif\"\n " 0)
+ (ruby-should-indent "a = %w[abc\n def]\n " 0)
+ (ruby-should-indent "a = \"abc\n def\"\n " 0))
+
+(ert-deftest ruby-regexp-doesnt-start-in-string ()
+ (ruby-assert-state "'(/', /\d+/" 3 nil))
+
+(ert-deftest ruby-regexp-starts-after-string ()
+ (ruby-assert-state "'(/', /\d+/" 3 ?/ 8))
+
+(ert-deftest ruby-regexp-interpolation-is-highlighted ()
+ (ruby-assert-face "/#{foobs}/" 4 font-lock-variable-name-face))
+
+(ert-deftest ruby-regexp-skips-over-interpolation ()
+ (ruby-assert-state "/#{foobs.join('/')}/" 3 nil))
+
+(ert-deftest ruby-regexp-continues-till-end-when-unclosed ()
+ (ruby-assert-state "/bars" 3 ?/))
+
+(ert-deftest ruby-regexp-can-be-multiline ()
+ (ruby-assert-state "/bars\ntees # toots \nfoos/" 3 nil))
+
+(ert-deftest ruby-slash-symbol-is-not-mistaken-for-regexp ()
+ (ruby-assert-state ":/" 3 nil))
+
+(ert-deftest ruby-slash-char-literal-is-not-mistaken-for-regexp ()
+ (ruby-assert-state "?/" 3 nil))
+
+(ert-deftest ruby-indent-simple ()
+ (ruby-should-indent-buffer
+ "if foo
+ | bar
+ |end
+ |zot
+ |"
+ "if foo
+ |bar
+ | end
+ | zot
+ |"))
+
+(ert-deftest ruby-indent-keyword-label ()
+ (ruby-should-indent-buffer
+ "bar(class: XXX) do
+ | foo
+ |end
+ |bar
+ |"
+ "bar(class: XXX) do
+ | foo
+ | end
+ | bar
+ |"))
+
+(ert-deftest ruby-indent-method-with-question-mark ()
+ (ruby-should-indent-buffer
+ "if x.is_a?(XXX)
+ | foo
+ |end
+ |"
+ "if x.is_a?(XXX)
+ | foo
+ | end
+ |"))
+
+(ert-deftest ruby-indent-expr-in-regexp ()
+ (ruby-should-indent-buffer
+ "if /#{foo}/ =~ s
+ | x = 1
+ |end
+ |"
+ "if /#{foo}/ =~ s
+ | x = 1
+ | end
+ |"))
+
+(ert-deftest ruby-indent-singleton-class ()
+ (ruby-should-indent-buffer
+ "class<<bar
+ | foo
+ |end
+ |"
+ "class<<bar
+ |foo
+ | end
+ |"))
+
+(ert-deftest ruby-indent-inside-heredoc-after-operator ()
+ (ruby-should-indent-buffer
+ "b=<<eos
+ | 42"
+ "b=<<eos
+ | 42"))
+
+(ert-deftest ruby-indent-inside-heredoc-after-space ()
+ (ruby-should-indent-buffer
+ "foo <<eos.gsub(' ', '*')
+ | 42"
+ "foo <<eos.gsub(' ', '*')
+ | 42"))
+
+(ert-deftest ruby-indent-array-literal ()
+ (let ((ruby-deep-indent-paren nil))
+ (ruby-should-indent-buffer
+ "foo = [
+ | bar
+ |]
+ |"
+ "foo = [
+ | bar
+ | ]
+ |"))
+ (ruby-should-indent-buffer
+ "foo do
+ | [bar]
+ |end
+ |"
+ "foo do
+ |[bar]
+ | end
+ |"))
+
+(ert-deftest ruby-indent-begin-end ()
+ (ruby-should-indent-buffer
+ "begin
+ | a[b]
+ |end
+ |"
+ "begin
+ | a[b]
+ | end
+ |"))
+
+(ert-deftest ruby-indent-array-after-paren-and-space ()
+ (ruby-should-indent-buffer
+ "class A
+ | def foo
+ | foo( [])
+ | end
+ |end
+ |"
+ "class A
+ | def foo
+ |foo( [])
+ |end
+ | end
+ |"))
+
+(ert-deftest ruby-indent-after-block-in-continued-expression ()
+ (ruby-should-indent-buffer
+ "var =
+ | begin
+ | val
+ | end
+ |statement"
+ "var =
+ |begin
+ |val
+ |end
+ |statement"))
+
+(ert-deftest ruby-indent-spread-args-in-parens ()
+ (let ((ruby-deep-indent-paren '(?\()))
+ (ruby-should-indent-buffer
+ "foo(1,
+ | 2,
+ | 3)
+ |"
+ "foo(1,
+ | 2,
+ | 3)
+ |")))
+
+(ert-deftest ruby-align-to-stmt-keywords-t ()
+ (let ((ruby-align-to-stmt-keywords t))
+ (ruby-should-indent-buffer
+ "foo = if bar?
+ | 1
+ |else
+ | 2
+ |end
+ |
+ |foo || begin
+ | bar
+ |end
+ |
+ |foo ||
+ | begin
+ | bar
+ | end
+ |"
+ "foo = if bar?
+ | 1
+ |else
+ | 2
+ | end
+ |
+ | foo || begin
+ | bar
+ |end
+ |
+ | foo ||
+ | begin
+ |bar
+ | end
+ |")
+ ))
+
+(ert-deftest ruby-align-to-stmt-keywords-case ()
+ (let ((ruby-align-to-stmt-keywords '(case)))
+ (ruby-should-indent-buffer
+ "b = case a
+ |when 13
+ | 6
+ |else
+ | 42
+ |end"
+ "b = case a
+ | when 13
+ | 6
+ | else
+ | 42
+ | end")))
+
+(ert-deftest ruby-align-chained-calls ()
+ (let ((ruby-align-chained-calls t))
+ (ruby-should-indent-buffer
+ "one.two.three
+ | .four
+ |
+ |my_array.select { |str| str.size > 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 "\"<ul><li>#{@files.join(\"</li><li>\")}</li></ul>\""))
+ (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
--- /dev/null
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;;; subword-tests.el --- Testing the subword rules
+
++;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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:
+
+(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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; replace-tests.el --- tests for replace.el.
+
++;; 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 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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; simple-test.el --- Tests for simple.el -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
+
+;; 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)
+
+(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)))))
+
+\f
+;;; `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)"))))
+
+\f
+;;; `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))))
+
+\f
+;;; `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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; sort-tests.el --- Tests for sort.el -*- lexical-binding: t; -*-
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
+
+;; 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 '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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; subr-tests.el --- Tests for subr.el
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Oleh Krehel <ohwoeowho@gmail.com>,
+;; Nicolas Petton <nicolas@petton.fr>
+;; 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)
+
+(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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; reftex-tests.el --- Test suite for reftex. -*- lexical-binding: t -*-
+
++;; Copyright (C) 2013-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)
+
+;;; 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.
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; sgml-mode-tests.el --- Tests for sgml-mode
+
++;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Przemysław Wojnowski <esperanto@cumego.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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 "<p>Valar Morghulis</p>"))
+ (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
+ "<br />"
+ (sgml-delete-tag 1)
+ (should (string= "" (buffer-string))))
+ ;; Delete from position on whitespaces before tag:
+ (sgml-with-content
+ " \t\n<br />"
+ (sgml-delete-tag 1)
+ (should (string= "" (buffer-string))))
+ ;; Delete from position on tag:
+ (sgml-with-content
+ "<br />"
+ (goto-char 3)
+ (sgml-delete-tag 1)
+ (should (string= "" (buffer-string))))
+ ;; Delete one by one:
+ (sgml-with-content
+ "<h1><p>You know nothing, Jon Snow.</p></h1>"
+ (sgml-delete-tag 1)
+ (should (string= "<p>You know nothing, Jon Snow.</p>" (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
+ "<h1><p>You know nothing, Jon Snow.</p></h1>"
+ (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
+ "<ul><li>Keep your stones connected.</ul>"
+ (goto-char 5) ; position on "li" tag
+ (sgml-delete-tag 1)
+ (should (string= "<ul>Keep your stones connected.</ul>" (buffer-string)))))
+
+(ert-deftest sgml-delete-tag-should-signal-error-for-malformed-tags ()
+ (let ((content "<h1><h2>Drakaris!</h1></h2>"))
+ ;; Delete outside tag:
+ (sgml-with-content
+ content
+ (sgml-delete-tag 1)
+ (should (string= "<h2>Drakaris!</h2>" (buffer-string))))
+ ;; Delete inner tag:
+ (sgml-with-content
+ content
+ (goto-char 5) ; position the inner tag
+ (sgml-delete-tag 1)
+ (should (string= "<h1>Drakaris!</h1>" (buffer-string))))))
+
+(ert-deftest sgml-delete-tag-should-signal-error-when-deleting-too-much ()
+ (let ((content "<emph>Drakaris!</emph>"))
+ ;; 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
+ "<title>Winter is comin'</title>"
+ (sgml-delete-tag 1)
+ (should (string= "Winter is comin'" (buffer-string)))))
+
+(provide 'sgml-mode-tests)
+;;; sgml-mode-tests.el ends here
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; tildify-test.el --- ERT tests for tildify.el -*- lexical-binding: t -*-
+
++;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
+
+;; Author: Michal Nazarewicz <mina86@mina86.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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, <pre> tag is not treated specially."
+ (let ((with-nbsp (or with-nbsp sentence)))
+ (concat "<p>" with-nbsp "</p>\n"
+ "<pre>" (if is-xml with-nbsp sentence) "</pre>\n"
+ "<! -- " sentence " -- >\n"
+ "<p>" with-nbsp "</p>\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) " " "<pre>"))
+
+(ert-deftest tildify-space-test-html-nbsp ()
+ "Tests auto-tildification in an HTML document"
+ (tildify-space-test--test '(html-mode sgml-mode) " " "<pre>" t))
+
+(ert-deftest tildify-space-test-xml ()
+ "Tests auto-tildification in an XML document"
+ (tildify-space-test--test '(nxml-mode) " " "<! -- "))
+
+(ert-deftest tildify-space-test-tex ()
+ "Tests tildification in a TeX document"
+ (tildify-space-test--test '(tex-mode latex-mode plain-tex-mode)
+ "~" "\\verb# "))
+
+
+(defun tildify-space-undo-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 double-space-undos in "
+ (symbol-name mode) "\n")))
+ (erase-buffer)
+ (insert header "Lorem v" nbsp " ")
+ (should (not (tildify-space)))
+ (should (string-equal (concat header "Lorem v ") (buffer-string)))))))
+
+(ert-deftest tildify-space-undo-test-html ()
+ "Tests auto-tildification in an HTML document"
+ (tildify-space-undo-test--test '(html-mode sgml-mode) " " "<pre>"))
+
+(ert-deftest tildify-space-undo-test-html-nbsp ()
+ "Tests auto-tildification in an HTML document"
+ (tildify-space-undo-test--test '(html-mode sgml-mode) " " "<pre>" t))
+
+(ert-deftest tildify-space-undo-test-xml ()
+ "Tests auto-tildification in an XML document"
+ (tildify-space-undo-test--test '(nxml-mode) " " "<! -- "))
+
+(ert-deftest tildify-space-undo-test-tex ()
+ "Tests tildification in a TeX document"
+ (tildify-space-undo-test--test '(tex-mode latex-mode plain-tex-mode)
+ "~" "\\verb# "))
+
+
+
+(provide 'tildify-tests)
+
+;;; tildify-tests.el ends here
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; thingatpt.el --- tests for thing-at-point.
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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)
+ ("<url:>" 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")
+ ;; <url:...> markup
+ ("Url: <url:foo://1.example.com>..." 8 url "foo://1.example.com")
+ ("Url: <url:foo://2.example.com>..." 30 url "foo://2.example.com")
+ ("Url: <url:foo://www.gnu.org/a bc>..." 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 <http://12.gnu.org> now." 8 url "http://12.gnu.org")
+ ("Go to <http://13.gnu.org> 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
+ ("<url:foo@example.com>" 1 url "mailto:foo@example.com")
+ ("<url:ftp.example.net/abc/>" 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
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; url-expand-tests.el --- Test suite for relative URI/URL resolution.
+
++;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
+
+;; Author: Alain Schneble <a.s@realize.ch>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;;; url-future-tests.el --- Test suite for url-future.
+
++;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Teodor Zlatanov <tzz@lifelogs.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; url-parse-tests.el --- Test suite for URI/URL parsing.
+
++;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
+
+;; Author: Alain Schneble <a.s@realize.ch>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; url-util-tests.el --- Test suite for url-util.
+
++;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
+
+;; Author: Teodor Zlatanov <tzz@lifelogs.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; add-log-tests.el --- Test suite for add-log.
+
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Masatake YAMATO <yamato@redhat.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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><oc"
+"><" "DIR")
+
+(provide 'add-log-tests)
+
+;;; add-log-tests.el ends here
--- /dev/null
- ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;;; vc-bzr.el --- tests for vc/vc-bzr.el
+
++;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Glenn Morris <rgm@gnu.org>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; vc-tests.el --- Tests of different backends of vc.el
+
++;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.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, 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
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; xml-parse-tests.el --- Test suite for XML parsing.
+
++;; Copyright (C) 2012-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-xml-parse RET to generate the test buffer.
+
+;;; Code:
+
+(require 'ert)
+(require 'xml)
+
+(defvar xml-parse-tests--data
+ `(;; General entity substitution
+ ("<?xml version=\"1.0\"?><!DOCTYPE foo SYSTEM \"bar.dtd\" [<!ENTITY ent \"AbC\">]><foo a=\"b\"><bar>&ent;;</bar></foo>" .
+ ((foo ((a . "b")) (bar nil "AbC;"))))
+ ("<?xml version=\"1.0\"?><foo>&amp;&apos;'<>"</foo>" .
+ ((foo () "&''<>\"")))
+ ;; Parameter entity substitution
+ ("<?xml version=\"1.0\"?><!DOCTYPE foo SYSTEM \"bar.dtd\" [<!ENTITY % pent \"AbC\"><!ENTITY ent \"%pent;\">]><foo a=\"b\"><bar>&ent;;</bar></foo>" .
+ ((foo ((a . "b")) (bar nil "AbC;"))))
+ ;; Tricky parameter entity substitution (like XML spec Appendix D)
+ ("<?xml version='1.0'?><!DOCTYPE foo [ <!ENTITY % xx '%zz;'><!ENTITY % zz '<!ENTITY ent \"b\" >' > %xx; ]><foo>A&ent;C</foo>" .
+ ((foo () "AbC")))
+ ;; Bug#7172
+ ("<?xml version=\"1.0\"?><!DOCTYPE foo [ <!ELEMENT EXAM_PLE EMPTY> ]><foo></foo>" .
+ ((foo ())))
+ ;; Entities referencing entities, in character data
+ ("<!DOCTYPE foo [ <!ENTITY b \"B\"><!ENTITY abc \"a&b;c\">]><foo>&abc;</foo>" .
+ ((foo () "aBc")))
+ ;; Entities referencing entities, in attribute values
+ ("<!DOCTYPE foo [ <!ENTITY b \"B\"><!ENTITY abc \"a&b;c\">]><foo a=\"-&abc;-\">1</foo>" .
+ ((foo ((a . "-aBc-")) "1")))
+ ;; Character references must be treated as character data
+ ("<foo>AT&T;</foo>" . ((foo () "AT&T;")))
+ ("<foo>&amp;</foo>" . ((foo () "&")))
+ ("<foo>&amp;</foo>" . ((foo () "&")))
+ ;; Unusual but valid XML names [5]
+ ("<ÀÖØö.3·-‿⁀>abc</ÀÖØö.3·-‿⁀>" . ((,(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
+ "<!DOCTYPE foo [<!ENTITY lol \"lol\"><!ENTITY lol1 \"&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;\"><!ENTITY lol2 \"&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;\">]><foo>&lol2;</foo>"
+ ;; XML bomb in attribute value
+ "<!DOCTYPE foo [<!ENTITY lol \"lol\"><!ENTITY lol1 \"&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;\"><!ENTITY lol2 \"&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;\">]><foo a=\"&lol2;\">!</foo>"
+ ;; Non-terminating DTD
+ "<!DOCTYPE foo [ <!ENTITY b \"B\"><!ENTITY abc \"a&b;c\">"
+ "<!DOCTYPE foo [ <!ENTITY b \"B\"><!ENTITY abc \"a&b;c\">asdf"
+ "<!DOCTYPE foo [ <!ENTITY b \"B\"><!ENTITY abc \"a&b;c\">asdf&abc;"
+ ;; Invalid XML names
+ "<0foo>abc</0foo>"
+ "<‿foo>abc</‿foo>"
+ "<f¿>abc</f¿>")
+ "List of XML strings that should signal an error in the parser")
+
+(defvar xml-parse-tests--qnames
+ '( ;; Test data for name expansion
+ ("<?xml version=\"1.0\" encoding=\"UTF-8\"?><D:multistatus xmlns:D=\"DAV:\"><D:response><D:href>/calendar/events/</D:href><D:propstat><D:status>HTTP/1.1 200 OK</D:status></D:propstat></D:response></D:multistatus>"
+ ;; 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"))))))
+ ("<?xml version=\"1.0\" encoding=\"UTF-8\"?><F:something>hi there</F:something>"
+ ((("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.
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; biditest.el --- test bidi reordering in GNU Emacs display engine.
+
++;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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)
--- /dev/null
- ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
+;;; cedet-utests.el --- Run all unit tests in the CEDET suite.
+
++;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+;;; 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 "<Press a key> Pulse one line.")
+ (read-char))
+ (pulse-momentary-highlight-one-line (point))
+ (when (interactive-p)
+ (message "<Press a key> 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 "<Press a key> Pulse line a specific color.")
+ (read-char))
+ (pulse-momentary-highlight-one-line (point) 'modeline)
+ (when (interactive-p)
+ (message "<Press a key> 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
--- /dev/null
- ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
+;;; ede-tests.el --- Some tests for the Emacs Development Environment
+
++;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+;;; 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
--- /dev/null
- ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
+;;; semantic-ia-utest.el --- Analyzer unit tests
+
++;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+;;; 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) "<No tag found>")
+ (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
--- /dev/null
- ;;; Copyright (C) 2003-2004, 2007-2015 Free Software Foundation, Inc.
+;;; semantic-utest.el --- Miscellaneous Semantic tests.
+
++;;; Copyright (C) 2003-2004, 2007-2016 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@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 <http://www.gnu.org/licenses/>.
+
+;;; 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))
+ )
--- /dev/null
- ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
+;;; semantic-utest-c.el --- C based parsing tests.
+
++;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+;;; 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
--- /dev/null
- ;;; Copyright (C) 2003-2004, 2007-2015 Free Software Foundation, Inc.
+;;; semantic-utest.el --- Tests for semantic's parsing system.
+
++;;; Copyright (C) 2003-2004, 2007-2016 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@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 <http://www.gnu.org/licenses/>.
+
+;;; 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 <stdio.h>
+#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
+ "
+<html>
+ <body>
+ <h1>hello</h1>
+ </body><!--1-->
+</html>
+"
+ )
+
+(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
+ "<?php
+
+function fun1(){
+ return \"fun1\";
+}
+
+function fun2($arg1){
+ $output = \"argument to fun2: \" . $arg1;
+ return $output;
+}
+
+class aClass {
+ public function fun1($a, $b){
+ return $a;
+ }
+
+ public function fun2($a, $b){
+ return $b;
+ }
+}
+?> "
+ )
+
+(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") "<!--1-->" "<!--deleted line-->")
+ ))
+
+(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 from \\([0-9]+\\) to \\([0-9]+\\) in \\([^>]*\\)>"
+;#<overlay from \([0-9]+\) to \([0-9]+\) in \([^>]*\)>
+;(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
--- /dev/null
- ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
+;;; srecode-tests.el --- Some tests for CEDET's srecode
+
++;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+;;; 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
--- /dev/null
- Copyright (C) 2001-2015 Free Software Foundation, Inc.
+/* test.c --- Semantic unit test for C.
+
++ Copyright (C) 2001-2016 Free Software Foundation, Inc.
+
+ Author: Eric M. Ludlam <eric@siege-engine.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/>.
+*/
+
+/* Attempt to include as many aspects of the C language as possible.
+ */
+
+/* types of include files */
+#include "includeme1.h"
+#include <includeme2.h>
+#include <subdir/includeme3.h>
+#include <includeme.notanhfile>
+#include <stdlib.h>
+#include <cmath>
+
+#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 */
+
--- /dev/null
- ;; Copyright (C) 2005-2015 Free Software Foundation, Inc.
+;;; test.el --- Unit test file for Semantic Emacs Lisp support.
+
++;; Copyright (C) 2005-2016 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+;;; 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)
--- /dev/null
- # Copyright (C) 2001-2002, 2010-2015 Free Software Foundation, Inc.
+# test.make --- Semantic unit test for Make -*- makefile -*-
+
++# Copyright (C) 2001-2002, 2010-2016 Free Software Foundation, Inc.
+
+# Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+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
--- /dev/null
- // Copyright (C) 2008-2015 Free Software Foundation, Inc.
+// testdoublens.cpp --- semantic-ia-utest completion engine unit tests
+
++// Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+// Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+#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
+
--- /dev/null
- // Copyright (C) 2008-2015 Free Software Foundation, Inc.
+// testdoublens.hpp --- Header file used in one of the Semantic tests
+
++// Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+// Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+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
+
--- /dev/null
- // Copyright (C) 2009-2015 Free Software Foundation, Inc.
+// testjavacomp.java --- Semantic unit test for Java
+
++// Copyright (C) 2009-2016 Free Software Foundation, Inc.
+
+// Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+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
--- /dev/null
- * Copyright (C) 2009-2015 Free Software Foundation, Inc.
+/** testpolymorph.cpp --- A sequence of polymorphism examples.
+ *
++ * Copyright (C) 2009-2016 Free Software Foundation, Inc.
+ *
+ * Author: Eric M. Ludlam <eric@siege-engine.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/>.
+ */
+
+#include <cmath>
+
+// 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 <typename T> class test
+ {
+ public:
+ void doSomething(T t) { };
+ };
+
+ template <typename T> class test<T *>
+ {
+ public:
+ void doSomething(T* t) { };
+ };
+}
+
+// Test 5 - Templates w/ full specialization which may or may not share
+// common functions.
+namespace template_full_spec {
+ template <typename T> class test
+ {
+ public:
+ void doSomething(T t) { };
+ void doSomethingElse(T t) { };
+ };
+
+ template <> class test<int>
+ {
+ public:
+ void doSomethingElse(int t) { };
+ void doSomethingCompletelyDifferent(int t) { };
+ };
+}
+
+// Test 6 - Dto., but for templates with multiple parameters.
+namespace template_multiple_spec {
+ template <typename T1, typename T2> class test
+ {
+ public:
+ void doSomething(T1 t) { };
+ void doSomethingElse(T2 t) { };
+ };
+
+ template <typename T2> class test<int, T2>
+ {
+ public:
+ void doSomething(int t) { };
+ void doSomethingElse(T2 t) { };
+ };
+
+ template <> class test<float, int>
+ {
+ public:
+ void doSomething(float t) { };
+ void doSomethingElse(int t) { };
+ void doNothing(void) { };
+ };
+}
+
+
+// End of polymorphism test file.
--- /dev/null
- Copyright (C) 2007-2015 Free Software Foundation, Inc.
+/* testspp.cpp --- Semantic unit test for the C preprocessor
+
++ Copyright (C) 2007-2016 Free Software Foundation, Inc.
+
+ Author: Eric M. Ludlam <eric@siege-engine.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/>.
+*/
+
+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
+
--- /dev/null
- Copyright (C) 2007-2015 Free Software Foundation, Inc.
+/* testsppreplace.c --- unit test for CPP/SPP Replacement
++ Copyright (C) 2007-2016 Free Software Foundation, Inc.
+
+ Author: Eric M. Ludlam <eric@siege-engine.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/>.
+*/
+
+/* 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 <lsdsgster@...> */
+#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 */
+
--- /dev/null
- Copyright (C) 2007-2015 Free Software Foundation, Inc.
+/* testsppreplaced.c --- unit test for CPP/SPP Replacement
++ Copyright (C) 2007-2016 Free Software Foundation, Inc.
+
+ Author: Eric M. Ludlam <eric@siege-engine.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/>.
+*/
+
+/* 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 <lsdsgster@...> */
+
+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 */
--- /dev/null
- // Copyright (C) 2007-2015 Free Software Foundation, Inc.
+// testsubclass.cpp --- unit test for analyzer and complex C++ inheritance
+
++// Copyright (C) 2007-2016 Free Software Foundation, Inc.
+
+// Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+//#include <iostream>
+#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" )
+ ;
+}
+
--- /dev/null
- // Copyright (C) 2007-2015 Free Software Foundation, Inc.
+// testsubclass.hh --- unit test for analyzer and complex C++ inheritance
+
++// Copyright (C) 2007-2016 Free Software Foundation, Inc.
+
+// Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+//#include <cmath>
+// #include <stdio.h>
+
+#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
+
--- /dev/null
- // Copyright (C) 2008-2015 Free Software Foundation, Inc.
+// testtypedefs.cpp --- Sample with some fake bits out of std::string
+
++// Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+// Author: Eric M. Ludlam <eric@siege-engine.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/>.
+
+// Thanks Ming-Wei Chang for these examples.
+
+namespace std {
+ template <T>class basic_string {
+ public:
+ void resize(int);
+ };
+}
+
+typedef std::basic_string<char> mstring;
+
+using namespace std;
+typedef basic_string<char> 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 mytype>
+class TBar
+{
+public:
+ void otherFunc() {}
+};
+
+typedef TBar<char> new_TBar;
+
+int main()
+{
+ new_Bar nb;
+ new_TBar ntb;
+
+ nb.// -3-
+ ;
+ // #3# ("someFunc")
+ ntb.// -4-
+ ;
+ // #4# ("otherFunc")
+ return 0;
+}
+
--- /dev/null
- Copyright (C) 2008-2015 Free Software Foundation, Inc.
+/* testvarnames.cpp
+ Test variable and function names, lists of variables on one line, etc.
+
++ Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+ Author: Eric M. Ludlam <eric@siege-engine.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/>.
+*/
+
+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")
+}
--- /dev/null
- Copyright (C) 1985, 1986, 1993, 1996, 1998 Free Software Foundation, Inc.
+/* Primitives for word-abbrev mode.
++ 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 <config.h>
+#include <stdio.h>
+#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;
+\f
+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;
+}
+\f
+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);
+}
+\f
+/* 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;
+}
+\f
+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;
+}
+\f
+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;
+}
+\f
+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);
+}
--- /dev/null
- Copyright (C) 1990-1993, 1995-1996, 1999, 2002-2007, 2013-2015 Free
+/* Declarations for `malloc' and friends.
++ 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 <http://www.gnu.org/licenses/>.
+
+ 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 <config.h>
+
+#if defined HAVE_PTHREAD && !defined HYBRID_MALLOC
+#define USE_PTHREAD
+#endif
+
+#include <string.h>
+#include <limits.h>
+#include <stdint.h>
+
+#ifdef HYBRID_GET_CURRENT_DIR_NAME
+#undef get_current_dir_name
+#endif
+
+#include <unistd.h>
+
+#ifdef USE_PTHREAD
+#include <pthread.h>
+#endif
+
+#ifdef WINDOWSNT
+#include <w32heap.h> /* 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 <stddef.h>
+
+
+/* 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 <http://www.gnu.org/licenses/>.
+
+ 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 <errno.h>
+
+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 <sys/types.h>
+#include <sys/mman.h>
+
+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);
+}
+\f
+#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 <http://www.gnu.org/licenses/>.
+
+ 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 <http://www.gnu.org/licenses/>.
+
+ 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 <http://www.gnu.org/licenses/>.
+
+ 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 <http://www.gnu.org/licenses/>. */
+
+/* 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 <http://www.gnu.org/licenses/>. */
+
+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 <http://www.gnu.org/licenses/>.
+
+ 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 <http://www.gnu.org/licenses/>.
+
+ 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 <stdio.h>
+
+/* 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 */
--- /dev/null
- Copyright (C) 1985-1989, 1993-1997, 1999-2015 Free Software Foundation,
+/* Keyboard and mouse input; editor command loop.
+
++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 <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include "sysstdio.h"
+#include <sys/stat.h>
+
+#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 <errno.h>
+
+#ifdef HAVE_PTHREAD
+#include <pthread.h>
+#endif
+#ifdef MSDOS
+#include "msdos.h"
+#include <time.h>
+#else /* not MSDOS */
+#include <sys/ioctl.h>
+#endif /* not MSDOS */
+
+#if defined USABLE_FIONREAD && defined USG5_4
+# include <sys/filio.h>
+#endif
+
+#include "syssignal.h"
+
+#include <sys/types.h>
+#include <unistd.h>
+#include <fcntl.h>
+
+#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;
+
+\f
+/* 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;
+}
+
+\f
+/* 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);
+}
+
+\f
+/* 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;
+}
+
+\f
+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
+\f
+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;
+}
+
+\f
+#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 ();
+ }
+}
+
+\f
+/* 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");
+}
+\f
+/* 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;
+}
+
+\f
+/* 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;
+}
+
+\f
+/* 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
+}
+\f
+/* 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);
+ }
+}
+
+
+\f
+/* 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 <brackets>. 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);
+}
+\f
+/* 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);
+}
+
+\f
+/* 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;
+}
+
+\f
+/* 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);
+}
+\f
+/* 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);
+}
+\f
+/* 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;
+}
+\f
+/* 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<<i) <= modifiers && i < NUM_MOD_NAMES; i++)
+ if (modifiers & (1<<i))
+ modifier_list = Fcons (AREF (modifier_symbols, i),
+ modifier_list);
+
+ return modifier_list;
+}
+
+
+/* Parse the modifiers on SYMBOL, and return a list like (UNMODIFIED MASK),
+ where UNMODIFIED is the unmodified form of SYMBOL,
+ MASK is the set of modifiers present in SYMBOL's name.
+ This is similar to parse_modifiers_uncached, but uses the cache in
+ SYMBOL's Qevent_symbol_element_mask property, and maintains the
+ Qevent_symbol_elements property. */
+
+#define KEY_TO_CHAR(k) (XINT (k) & ((1 << CHARACTERBITS) - 1))
+
+Lisp_Object
+parse_modifiers (Lisp_Object symbol)
+{
+ Lisp_Object elements;
+
+ if (INTEGERP (symbol))
+ return list2i (KEY_TO_CHAR (symbol), XINT (symbol) & CHAR_MODIFIER_MASK);
+ else if (!SYMBOLP (symbol))
+ return Qnil;
+
+ elements = Fget (symbol, Qevent_symbol_element_mask);
+ if (CONSP (elements))
+ return elements;
+ else
+ {
+ ptrdiff_t end;
+ int modifiers = parse_modifiers_uncached (symbol, &end);
+ Lisp_Object unmodified;
+ Lisp_Object mask;
+
+ unmodified = Fintern (make_string (SSDATA (SYMBOL_NAME (symbol)) + end,
+ SBYTES (SYMBOL_NAME (symbol)) - end),
+ Qnil);
+
+ if (modifiers & ~INTMASK)
+ emacs_abort ();
+ XSETFASTINT (mask, modifiers);
+ elements = list2 (unmodified, mask);
+
+ /* Cache the parsing results on SYMBOL. */
+ Fput (symbol, Qevent_symbol_element_mask,
+ elements);
+ Fput (symbol, Qevent_symbol_elements,
+ Fcons (unmodified, lispy_modifier_list (modifiers)));
+
+ /* Since we know that SYMBOL is modifiers applied to unmodified,
+ it would be nice to put that in unmodified's cache.
+ But we can't, since we're not sure that parse_modifiers is
+ canonical. */
+
+ return elements;
+ }
+}
+
+DEFUN ("internal-event-symbol-parse-modifiers", Fevent_symbol_parse_modifiers,
+ Sevent_symbol_parse_modifiers, 1, 1, 0,
+ doc: /* Parse the event symbol. For internal use. */)
+ (Lisp_Object symbol)
+{
+ /* Fill the cache if needed. */
+ parse_modifiers (symbol);
+ /* Ignore the result (which is stored on Qevent_symbol_element_mask)
+ and use the Lispier representation stored on Qevent_symbol_elements
+ instead. */
+ return Fget (symbol, Qevent_symbol_elements);
+}
+
+/* Apply the modifiers MODIFIERS to the symbol BASE.
+ BASE must be unmodified.
+
+ This is like apply_modifiers_uncached, but uses BASE's
+ Qmodifier_cache property, if present. It also builds
+ Qevent_symbol_elements properties, since it has that info anyway.
+
+ apply_modifiers copies the value of BASE's Qevent_kind property to
+ the modified symbol. */
+static Lisp_Object
+apply_modifiers (int modifiers, Lisp_Object base)
+{
+ Lisp_Object cache, idx, entry, new_symbol;
+
+ /* Mask out upper bits. We don't know where this value's been. */
+ modifiers &= INTMASK;
+
+ if (INTEGERP (base))
+ return make_number (XINT (base) | modifiers);
+
+ /* The click modifier never figures into cache indices. */
+ cache = Fget (base, Qmodifier_cache);
+ XSETFASTINT (idx, (modifiers & ~click_modifier));
+ entry = assq_no_quit (idx, cache);
+
+ if (CONSP (entry))
+ new_symbol = XCDR (entry);
+ else
+ {
+ /* We have to create the symbol ourselves. */
+ new_symbol = apply_modifiers_uncached (modifiers,
+ SSDATA (SYMBOL_NAME (base)),
+ SCHARS (SYMBOL_NAME (base)),
+ SBYTES (SYMBOL_NAME (base)));
+
+ /* Add the new symbol to the base's cache. */
+ entry = Fcons (idx, new_symbol);
+ Fput (base, Qmodifier_cache, Fcons (entry, cache));
+
+ /* We have the parsing info now for free, so we could add it to
+ the caches:
+ XSETFASTINT (idx, modifiers);
+ Fput (new_symbol, Qevent_symbol_element_mask,
+ list2 (base, idx));
+ Fput (new_symbol, Qevent_symbol_elements,
+ Fcons (base, lispy_modifier_list (modifiers)));
+ Sadly, this is only correct if `base' is indeed a base event,
+ which is not necessarily the case. -stef */
+ }
+
+ /* Make sure this symbol is of the same kind as BASE.
+
+ You'd think we could just set this once and for all when we
+ intern the symbol above, but reorder_modifiers may call us when
+ BASE's property isn't set right; we can't assume that just
+ because it has a Qmodifier_cache property it must have its
+ Qevent_kind set right as well. */
+ if (NILP (Fget (new_symbol, Qevent_kind)))
+ {
+ Lisp_Object kind;
+
+ kind = Fget (base, Qevent_kind);
+ if (! NILP (kind))
+ Fput (new_symbol, Qevent_kind, kind);
+ }
+
+ return new_symbol;
+}
+
+
+/* Given a symbol whose name begins with modifiers ("C-", "M-", etc),
+ return a symbol with the modifiers placed in the canonical order.
+ Canonical order is alphabetical, except for down and drag, which
+ always come last. The 'click' modifier is never written out.
+
+ Fdefine_key calls this to make sure that (for example) C-M-foo
+ and M-C-foo end up being equivalent in the keymap. */
+
+Lisp_Object
+reorder_modifiers (Lisp_Object symbol)
+{
+ /* It's hopefully okay to write the code this way, since everything
+ will soon be in caches, and no consing will be done at all. */
+ Lisp_Object parsed;
+
+ parsed = parse_modifiers (symbol);
+ return apply_modifiers (XFASTINT (XCAR (XCDR (parsed))),
+ XCAR (parsed));
+}
+
+
+/* For handling events, we often want to produce a symbol whose name
+ is a series of modifier key prefixes ("M-", "C-", etcetera) attached
+ to some base, like the name of a function key or mouse button.
+ modify_event_symbol produces symbols of this sort.
+
+ NAME_TABLE should point to an array of strings, such that NAME_TABLE[i]
+ is the name of the i'th symbol. TABLE_SIZE is the number of elements
+ in the table.
+
+ Alternatively, NAME_ALIST_OR_STEM is either an alist mapping codes
+ into symbol names, or a string specifying a name stem used to
+ construct a symbol name or the form `STEM-N', where N is the decimal
+ representation of SYMBOL_NUM. NAME_ALIST_OR_STEM is used if it is
+ non-nil; otherwise NAME_TABLE is used.
+
+ SYMBOL_TABLE should be a pointer to a Lisp_Object whose value will
+ persist between calls to modify_event_symbol that it can use to
+ store a cache of the symbols it's generated for this NAME_TABLE
+ before. The object stored there may be a vector or an alist.
+
+ SYMBOL_NUM is the number of the base name we want from NAME_TABLE.
+
+ MODIFIERS is a set of modifier bits (as given in struct input_events)
+ whose prefixes should be applied to the symbol name.
+
+ SYMBOL_KIND is the value to be placed in the event_kind property of
+ the returned symbol.
+
+ The symbols we create are supposed to have an
+ `event-symbol-elements' property, which lists the modifiers present
+ in the symbol's name. */
+
+static Lisp_Object
+modify_event_symbol (ptrdiff_t symbol_num, int modifiers, Lisp_Object symbol_kind,
+ Lisp_Object name_alist_or_stem, const char *const *name_table,
+ Lisp_Object *symbol_table, ptrdiff_t table_size)
+{
+ Lisp_Object value;
+ Lisp_Object symbol_int;
+
+ /* Get rid of the "vendor-specific" bit here. */
+ XSETINT (symbol_int, symbol_num & 0xffffff);
+
+ /* Is this a request for a valid symbol? */
+ if (symbol_num < 0 || symbol_num >= 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);
+}
+\f
+/* 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);
+}
+\f
+/* 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 <jch@bsdi.com> 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;
+}
+\f
+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 */
+
+\f
+/* 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);
+ }
+}
+
+\f
+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;
+}
+\f
+/* 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);
+ }
+}
+\f
+ /* 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;
+}
+
+
+\f
+/***********************************************************************
+ 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;
+}
+
+
+
+
+\f
+/* 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. */
+ }
+}
+\f
+/* 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);
+}
+\f
+/* 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;
+}
+\f
+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 */
+}
+\f
+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);
+}
+\f
+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);
+ }
+ }
+ }
+}
--- /dev/null
- Copyright (C) 1985-1987, 1993-1995, 1997-2015 Free Software Foundation,
+/* Fundamental definitions for GNU Emacs Lisp interpreter.
+
++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 <http://www.gnu.org/licenses/>. */
+
+#ifndef EMACS_LISP_H
+#define EMACS_LISP_H
+
+#include <setjmp.h>
+#include <stdalign.h>
+#include <stdarg.h>
+#include <stddef.h>
+#include <float.h>
+#include <inttypes.h>
+#include <limits.h>
+
+#include <intprops.h>
+#include <verify.h>
+
+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 <assert.h>'s 'assert (COND)' and <verify.h>'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 */
+
+\f
+/* 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)
+\f
+/* 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);
+
+\f
+/* 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
+ };
+\f
+/* 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;
+}
+\f
+
+/* 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 */
+
+\f
+/***********************************************************************
+ 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;
+}
+
+\f
+/* 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;
+}
+\f
+/* 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 <rms@gnu.ai.mit.edu> 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
+ };
+\f
+/* 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);
+}
+\f
+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);
+}
+\f
+/* 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)
+\f
+/* 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
+
+\f
+/* 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))
+\f
+extern Lisp_Object Vascii_downcase_table;
+extern Lisp_Object Vascii_canon_table;
+\f
+/* 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 *);
+\f
+/* 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 */
--- /dev/null
- Copyright (C) 1985, 1989-1993, 1995, 2000-2015 Free Software
+/* Definitions for data structures and routines for the regular
+ expression library, version 0.12.
+
++ 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 <http://www.gnu.org/licenses/>. */
+
+#ifndef _REGEX_H
+#define _REGEX_H 1
+
+/* Allow the use in C++ code. */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* POSIX says that <sys/types.h> must be included (by the caller) before
+ <regex.h>. */
+
+#if !defined _POSIX_C_SOURCE && !defined _POSIX_SOURCE && defined VMS
+/* VMS doesn't have `size_t' in <sys/types.h>, even though POSIX says it
+ should be there. */
+# include <stddef.h>
+#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 \<digit> matches <digit>.
+ If not set, then \<digit> 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;
+
+\f
+/* 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]]] */
+\f
+/* 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;
+\f
+/* 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;
+\f
+/* 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;
+\f
+/* 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: <wchar.h> must be included before <wctype.h>. */
+# include <wchar.h>
+# include <wctype.h>
+#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 */
+\f
--- /dev/null
- Copyright (C) 1984, 1987-1989, 1993-1995, 1998-2015 Free Software
+/* 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-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 <http://www.gnu.org/licenses/>. */
+
+
+/* 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ì <pot@gnu.org> 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 <config.h>
+
+#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 <sys/param.h>
+#else
+# define MSDOS false
+#endif /* MSDOS */
+
+#ifdef WINDOWSNT
+# include <direct.h>
+# define MAXPATHLEN _MAX_PATH
+# undef HAVE_NTGUI
+# undef DOS_NT
+# define DOS_NT
+#endif /* WINDOWSNT */
+
+#include <unistd.h>
+#include <stdarg.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sysstdio.h>
+#include <ctype.h>
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <binary-io.h>
+#include <c-strcase.h>
+
+#include <assert.h>
+#ifdef NDEBUG
+# undef assert /* some systems have a buggy assert.h */
+# define assert(x) ((void) 0)
+#endif
+
+#include <getopt.h>
+#include <regex.h>
+
+/* 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);
+
+\f
+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 <RET> bidule/b <RET>' will go directly to the\n\
+body of the package `bidule', while `M-x find-tag <RET> bidule <RET>'\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 */
+};
+
+\f
+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);
+}
+
+\f
+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 <vivek@etla.org>. */
+ 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 <vladimir@cs.ualberta.ca> (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;
+}
+
+\f
+/*
+ * 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 ();
+}
+
+\f
+/*
+ * 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 <kendall@mv.mv.com> (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<thisfilename>. */
+ 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);
+ }
+}
+
+\f
+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);
+}
+
+\f
+/* 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;
+}
+
+\f
+/*
+ * 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 = "<uninited>";
+
+/*
+ * 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 <tom@basil.icce.rug.nl> (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 <mdzyuba@yahoo.com> (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);
+ }
+}
+
+\f
+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;
+}
+
+\f
+/*
+ * 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);
+}
+
+\f
+/* 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);
+}
+
+\f
+/* 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;
+ }
+ }
+}
+
+\f
+/*
+ * 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 */
+}
+
+\f
+/*
+ * 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);
+ }
+ }
+}
+
+\f
+/*
+ * 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 <lomew@cs.utah.edu> (1995)
+ * Additions by Michael Ernst <mernst@alum.mit.edu> (1997)
+ * Ideas by Kai Großjohann <Kai.Grossjohann@CS.Uni-Dortmund.DE> (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 <esr@thyrsus.com> (1997)
+ * More ideas by seb bacon <seb@jamkit.com> (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);
+ }
+ }
+}
+
+\f
+/*
+ * 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);
+ }
+ }
+}
+
+\f
+/*
+ * 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);
+ }
+}
+
+\f
+/*
+ * Makefile support
+ * Ideas by Assar Westerlund <assar@sics.se> (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);
+ }
+ }
+}
+
+\f
+/*
+ * 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);
+}
+
+\f
+/*
+ * 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 ();
+ }
+ }
+ }
+ }
+}
+
+\f
+/*
+ * Lua script language parsing
+ * Original code by David A. Capello <dacap@users.sourceforge.net> (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);
+ }
+}
+
+\f
+/*
+ * PostScript tags
+ * Just look for lines where the first character is '/'
+ * Also look at "defineps" for PSWrap
+ * Ideas by:
+ * Richard Mlynarik <mly@adoc.xerox.com> (1997)
+ * Masatake Yamato <masata-y@is.aist-nara.ac.jp> (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);
+ }
+}
+
+\f
+/*
+ * 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 <eeh@netbsd.org> (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);
+}
+
+\f
+/*
+ * 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);
+ }
+}
+
+\f
+/* 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;
+ }
+ }
+}
+
+\f
+/* 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);
+ }
+}
+
+\f
+/*
+ * HTML support.
+ * Contents of <title>, <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;
+ }
+ }
+}
+
+\f
+/*
+ * 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;
+}
+
+\f
+/*
+ * 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;
+}
+
+\f
+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;
+ }
+ }
+ }
+}
+
+\f
+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;
+ }
+ }
+ }
+}
+
+\f
+/*
+ * 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;
+}
+
+\f
+/* 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';
+}
+
+\f
+/* 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 */
--- /dev/null
- /* 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);
+}
+
--- /dev/null
- /* 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);
+}
+
--- /dev/null
- Copyright (C) 1989, 1990, 1991, 1992 Free Software Foundation, Inc.
+/* Declarations for getopt.
++ 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 */
--- /dev/null
- /* 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
--- /dev/null
- ;; Copyright (C) 1985-1986, 1988-1989, 1992-1996, 1998, 2000-2015 Free
+;;; etags.el --- etags facility for Emacs -*- lexical-binding: t -*-
+
++;; 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].")
+\f
+;; 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.")
+\f
+;; 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.")
+\f
+(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))
+\f
+(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))))
+\f
+(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))))))
+\f
+(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)
+
+\f
+(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)))))
+\f
+;; `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)))
+\f
+;; 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))))))
+\f
+;; 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)))))
+\f
+(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)))
+\f
+(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)))
+\f
+;; 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)))
+\f
+;;;###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)))))
+
+\f
+;;; 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)))
+
+\f
+(provide 'etags)
+
+;;; etags.el ends here
--- /dev/null
- % Copyright (C) 1985, 1986, 1988, 1990, 1991 Free Software Foundation, Inc.
+%% TeX macros to handle texinfo files
+
++% 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 `\\ 1=\other
+\catcode `\\ 2=\other
+\catcode `\^^C=\other
+\catcode `\^^D=\other
+\catcode `\^^E=\other
+\catcode `\^^F=\other
+\catcode `\^^G=\other
+\catcode `\^^H=\other
+\catcode `\\v=\other
+\catcode `\^^L=\other
+\catcode `\\ e=\other
+\catcode `\\ f=\other
+\catcode `\\10=\other
+\catcode `\\11=\other
+\catcode `\\12=\other
+\catcode `\\13=\other
+\catcode `\\14=\other
+\catcode `\\15=\other
+\catcode `\\16=\other
+\catcode `\\17=\other
+\catcode `\\18=\other
+\catcode `\\19=\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:
--- /dev/null
- Copyright (C) 1984, 1989, 1990, 2000, 2001 Free Software Foundation, Inc.
+/* 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, 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
+\f
+#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
+\f
+#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"
+
+\f
+ 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"
+
+\f
+/* 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;
+}
+\f
+/* 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 () */
+}
+\f
+#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
--- /dev/null
- /* Copyright (C) 1990, 1992, 1993 Free Software Foundation, Inc.
+/* 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, 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
+\f
+#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
+\f
+#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"
+
+\f
+ 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;
+}
--- /dev/null
- /* 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. */
+%}
+\f
+
+%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;
+}
--- /dev/null
- Copyright (C) 1999-2006, 2013-2015 Free Software Foundation, Inc.
+{ GPC demo program for the CRT unit.
+
++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.
--- /dev/null
- ;; Copyright (C) 2009-2015 Free Software Foundation, Inc.
+;;; redisplay-testsuite.el --- Test suite for redisplay.
+
++;; 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))))
+
--- /dev/null
- ;; Copyright (C) 2006-2015 Free Software Foundation, Inc.
+;;; rmailmm.el --- tests for mail/rmailmm.el
+
++;; 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
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; alloc-tests.el --- alloc tests -*- lexical-binding: t -*-
+
++;; 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)))
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; buffer-tests.el --- tests for buffer.c functions -*- lexical-binding: t -*-
+
++;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; cmds-tests.el --- Testing some Emacs commands
+
++;; 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
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; data-tests.el --- tests for src/data.c
+
++;; 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))))
--- /dev/null
- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;;; decompress-tests.el --- Test suite for decompress.
+
++;; 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.
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; fns-tests.el --- tests for src/fns.c
+
++;; 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"))))
--- /dev/null
- ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
+;;; inotify-tests.el --- Test suite for inotify. -*- lexical-binding: t -*-
+
++;; 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.
--- /dev/null
- ;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;; keymap-tests.el --- Test suite for src/keymap.c
+
++;; 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
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; print-tests.el --- tests for src/print.c -*- lexical-binding: t; -*-
+
++;; 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
--- /dev/null
- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;;; libxml-parse-tests.el --- Test suite for libxml parsing.
+
++;; 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
projects / emacs.git / commitdiff