Mercurial > dotfiles
changeset 211:8980dc2deda0
emacs: use package.el to bootstrap instead of checking in all needed libs
| author | Augie Fackler <durin42@gmail.com> |
|---|---|
| date | Sat, 13 Feb 2010 20:00:15 -0600 |
| parents | 0590f34b92a0 |
| children | 4716b238db2e |
| files | .elisp/diff-mode-.el .elisp/doctest-mode.el .elisp/http-twiddle.el .elisp/ipython.el .elisp/js2.el .elisp/js2.elc .elisp/nose.el .elisp/package.el .elisp/paredit.el .elisp/pycomplete.el .elisp/pycomplete.py .elisp/pymacs.el .elisp/settings/10.require.el .elisp/yaml-mode.el |
| diffstat | 14 files changed, 1472 insertions(+), 17790 deletions(-) [+] |
line wrap: on
line diff
deleted file mode 100644 --- a/.elisp/diff-mode-.el +++ /dev/null @@ -1,189 +0,0 @@ -;;; diff-mode-.el --- Extensions to `diff-mode.el'. -;; -;; Filename: diff-mode-.el -;; Description: Extensions to `diff-mode.el'. -;; Author: Drew Adams -;; Maintainer: Drew Adams -;; Copyright (C) 2004-2009, Drew Adams, all rights reserved. -;; Created: Mon Nov 08 16:36:09 2004 -;; Version: 21.0 -;; Last-Updated: Sat Dec 27 10:19:33 2008 (-0800) -;; By: dradams -;; Update #: 646 -;; URL: http://www.emacswiki.org/cgi-bin/wiki/diff-mode-.el -;; Keywords: data, matching, tools, unix, local, font, face -;; Compatibility: GNU Emacs 21.x, GNU Emacs 22.x -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Extensions to `diff-mode.el'. -;; -;; "*Diff*" buffer is highlighted differently. -;; -;; NOTE: The faces defined here look best on a medium-dark -;; background, because some are light and some are dark. -;; Try, for example, setting the background to "LightSteelBlue" -;; in your `~/.emacs' file: You can do this is via -;; `special-display-buffer-names': -;; -;; (setq special-display-buffer-names -;; (cons '("*Diff*" (background-color . "LightSteelBlue")) -;; special-display-buffer-names)) -;; -;; You can alternatively change the background value of -;; `special-display-frame-alist' and set -;; `special-display-regexps' to something matching "*info*": -;; -;; (setq special-display-frame-alist -;; (cons '(background-color . "LightSteelBlue") -;; special-display-frame-alist)) -;; (setq special-display-regexps '("[ ]?[*][^*]+[*]")) -;; -;; -;; New faces defined here: -;; -;; `diff-file1-hunk-header', `diff-file2-hunk-header'. -;; -;; New user options defined here: -;; -;; `diff-file1-hunk-header-face', `diff-file2-hunk-header-face'. -;; -;; -;; ***** NOTE: The following faces defined in `diff-mode.el' have -;; been REDEFINED HERE: -;; -;; `diff-added', `diff-changed', `diff-context', -;; `diff-file-header', `diff-header', `diff-hunk-header', -;; `diff-index', `diff-indicator-added', `diff-indicator-changed', -;; `diff-indicator-removed', `diff-nonexistent', `diff-removed'. -;; -;; -;; ***** NOTE: The following variable defined in `diff-mode.el' has -;; been REDEFINED HERE: -;; -;; `diff-font-lock-keywords'. -;; -;; -;; This library should be loaded *before* library `diff-mode.el'. -;; Put this in your initialization file, `~/.emacs': -;; (require 'diff-mode-) -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; 2008/01/01 dadams -;; Added :group for deffaces. -;; 2006/01/04 dadams -;; Updated to use new Emacs 22 face names for indicator faces. -;; Thanks to Juri Linkov for the letting me know about the new faces. -;; Updated diff-font-lock-keywords to be = Emacs 22, except for file name. -;; 2006/01/01 dadams -;; Renamed faces, without "-face". -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;; - - -;;; Define some additional faces. -(defface diff-file1-hunk-header - '((t (:foreground "Blue" :background "DarkSeaGreen1"))) - "Face used to highlight a diff hunk for the first `diff' argument." - :group 'diff-mode) -(defvar diff-file1-hunk-header-face 'diff-file1-hunk-header) - -(defface diff-file2-hunk-header - '((t (:foreground "Red" :background "PaleGoldenrod"))) - "Face used to highlight a diff hunk for the second `diff' argument." - :group 'diff-mode) -(defvar diff-file2-hunk-header-face 'diff-file2-hunk-header) - -;;; These faces are standard in Emacs 22, but they are new for Emacs 21. -(defface diff-indicator-changed - '((t (:foreground "PaleGoldenrod" :background "MediumBlue"))) - "*Face used to highlight the line-start indicator of a modified line." - :group 'diff-mode) -(defvar diff-indicator-changed-face 'diff-indicator-changed) - -(defface diff-indicator-added - '((t (:foreground "PaleGoldenrod" :background "DarkGreen"))) - "*Face used to highlight the line-start indicator of an inserted line." - :group 'diff-mode) -(defvar diff-indicator-added-face 'diff-indicator-added) - -(defface diff-indicator-removed - '((t (:foreground "PaleGoldenrod" :background "DarkMagenta"))) - "*Face used to highlight the line-start indicator of a removed line." - :group 'diff-mode) -(defvar diff-indicator-removed-face 'diff-indicator-removed) - -;;; Change existing `diff-mode' faces too. -(custom-set-faces - '(diff-added ((t (:foreground "DarkGreen"))) 'now) - '(diff-changed ((t (:foreground "MediumBlue"))) 'now) - '(diff-context ((t (:foreground "LightSteelBlue"))) 'now) - '(diff-file-header ((t (:foreground "White"))) 'now) - '(diff-header ((t (:foreground "White"))) 'now) - '(diff-hunk-header ((t (:foreground "White"))) 'now) - '(diff-index ((t (:foreground "Green"))) 'now) - '(diff-nonexistent ((t (:foreground "DarkBlue"))) 'now) - '(diff-removed ((t (:foreground "Red"))) 'now) - ) - -;;; The only real difference here now from the standard Emacs 22 version is the -;;; use of diff-file1* and diff-file2*. -(defvar diff-font-lock-keywords - `( - ("^\\(@@ -[0-9,]+ \\+[0-9,]+ @@\\)\\(.*\\)$" ;unified - (1 diff-hunk-header-face) (2 diff-function-face)) - ("^\\(\\*\\{15\\}\\)\\(.*\\)$" ;context - (1 diff-hunk-header-face) (2 diff-function-face)) - ("^\\*\\*\\* .+ \\*\\*\\*\\*". diff-file1-hunk-header-face) ;context - ("^--- .+ ----$" . diff-file2-hunk-header-face) ;context - ("^[0-9,]+[acd][0-9,]+$" . diff-hunk-header-face) ; normal - ("^---$" . diff-hunk-header-face) ;normal - ("^\\(---\\|\\+\\+\\+\\|\\*\\*\\*\\) \\(\\S-+\\)\\(.*[^*-]\\)?\n" - (0 diff-header-face) (2 diff-file-header-face prepend)) - ("^\\([-<]\\)\\(.*\n\\)" (1 diff-indicator-removed-face) (2 diff-removed-face)) - ("^\\([+>]\\)\\(.*\n\\)" (1 diff-indicator-added-face) (2 diff-added-face)) - ("^\\(!\\)\\(.*\n\\)" (1 diff-indicator-changed-face) (2 diff-changed-face)) - ("^Index: \\(.+\\).*\n" (0 diff-header-face) (1 diff-index-face prepend)) - ("^Only in .*\n" . diff-nonexistent-face) - ("^\\(#\\)\\(.*\\)" - (1 (if (facep 'font-lock-comment-delimiter-face) - 'font-lock-comment-face)) - (2 font-lock-comment-face)) - ("^[^-=+*!<>#].*\n" (0 diff-context-face)))) - -;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'diff-mode-) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; diff-mode-.el ends here
deleted file mode 100644 --- a/.elisp/doctest-mode.el +++ /dev/null @@ -1,2061 +0,0 @@ -;;; doctest-mode.el --- Major mode for editing Python doctest files - -;; Copyright (C) 2004-2007 Edward Loper - -;; Author: Edward Loper -;; Maintainer: edloper@alum.mit.edu -;; Created: Aug 2004 -;; Keywords: python doctest unittest test docstring - -(defconst doctest-version "0.5 alpha" - "`doctest-mode' version number.") - -;; This software is provided as-is, without express or implied -;; warranty. Permission to use, copy, modify, distribute or sell this -;; software, without fee, for any purpose and by any individual or -;; organization, is hereby granted, provided that the above copyright -;; notice and this paragraph appear in all copies. - -;; This is a major mode for editing text files that contain Python -;; doctest examples. Doctest is a testing framework for Python that -;; emulates an interactive session, and checks the result of each -;; command. For more information, see the Python library reference: -;; <http://docs.python.org/lib/module-doctest.html> - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Table of Contents -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; 1. Customization: use-editable variables to customize -;; doctest-mode. -;; -;; 2. Fonts: defines new font-lock faces. -;; -;; 3. Constants: various consts (mainly regexps) used by the rest -;; of the code. -;; -;; 4. Syntax Highlighting: defines variables and functions used by -;; font-lock-mode to perform syntax highlighting. -;; -;; 5. Source code editing & indentation: commands used to -;; automatically indent, dedent, & handle prompts. -;; -;; 6. Code Execution: commands used to start doctest processes, -;; and handle their output. -;; -;; 7. Markers: functions used to insert markers at the start of -;; doctest examples. These are used to keep track of the -;; correspondence between examples in the source buffer and -;; results in the output buffer. -;; -;; 8. Navigation: commands used to navigate between failed examples. -;; -;; 9. Replace Output: command used to replace a doctest example's -;; expected output with its actual output. -;; -;; 10. Helper functions: various helper functions used by the rest -;; of the code. -;; -;; 11. Emacs compatibility functions: defines compatible versions of -;; functions that are defined for some versions of emacs but not -;; others. -;; -;; 12. Doctest Results Mode: defines doctest-results-mode, which is -;; used for the output generated by doctest. -;; -;; 13. Doctest Mode: defines doctest-mode itself. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Customizable Constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defgroup doctest nil - "Support for the Python doctest framework" - :group 'languages - :prefix "doctest-") - -(defcustom doctest-default-margin 4 - "The default pre-prompt margin for doctest examples." - :type 'integer - :group 'doctest) - -(defcustom doctest-avoid-trailing-whitespace t - "If true, then delete trailing whitespace when inserting a newline." - :type 'boolean - :group 'doctest) - -(defcustom doctest-temp-directory - (let ((ok '(lambda (x) - (and x - (setq x (expand-file-name x)) ; always true - (file-directory-p x) - (file-writable-p x) - x)))) - (or (funcall ok (getenv "TMPDIR")) - (funcall ok "/usr/tmp") - (funcall ok "/tmp") - (funcall ok "/var/tmp") - (funcall ok ".") - (error (concat "Couldn't find a usable temp directory -- " - "set `doctest-temp-directory'")))) - "Directory used for temporary files created when running doctest. -By default, the first directory from this list that exists and that you -can write into: the value (if any) of the environment variable TMPDIR, -/usr/tmp, /tmp, /var/tmp, or the current directory." - :type 'string - :group 'doctest) - -(defcustom doctest-hide-example-source nil - "If true, then don't display the example source code for each -failure in the results buffer." - :type 'boolean - :group 'doctest) - -(defcustom doctest-python-command "python" - "Shell command used to start the python interpreter" - :type 'string - :group 'doctest) - -(defcustom doctest-results-buffer-name "*doctest-output (%N)*" - "The name of the buffer used to store the output of the doctest -command. This name can contain the following special sequences: - %n -- replaced by the doctest buffer's name. - %N -- replaced by the doctest buffer's name, with '.doctest' - stripped off. - %f -- replaced by the doctest buffer's filename." - :type 'string - :group 'doctest) - -(defcustom doctest-optionflags '() - "Option flags for doctest" - :group 'doctest - :type '(repeat (choice (const :tag "Select an option..." "") - (const :tag "Normalize whitespace" - "NORMALIZE_WHITESPACE") - (const :tag "Ellipsis" - "ELLIPSIS") - (const :tag "Don't accept True for 1" - "DONT_ACCEPT_TRUE_FOR_1") - (const :tag "Don't accept <BLANKLINE>" - "DONT_ACCEPT_BLANKLINE") - (const :tag "Ignore Exception detail" - "IGNORE_EXCEPTION_DETAIL") - (const :tag "Report only first failure" - "REPORT_ONLY_FIRST_FAILURE") - ))) - -(defcustom doctest-async t - "If true, then doctest will be run asynchronously." - :type 'boolean - :group 'doctest) - -(defcustom doctest-trim-exceptions t - "If true, then any exceptions inserted by doctest-replace-output -will have the stack trace lines trimmed." - :type 'boolean - :group 'doctest) - -(defcustom doctest-highlight-strings t - "If true, then highlight strings. If you find that doctest-mode -is responding slowly when you type, turning this off might help." - :type 'boolean - :group 'doctest) - -(defcustom doctest-follow-output t - "If true, then when doctest is run asynchronously, the output buffer -will scroll to display its output as it is generated. If false, then -the output buffer not scroll." - :type 'boolean - :group 'doctest) - -(defvar doctest-mode-hook nil - "Hook called by `doctest-mode'.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Fonts -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defface doctest-prompt-face - '((((class color) (background dark)) - (:foreground "#68f")) - (t (:foreground "#226"))) - "Face for Python prompts in doctest examples." - :group 'doctest) - -(defface doctest-output-face - '((((class color) (background dark)) - (:foreground "#afd")) - (t (:foreground "#262"))) - "Face for the output of doctest examples." - :group 'doctest) - -(defface doctest-output-marker-face - '((((class color) (background dark)) - (:foreground "#0f0")) - (t (:foreground "#080"))) - "Face for markers in the output of doctest examples." - :group 'doctest) - -(defface doctest-output-traceback-face - '((((class color) (background dark)) - (:foreground "#f88")) - (t (:foreground "#622"))) - "Face for traceback headers in the output of doctest examples." - :group 'doctest) - -(defface doctest-results-divider-face - '((((class color) (background dark)) - (:foreground "#08f")) - (t (:foreground "#00f"))) - "Face for dividers in the doctest results window." - :group 'doctest) - -(defface doctest-results-loc-face - '((((class color) (background dark)) - (:foreground "#0f8")) - (t (:foreground "#084"))) - "Face for location headers in the doctest results window." - :group 'doctest) - -(defface doctest-results-header-face - '((((class color) (background dark)) - (:foreground "#8ff")) - (t (:foreground "#088"))) - "Face for sub-headers in the doctest results window." - :group 'doctest) - -(defface doctest-results-selection-face - '((((class color) (background dark)) - (:foreground "#ff0" :background "#008")) - (t (:background "#088" :foreground "#fff"))) - "Face for selected failure's location header in the results window." - :group 'doctest) - -(defface doctest-selection-face - '((((class color) (background dark)) - (:foreground "#ff0" :background "#00f" :bold t)) - (t (:foreground "#f00"))) - "Face for selected example's prompt" - :group 'doctest) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst doctest-prompt-re - "^\\(?:\\([ \t]*\\)\\(>>> ?\\|[.][.][.] ?\\)\\([ \t]*\\)\\)" - "Regular expression for doctest prompts. It defines three groups: -the pre-prompt margin; the prompt; and the post-prompt indentation.") - -(defconst doctest-open-block-re - "[^\n]+:[ \t]*\\(#.*\\)?$" - "Regular expression for a line that opens a block") - -(defconst doctest-close-block-re - "\\(return\\|raise\\|break\\|continue\\|pass\\)\\b" - "Regular expression for a line that closes a block") - -(defconst doctest-example-source-re - "^Failed example:\n\\(\n\\| [^\n]*\n\\)+" - "Regular expression for example source in doctest's output.") - -(defconst doctest-results-divider-re - "^\\([*]\\{60,\\}\\)$" - "Regular expression for example dividers in doctest's output.") - -(defconst doctest-py24-results-loc-re - "^File \"[^\"]+\", line \\([0-9]+\\), in [^\n]+" - "Regular expression for example location markers in doctest's output.") - -(defconst doctest-py21-results-loc-re - "^from line #\\([0-9]+\\) of [^\n]*" - "Regular expression for example location markers in doctest's output, -when the output was generated by an old version of doctest.") - -(defconst doctest-results-header-re - "^\\([^ \n\t].+:\\|Expected nothing\\|Got nothing\\)$" - "Regular expression for example headers in doctest's output.") - -(defconst doctest-traceback-header-re - "^[ \t]*Traceback (\\(most recent call last\\|innermost last\\)):" - "Regular expression for Python traceback headers.") - -(defconst doctest-py21-results-re - "^from line #" - "Regular expression used to test which version of doctest was used.") - -;; nb: There's a bug in Python's traceback.print_exception function -;; which causes SyntaxError exceptions to be displayed incorrectly; -;; which prevents this regexp from matching. But there shouldn't be -;; too many people testing for SyntaxErrors, so I won't worry about -;; it. -(defconst doctest-traceback-re - (let ((nonprompt - ;; This matches any non-blank line that doesn't start with - ;; a prompt (... or >>>). - (concat - "\\(?:[.][.][^.\n]\\|[>][>][^>\n]\\|" - "[.][^.\n]\\|[>][^>\n]\\|[^.>\n \t]\\)[^\n]*"))) - (concat - "^\\(\\([ \t]*\\)Traceback " - "(\\(?:most recent call last\\|innermost last\\)):\n\\)" - "\\(?:\\2[ \t]+[^ \t\n][^\n]*\n\\)*" - "\\(\\(?:\\2" nonprompt "\n\\)" - "\\(?:\\2[ \t]*" nonprompt "\n\\)*\\)")) - "Regular expression that matches a complete exception traceback. -It contains three groups: group 1 is the header line; group 2 is -the indentation; and group 3 is the exception message.") - -(defconst doctest-blankline-re - "^[ \t]*<BLANKLINE>" - "Regular expression that matches blank line markers in doctest -output.") - -(defconst doctest-outdent-re - (concat "\\(" (mapconcat 'identity - '("else:" - "except\\(\\s +.*\\)?:" - "finally:" - "elif\\s +.*:") - "\\|") - "\\)") - "Regular expression for a line that should be outdented. Any line -that matches `doctest-outdent-re', but does not follow a line matching -`doctest-no-outdent-re', will be outdented.") - -;; It's not clear to me *why* the behavior given by this definition of -;; doctest-no-outdent-re is desirable; but it's basically just copied -;; from python-mode. -(defconst doctest-no-outdent-re - (concat - "\\(" - (mapconcat 'identity - (list "try:" - "except\\(\\s +.*\\)?:" - "while\\s +.*:" - "for\\s +.*:" - "if\\s +.*:" - "elif\\s +.*:" - "\\(return\\|raise\\|break\\|continue\\|pass\\)[ \t\n]" - ) - "\\|") - "\\)") - "Regular expression matching lines not to outdent after. Any line -that matches `doctest-outdent-re', but does not follow a line matching -`doctest-no-outdent-re', will be outdented.") - -(defconst doctest-script - "\ -from doctest import * -import sys -if '%m': - import imp - try: - m = imp.load_source('__imported__', '%m') - globs = m.__dict__ - except Exception, e: - print ('doctest-mode encountered an error while importing ' - 'the current buffer:\\n\\n %s' % e) - sys.exit(1) -else: - globs = {} -doc = open('%t').read() -if sys.version_info[:2] >= (2,4): - test = DocTestParser().get_doctest(doc, globs, '%n', '%f', 0) - r = DocTestRunner(optionflags=%l) - r.run(test) -else: - Tester(globs=globs).runstring(doc, '%f')" - ;; Docstring: - "Python script used to run doctest. -The following special sequences are defined: - %n -- replaced by the doctest buffer's name. - %f -- replaced by the doctest buffer's filename. - %l -- replaced by the doctest flags string. - %t -- replaced by the name of the tempfile containing the doctests." - ) - -(defconst doctest-keyword-re - (let* ((kw1 (mapconcat 'identity - '("and" "assert" "break" "class" - "continue" "def" "del" "elif" - "else" "except" "exec" "for" - "from" "global" "if" "import" - "in" "is" "lambda" "not" - "or" "pass" "print" "raise" - "return" "while" "yield" - ) - "\\|")) - (kw2 (mapconcat 'identity - '("else:" "except:" "finally:" "try:") - "\\|")) - (kw3 (mapconcat 'identity - '("ArithmeticError" "AssertionError" - "AttributeError" "DeprecationWarning" "EOFError" - "Ellipsis" "EnvironmentError" "Exception" "False" - "FloatingPointError" "FutureWarning" "IOError" - "ImportError" "IndentationError" "IndexError" - "KeyError" "KeyboardInterrupt" "LookupError" - "MemoryError" "NameError" "None" "NotImplemented" - "NotImplementedError" "OSError" "OverflowError" - "OverflowWarning" "PendingDeprecationWarning" - "ReferenceError" "RuntimeError" "RuntimeWarning" - "StandardError" "StopIteration" "SyntaxError" - "SyntaxWarning" "SystemError" "SystemExit" - "TabError" "True" "TypeError" "UnboundLocalError" - "UnicodeDecodeError" "UnicodeEncodeError" - "UnicodeError" "UnicodeTranslateError" - "UserWarning" "ValueError" "Warning" - "ZeroDivisionError" "__debug__" - "__import__" "__name__" "abs" "apply" "basestring" - "bool" "buffer" "callable" "chr" "classmethod" - "cmp" "coerce" "compile" "complex" "copyright" - "delattr" "dict" "dir" "divmod" - "enumerate" "eval" "execfile" "exit" "file" - "filter" "float" "getattr" "globals" "hasattr" - "hash" "hex" "id" "input" "int" "intern" - "isinstance" "issubclass" "iter" "len" "license" - "list" "locals" "long" "map" "max" "min" "object" - "oct" "open" "ord" "pow" "property" "range" - "raw_input" "reduce" "reload" "repr" "round" - "setattr" "slice" "staticmethod" "str" "sum" - "super" "tuple" "type" "unichr" "unicode" "vars" - "xrange" "zip") - "\\|")) - (pseudokw (mapconcat 'identity - '("self" "None" "True" "False" "Ellipsis") - "\\|")) - (string (concat "'\\(?:\\\\[^\n]\\|[^\n']*\\)'" "\\|" - "\"\\(?:\\\\[^\n]\\|[^\n\"]*\\)\"")) - (brk "\\(?:[ \t(]\\|$\\)")) - (concat - ;; Comments (group 1) - "\\(#.*\\)" - ;; Function & Class Definitions (groups 2-3) - "\\|\\b\\(class\\|def\\)" - "[ \t]+\\([a-zA-Z_][a-zA-Z0-9_]*\\)" - ;; Builtins preceeded by '.'(group 4) - "\\|[.][\t ]*\\(" kw3 "\\)" - ;; Keywords & builtins (group 5) - "\\|\\b\\(" kw1 "\\|" kw2 "\\|" - kw3 "\\|" pseudokw "\\)" brk - ;; Decorators (group 6) - "\\|\\(@[a-zA-Z_][a-zA-Z0-9_]*\\)" - )) - "A regular expression used for syntax highlighting of Python -source code.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Syntax Highlighting (font-lock mode) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Define the font-lock keyword table. -(defconst doctest-font-lock-keywords - `( - ;; The following pattern colorizes source lines. In particular, - ;; it first matches prompts, and then looks for any of the - ;; following matches *on the same line* as the prompt. It uses - ;; the form: - ;; - ;; (MATCHER MATCH-HIGHLIGHT - ;; (ANCHOR-MATCHER nil nil MATCH-HIGHLIGHT)) - ;; - ;; See the variable documentation for font-lock-keywords for a - ;; description of what each of those means. - ("^[ \t]*\\(>>>\\|\\.\\.\\.\\)" - (1 'doctest-prompt-face) - (doctest-source-matcher - nil nil - (1 'font-lock-comment-face t t) ; comments - (2 'font-lock-keyword-face t t) ; def/class - (3 'font-lock-type-face t t) ; func/class name - ;; group 4 (builtins preceeded by '.') gets no colorization. - (5 'font-lock-keyword-face t t) ; keywords & builtins - (6 'font-lock-preprocessor-face t t) ; decorators - (7 'font-lock-string-face t t) ; strings - )) - - ;; The following pattern colorizes output lines. In particular, - ;; it uses doctest-output-line-matcher to check if this is an - ;; output line, and if so, it colorizes it, and any special - ;; markers it contains. - (doctest-output-line-matcher - (0 'doctest-output-face t) - ("\\.\\.\\." (beginning-of-line) (end-of-line) - (0 'doctest-output-marker-face t)) - (,doctest-blankline-re (beginning-of-line) (end-of-line) - (0 'doctest-output-marker-face t)) - (doctest-traceback-line-matcher (beginning-of-line) (end-of-line) - (0 'doctest-output-traceback-face t)) - (,doctest-traceback-header-re (beginning-of-line) (end-of-line) - (0 'doctest-output-traceback-face t)) - ) - - ;; A PS1 prompt followed by a non-space is an error. - ("^[ \t]*\\(>>>[^ \t\n][^\n]*\\)" (1 'font-lock-warning-face t)) - ) - "Expressions to highlight in doctest-mode.") - -(defconst doctest-results-font-lock-keywords - `((,doctest-results-divider-re - (0 'doctest-results-divider-face)) - (,doctest-py24-results-loc-re - (0 'doctest-results-loc-face)) - (,doctest-results-header-re - (0 'doctest-results-header-face)) - (doctest-results-selection-matcher - (0 'doctest-results-selection-face t))) - "Expressions to highlight in doctest-results-mode.") - -(defun doctest-output-line-matcher (limit) - "A `font-lock-keyword' MATCHER that returns t if the current -line is the expected output for a doctest example, and if so, -sets `match-data' so that group 0 spans the current line." - ;; The real work is done by doctest-find-output-line. - (when (doctest-find-output-line limit) - ;; If we found one, then mark the entire line. - (beginning-of-line) - (re-search-forward "[^\n]*" limit))) - -(defun doctest-traceback-line-matcher (limit) - "A `font-lock-keyword' MATCHER that returns t if the current line is -the beginning of a traceback, and if so, sets `match-data' so that -group 0 spans the entire traceback. n.b.: limit is ignored." - (beginning-of-line) - (when (looking-at doctest-traceback-re) - (goto-char (match-end 0)) - t)) - -(defun doctest-source-matcher (limit) - "A `font-lock-keyword' MATCHER that returns t if the current line -contains a Python source expression that should be highlighted -after the point. If so, it sets `match-data' to cover the string -literal. The groups in `match-data' should be interpreted as follows: - - Group 1: comments - Group 2: def/class - Group 3: function/class name - Group 4: builtins preceeded by '.' - Group 5: keywords & builtins - Group 6: decorators - Group 7: strings -" - (let ((matchdata nil)) - ;; First, look for string literals. - (when doctest-highlight-strings - (save-excursion - (when (doctest-string-literal-matcher limit) - (setq matchdata - (list (match-beginning 0) (match-end 0) - nil nil nil nil nil nil nil nil nil nil nil nil - (match-beginning 0) (match-end 0)))))) - ;; Then, look for other keywords. If they occur before the - ;; string literal, then they take precedence. - (save-excursion - (when (and (re-search-forward doctest-keyword-re limit t) - (or (null matchdata) - (< (match-beginning 0) (car matchdata)))) - (setq matchdata (match-data)))) - (when matchdata - (set-match-data matchdata) - (goto-char (match-end 0)) - t))) - -(defun doctest-string-literal-matcher (limit &optional debug) - "A `font-lock-keyword' MATCHER that returns t if the current line -contains a string literal starting at or after the point. If so, it -expands `match-data' to cover the string literal. This matcher uses -`doctest-statement-info' to collect information about strings that -continue over multiple lines. It therefore might be a little slow for -very large statements." - (let* ((stmt-info (doctest-statement-info)) - (quotes (reverse (nth 5 stmt-info))) - (result nil)) - (if debug (doctest-debug "quotes %s" quotes)) - (while (and quotes (null result)) - (let* ((quote (pop quotes)) - (start (car quote)) - (end (min limit (or (cdr quote) limit)))) - (if debug (doctest-debug "quote %s-%s pt=%s lim=%s" - start end (point) limit)) - (when (or (and (<= (point) start) (< start limit)) - (and (< start (point)) (< (point) end))) - (setq start (max start (point))) - (set-match-data (list start end)) - (if debug (doctest-debug "marking string %s" (match-data))) - (goto-char end) - (setq result t)))) - result)) - -(defun doctest-results-selection-matcher (limit) - "Matches from `doctest-selected-failure' to the end of the -line. This is used to highlight the currently selected failure." - (when (and doctest-selected-failure - (<= (point) doctest-selected-failure) - (< doctest-selected-failure limit)) - (goto-char doctest-selected-failure) - (re-search-forward "[^\n]+" limit))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Source code editing & indentation -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun doctest-indent-source-line (&optional dedent-only) - "Re-indent the current line, as doctest source code. I.e., add a -prompt to the current line if it doesn't have one, and re-indent the -source code (to the right of the prompt). If `dedent-only' is true, -then don't increase the indentation level any." - (interactive "*") - (let ((indent-end nil)) - (save-excursion - (beginning-of-line) - (let ((new-indent (doctest-current-source-line-indentation dedent-only)) - (new-margin (doctest-current-source-line-margin)) - (line-had-prompt (looking-at doctest-prompt-re))) - ;; Delete the old prompt (if any). - (when line-had-prompt - (goto-char (match-beginning 2)) - (delete-char (- (match-end 2) (match-beginning 2)))) - ;; Delete the old indentation. - (delete-backward-char (skip-chars-forward " \t")) - ;; If it's a continuation line, or a new PS1 prompt, - ;; then copy the margin. - (when (or new-indent (not line-had-prompt)) - (beginning-of-line) - (delete-backward-char (skip-chars-forward " \t")) - (insert-char ?\ new-margin)) - ;; Add the new prompt. - (insert-string (if new-indent "... " ">>> ")) - ;; Add the new indentation - (if new-indent (insert-char ?\ new-indent)) - (setq indent-end (point)))) - ;; If we're left of the indentation end, then move up to the - ;; indentation end. - (if (< (point) indent-end) (goto-char indent-end)))) - -(defun doctest-current-source-line-indentation (&optional dedent-only) - "Return the post-prompt indent to use for this line. This is an -integer for a continuation lines, and nil for non-continuation lines." - (save-excursion - ;; Examine the previous doctest line (if present). - (let* ((prev-stmt-info (doctest-prev-statement-info)) - (prev-stmt-indent (nth 0 prev-stmt-info)) - (continuation-indent (nth 1 prev-stmt-info)) - (prev-stmt-opens-block (nth 2 prev-stmt-info)) - (prev-stmt-closes-block (nth 3 prev-stmt-info)) - (prev-stmt-blocks-outdent (nth 4 prev-stmt-info)) - ) - ;; Examine this doctest line. - (let* ((curr-line-indent 0) - (curr-line-outdented nil)) - (beginning-of-line) - (when (looking-at doctest-prompt-re) - (setq curr-line-indent (- (match-end 3) (match-beginning 3))) - (goto-char (match-end 3))) - (setq curr-line-outdented (and (looking-at doctest-outdent-re) - (not prev-stmt-blocks-outdent))) - ;; Compute the overall indent. - (let ((indent (or continuation-indent - (+ prev-stmt-indent - (if curr-line-outdented -4 0) - (if prev-stmt-opens-block 4 0) - (if prev-stmt-closes-block -4 0))))) - ;; If dedent-only is true, then make sure we don't indent. - (when dedent-only - (setq indent (min indent curr-line-indent))) - ;; If indent=0 and we're not outdented, then set indent to - ;; nil (to signify the start of a new source example). - (when (and (= indent 0) - (not (or curr-line-outdented continuation-indent))) - (setq indent nil)) - ;; Return the indentation. - indent))))) - -(defun doctest-prev-statement-info (&optional debug) - (save-excursion - (forward-line -1) - (doctest-statement-info debug))) - -(defun doctest-statement-info (&optional debug) - "Collect info about the previous statement, and return it as a list: - - (INDENT, CONTINUATION, OPENS-BLOCK, CLOSES-BLOCK, BLOCKS-OUTDENT, - QUOTES) - -INDENT -- The indentation of the previous statement (after the prompt) - -CONTINUATION -- If the previous statement is incomplete (e.g., has an -open paren or quote), then this is the appropriate indentation -level; otherwise, it's nil. - -OPENS-BLOCK -- True if the previous statement opens a Python control -block. - -CLOSES-BLOCK -- True if the previous statement closes a Python control -block. - -BLOCKS-OUTDENT -- True if the previous statement should 'block the -next statement from being considered an outdent. - -QUOTES -- A list of (START . END) pairs for all quotation strings. -" - (save-excursion - (end-of-line) - (let ((end (point))) - (while (and (doctest-on-source-line-p "...") (= (forward-line -1) 0))) - (cond - ;; If there's no previous >>> line, then give up. - ((not (doctest-on-source-line-p ">>>")) - '(0 nil nil nil nil)) - - ;; If there is a previous statement, walk through the source - ;; code, checking for operators that may be of interest. - (t - (beginning-of-line) - (let* ((quote-mark nil) (nesting 0) (indent-stack '()) - (stmt-indent 0) - (stmt-opens-block nil) - (stmt-closes-block nil) - (stmt-blocks-outdent nil) - (quotes '()) - (elt-re (concat "\\\\[^\n]\\|" - "(\\|)\\|\\[\\|\\]\\|{\\|}\\|" - "\"\"\"\\|\'\'\'\\|\"\\|\'\\|" - "#[^\n]*\\|" doctest-prompt-re))) - (while (re-search-forward elt-re end t) - (let* ((elt (match-string 0)) - (elt-first-char (substring elt 0 1))) - (if debug (doctest-debug "Debug: %s" elt)) - (cond - ;; Close quote -- set quote-mark back to nil. The - ;; second case is for cases like: ' ''' - (quote-mark - (cond - ((equal quote-mark elt) - (setq quote-mark nil) - (setcdr (car quotes) (point))) - ((equal quote-mark elt-first-char) - (setq quote-mark nil) - (setcdr (car quotes) (point)) - (backward-char 2)))) - ;; Prompt -- check if we're starting a new stmt. If so, - ;; then collect various info about it. - ((string-match doctest-prompt-re elt) - (when (and (null quote-mark) (= nesting 0)) - (let ((indent (- (match-end 3) (match-end 2)))) - (unless (looking-at "[ \t]*\n") - (setq stmt-indent indent) - (setq stmt-opens-block - (looking-at doctest-open-block-re)) - (setq stmt-closes-block - (looking-at doctest-close-block-re)) - (setq stmt-blocks-outdent - (looking-at doctest-no-outdent-re)))))) - ;; Open paren -- increment nesting, and update indent-stack. - ((string-match "(\\|\\[\\|{" elt-first-char) - (let ((elt-pos (point)) - (at-eol (looking-at "[ \t]*\n")) - (indent 0)) - (save-excursion - (re-search-backward doctest-prompt-re) - (if at-eol - (setq indent (+ 4 (- (match-end 3) (match-end 2)))) - (setq indent (- elt-pos (match-end 2)))) - (push indent indent-stack))) - (setq nesting (+ nesting 1))) - ;; Close paren -- decrement nesting, and pop indent-stack. - ((string-match ")\\|\\]\\|}" elt-first-char) - (setq indent-stack (cdr indent-stack)) - (setq nesting (max 0 (- nesting 1)))) - ;; Open quote -- set quote-mark. - ((string-match "\"\\|\'" elt-first-char) - (push (cons (- (point) (length elt)) nil) quotes) - (setq quote-mark elt))))) - - (let* ((continuation-indent - (cond - (quote-mark 0) - ((> nesting 0) (if (null indent-stack) 0 (car indent-stack))) - (t nil))) - (result - (list stmt-indent continuation-indent - stmt-opens-block stmt-closes-block - stmt-blocks-outdent quotes))) - (if debug (doctest-debug "Debug: %s" result)) - result))))))) - -(defun doctest-current-source-line-margin () - "Return the pre-prompt margin to use for this source line. This is -copied from the most recent source line, or set to -`doctest-default-margin' if there are no preceeding source lines." - (save-excursion - (save-restriction - (when (doctest-in-mmm-docstring-overlay) - (doctest-narrow-to-mmm-overlay)) - (beginning-of-line) - (forward-line -1) - (while (and (not (doctest-on-source-line-p)) - (re-search-backward doctest-prompt-re nil t)))) - (cond ((looking-at doctest-prompt-re) - (- (match-end 1) (match-beginning 1))) - ((doctest-in-mmm-docstring-overlay) - (doctest-default-margin-in-mmm-docstring-overlay)) - (t - doctest-default-margin)))) - -(defun doctest-electric-backspace () - "Delete the preceeding character, level of indentation, or -prompt. - -If point is at the leftmost column, delete the preceding newline. - -Otherwise, if point is at the first non-whitespace character -following an indented source line's prompt, then reduce the -indentation to the next multiple of 4; and update the source line's -prompt, when necessary. - -Otherwise, if point is at the first non-whitespace character -following an unindented source line's prompt, then remove the -prompt (converting the line to an output line or text line). - -Otherwise, if point is at the first non-whitespace character of a -line, the delete the line's indentation. - -Otherwise, delete the preceeding character. -" - (interactive "*") - (cond - ;; Beginning of line: delete preceeding newline. - ((bolp) (backward-delete-char 1)) - - ;; First non-ws char following prompt: dedent or remove prompt. - ((and (looking-at "[^ \t\n]\\|$") (doctest-looking-back doctest-prompt-re)) - (let* ((prompt-beg (match-beginning 2)) - (indent-beg (match-beginning 3)) (indent-end (match-end 3)) - (old-indent (- indent-end indent-beg)) - (new-indent (* (/ (- old-indent 1) 4) 4))) - (cond - ;; Indented source line: dedent it. - ((> old-indent 0) - (goto-char indent-beg) - (delete-region indent-beg indent-end) - (insert-char ?\ new-indent) - ;; Change prompt to PS1, when appropriate. - (when (and (= new-indent 0) (not (looking-at doctest-outdent-re))) - (delete-backward-char 4) - (insert-string ">>> "))) - ;; Non-indented source line: remove prompt. - (t - (goto-char indent-end) - (delete-region prompt-beg indent-end))))) - - ;; First non-ws char of a line: delete all indentation. - ((and (looking-at "[^ \n\t]\\|$") (doctest-looking-back "^[ \t]+")) - (delete-region (match-beginning 0) (match-end 0))) - - ;; Otherwise: delete a character. - (t - (backward-delete-char 1)))) - -(defun doctest-newline-and-indent () - "Insert a newline, and indent the new line appropriately. - -If the current line is a source line containing a bare prompt, -then clear the current line, and insert a newline. - -Otherwise, if the current line is a source line, then insert a -newline, and add an appropriately indented prompt to the new -line. - -Otherwise, if the current line is an output line, then insert a -newline and indent the new line to match the example's margin. - -Otherwise, insert a newline. - -If `doctest-avoid-trailing-whitespace' is true, then clear any -whitespace to the left of the point before inserting a newline. -" - (interactive "*") - ;; If we're avoiding trailing spaces, then delete WS before point. - (if doctest-avoid-trailing-whitespace - (delete-char (- (skip-chars-backward " \t")))) - (cond - ;; If we're on an empty prompt, delete it. - ((doctest-on-empty-source-line-p) - (delete-region (match-beginning 0) (match-end 0)) - (insert-char ?\n 1)) - ;; If we're on a doctest line, add a new prompt. - ((doctest-on-source-line-p) - (insert-char ?\n 1) - (doctest-indent-source-line)) - ;; If we're in doctest output, indent to the margin. - ((doctest-on-output-line-p) - (insert-char ?\n 1) - (insert-char ?\ (doctest-current-source-line-margin))) - ;; Otherwise, just add a newline. - (t (insert-char ?\n 1)))) - -(defun doctest-electric-colon () - "Insert a colon, and dedent the line when appropriate." - (interactive "*") - (insert-char ?: 1) - (when (doctest-on-source-line-p) - (doctest-indent-source-line t))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Code Execution -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun doctest-execute () - "Run doctest on the current buffer, or on the current docstring -if the point is inside an `mmm-mode' `doctest-docstring' region. -Display the results in the *doctest-output* buffer." - (interactive) - (doctest-execute-region (point-min) (point-max) nil t)) - -(defun doctest-execute-with-diff () - "Run doctest on the current buffer, or on the current docstring -if the point is inside an `mmm-mode' `doctest-docstring' region. -Display the results in the *doctest-output* buffer, using diff format." - (interactive) - (doctest-execute-region (point-min) (point-max) t t)) - -(defun doctest-execute-buffer-with-diff () - "Run doctest on the current buffer, and display the results in the -*doctest-output* buffer, using the diff format." - (interactive) - (doctest-execute-region (point-min) (point-max) t nil)) - -(defun doctest-execute-buffer () - "Run doctest on the current buffer, and display the results in the -*doctest-output* buffer." - (interactive) - (doctest-execute-region (point-min) (point-max) nil nil)) - -(defun doctest-execute-region (start end &optional diff - check-for-mmm-docstring-overlay) - "Run doctest on the current buffer, and display the results in the -*doctest-output* buffer." - (interactive "r") - ;; If it's already running, give the user a chance to restart it. - (when (doctest-process-live-p doctest-async-process) - (when (y-or-n-p "Doctest is already running. Restart it? ") - (doctest-cancel-async-process) - (message "Killing doctest..."))) - (cond - ((and doctest-async (doctest-process-live-p doctest-async-process)) - (message "Can't run two doctest processes at once!")) - (t - (let* ((results-buf-name (doctest-results-buffer-name)) - (in-docstring (and check-for-mmm-docstring-overlay - (doctest-in-mmm-docstring-overlay))) - (temp (doctest-temp-name)) (dir doctest-temp-directory) - (input-file (expand-file-name (concat temp ".py") dir)) - (globs-file (when in-docstring - (expand-file-name (concat temp "-globs.py") dir))) - (cur-buf (current-buffer)) - (in-buf (get-buffer-create "*doctest-input*")) - (script (doctest-script input-file globs-file diff))) - ;; If we're in a docstring, narrow start & end. - (when in-docstring - (let ((bounds (doctest-mmm-overlay-bounds))) - (setq start (max start (car bounds)) - end (min end (cdr bounds))))) - ;; Write the doctests to a file. - (save-excursion - (goto-char (min start end)) - (let ((lineno (doctest-line-number))) - (set-buffer in-buf) - ;; Add blank lines, to keep line numbers the same: - (dotimes (n (- lineno 1)) (insert-string "\n")) - ;; Add the selected region - (insert-buffer-substring cur-buf start end) - ;; Write it to a file - (write-file input-file))) - ;; If requested, write the buffer to a file for use as globs. - (when globs-file - (let ((cur-buf-start (point-min)) (cur-buf-end (point-max))) - (save-excursion - (set-buffer in-buf) - (delete-region (point-min) (point-max)) - (insert-buffer-substring cur-buf cur-buf-start cur-buf-end) - (write-file globs-file)))) - ;; Dispose of in-buf (we're done with it now. - (kill-buffer in-buf) - ;; Prepare the results buffer. Clear it, if it contains - ;; anything, and set its mode. - (setq doctest-results-buffer (get-buffer-create results-buf-name)) - (save-excursion - (set-buffer doctest-results-buffer) - (toggle-read-only 0) - (delete-region (point-min) (point-max)) - (doctest-results-mode) - (setq doctest-source-buffer cur-buf) - ) - ;; Add markers to examples, and record what line number each one - ;; starts at. That way, if the input buffer is edited, we can - ;; still find corresponding examples in the output. - (doctest-mark-examples) - - ;; Run doctest - (cond (doctest-async - ;; Asynchronous mode: - (let ((process (start-process "*doctest*" doctest-results-buffer - doctest-python-command - "-c" script))) - ;; Store some information about the process. - (setq doctest-async-process-buffer cur-buf) - (setq doctest-async-process process) - (push input-file doctest-async-process-tempfiles) - (when globs-file - (push globs-file doctest-async-process-tempfiles)) - ;; Set up a sentinel to respond when it's done running. - (set-process-sentinel process 'doctest-async-process-sentinel) - - ;; Show the output window. - (let ((w (display-buffer doctest-results-buffer))) - (when doctest-follow-output - ;; Insert a newline, which will move the buffer's - ;; point past the process's mark -- this causes the - ;; window to scroll as new output is generated. - (save-current-buffer - (set-buffer doctest-results-buffer) - (insert-string "\n") - (set-window-point w (point))))) - - ;; Let the user know the process is running. - (doctest-update-mode-line ":running") - (message "Running doctest..."))) - (t - ;; Synchronous mode: - (call-process doctest-python-command nil - doctest-results-buffer t "-c" script) - (doctest-handle-output) - (delete-file input-file) - (when globs-file - (delete-file globs-file)))))))) - -(defun doctest-handle-output () - "This function, which is called after the 'doctest' process spawned -by doctest-execute-buffer has finished, checks the doctest results -buffer. If that buffer is empty, it reports no errors and hides it; -if that buffer is not empty, it reports that errors occured, displays -the buffer, and runs doctest-postprocess-results." - ;; If any tests failed, display them. - (cond ((not (buffer-live-p doctest-results-buffer)) - (doctest-warn "Results buffer not found!")) - ((> (buffer-size doctest-results-buffer) 1) - (display-buffer doctest-results-buffer) - (doctest-postprocess-results) - (let ((num (length doctest-example-markers))) - (message "%d doctest example%s failed!" num - (if (= num 1) "" "s")))) - (t - (display-buffer doctest-results-buffer) - (delete-windows-on doctest-results-buffer) - (message "All doctest examples passed!")))) - -(defun doctest-async-process-sentinel (process state) - "A process sentinel, called when the asynchronous doctest process -completes, which calls doctest-handle-output." - ;; Check to make sure we got the process we're expecting. On - ;; some operating systems, this will end up getting called twice - ;; when we use doctest-cancel-async-process; this check keeps us - ;; from trying to clean up after the same process twice (since we - ;; set doctest-async-process to nil when we're done). - (when (and (equal process doctest-async-process) - (buffer-live-p doctest-async-process-buffer)) - (save-current-buffer - (set-buffer doctest-async-process-buffer) - (cond ((not (buffer-live-p doctest-results-buffer)) - (doctest-warn "Results buffer not found!")) - ((equal state "finished\n") - (doctest-handle-output) - (let ((window (get-buffer-window - doctest-async-process-buffer t))) - (when window (set-window-point window (point))))) - ((equal state "killed\n") - (message "Doctest killed.")) - (t - (message "Doctest failed -- %s" state) - (display-buffer doctest-results-buffer))) - (doctest-update-mode-line "") - (while doctest-async-process-tempfiles - (delete-file (pop doctest-async-process-tempfiles))) - (setq doctest-async-process nil)))) - -(defun doctest-cancel-async-process () - "If a doctest process is running, then kill it." - (interactive "") - (when (doctest-process-live-p doctest-async-process) - ;; Update the modeline - (doctest-update-mode-line ":killing") - ;; Kill the process. - (kill-process doctest-async-process) - ;; Run the sentinel. (Depending on what OS we're on, the sentinel - ;; may end up getting called once or twice.) - (doctest-async-process-sentinel doctest-async-process "killed\n") - )) - -(defun doctest-postprocess-results () - "Post-process the doctest results buffer: check what version of -doctest was used, and set doctest-results-py-version accordingly; -turn on read-only mode; filter the example markers; hide the example -source (if `doctest-hide-example-source' is non-nil); and select the -first failure." - (save-excursion - (set-buffer doctest-results-buffer) - ;; Check if we're using an old doctest version. - (goto-char (point-min)) - (if (re-search-forward doctest-py21-results-re nil t) - (setq doctest-results-py-version 'py21) - (setq doctest-results-py-version 'py24)) - ;; Turn on read-only mode. - (toggle-read-only t)) - - (doctest-filter-example-markers) - (if doctest-hide-example-source - (doctest-hide-example-source)) - (doctest-next-failure 1)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Markers -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun doctest-mark-examples () - "Add a marker at the beginning of every (likely) example in the -input buffer; and create a list, `doctest-example-markers', -which maps from markers to the line numbers they originally occured -on. This will allow us to find the corresponding example in the -doctest output, even if the input buffer is edited." - (dolist (marker-info doctest-example-markers) - (set-marker (car marker-info) nil)) - (setq doctest-example-markers '()) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^ *>>> " nil t) - (backward-char 4) - (push (cons (point-marker) (doctest-line-number)) - doctest-example-markers) - (forward-char 4)))) - -(defun doctest-filter-example-markers () - "Remove any entries from `doctest-example-markers' that do not -correspond to a failed example." - (let ((filtered nil) (markers doctest-example-markers)) - (save-excursion - (set-buffer doctest-results-buffer) - (goto-char (point-max)) - (while (re-search-backward (doctest-results-loc-re) nil t) - (let ((lineno (string-to-int (match-string 1)))) - (when (equal doctest-results-py-version 'py21) - (setq lineno (+ lineno 1))) - (while (and markers (< lineno (cdar markers))) - (set-marker (caar markers) nil) - (setq markers (cdr markers))) - (if (and markers (= lineno (cdar markers))) - (push (pop markers) filtered) - (doctest-warn "Example expected on line %d but not found %s" - lineno markers))))) - (dolist (marker-info markers) - (set-marker (car marker-info) nil)) - (setq doctest-example-markers filtered))) - -(defun doctest-prev-example-marker () - "Helper for doctest-replace-output: move to the preceeding example -marker, and return the corresponding 'original' lineno. If none is -found, return nil." - (let ((lineno nil) - (pos nil)) - (save-excursion - (end-of-line) - (when (re-search-backward "^\\( *\\)>>> " nil t) - (goto-char (match-end 1)) - (dolist (marker-info doctest-example-markers) - (when (= (marker-position (car marker-info)) (point)) - (setq lineno (cdr marker-info)) - (setq pos (point)))))) - (unless (null lineno) - (goto-char pos) - lineno))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Navigation -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun doctest-next-failure (count) - "Move to the top of the next failing example, and highlight the -example's failure description in *doctest-output*." - (interactive "p") - (cond - ((and doctest-async (doctest-process-live-p doctest-async-process)) - (message "Wait for doctest to finish running!")) - ((not (doctest-results-buffer-valid-p)) - (message "Run doctest first! (C-c C-c)")) - ((equal count 0) - t) - (t - (let ((marker nil) (example-markers doctest-example-markers) - (results-window (display-buffer doctest-results-buffer))) - (save-excursion - (set-buffer doctest-results-buffer) - ;; Pick up where we left off. - ;; (nb: doctest-selected-failure is buffer-local) - (goto-char (or doctest-selected-failure (point-min))) - ;; Skip past anything on *this* line. - (if (>= count 0) (end-of-line) (beginning-of-line)) - ;; Look for the next failure - (when - (if (>= count 0) - (re-search-forward (doctest-results-loc-re) nil t count) - (re-search-backward (doctest-results-loc-re) nil t (- count))) - ;; We found a failure: - (let ((old-selected-failure doctest-selected-failure)) - (beginning-of-line) - ;; Extract the line number for the doctest file. - (let ((orig-lineno (string-to-int (match-string 1)))) - (when (equal doctest-results-py-version 'py21) - (setq orig-lineno (+ orig-lineno 1))) - (dolist (marker-info example-markers) - (when (= orig-lineno (cdr marker-info)) - (setq marker (car marker-info))))) - - ;; Update the window cursor. - (beginning-of-line) - (set-window-point results-window (point)) - ;; Store our position for next time. - (setq doctest-selected-failure (point)) - ;; Update selection. - (doctest-fontify-line old-selected-failure) - (doctest-fontify-line doctest-selected-failure)))) - - (cond - ;; We found a failure -- move point to the selected failure. - (marker - (goto-char (marker-position marker)) - (beginning-of-line)) - ;; We didn't find a failure, but there is one -- wrap. - ((> (length doctest-example-markers) 0) - (if (>= count 0) (doctest-first-failure) (doctest-last-failure))) - ;; We didn't find a failure -- alert the user. - (t (message "No failures found!"))))))) - -(defun doctest-prev-failure (count) - "Move to the top of the previous failing example, and highlight -the example's failure description in *doctest-output*." - (interactive "p") - (doctest-next-failure (- count))) - -(defun doctest-first-failure () - "Move to the top of the first failing example, and highlight -the example's failure description in *doctest-output*." - (interactive) - (if (buffer-live-p doctest-results-buffer) - (save-excursion - (set-buffer doctest-results-buffer) - (let ((old-selected-failure doctest-selected-failure)) - (setq doctest-selected-failure (point-min)) - (doctest-fontify-line old-selected-failure)))) - (doctest-next-failure 1)) - -(defun doctest-last-failure () - "Move to the top of the last failing example, and highlight -the example's failure description in *doctest-output*." - (interactive) - (if (buffer-live-p doctest-results-buffer) - (save-excursion - (set-buffer doctest-results-buffer) - (let ((old-selected-failure doctest-selected-failure)) - (setq doctest-selected-failure (point-max)) - (doctest-fontify-line old-selected-failure)))) - (doctest-next-failure -1)) - -(defun doctest-select-failure () - "Move to the top of the currently selected example, and select that -example in the source buffer. Intended for use in the results -buffer." - (interactive) - (re-search-backward doctest-results-divider-re) - (let ((old-selected-failure doctest-selected-failure)) - (setq doctest-selected-failure (point)) - (doctest-fontify-line doctest-selected-failure) - (doctest-fontify-line old-selected-failure)) - (pop-to-buffer doctest-source-buffer) - (doctest-next-failure 1)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Replace Output -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun doctest-replace-output () - "Move to the top of the closest example, and replace its output -with the 'got' output from the *doctest-output* buffer. An error is -displayed if the chosen example is not listed in *doctest-output*, or -if the 'expected' output for the example does not exactly match the -output listed in the source buffer. The user is asked to confirm the -replacement." - (interactive) - ;; Move to the beginning of the example. - (cond - ((and doctest-async (doctest-process-live-p doctest-async-process)) - (message "Wait for doctest to finish running!")) - ((not (doctest-results-buffer-valid-p)) - (message "Run doctest first! (C-c C-c)")) - ((save-excursion (set-buffer doctest-results-buffer) - (equal doctest-results-py-version 'py21)) - (error "doctest-replace-output requires python 2.4+")) - (t - (save-excursion - (save-restriction - (when (doctest-in-mmm-docstring-overlay) - (doctest-narrow-to-mmm-overlay)) - - (let* ((orig-buffer (current-buffer)) - ;; Find an example, and look up its original lineno. - (lineno (doctest-prev-example-marker)) - ;; Find the example's indentation. - (prompt-indent (doctest-line-indentation))) - - ;; Switch to the output buffer, and look for the example. - ;; If we don't find one, complain. - (cond - ((null lineno) (message "Doctest example not found")) - (t - (set-buffer doctest-results-buffer) - (goto-char (point-min)) - (let ((output-re (format "^File .*, line %s," lineno))) - (when (not (re-search-forward output-re nil t)) - (message "This doctest example did not fail") - (setq lineno nil))))) - - ;; If we didn't find an example, give up. - (when (not (null lineno)) - ;; Get the output's 'expected' & 'got' texts. - (let ((doctest-got nil) (doctest-expected nil) (header nil)) - (while (setq header (doctest-results-next-header)) - (cond - ((equal header "Failed example:") - t) - ((equal header "Expected nothing") - (setq doctest-expected "")) - ((equal header "Expected:") - (unless (re-search-forward "^\\(\\( \\).*\n\\)*" nil t) - (error "Error parsing doctest output")) - (setq doctest-expected (doctest-replace-regexp-in-string - "^ " prompt-indent - (match-string 0)))) - ((equal header "Got nothing") - (setq doctest-got "")) - ((or (equal header "Got:") (equal header "Exception raised:")) - (unless (re-search-forward "^\\(\\( \\).*\n\\)*" nil t) - (error "Error parsing doctest output")) - (setq doctest-got (doctest-replace-regexp-in-string - "^ " prompt-indent (match-string 0)))) - ((string-match "^Differences" header) - (error (concat "doctest-replace-output can not be used " - "with diff style output"))) - (t (error "Unexpected header %s" header)))) - - ;; Go back to the source buffer. - (set-buffer orig-buffer) - - ;; Skip ahead to the output. - (beginning-of-line) - (unless (re-search-forward "^ *>>>.*") - (error "Error parsing doctest output")) - (re-search-forward "\\(\n *\\.\\.\\..*\\)*\n?") - (when (looking-at "\\'") (insert-char ?\n)) - - ;; Check that the output matches. - (let ((start (point)) end) - (cond ((re-search-forward "^ *\\(>>>.*\\|$\\)" nil t) - (setq end (match-beginning 0))) - (t - (goto-char (point-max)) - (insert-string "\n") - (setq end (point-max)))) - (when (and doctest-expected - (not (equal (buffer-substring start end) - doctest-expected))) - (warn "{%s} {%s}" (buffer-substring start end) - doctest-expected) - (error (concat "This example's output has been modified " - "since doctest was last run"))) - (setq doctest-expected (buffer-substring start end)) - (goto-char end)) - - ;; Trim exceptions - (when (and doctest-trim-exceptions - (string-match doctest-traceback-re - doctest-got)) - (let ((s1 0) (e1 (match-end 1)) - (s2 (match-beginning 2)) (e2 (match-end 2)) - (s3 (match-beginning 3)) (e3 (length doctest-got))) - (setq doctest-got - (concat (substring doctest-got s1 e1) - (substring doctest-got s2 e2) " . . .\n" - (substring doctest-got s3 e3))))) - - ;; Confirm it with the user. - (let ((confirm-buffer (get-buffer-create "*doctest-confirm*"))) - (set-buffer confirm-buffer) - ;; Erase anything left over in the buffer. - (delete-region (point-min) (point-max)) - ;; Write a confirmation message - (if (equal doctest-expected "") - (insert-string "Replace nothing\n") - (insert-string (concat "Replace:\n" doctest-expected))) - (if (equal doctest-got "") - (insert-string "With nothing\n") - (insert-string (concat "With:\n" doctest-got))) - (let ((confirm-window (display-buffer confirm-buffer))) - ;; Shrink the confirm window. - (shrink-window-if-larger-than-buffer confirm-window) - ;; Return to the original buffer. - (set-buffer orig-buffer) - ;; Match the old expected region. - (when doctest-expected - (search-backward doctest-expected)) - (when (equal doctest-expected "") (backward-char 1)) - ;; Get confirmation & do the replacement - (widen) - (cond ((y-or-n-p "Ok to replace? ") - (when (equal doctest-expected "") (forward-char 1)) - (replace-match doctest-got t t) - (message "Replaced.")) - (t - (message "Replace cancelled."))) - ;; Clean up our confirm window - (kill-buffer confirm-buffer) - (delete-window confirm-window))))))))))) - -(defun doctest-results-next-header () - "Move to the next header in the doctest results buffer, and return -the string contents of that header. If no header is found, return -nil." - (if (re-search-forward (concat doctest-results-header-re "\\|" - doctest-results-divider-re) nil t) - (let ((result (match-string 0))) - (if (string-match doctest-results-header-re result) - result - nil)) - nil)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mmm-mode support -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; MMM Mode is a minor mode for Emacs which allows Multiple Major -;; Modes to coexist in a single buffer. - -;;;###autoload -(defun doctest-register-mmm-classes (&optional add-mode-ext-classes - fix-mmm-fontify-region-bug) - "Register doctest's mmm classes, allowing doctest to be used as a -submode region in other major modes, such as python-mode and rst-mode. -Two classes are registered: - -`doctest-docstring' - - Used to edit docstrings containing doctest examples in python- - mode. Docstring submode regions start and end with triple-quoted - strings (\"\"\"). In order to avoid confusing start-string - markers and end-string markers, all triple-quote strings in the - buffer are treated as submode regions (even if they're not - actually docstrings). Use (C-c % C-d) to insert a new doctest- - docstring region. When `doctest-execute' (C-c C-c) is called - inside a doctest-docstring region, it executes just the current - docstring. The globals for this execution are constructed by - importing the current buffer's contents in Python. - -`doctest-example' - - Used to edit doctest examples in text-editing modes, such as - `rst-mode' or `text-mode'. Docstring submode regions start with - optionally indented prompts (>>>) and end with blank lines. Use - (C-c % C-e) to insert a new doctest-example region. When - `doctest-execute' (C-c C-c) is called inside a doctest-example - region, it executes all examples in the buffer. - -If ADD-MODE-EXT-CLASSES is true, then register the new classes in -`mmm-mode-ext-classes-alist', which will cause them to be used by -default in the following modes: - - doctest-docstring: python-mode - doctest-example: rst-mode - -If FIX-MMM-FONTIFY-REGION-BUG is true, then register a hook that will -fix a bug in `mmm-fontify-region' that affects some (but not all) -versions of emacs. (See `doctest-fixed-mmm-fontify-region' for more -info.)" - (interactive) - (require 'mmm-auto) - (mmm-add-classes - '( - ;; === doctest-docstring === - (doctest-docstring :submode doctest-mode - - ;; The front is any triple-quote. Include it in the submode region, - ;; to prevent clashes between the two syntax tables over quotes. - :front "\\(\"\"\"\\|'''\\)" :include-front t - - ;; The back matches the front. Include just the first character - ;; of the quote. If we didn't include at least one quote, then - ;; the outer modes quote-counting would be thrown off. But if - ;; we include all three, we run into a bug in mmm-mode. See - ;; <http://tinyurl.com/2fa83w> for more info about the bug. - :save-matches t :back "~1" :back-offset 1 :end-not-begin t - - ;; Define a skeleton for entering new docstrings. - :insert ((?d docstring nil @ "\"\"" @ "\"" \n - _ \n "\"" @ "\"\"" @))) - - ;; === doctest-example === - (doctest-example - :submode doctest-mode - ;; The front is an optionally indented prompt. - :front "^[ \t]*>>>" :include-front t - ;; The back is a blank line. - :back "^[ \t]*$" - ;; Define a skeleton for entering new docstrings. - :insert ((?e doctest-example nil - @ @ " >>> " _ "\n\n" @ @))))) - - ;; Register some local variables that need to be saved. - (add-to-list 'mmm-save-local-variables - '(doctest-results-buffer buffer)) - (add-to-list 'mmm-save-local-variables - '(doctest-example-markers buffer)) - - ;; Register association with modes, if requested. - (when add-mode-ext-classes - (mmm-add-mode-ext-class 'python-mode nil 'doctest-docstring) - (mmm-add-mode-ext-class 'rst-mode nil 'doctest-example)) - - ;; Fix the buggy mmm-fontify-region, if requested. - (when fix-mmm-fontify-region-bug - (add-hook 'mmm-mode-hook 'doctest-fix-mmm-fontify-region-bug))) - -(defvar doctest-old-mmm-fontify-region 'nil - "Used to hold the original definition of `mmm-fontify-region' when it -is rebound by `doctest-fix-mmm-fontify-region-bug'.") - -(defun doctest-fix-mmm-fontify-region-bug () - "A function for `mmm-mode-hook' which fixes a potential bug in -`mmm-fontify-region' by using `doctest-fixed-mmm-fontify-region' -instead. (See `doctest-fixed-mmm-fontify-region' for more info.)" - (setq font-lock-fontify-region-function - 'doctest-fixed-mmm-fontify-region)) - -(defun doctest-fixed-mmm-fontify-region (start stop &optional loudly) - "A replacement for `mmm-fontify-region', which fixes a bug caused by -versions of emacs where post-command-hooks are run *before* -fontification. `mmm-mode' assumes that its post-command-hook will be -run after fontification; and if it's not, then mmm-mode can end up -with the wrong local variables, keymap, etc. after fontification. We -fix that here by redefining `mmm-fontify-region' to remember what -submode overlay it started in; and to return to that overlay after -fontification is complete. The original definition of -`mmm-fontify-region' is stored in `doctest-old-mmm-fontify-region'." - (let ((overlay mmm-current-overlay)) - (mmm-fontify-region start stop loudly) - (if (and overlay (or (< (point) (overlay-start overlay)) - (> (point) (overlay-end overlay)))) - (goto-char (overlay-start overlay))) - (mmm-update-submode-region))) - -(defun doctest-in-mmm-docstring-overlay () - (and (featurep 'mmm-auto) - (mmm-overlay-at (point)) - (save-excursion - (goto-char (overlay-start (mmm-overlay-at (point)))) - (looking-at "\"\"\"\\|\'\'\'")))) - -(defun doctest-narrow-to-mmm-overlay () - "If we're in an mmm-mode overlay, then narrow to that overlay. -This is useful, e.g., to keep from interpreting the close-quote of a -docstring as part of the example's output." - (let ((bounds (doctest-mmm-overlay-bounds))) - (when bounds (narrow-to-region (car bounds) (cdr bounds))))) - -(defun doctest-default-margin-in-mmm-docstring-overlay () - (save-excursion - (let ((pos (car (doctest-mmm-overlay-bounds)))) - (goto-char pos) - (when (doctest-looking-back "\"\"\"\\|\'\'\'") - (setq pos (- pos 3))) - (beginning-of-line) - (- pos (point))))) - -(defun doctest-mmm-overlay-bounds () - (when (featurep 'mmm-auto) - (let ((overlay (mmm-overlay-at (point)))) - (when overlay - (let ((start (overlay-start overlay)) - (end (overlay-end overlay))) - (when (doctest-in-mmm-docstring-overlay) - (save-excursion - (goto-char start) - (re-search-forward "[\"\']*") - (setq start (point)) - (goto-char end) - (while (doctest-looking-back "[\"\']") - (backward-char 1)) - (setq end (point)))) - (cons start end)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Helper functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun doctest-on-source-line-p (&optional prompt) - "Return true if the current line is a source line. The optional -argument prompt can be used to specify which type of source -line (... or >>>)." - (save-excursion - (beginning-of-line) - ;; Check if we're looking at a prompt (of the right type). - (when (and (looking-at doctest-prompt-re) - (or (null prompt) - (equal prompt (substring (match-string 2) 0 3)))) - ;; Scan backwards to make sure there's a >>> somewhere. Otherwise, - ;; this might be a '...' in the text or in an example's output. - (while (looking-at "^[ \t]*[.][.][.]") - (forward-line -1)) - (looking-at "^[ \t]*>>>")))) - -(defun doctest-on-empty-source-line-p () - "Return true if the current line contains a bare prompt." - (save-excursion - (beginning-of-line) - (and (doctest-on-source-line-p) - (looking-at (concat doctest-prompt-re "$"))))) - -(defun doctest-on-output-line-p () - "Return true if the current line is an output line." - (save-excursion - (beginning-of-line) - ;; The line must not be blank or a source line. - (when (not (or (doctest-on-source-line-p) (looking-at "[ \t]*$"))) - ;; The line must follow a source line, with no intervening blank - ;; lines. - (while (not (or (doctest-on-source-line-p) (looking-at "[ \t]*$") - (= (point) (point-min)))) - (forward-line -1)) - (doctest-on-source-line-p)))) - -(defun doctest-find-output-line (&optional limit) - "Move forward to the next doctest output line (staying within -the given bounds). Return the character position of the doctest -output line if one was found, and false otherwise." - (let ((found-it nil) ; point where we found an output line - (limit (or limit (point-max)))) ; default value for limit - (save-excursion - ;; Keep moving forward, one line at a time, until we find a - ;; doctest output line. - (while (and (not found-it) (< (point) limit) (not (eobp))) - (if (and (not (eolp)) (doctest-on-output-line-p)) - (setq found-it (point)) - (forward-line)))) - ;; If we found a doctest output line, then go to it. - (if found-it (goto-char found-it)))) - -(defun doctest-line-indentation () - "Helper for doctest-replace-output: return the whitespace indentation -at the beginning of this line." - (save-excursion - (end-of-line) - (re-search-backward "^\\( *\\)" nil t) - (match-string 1))) - -(defun doctest-optionflags (&optional diff) - "Return a string describing the optionflags that should be used -by doctest. If DIFF is non-nil, then add the REPORT_UDIFF flag." - (let ((flags "0")) - (dolist (flag doctest-optionflags) - (setq flags (concat flags "|" flag))) - (if diff (concat flags "|" "REPORT_UDIFF") flags))) - -(defun doctest-results-loc-re () - "Return the regexp that should be used to look for doctest example -location markers in doctest's output (based on which version of -doctest was used" - (cond - ((equal doctest-results-py-version 'py21) - doctest-py21-results-loc-re) - ((equal doctest-results-py-version 'py24) - doctest-py24-results-loc-re) - (t (error "bad value for doctest-results-py-version")))) - -(defun doctest-results-buffer-name () - "Return the buffer name that should be used for the doctest results -buffer. This is computed from the variable -`doctest-results-buffer-name'." - (doctest-replace-regexp-in-string - "%[nfN]" - (lambda (sym) - (cond ((equal sym "%n") (buffer-name)) - ((equal sym "%N") (doctest-replace-regexp-in-string - "[.]doctest$" "" (buffer-name) t)) - ((equal sym "%f") (buffer-file-name)))) - doctest-results-buffer-name t)) - -(defun doctest-script (input-file globs-file diff) - "..." - (doctest-replace-regexp-in-string - "%[tnflm]" - (lambda (sym) - (cond ((equal sym "%n") (buffer-name)) - ((equal sym "%f") (buffer-file-name)) - ((equal sym "%l") (doctest-optionflags diff)) - ((equal sym "%t") input-file) - ((equal sym "%m") (or globs-file "")))) - doctest-script t)) - -(defun doctest-hide-example-source () - "Delete the source code listings from the results buffer (since it's -easy enough to see them in the original buffer)" - (save-excursion - (set-buffer doctest-results-buffer) - (toggle-read-only 0) - (goto-char (point-min)) - (while (re-search-forward doctest-example-source-re nil t) - (replace-match "" nil nil)) - (toggle-read-only t))) - -(defun doctest-results-buffer-valid-p () - "Return true if this buffer has a live results buffer; and that -results buffer reports this buffer as its source buffer. (Two -buffers in doctest-mode might point to the same results buffer; -but only one of them will be equal to that results buffer's -source buffer." - (let ((cur-buf (current-buffer))) - (and (buffer-live-p doctest-results-buffer) - (save-excursion - (set-buffer doctest-results-buffer) - (equal cur-buf doctest-source-buffer))))) - -(defun doctest-update-mode-line (value) - "Update the doctest mode line with the given string value. This -is used to display information about asynchronous processes that -are run by doctest-mode." - (setq doctest-mode-line-process - value) - (force-mode-line-update t)) - -(defun doctest-version () - "Echo the current version of `doctest-mode' in the minibuffer." - (interactive) - (message "Using `doctest-mode' version %s" doctest-version)) - -(defun doctest-warn (msg &rest args) - "Display a doctest warning message." - (if (fboundp 'display-warning) - (display-warning 'doctest (apply 'format msg args)) - (apply 'message msg args))) - -(defun doctest-debug (msg &rest args) - "Display a doctest debug message." - (if (fboundp 'display-warning) - (display-warning 'doctest (apply 'format msg args) 'debug) - (apply 'message msg args))) - -(defvar doctest-serial-number 0) ;used if broken-temp-names. -(defun doctest-temp-name () - "Return a new temporary filename, for use in calling doctest." - (if (memq 'broken-temp-names features) - (let - ((sn doctest-serial-number) - (pid (and (fboundp 'emacs-pid) (emacs-pid)))) - (setq doctest-serial-number (1+ doctest-serial-number)) - (if pid - (format "doctest-%d-%d" sn pid) - (format "doctest-%d" sn))) - (make-temp-name "doctest-"))) - -(defun doctest-fontify-line (charpos) - "Run font-lock-fontify-region on the line containing the given -position." - (if (and charpos (functionp 'font-lock-fontify-region)) - (save-excursion - (goto-char charpos) - (let ((beg (progn (beginning-of-line) (point))) - (end (progn (end-of-line) (point)))) - (font-lock-fontify-region beg end))))) - -(defun doctest-do-auto-fill () - "If the current line is a soucre line or an output line, do nothing. -Otherwise, call (do-auto-fill)." - (cond - ;; Don't wrap source lines. - ((doctest-on-source-line-p) nil) - ;; Don't wrap output lines - ((doctest-on-output-line-p) nil) - ;; Wrap all other lines - (t (do-auto-fill)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Emacs Compatibility Functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Define compatible versions of functions that are defined -;; for some versions of emacs but not others. - -;; Backwards compatibility: looking-back -(cond ((fboundp 'looking-back) ;; Emacs 22.x - (defalias 'doctest-looking-back 'looking-back)) - (t - (defun doctest-looking-back (regexp) - "Return true if text before point matches REGEXP." - (save-excursion - (let ((orig-pos (point))) - ;; Search backwards for the regexp. - (if (re-search-backward regexp nil t) - ;; Check if it ends at the original point. - (= orig-pos (match-end 0)))))))) - -;; Backwards compatibility: replace-regexp-in-string -(cond ((fboundp 'replace-regexp-in-string) - (defalias 'doctest-replace-regexp-in-string 'replace-regexp-in-string)) - (t ;; XEmacs 21.x or Emacs 20.x - (defun doctest-replace-regexp-in-string - (regexp rep string &optional fixedcase literal) - "Replace all matches for REGEXP with REP in STRING." - (let ((start 0)) - (while (and (< start (length string)) - (string-match regexp string start)) - (setq start (+ (match-end 0) 1)) - (let ((newtext (if (functionp rep) - (save-match-data - (funcall rep (match-string 0 string))) - rep))) - (setq string (replace-match newtext fixedcase - literal string))))) - string))) - -;; Backwards compatibility: line-number -(cond ((fboundp 'line-number) ;; XEmacs - (defalias 'doctest-line-number 'line-number)) - ((fboundp 'line-number-at-pos) ;; Emacs 22.x - (defalias 'doctest-line-number 'line-number-at-pos)) - (t ;; Emacs 21.x - (defun doctest-line-number (&optional pos) - "Return the line number of POS (default=point)." - (1+ (count-lines 1 - (save-excursion (progn (beginning-of-line) - (or pos (point))))))))) - -;; Backwards compatibility: process-live-p -(cond ((fboundp 'process-live-p) ;; XEmacs - (defalias 'doctest-process-live-p 'process-live-p)) - (t ;; Emacs - (defun doctest-process-live-p (process) - (and (processp process) - (equal (process-status process) 'run))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Doctest Results Mode (output of doctest-execute-buffer) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Register the font-lock keywords (xemacs) -(put 'doctest-results-mode 'font-lock-defaults - '(doctest-results-font-lock-keywords)) - -;; Register the font-lock keywords (older versions of gnu emacs) -(when (boundp 'font-lock-defaults-alist) - (add-to-list 'font-lock-defaults-alist - '(doctest-results-mode doctest-results-font-lock-keywords - nil nil nil nil))) - -(defvar doctest-selected-failure nil - "The location of the currently selected failure. -This variable is uffer-local to doctest-results-mode buffers.") - -(defvar doctest-source-buffer nil - "The buffer that spawned this one. -This variable is uffer-local to doctest-results-mode buffers.") - -(defvar doctest-results-py-version nil - "A symbol indicating which version of Python was used to generate -the results in a doctest-results-mode buffer. Can be either the -symbol `py21' or the symbol `py24'. -This variable is uffer-local to doctest-results-mode buffers.") - -;; Keymap for doctest-results-mode. -(defconst doctest-results-mode-map - (let ((map (make-keymap))) - (define-key map [return] 'doctest-select-failure) - map) - "Keymap for doctest-results-mode.") - -;; Syntax table for doctest-results-mode. -(defvar doctest-results-mode-syntax-table nil - "Syntax table used in `doctest-results-mode' buffers.") -(when (not doctest-results-mode-syntax-table) - (setq doctest-results-mode-syntax-table (make-syntax-table)) - (dolist (entry '(("(" . "()") ("[" . "(]") ("{" . "(}") - (")" . ")(") ("]" . ")[") ("}" . "){") - ("$%&*+-/<=>|'\"`" . ".") ("_" . "w"))) - (dolist (char (string-to-list (car entry))) - (modify-syntax-entry char (cdr entry) - doctest-results-mode-syntax-table)))) - -;; Define the mode -(defun doctest-results-mode () - "A major mode used to display the results of running doctest. -See `doctest-mode'. - -\\{doctest-results-mode-map}" - (interactive) - - ;; Declare local variables. - (kill-all-local-variables) - (make-local-variable 'font-lock-defaults) - (make-local-variable 'doctest-selected-failure) - (make-local-variable 'doctest-source-buffer) - (make-local-variable 'doctest-results-py-version) - - ;; Define local variables. - (setq major-mode 'doctest-results-mode - mode-name "Doctest-Results" - mode-line-process 'doctest-mode-line-process - font-lock-defaults '(doctest-results-font-lock-keywords - nil nil nil nil)) - ;; Define keymap. - (use-local-map doctest-results-mode-map) - - ;; Define the syntax table. - (set-syntax-table doctest-results-mode-syntax-table) - - ;; Enable font-lock mode. - (if (featurep 'font-lock) (font-lock-mode 1))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Doctest Mode -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Register the font-lock keywords (xemacs) -(put 'doctest-mode 'font-lock-defaults '(doctest-font-lock-keywords - nil nil nil nil)) - -;; Register the font-lock keywords (older versions of gnu emacs) -(when (boundp 'font-lock-defaults-alist) - (add-to-list 'font-lock-defaults-alist - '(doctest-mode doctest-font-lock-keywords - nil nil nil nil))) - -(defvar doctest-results-buffer nil - "The output buffer for doctest-mode. -This variable is buffer-local to doctest-mode buffers.") - -(defvar doctest-example-markers nil - "A list mapping markers to the line numbers at which they appeared -in the buffer at the time doctest was last run. This is used to find -'original' line numbers, which can be used to search the doctest -output buffer. It's encoded as a list of (MARKER . POS) tuples, in -reverse POS order. -This variable is buffer-local to doctest-mode buffers.") - -;; These are global, since we only one run process at a time: -(defvar doctest-async-process nil - "The process object created by the asynchronous doctest process") -(defvar doctest-async-process-tempfiles nil - "A list of tempfile names created by the asynchronous doctest process") -(defvar doctest-async-process-buffer nil - "The source buffer for the asynchronous doctest process") -(defvar doctest-mode-line-process "" - "A string displayed on the modeline, to indicate when doctest is -running asynchronously.") - -;; Keymap for doctest-mode. n.b.: we intentionally define [tab] -;; rather than overriding indent-line-function, since we don't want -;; doctest-indent-source-line to be called by do-auto-fill. -(defconst doctest-mode-map - (let ((map (make-keymap))) - (define-key map [backspace] 'doctest-electric-backspace) - (define-key map [return] 'doctest-newline-and-indent) - (define-key map [tab] 'doctest-indent-source-line) - (define-key map ":" 'doctest-electric-colon) - (define-key map "\C-c\C-v" 'doctest-version) - (define-key map "\C-c\C-c" 'doctest-execute) - (define-key map "\C-c\C-d" 'doctest-execute-with-diff) - (define-key map "\C-c\C-n" 'doctest-next-failure) - (define-key map "\C-c\C-p" 'doctest-prev-failure) - (define-key map "\C-c\C-a" 'doctest-first-failure) - (define-key map "\C-c\C-e" 'doctest-last-failure) - (define-key map "\C-c\C-z" 'doctest-last-failure) - (define-key map "\C-c\C-r" 'doctest-replace-output) - (define-key map "\C-c|" 'doctest-execute-region) - map) - "Keymap for doctest-mode.") - -;; Syntax table for doctest-mode. -(defvar doctest-mode-syntax-table nil - "Syntax table used in `doctest-mode' buffers.") -(when (not doctest-mode-syntax-table) - (setq doctest-mode-syntax-table (make-syntax-table)) - (dolist (entry '(("(" . "()") ("[" . "(]") ("{" . "(}") - (")" . ")(") ("]" . ")[") ("}" . "){") - ("$%&*+-/<=>|'\"`" . ".") ("_" . "w"))) - (dolist (char (string-to-list (car entry))) - (modify-syntax-entry char (cdr entry) doctest-mode-syntax-table)))) - -;; Use doctest mode for files ending in .doctest -;;;###autoload -(add-to-list 'auto-mode-alist '("\\.doctest$" . doctest-mode)) - -;;;###autoload -(defun doctest-mode () - "A major mode for editing text files that contain Python -doctest examples. Doctest is a testing framework for Python that -emulates an interactive session, and checks the result of each -command. For more information, see the Python library reference: -<http://docs.python.org/lib/module-doctest.html> - -`doctest-mode' defines three kinds of line, each of which is -treated differently: - - - 'Source lines' are lines consisting of a Python prompt - ('>>>' or '...'), followed by source code. Source lines are - colored (similarly to `python-mode') and auto-indented. - - - 'Output lines' are non-blank lines immediately following - source lines. They are colored using several doctest- - specific output faces. - - - 'Text lines' are any other lines. They are not processed in - any special way. - -\\{doctest-mode-map}" - (interactive) - - ;; Declare local variables. - (kill-all-local-variables) - (make-local-variable 'font-lock-defaults) - (make-local-variable 'doctest-results-buffer) - (make-local-variable 'doctest-example-markers) - - ;; Define local variables. - (setq major-mode 'doctest-mode - mode-name "Doctest" - mode-line-process 'doctest-mode-line-process - font-lock-defaults '(doctest-font-lock-keywords - nil nil nil nil)) - - ;; Define keymap. - (use-local-map doctest-mode-map) - - ;; Define the syntax table. - (set-syntax-table doctest-mode-syntax-table) - - ;; Enable auto-fill mode. - (auto-fill-mode 1) - (setq auto-fill-function 'doctest-do-auto-fill) - - ;; Enable font-lock mode. - (if (featurep 'font-lock) (font-lock-mode 1)) - - ;; Run the mode hook. - (run-hooks 'doctest-mode-hook)) - -(provide 'doctest-mode) -;;; doctest-mode.el ends here
deleted file mode 100644 --- a/.elisp/http-twiddle.el +++ /dev/null @@ -1,153 +0,0 @@ -;;; http-twiddle.el -- send & twiddle & resend HTTP requests -;; -;; Version 1.0 written by Luke Gorrie <luke@synap.se> in February 2006 -;; This program belongs to the public domain. -;; -;; (downloaded from http://fresh.homeunix.net/~luke/misc/emacs/http-twiddle.el) -;; -;; This is a program for testing hand-written HTTP requests. You write -;; your request in an Emacs buffer (using http-twiddle-mode) and then -;; press `C-c C-c' each time you want to try sending it to the server. -;; This way you can interactively debug the requests. To change port or -;; destination do `C-u C-c C-c'. -;; -;; The program is particularly intended for the POST-"500 internal -;; server error"-edit-POST loop of integration with SOAP programs. -;; -;; The mode is activated by `M-x http-twiddle-mode' or automatically -;; when opening a filename ending with .http-twiddle. -;; -;; The request can either be written from scratch or you can paste it -;; from a snoop/tcpdump and then twiddle from there. -;; -;; See the documentation for the `http-twiddle-mode' and -;; `http-twiddle-mode-send' functions below for more details and try -;; `M-x http-twiddle-mode-demo' for a simple get-started example. -;; -;; Tested with GNU Emacs 21.4.1 and not tested/ported on XEmacs yet. - -;;; Example buffer: - -;; POST / HTTP/1.0 -;; Connection: close -;; Content-Length: $Content-Length -;; -;; The request body goes here - -(require 'font-lock) ; faces - -(eval-when-compile - (unless (fboundp 'define-minor-mode) - (require 'easy-mmode) - (defalias 'define-minor-mode 'easy-mmode-define-minor-mode)) - (require 'cl)) - -(define-minor-mode http-twiddle-mode - "Major mode for twiddling around with HTTP requests and sending them. -Use `http-twiddle-mode-send' (\\[http-twiddle-mode-send]) to send the request." - nil - " http-twiddle" - '(("\C-c\C-c" . http-twiddle-mode-send))) - -(defvar http-twiddle-show-request t - "*Show the request in the transcript.") - -(add-to-list 'auto-mode-alist '("\\.http-twiddle$" . http-twiddle-mode)) - -(defvar http-twiddle-endpoint nil - "Cache of the (HOST PORT) to send the request to.") - -(defvar http-twiddle-process nil - "Socket connected to the webserver.") - -(defvar http-twiddle-port-history '() - "History of port arguments entered in the minibuffer. -\(To make XEmacs happy.)") - -(defvar http-twiddle-host-history '() - "History of port arguments entered in the minibuffer. -\(To make XEmacs happy.)") - -(defun http-twiddle-mode-send (host port) - "Send the current buffer to the server. -Linebreaks are automatically converted to CRLF (\\r\\n) format and any -occurences of \"$Content-Length\" are replaced with the actual content -length." - (interactive (http-twiddle-read-endpoint)) - ;; close any old connection - (when http-twiddle-process - (kill-buffer (process-buffer http-twiddle-process))) - (let ((content (buffer-string))) - (with-temp-buffer - (insert content) - (http-twiddle-convert-cr-to-crlf) - (http-twiddle-expand-content-length) - (let ((request (buffer-string))) - (setq http-twiddle-process - (open-network-stream "http-twiddle" "*HTTP Twiddle*" host port)) - (set-process-filter http-twiddle-process 'http-twiddle-process-filter) - (set-process-sentinel http-twiddle-process 'http-twiddle-process-sentinel) - (process-send-string http-twiddle-process request) - (save-selected-window - (pop-to-buffer (process-buffer http-twiddle-process)) - (when http-twiddle-show-request - (insert request) - (set-window-start (selected-window) (point)) - (add-text-properties (point-min) (point-max) - '(face font-lock-comment-face))) - (set-mark (point))))))) - -(defun http-twiddle-read-endpoint () - "Return the endpoint (HOST PORT) to send the request to." - (if (and http-twiddle-endpoint (null current-prefix-arg)) - http-twiddle-endpoint - (setq http-twiddle-endpoint - (list (read-string "Host: (default localhost) " - nil 'http-twiddle-host-history "localhost") - (let ((input (read-from-minibuffer "Port: " nil nil t 'http-twiddle-port-history))) - (if (integerp input) - input - (error "Not an integer: %S" input))))))) - -(defun http-twiddle-convert-cr-to-crlf () - "Convert \\n linebreaks to \\r\\n in the whole buffer." - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "[^\r]\n" nil t) - (backward-char) - (insert "\r")))) - -(defun http-twiddle-expand-content-length () - "Replace any occurences of $Content-Length with the actual Content-Length." - (save-excursion - (goto-char (point-min)) - (let ((content-length - (save-excursion (when (search-forward "\r\n\r\n" nil t) - (- (point-max) (point)))))) - (unless (null content-length) - (let ((case-fold-search t)) - (while (search-forward "$content-length" nil t) - (replace-match (format "%d" content-length) nil t))))))) - -(defun http-twiddle-process-filter (process string) - "Process data from the socket by inserting it at the end of the buffer." - (with-current-buffer (process-buffer process) - (goto-char (point-max)) - (insert string))) - -(defun http-twiddle-process-sentinel (process what) - (with-current-buffer (process-buffer process) - (goto-char (point-max)) - (let ((start (point))) - (insert "Connection closed\n") - (add-text-properties start (point) '(face font-lock-string-face))))) - -(defun http-twiddle-mode-demo () - (interactive) - (pop-to-buffer (get-buffer-create "*http-twiddle demo*")) - (http-twiddle-mode 1) - (erase-buffer) - (insert "POST / HTTP/1.0\nContent-Length: $Content-Length\nConnection: close\n\nThis is the POST body.\n") - (message "Now press `C-c C-c' and enter a webserver address (e.g. google.com port 80).")) - -(provide 'http-twiddle)
deleted file mode 100644 --- a/.elisp/ipython.el +++ /dev/null @@ -1,483 +0,0 @@ -;;; ipython.el --- Adds support for IPython to python-mode.el - -;; Copyright (C) 2002, 2003, 2004, 2005 Alexander Schmolck -;; Author: Alexander Schmolck -;; Keywords: ipython python languages oop -;; URL: http://ipython.scipy.org -;; Compatibility: Emacs21, XEmacs21 -;; FIXME: #$@! INPUT RING -(defconst ipython-version "$Revision: 2275 $" - "VC version number.") - -;;; Commentary -;; This library makes all the functionality python-mode has when running with -;; the normal python-interpreter available for ipython, too. It also enables a -;; persistent py-shell command history across sessions (if you exit python -;; with C-d in py-shell) and defines the command `ipython-to-doctest', which -;; can be used to convert bits of a ipython session into something that can be -;; used for doctests. To install, put this file somewhere in your emacs -;; `load-path' [1] and add the following line to your ~/.emacs file (the first -;; line only needed if the default (``"ipython"``) is wrong):: -;; -;; (setq ipython-command "/SOME-PATH/ipython") -;; (require 'ipython) -;; -;; Ipython will be set as the default python shell, but only if the ipython -;; executable is in the path. For ipython sessions autocompletion with <tab> -;; is also enabled (experimental feature!). Please also note that all the -;; terminal functions in py-shell are handled by emacs's comint, **not** by -;; (i)python, so importing readline etc. will have 0 effect. -;; -;; To start an interactive ipython session run `py-shell' with ``M-x py-shell`` -;; (or the default keybinding ``C-c C-!``). -;; -;; NOTE: This mode is currently somewhat alpha and although I hope that it -;; will work fine for most cases, doing certain things (like the -;; autocompletion and a decent scheme to switch between python interpreters) -;; properly will also require changes to ipython that will likely have to wait -;; for a larger rewrite scheduled some time in the future. -;; -;; Also note that you currently NEED THE CVS VERSION OF PYTHON.EL. -;; -;; Further note that I don't know whether this runs under windows or not and -;; that if it doesn't I can't really help much, not being afflicted myself. -;; -;; -;; Hints for effective usage -;; ------------------------- -;; -;; - IMO the best feature by far of the ipython/emacs combo is how much easier it -;; makes it to find and fix bugs thanks to the ``%pdb on``/ pdbtrack combo. Try -;; it: first in the ipython to shell do ``%pdb on`` then do something that will -;; raise an exception (FIXME nice example) -- and be amazed how easy it is to -;; inspect the live objects in each stack frames and to jump to the -;; corresponding sourcecode locations as you walk up and down the stack trace -;; (even without ``%pdb on`` you can always use ``C-c -`` (`py-up-exception') -;; to jump to the corresponding source code locations). -;; -;; - emacs gives you much more powerful commandline editing and output searching -;; capabilities than ipython-standalone -- isearch is your friend if you -;; quickly want to print 'DEBUG ...' to stdout out etc. -;; -;; - This is not really specific to ipython, but for more convenient history -;; access you might want to add something like the following to *the beggining* -;; of your ``.emacs`` (if you want behavior that's more similar to stand-alone -;; ipython, you can change ``meta p`` etc. for ``control p``):: -;; -;; (require 'comint) -;; (define-key comint-mode-map [(meta p)] -;; 'comint-previous-matching-input-from-input) -;; (define-key comint-mode-map [(meta n)] -;; 'comint-next-matching-input-from-input) -;; (define-key comint-mode-map [(control meta n)] -;; 'comint-next-input) -;; (define-key comint-mode-map [(control meta p)] -;; 'comint-previous-input) -;; -;; - Be aware that if you customize py-python-command previously, this value -;; will override what ipython.el does (because loading the customization -;; variables comes later). -;; -;; Please send comments and feedback to the ipython-list -;; (<ipython-user@scipy.net>) where I (a.s.) or someone else will try to -;; answer them (it helps if you specify your emacs version, OS etc; -;; familiarity with <http://www.catb.org/~esr/faqs/smart-questions.html> might -;; speed up things further). -;; -;; Footnotes: -;; -;; [1] If you don't know what `load-path' is, C-h v load-path will tell -;; you; if required you can also add a new directory. So assuming that -;; ipython.el resides in ~/el/, put this in your emacs: -;; -;; -;; (add-to-list 'load-path "~/el") -;; (setq ipython-command "/some-path/ipython") -;; (require 'ipython) -;; -;; -;; -;; -;; TODO: -;; - do autocompletion properly -;; - implement a proper switching between python interpreters -;; -;; BUGS: -;; - neither:: -;; -;; (py-shell "-c print 'FOOBAR'") -;; -;; nor:: -;; -;; (let ((py-python-command-args (append py-python-command-args -;; '("-c" "print 'FOOBAR'")))) -;; (py-shell)) -;; -;; seem to print anything as they should -;; -;; - look into init priority issues with `py-python-command' (if it's set -;; via custom) - - -;;; Code -(require 'cl) -(require 'shell) -(require 'executable) -(require 'ansi-color) - -(defcustom ipython-command "ipython" - "*Shell command used to start ipython." - :type 'string - :group 'python) - -;; Users can set this to nil -(defvar py-shell-initial-switch-buffers t - "If nil, don't switch to the *Python* buffer on the first call to - `py-shell'.") - -(defvar ipython-backup-of-py-python-command nil - "HACK") - - -(defvar ipython-de-input-prompt-regexp "\\(?: -In \\[[0-9]+\\]: *.* -----+> \\(.* -\\)[\n]?\\)\\|\\(?: -In \\[[0-9]+\\]: *\\(.* -\\)\\)\\|^[ ]\\{3\\}[.]\\{3,\\}: *\\(.* -\\)" - "A regular expression to match the IPython input prompt and the python -command after it. The first match group is for a command that is rewritten, -the second for a 'normal' command, and the third for a multiline command.") -(defvar ipython-de-output-prompt-regexp "^Out\\[[0-9]+\\]: " - "A regular expression to match the output prompt of IPython.") - - -(if (not (executable-find ipython-command)) - (message (format "Can't find executable %s - ipython.el *NOT* activated!!!" - ipython-command)) - ;; XXX load python-mode, so that we can screw around with its variables - ;; this has the disadvantage that python-mode is loaded even if no - ;; python-file is ever edited etc. but it means that `py-shell' works - ;; without loading a python-file first. Obviously screwing around with - ;; python-mode's variables like this is a mess, but well. - (require 'python-mode) - ;; turn on ansi colors for ipython and activate completion - (defun ipython-shell-hook () - ;; the following is to synchronize dir-changes - (make-local-variable 'shell-dirstack) - (setq shell-dirstack nil) - (make-local-variable 'shell-last-dir) - (setq shell-last-dir nil) - (make-local-variable 'shell-dirtrackp) - (setq shell-dirtrackp t) - (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t) - - (ansi-color-for-comint-mode-on) - (define-key py-shell-map [tab] 'ipython-complete) - ;; Add this so that tab-completion works both in X11 frames and inside - ;; terminals (such as when emacs is called with -nw). - (define-key py-shell-map "\t" 'ipython-complete) - ;;XXX this is really just a cheap hack, it only completes symbols in the - ;;interactive session -- useful nonetheless. - (define-key py-mode-map [(meta tab)] 'ipython-complete) - - ) - (add-hook 'py-shell-hook 'ipython-shell-hook) - ;; Regular expression that describes tracebacks for IPython in context and - ;; verbose mode. - - ;;Adapt python-mode settings for ipython. - ;; (this works for %xmode 'verbose' or 'context') - - ;; XXX putative regexps for syntax errors; unfortunately the - ;; current python-mode traceback-line-re scheme is too primitive, - ;; so it's either matching syntax errors, *or* everything else - ;; (XXX: should ask Fernando for a change) - ;;"^ File \"\\(.*?\\)\", line \\([0-9]+\\).*\n.*\n.*\nSyntaxError:" - ;;^ File \"\\(.*?\\)\", line \\([0-9]+\\)" - - (setq py-traceback-line-re - "\\(^[^\t >].+?\\.py\\).*\n +[0-9]+[^\00]*?\n-+> \\([0-9]+\\)+") - - - ;; Recognize the ipython pdb, whose prompt is 'ipdb>' or 'ipydb>' - ;;instead of '(Pdb)' - (setq py-pdbtrack-input-prompt "\n[(<]*[Ii]?[Pp]y?db[>)]+ ") - (setq pydb-pydbtrack-input-prompt "\n[(]*ipydb[>)]+ ") - - (setq py-shell-input-prompt-1-regexp "^In \\[[0-9]+\\]: *" - py-shell-input-prompt-2-regexp "^ [.][.][.]+: *" ) - ;; select a suitable color-scheme - (unless (member "-colors" py-python-command-args) - (setq py-python-command-args - (nconc py-python-command-args - (list "-colors" - (cond - ((eq frame-background-mode 'dark) - "Linux") - ((eq frame-background-mode 'light) - "LightBG") - (t ; default (backg-mode isn't always set by XEmacs) - "LightBG")))))) - (unless (equal ipython-backup-of-py-python-command py-python-command) - (setq ipython-backup-of-py-python-command py-python-command)) - (setq py-python-command ipython-command)) - - -;; MODIFY py-shell so that it loads the editing history -(defadvice py-shell (around py-shell-with-history) - "Add persistent command-history support (in -$PYTHONHISTORY (or \"~/.ipython/history\", if we use IPython)). Also, if -`py-shell-initial-switch-buffers' is nil, it only switches to *Python* if that -buffer already exists." - (if (comint-check-proc "*Python*") - ad-do-it - (setq comint-input-ring-file-name - (if (string-equal py-python-command ipython-command) - (concat (or (getenv "IPYTHONDIR") "~/.ipython") "/history") - (or (getenv "PYTHONHISTORY") "~/.python-history.py"))) - (comint-read-input-ring t) - (let ((buf (current-buffer))) - ad-do-it - (unless py-shell-initial-switch-buffers - (switch-to-buffer-other-window buf))))) -(ad-activate 'py-shell) -;; (defadvice py-execute-region (before py-execute-buffer-ensure-process) -;; "HACK: test that ipython is already running before executing something. -;; Doing this properly seems not worth the bother (unless people actually -;; request it)." -;; (unless (comint-check-proc "*Python*") -;; (error "Sorry you have to first do M-x py-shell to send something to ipython."))) -;; (ad-activate 'py-execute-region) - -(defadvice py-execute-region (around py-execute-buffer-ensure-process) - "HACK: if `py-shell' is not active or ASYNC is explicitly desired, fall back - to python instead of ipython." - (let ((py-which-shell (if (and (comint-check-proc "*Python*") (not async)) - py-python-command - ipython-backup-of-py-python-command))) - ad-do-it)) -(ad-activate 'py-execute-region) - -(defun ipython-to-doctest (start end) - "Transform a cut-and-pasted bit from an IPython session into something that -looks like it came from a normal interactive python session, so that it can -be used in doctests. Example: - - - In [1]: import sys - - In [2]: sys.stdout.write 'Hi!\n' - ------> sys.stdout.write ('Hi!\n') - Hi! - - In [3]: 3 + 4 - Out[3]: 7 - -gets converted to: - - >>> import sys - >>> sys.stdout.write ('Hi!\n') - Hi! - >>> 3 + 4 - 7 - -" - (interactive "*r\n") - ;(message (format "###DEBUG s:%de:%d" start end)) - (save-excursion - (save-match-data - ;; replace ``In [3]: bla`` with ``>>> bla`` and - ;; ``... : bla`` with ``... bla`` - (goto-char start) - (while (re-search-forward ipython-de-input-prompt-regexp end t) - ;(message "finding 1") - (cond ((match-string 3) ;continued - (replace-match "... \\3" t nil)) - (t - (replace-match ">>> \\1\\2" t nil)))) - ;; replace `` - (goto-char start) - (while (re-search-forward ipython-de-output-prompt-regexp end t) - (replace-match "" t nil))))) - -(defvar ipython-completion-command-string - "print ';'.join(__IP.Completer.all_completions('%s')) #PYTHON-MODE SILENT\n" - "The string send to ipython to query for all possible completions") - - -;; xemacs doesn't have `comint-preoutput-filter-functions' so we'll try the -;; following wonderful hack to work around this case -(if (featurep 'xemacs) - ;;xemacs - (defun ipython-complete () - "Try to complete the python symbol before point. Only knows about the stuff -in the current *Python* session." - (interactive) - (let* ((ugly-return nil) - (sep ";") - (python-process (or (get-buffer-process (current-buffer)) - ;XXX hack for .py buffers - (get-process py-which-bufname))) - ;; XXX currently we go backwards to find the beginning of an - ;; expression part; a more powerful approach in the future might be - ;; to let ipython have the complete line, so that context can be used - ;; to do things like filename completion etc. - (beg (save-excursion (skip-chars-backward "a-z0-9A-Z_." (point-at-bol)) - (point))) - (end (point)) - (pattern (buffer-substring-no-properties beg end)) - (completions nil) - (completion-table nil) - completion - (comint-output-filter-functions - (append comint-output-filter-functions - '(ansi-color-filter-apply - (lambda (string) - ;(message (format "DEBUG filtering: %s" string)) - (setq ugly-return (concat ugly-return string)) - (delete-region comint-last-output-start - (process-mark (get-buffer-process (current-buffer))))))))) - ;(message (format "#DEBUG pattern: '%s'" pattern)) - (process-send-string python-process - (format ipython-completion-command-string pattern)) - (accept-process-output python-process) - ;(message (format "DEBUG return: %s" ugly-return)) - (setq completions - (split-string (substring ugly-return 0 (position ?\n ugly-return)) sep)) - (setq completion-table (loop for str in completions - collect (list str nil))) - (setq completion (try-completion pattern completion-table)) - (cond ((eq completion t)) - ((null completion) - (message "Can't find completion for \"%s\"" pattern) - (ding)) - ((not (string= pattern completion)) - (delete-region beg end) - (insert completion)) - (t - (message "Making completion list...") - (with-output-to-temp-buffer "*Python Completions*" - (display-completion-list (all-completions pattern completion-table))) - (message "Making completion list...%s" "done"))))) - ;; emacs - (defun ipython-complete () - "Try to complete the python symbol before point. Only knows about the stuff -in the current *Python* session." - (interactive) - (let* ((ugly-return nil) - (sep ";") - (python-process (or (get-buffer-process (current-buffer)) - ;XXX hack for .py buffers - (get-process py-which-bufname))) - ;; XXX currently we go backwards to find the beginning of an - ;; expression part; a more powerful approach in the future might be - ;; to let ipython have the complete line, so that context can be used - ;; to do things like filename completion etc. - (beg (save-excursion (skip-chars-backward "a-z0-9A-Z_." (point-at-bol)) - (point))) - (end (point)) - (pattern (buffer-substring-no-properties beg end)) - (completions nil) - (completion-table nil) - completion - (comint-preoutput-filter-functions - (append comint-preoutput-filter-functions - '(ansi-color-filter-apply - (lambda (string) - (setq ugly-return (concat ugly-return string)) - ""))))) - (process-send-string python-process - (format ipython-completion-command-string pattern)) - (accept-process-output python-process) - (setq completions - (split-string (substring ugly-return 0 (position ?\n ugly-return)) sep)) - ;(message (format "DEBUG completions: %S" completions)) - (setq completion-table (loop for str in completions - collect (list str nil))) - (setq completion (try-completion pattern completion-table)) - (cond ((eq completion t)) - ((null completion) - (message "Can't find completion for \"%s\"" pattern) - (ding)) - ((not (string= pattern completion)) - (delete-region beg end) - (insert completion)) - (t - (message "Making completion list...") - (with-output-to-temp-buffer "*IPython Completions*" - (display-completion-list (all-completions pattern completion-table))) - (message "Making completion list...%s" "done"))))) -) - -;;; autoindent support: patch sent in by Jin Liu <m.liu.jin@gmail.com>, -;;; originally written by doxgen@newsmth.net -;;; Minor modifications by fperez for xemacs compatibility. - -(defvar ipython-autoindent t - "If non-nil, enable autoindent for IPython shell through python-mode.") - -(defvar ipython-indenting-buffer-name "*IPython Indentation Calculation*" - "Temporary buffer for indenting multiline statement.") - -(defun ipython-get-indenting-buffer () - "Return a temporary buffer set in python-mode. Create one if necessary." - (let ((buf (get-buffer-create ipython-indenting-buffer-name))) - (set-buffer buf) - (unless (eq major-mode 'python-mode) - (python-mode)) - buf)) - -(defvar ipython-indentation-string nil - "Indentation for the next line in a multiline statement.") - -(defun ipython-send-and-indent () - "Send the current line to IPython, and calculate the indentation for -the next line." - (interactive) - (if ipython-autoindent - (let ((line (buffer-substring (point-at-bol) (point))) - (after-prompt1) - (after-prompt2)) - (save-excursion - (comint-bol t) - (if (looking-at py-shell-input-prompt-1-regexp) - (setq after-prompt1 t) - (setq after-prompt2 (looking-at py-shell-input-prompt-2-regexp))) - (with-current-buffer (ipython-get-indenting-buffer) - (when after-prompt1 - (erase-buffer)) - (when (or after-prompt1 after-prompt2) - (delete-region (point-at-bol) (point)) - (insert line) - (newline-and-indent)))))) - ;; send input line to ipython interpreter - (comint-send-input)) - -(defun ipython-indentation-hook (string) - "Insert indentation string if py-shell-input-prompt-2-regexp -matches last process output." - (let* ((start-marker (or comint-last-output-start - (point-min-marker))) - (end-marker (process-mark (get-buffer-process (current-buffer)))) - (text (ansi-color-filter-apply (buffer-substring start-marker end-marker)))) - ;; XXX if `text' matches both pattern, it MUST be the last prompt-2 - (when (and (string-match py-shell-input-prompt-2-regexp text) - (not (string-match "\n$" text))) - (with-current-buffer (ipython-get-indenting-buffer) - (setq ipython-indentation-string - (buffer-substring (point-at-bol) (point)))) - (goto-char end-marker) - (insert ipython-indentation-string) - (setq ipython-indentation-string nil)))) - -(add-hook 'py-shell-hook - (lambda () - (add-hook 'comint-output-filter-functions - 'ipython-indentation-hook))) - -(define-key py-shell-map (kbd "RET") 'ipython-send-and-indent) -;;; / end autoindent support - -(provide 'ipython)
deleted file mode 100644 --- a/.elisp/js2.el +++ /dev/null @@ -1,11659 +0,0 @@ -;;; js2.el -- an improved JavaScript editing mode -;;; -;;; This file was auto-generated on Mon Jun 16 01:46:45 2008 from files: -;;; js2-vars.el -;;; js2-util.el -;;; js2-scan.el -;;; js2-messages.el -;;; js2-ast.el -;;; js2-highlight.el -;;; js2-browse.el -;;; js2-parse.el -;;; js2-indent.el -;;; js2-mode.el - -;;; js2-mode.el --- an improved JavaScript editing mode - -;; Author: Steve Yegge (steve.yegge@gmail.com) -;; Version: 20080616 -;; Keywords: javascript languages - -;; 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 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, write to the Free -;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, -;; MA 02111-1307 USA - -;;; Commentary: - -;; This JavaScript editing mode supports: -;; -;; - the full JavaScript language through version 1.7 -;; - support for most Rhino and SpiderMonkey extensions from 1.5 to 1.7 -;; - accurate syntax highlighting using a recursive-descent parser -;; - syntax-error and strict-mode warning reporting -;; - "bouncing" line indentation to choose among alternate indentation points -;; - smart line-wrapping within comments (Emacs 22+) and strings -;; - code folding: -;; - show some or all function bodies as {...} -;; - show some or all block comments as /*...*/ -;; - context-sensitive menu bar and popup menus -;; - code browsing using the `imenu' package -;; - typing helpers (e.g. inserting matching braces/parens) -;; - many customization options -;; -;; It is only compatible with GNU Emacs versions 21 and higher (not XEmacs). -;; -;; Installation: -;; -;; - put `js2.el' somewhere in your emacs load path -;; - M-x byte-compile-file RET <path-to-js2.el> RET -;; Note: it will refuse to run unless byte-compiled -;; - add these lines to your .emacs file: -;; (autoload 'js2-mode "js2" nil t) -;; (add-to-list 'auto-mode-alist '("\\.js$" . js2-mode)) -;; -;; To customize how it works: -;; M-x customize-group RET js2-mode RET -;; -;; The variable `js2-mode-version' is a date stamp. When you upgrade -;; to a newer version, you must byte-compile the file again. -;; -;; Notes: -;; -;; This mode is different in many ways from standard Emacs language editing -;; modes, inasmuch as it attempts to be more like an IDE. If this drives -;; you crazy, it IS possible to customize it to be more like other Emacs -;; editing modes. Please customize the group `js2-mode' to see all of the -;; configuration options. -;; -;; Some of the functionality does not work in Emacs 21 -- upgrading to -;; Emacs 22 or higher will get you better results. If you byte-compiled -;; js2.el with Emacs 21, you should re-compile it for Emacs 22. -;; -;; Unlike cc-engine based language modes, js2-mode's line-indentation is not -;; customizable. It is a surprising amount of work to support customizable -;; indentation. The current compromise is that the tab key lets you cycle among -;; various likely indentation points, similar to the behavior of python-mode. -;; -;; This mode does not yet work with "multi-mode" modes such as mmm-mode -;; and mumamo, although it could possibly be made to do so with some effort. -;; This means that js2-mode is currently only useful for editing JavaScript -;; files, and not for editing JavaScript within <script> tags or templates. -;; -;; This code is part of a larger project, in progress, to enable writing -;; Emacs customizations in JavaScript. -;; -;; Please email bug reports and suggestions to the author, or submit them -;; at http://code.google.com/p/js2-mode/issues - -;; TODO: -;; - add unreachable-code warning (error?) using the inconsistent-return analysis -;; - labeled stmt length is now 1 -;; - "anonymous function does not always return a value" - use getter/setter name -;; - extend js2-missing-semi-one-line-override to handle catch (e) {return x} -;; - set a text prop on autoinserted delimiters and don't biff user-entered ones -;; - when inserting magic curlies, look for matching close-curly before inserting -;; - get more use out of the symbol table: -;; - jump to declaration (put hyperlinks on all non-decl var usages?) -;; - rename variable/function -;; - warn on unused var -;; - add some dabbrev-expansions for built-in keywords like finally, function -;; - add at least some completion support, e.g. for built-ins -;; - code formatting - -;;; Code: -;;; js2-vars.el -- byte-compiler support for js2-mode - -;; Author: Steve Yegge (steve.yegge@gmail.com) -;; Keywords: javascript languages - -;;; Code: - -(eval-when-compile - (require 'cl)) - -(eval-and-compile - (require 'cc-mode) ; (only) for `c-populate-syntax-table' - (require 'cc-langs) ; it's here in Emacs 21... - (require 'cc-engine)) ; for `c-paragraph-start' et. al. - -(defvar js2-emacs22 (>= emacs-major-version 22)) - -(defcustom js2-highlight-level 2 - "Amount of syntax highlighting to perform. -nil, zero or negative means none. -1 adds basic syntax highlighting. -2 adds highlighting of some Ecma built-in properties. -3 adds highlighting of many Ecma built-in functions." - :type 'integer - :group 'js2-mode) - -(defvar js2-mode-dev-mode-p nil - "Non-nil if running in development mode. Normally nil.") - -(defgroup js2-mode nil - "An improved JavaScript mode." - :group 'languages) - -(defcustom js2-basic-offset (if (and (boundp 'c-basic-offset) - (numberp c-basic-offset)) - c-basic-offset - 2) - "Number of spaces to indent nested statements. -Similar to `c-basic-offset'." - :group 'js2-mode - :type 'integer) -(make-variable-buffer-local 'js2-basic-offset) - -(defcustom js2-cleanup-whitespace t - "Non-nil to invoke `delete-trailing-whitespace' before saves." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-move-point-on-right-click t - "Non-nil to move insertion point when you right-click. -This makes right-click context menu behavior a bit more intuitive, -since menu operations generally apply to the point. The exception -is if there is a region selection, in which case the point does -not- -move, so cut/copy/paste etc. can work properly. - -Note that IntelliJ moves the point, and Eclipse leaves it alone, -so this behavior is customizable." - :group 'js2-mode - :type 'boolean) - -(defcustom js2-mirror-mode t - "Non-nil to insert closing brackets, parens, etc. automatically." - :group 'js2-mode - :type 'boolean) - -(defcustom js2-auto-indent-flag t - "Automatic indentation with punctuation characters. If non-nil, the -current line is indented when certain punctuations are inserted." - :group 'js2-mode - :type 'boolean) - -(defcustom js2-bounce-indent-flag t - "Non-nil to have indent-line function choose among alternatives. -If nil, the indent-line function will indent to a predetermined column -based on heuristic guessing. If non-nil, then if the current line is -already indented to that predetermined column, indenting will choose -another likely column and indent to that spot. Repeated invocation of -the indent-line function will cycle among the computed alternatives. -See the function `js2-bounce-indent' for details." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-indent-on-enter-key nil - "Non-nil to have Enter/Return key indent the line. -This is unusual for Emacs modes but common in IDEs like Eclipse." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-enter-indents-newline t - "Non-nil to have Enter/Return key indent the newly-inserted line. -This is unusual for Emacs modes but common in IDEs like Eclipse." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-rebind-eol-bol-keys t - "Non-nil to rebind beginning-of-line and end-of-line keys. -If non-nil, bounce between bol/eol and first/last non-whitespace char." - :group 'js2-mode - :type 'boolean) - -(defcustom js2-electric-keys '("{" "}" "(" ")" "[" "]" ":" ";" "," "*") - "Keys that auto-indent when `js2-auto-indent-flag' is non-nil. -Each value in the list is passed to `define-key'." - :type 'list - :group 'js2-mode) - -(defcustom js2-idle-timer-delay 0.2 - "Delay in secs before re-parsing after user makes changes. -Multiplied by `js2-dynamic-idle-timer-adjust', which see." - :type 'number - :group 'js2-mode) -(make-variable-buffer-local 'js2-idle-timer-delay) - -(defcustom js2-dynamic-idle-timer-adjust 0 - "Positive to adjust `js2-idle-timer-delay' based on file size. -The idea is that for short files, parsing is faster so we can be -more responsive to user edits without interfering with editing. -The buffer length in characters (typically bytes) is divided by -this value and used to multiply `js2-idle-timer-delay' for the -buffer. For example, a 21k file and 10k adjust yields 21k/10k -== 2, so js2-idle-timer-delay is multiplied by 2. -If `js2-dynamic-idle-timer-adjust' is 0 or negative, -`js2-idle-timer-delay' is not dependent on the file size." - :type 'number - :group 'js2-mode) - -(defcustom js2-mode-escape-quotes t - "Non-nil to disable automatic quote-escaping inside strings." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-mode-squeeze-spaces t - "Non-nil to normalize whitespace when filling in comments. -Multiple runs of spaces are converted to a single space." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-mode-show-parse-errors t - "True to highlight parse errors." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-mode-show-strict-warnings t - "Non-nil to emit Ecma strict-mode warnings. -Some of the warnings can be individually disabled by other flags, -even if this flag is non-nil." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-strict-trailing-comma-warning t - "Non-nil to warn about trailing commas in array literals. -Ecma-262 forbids them, but many browsers permit them. IE is the -big exception, and can produce bugs if you have trailing commas." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-strict-missing-semi-warning t - "Non-nil to warn about semicolon auto-insertion after statement. -Technically this is legal per Ecma-262, but some style guides disallow -depending on it." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-missing-semi-one-line-override nil - "Non-nil to permit missing semicolons in one-line functions. -In one-liner functions such as `function identity(x) {return x}' -people often omit the semicolon for a cleaner look. If you are -such a person, you can suppress the missing-semicolon warning -by setting this variable to t." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-strict-inconsistent-return-warning t - "Non-nil to warn about mixing returns with value-returns. -It's perfectly legal to have a `return' and a `return foo' in the -same function, but it's often an indicator of a bug, and it also -interferes with type inference (in systems that support it.)" - :type 'boolean - :group 'js2-mode) - -(defcustom js2-strict-cond-assign-warning t - "Non-nil to warn about expressions like if (a = b). -This often should have been '==' instead of '='. If the warning -is enabled, you can suppress it on a per-expression basis by -parenthesizing the expression, e.g. if ((a = b)) ..." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-strict-cond-assign-warning t - "Non-nil to warn about expressions like if (a = b). -This often should have been '==' instead of '='. If the warning -is enabled, you can suppress it on a per-expression basis by -parenthesizing the expression, e.g. if ((a = b)) ..." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-strict-var-redeclaration-warning t - "Non-nil to warn about redeclaring variables in a script or function." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-strict-var-hides-function-arg-warning t - "Non-nil to warn about a var decl hiding a function argument." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-skip-preprocessor-directives nil - "Non-nil to treat lines beginning with # as comments. -Useful for viewing Mozilla JavaScript source code." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-basic-offset c-basic-offset - "Functions like `c-basic-offset' in js2-mode buffers." - :type 'integer - :group 'js2-mode) -(make-variable-buffer-local 'js2-basic-offset) - -(defcustom js2-language-version 170 - "Configures what JavaScript language version to recognize. -Currently only 150, 160 and 170 are supported, corresponding -to JavaScript 1.5, 1.6 and 1.7, respectively. In a nutshell, -1.6 adds E4X support, and 1.7 adds let, yield, and Array -comprehensions." - :type 'integer - :group 'js2-mode) - -(defcustom js2-allow-keywords-as-property-names t - "If non-nil, you can use JavaScript keywords as object property names. -Examples: - - var foo = {int: 5, while: 6, continue: 7}; - foo.return = 8; - -Ecma-262 forbids this syntax, but many browsers support it." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-instanceof-has-side-effects nil - "If non-nil, treats the instanceof operator as having side effects. -This is useful for xulrunner apps." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-allow-rhino-new-expr-initializer nil - "Non-nil to support a Rhino's experimental syntactic construct. - -Rhino supports the ability to follow a `new' expression with an object -literal, which is used to set additional properties on the new object -after calling its constructor. Syntax: - - new <expr> [ ( arglist ) ] [initializer] - -Hence, this expression: - - new Object {a: 1, b: 2} - -results in an Object with properties a=1 and b=2. This syntax is -apparently not configurable in Rhino - it's currently always enabled, -as of Rhino version 1.7R2." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-allow-member-expr-as-function-name nil - "Non-nil to support experimental Rhino syntax for function names. - -Rhino supports an experimental syntax configured via the Rhino Context -setting `allowMemberExprAsFunctionName'. The experimental syntax is: - - function <member-expr> ( [ arg-list ] ) { <body> } - -Where member-expr is a non-parenthesized 'member expression', which -is anything at the grammar level of a new-expression or lower, meaning -any expression that does not involve infix or unary operators. - -When <member-expr> is not a simple identifier, then it is syntactic -sugar for assigning the anonymous function to the <member-expr>. Hence, -this code: - - function a.b().c[2] (x, y) { ... } - -is rewritten as: - - a.b().c[2] = function(x, y) {...} - -which doesn't seem particularly useful, but Rhino permits it." - :type 'boolean - :group 'js2-mode) - -(defvar js2-mode-version 20080616 - "Release number for `js2-mode'.") - -;; scanner variables - -;; We record the start and end position of each token. -(defvar js2-token-beg 1) -(make-variable-buffer-local 'js2-token-beg) -(defvar js2-token-end -1) -(make-variable-buffer-local 'js2-token-end) - -(defvar js2-EOF_CHAR -1 - "Represents end of stream. Distinct from js2-EOF token type.") - -;; I originally used symbols to represent tokens, but Rhino uses -;; ints and then sets various flag bits in them, so ints it is. -;; The upshot is that we need a `js2-' prefix in front of each name. -(defvar js2-ERROR -1) -(defvar js2-EOF 0) -(defvar js2-EOL 1) -(defvar js2-ENTERWITH 2) ; begin interpreter bytecodes -(defvar js2-LEAVEWITH 3) -(defvar js2-RETURN 4) -(defvar js2-GOTO 5) -(defvar js2-IFEQ 6) -(defvar js2-IFNE 7) -(defvar js2-SETNAME 8) -(defvar js2-BITOR 9) -(defvar js2-BITXOR 10) -(defvar js2-BITAND 11) -(defvar js2-EQ 12) -(defvar js2-NE 13) -(defvar js2-LT 14) -(defvar js2-LE 15) -(defvar js2-GT 16) -(defvar js2-GE 17) -(defvar js2-LSH 18) -(defvar js2-RSH 19) -(defvar js2-URSH 20) -(defvar js2-ADD 21) ; infix plus -(defvar js2-SUB 22) ; infix minus -(defvar js2-MUL 23) -(defvar js2-DIV 24) -(defvar js2-MOD 25) -(defvar js2-NOT 26) -(defvar js2-BITNOT 27) -(defvar js2-POS 28) ; unary plus -(defvar js2-NEG 29) ; unary minus -(defvar js2-NEW 30) -(defvar js2-DELPROP 31) -(defvar js2-TYPEOF 32) -(defvar js2-GETPROP 33) -(defvar js2-GETPROPNOWARN 34) -(defvar js2-SETPROP 35) -(defvar js2-GETELEM 36) -(defvar js2-SETELEM 37) -(defvar js2-CALL 38) -(defvar js2-NAME 39) ; an identifier -(defvar js2-NUMBER 40) -(defvar js2-STRING 41) -(defvar js2-NULL 42) -(defvar js2-THIS 43) -(defvar js2-FALSE 44) -(defvar js2-TRUE 45) -(defvar js2-SHEQ 46) ; shallow equality (===) -(defvar js2-SHNE 47) ; shallow inequality (!==) -(defvar js2-REGEXP 48) -(defvar js2-BINDNAME 49) -(defvar js2-THROW 50) -(defvar js2-RETHROW 51) ; rethrow caught exception: catch (e if ) uses it -(defvar js2-IN 52) -(defvar js2-INSTANCEOF 53) -(defvar js2-LOCAL_LOAD 54) -(defvar js2-GETVAR 55) -(defvar js2-SETVAR 56) -(defvar js2-CATCH_SCOPE 57) -(defvar js2-ENUM_INIT_KEYS 58) -(defvar js2-ENUM_INIT_VALUES 59) -(defvar js2-ENUM_INIT_ARRAY 60) -(defvar js2-ENUM_NEXT 61) -(defvar js2-ENUM_ID 62) -(defvar js2-THISFN 63) -(defvar js2-RETURN_RESULT 64) ; to return previously stored return result -(defvar js2-ARRAYLIT 65) ; array literal -(defvar js2-OBJECTLIT 66) ; object literal -(defvar js2-GET_REF 67) ; *reference -(defvar js2-SET_REF 68) ; *reference = something -(defvar js2-DEL_REF 69) ; delete reference -(defvar js2-REF_CALL 70) ; f(args) = something or f(args)++ -(defvar js2-REF_SPECIAL 71) ; reference for special properties like __proto -(defvar js2-YIELD 72) ; JS 1.7 yield pseudo keyword - -;; XML support -(defvar js2-DEFAULTNAMESPACE 73) -(defvar js2-ESCXMLATTR 74) -(defvar js2-ESCXMLTEXT 75) -(defvar js2-REF_MEMBER 76) ; Reference for x.@y, x..y etc. -(defvar js2-REF_NS_MEMBER 77) ; Reference for x.ns::y, x..ns::y etc. -(defvar js2-REF_NAME 78) ; Reference for @y, @[y] etc. -(defvar js2-REF_NS_NAME 79) ; Reference for ns::y, @ns::y@[y] etc. - -(defvar js2-first-bytecode js2-ENTERWITH) -(defvar js2-last-bytecode js2-REF_NS_NAME) - -(defvar js2-TRY 80) -(defvar js2-SEMI 81) ; semicolon -(defvar js2-LB 82) ; left and right brackets -(defvar js2-RB 83) -(defvar js2-LC 84) ; left and right curly-braces -(defvar js2-RC 85) -(defvar js2-LP 86) ; left and right parens -(defvar js2-RP 87) -(defvar js2-COMMA 88) ; comma operator - -(defvar js2-ASSIGN 89) ; simple assignment (=) -(defvar js2-ASSIGN_BITOR 90) ; |= -(defvar js2-ASSIGN_BITXOR 91) ; ^= -(defvar js2-ASSIGN_BITAND 92) ; &= -(defvar js2-ASSIGN_LSH 93) ; <<= -(defvar js2-ASSIGN_RSH 94) ; >>= -(defvar js2-ASSIGN_URSH 95) ; >>>= -(defvar js2-ASSIGN_ADD 96) ; += -(defvar js2-ASSIGN_SUB 97) ; -= -(defvar js2-ASSIGN_MUL 98) ; *= -(defvar js2-ASSIGN_DIV 99) ; /= -(defvar js2-ASSIGN_MOD 100) ; %= - -(defvar js2-first-assign js2-ASSIGN) -(defvar js2-last-assign js2-ASSIGN_MOD) - -(defvar js2-HOOK 101) ; conditional (?:) -(defvar js2-COLON 102) -(defvar js2-OR 103) ; logical or (||) -(defvar js2-AND 104) ; logical and (&&) -(defvar js2-INC 105) ; increment/decrement (++ --) -(defvar js2-DEC 106) -(defvar js2-DOT 107) ; member operator (.) -(defvar js2-FUNCTION 108) ; function keyword -(defvar js2-EXPORT 109) ; export keyword -(defvar js2-IMPORT 110) ; import keyword -(defvar js2-IF 111) ; if keyword -(defvar js2-ELSE 112) ; else keyword -(defvar js2-SWITCH 113) ; switch keyword -(defvar js2-CASE 114) ; case keyword -(defvar js2-DEFAULT 115) ; default keyword -(defvar js2-WHILE 116) ; while keyword -(defvar js2-DO 117) ; do keyword -(defvar js2-FOR 118) ; for keyword -(defvar js2-BREAK 119) ; break keyword -(defvar js2-CONTINUE 120) ; continue keyword -(defvar js2-VAR 121) ; var keyword -(defvar js2-WITH 122) ; with keyword -(defvar js2-CATCH 123) ; catch keyword -(defvar js2-FINALLY 124) ; finally keyword -(defvar js2-VOID 125) ; void keyword -(defvar js2-RESERVED 126) ; reserved keywords - -(defvar js2-EMPTY 127) - -;; Types used for the parse tree - never returned by scanner. - -(defvar js2-BLOCK 128) ; statement block -(defvar js2-LABEL 129) ; label -(defvar js2-TARGET 130) -(defvar js2-LOOP 131) -(defvar js2-EXPR_VOID 132) ; expression statement in functions -(defvar js2-EXPR_RESULT 133) ; expression statement in scripts -(defvar js2-JSR 134) -(defvar js2-SCRIPT 135) ; top-level node for entire script -(defvar js2-TYPEOFNAME 136) ; for typeof(simple-name) -(defvar js2-USE_STACK 137) -(defvar js2-SETPROP_OP 138) ; x.y op= something -(defvar js2-SETELEM_OP 139) ; x[y] op= something -(defvar js2-LOCAL_BLOCK 140) -(defvar js2-SET_REF_OP 141) ; *reference op= something - -;; For XML support: -(defvar js2-DOTDOT 142) ; member operator (..) -(defvar js2-COLONCOLON 143) ; namespace::name -(defvar js2-XML 144) ; XML type -(defvar js2-DOTQUERY 145) ; .() -- e.g., x.emps.emp.(name == "terry") -(defvar js2-XMLATTR 146) ; @ -(defvar js2-XMLEND 147) - -;; Optimizer-only tokens -(defvar js2-TO_OBJECT 148) -(defvar js2-TO_DOUBLE 149) - -(defvar js2-GET 150) ; JS 1.5 get pseudo keyword -(defvar js2-SET 151) ; JS 1.5 set pseudo keyword -(defvar js2-LET 152) ; JS 1.7 let pseudo keyword -(defvar js2-CONST 153) -(defvar js2-SETCONST 154) -(defvar js2-SETCONSTVAR 155) -(defvar js2-ARRAYCOMP 156) -(defvar js2-LETEXPR 157) -(defvar js2-WITHEXPR 158) -(defvar js2-DEBUGGER 159) - -(defvar js2-COMMENT 160) ; not yet in Rhino - -(defvar js2-num-tokens (1+ js2-COMMENT)) - -(defconst js2-debug-print-trees nil) - -;; Rhino accepts any string or stream as input. -;; Emacs character processing works best in buffers, so we'll -;; assume the input is a buffer. JavaScript strings can be -;; copied into temp buffers before scanning them. - -(defmacro deflocal (name value comment) - `(progn - (defvar ,name ,value ,comment) - (make-variable-buffer-local ',name))) - -;; Buffer-local variables yield much cleaner code than using `defstruct'. -;; They're the Emacs equivalent of instance variables, more or less. - -(deflocal js2-ts-dirty-line nil - "Token stream buffer-local variable. -Indicates stuff other than whitespace since start of line.") - -(deflocal js2-ts-regexp-flags nil - "Token stream buffer-local variable.") - -(deflocal js2-ts-string "" - "Token stream buffer-local variable. -Last string scanned.") - -(deflocal js2-ts-number nil - "Token stream buffer-local variable. -Last literal number scanned.") - -(deflocal js2-ts-hit-eof nil - "Token stream buffer-local variable.") - -(deflocal js2-ts-line-start 0 - "Token stream buffer-local variable.") - -(deflocal js2-ts-lineno 1 - "Token stream buffer-local variable.") - -(deflocal js2-ts-line-end-char -1 - "Token stream buffer-local variable.") - -(deflocal js2-ts-cursor 1 ; emacs buffers are 1-indexed - "Token stream buffer-local variable. -Current scan position.") - -(deflocal js2-ts-is-xml-attribute nil - "Token stream buffer-local variable.") - -(deflocal js2-ts-xml-is-tag-content nil - "Token stream buffer-local variable.") - -(deflocal js2-ts-xml-open-tags-count 0 - "Token stream buffer-local variable.") - -(deflocal js2-ts-string-buffer nil - "Token stream buffer-local variable. -List of chars built up while scanning various tokens.") - -(deflocal js2-ts-comment-type nil - "Token stream buffer-local variable.") - -;;; Parser variables - -(defvar js2-parsed-errors nil - "List of errors produced during scanning/parsing.") -(make-variable-buffer-local 'js2-parsed-errors) - -(defvar js2-parsed-warnings nil - "List of warnings produced during scanning/parsing.") -(make-variable-buffer-local 'js2-parsed-warnings) - -(defvar js2-recover-from-parse-errors t - "Non-nil to continue parsing after a syntax error. - -In recovery mode, the AST will be built in full, and any error -nodes will be flagged with appropriate error information. If -this flag is nil, a syntax error will result in an error being -signaled. - -The variable is automatically buffer-local, because different -modes that use the parser will need different settings.") -(make-variable-buffer-local 'js2-recover-from-parse-errors) - -(defvar js2-parse-hook nil - "List of callbacks for receiving parsing progress.") -(make-variable-buffer-local 'js2-parse-hook) - -(defvar js2-parse-finished-hook nil - "List of callbacks to notify when parsing finishes. -Not called if parsing was interrupted.") - -(defvar js2-is-eval-code nil - "True if we're evaluating code in a string. -If non-nil, the tokenizer will record the token text, and the AST nodes -will record their source text. Off by default for IDE modes, since the -text is available in the buffer.") -(make-variable-buffer-local 'js2-is-eval-code) - -(defvar js2-parse-ide-mode t - "Non-nil if the parser is being used for `js2-mode'. -If non-nil, the parser will set text properties for fontification -and the syntax-table. The value should be nil when using the -parser as a frontend to an interpreter or byte compiler.") - -;;; Parser instance variables (buffer-local vars for js2-parse) - -(defconst js2-clear-ti-mask #xFFFF - "Mask to clear token information bits.") - -(defconst js2-ti-after-eol (lsh 1 16) - "Flag: first token of the source line.") - -(defconst js2-ti-check-label (lsh 1 17) - "Flag: indicates to check for label.") - -;; Inline Rhino's CompilerEnvirons vars as buffer-locals. - -(defvar js2-compiler-generate-debug-info t) -(make-variable-buffer-local 'js2-compiler-generate-debug-info) - -(defvar js2-compiler-use-dynamic-scope nil) -(make-variable-buffer-local 'js2-compiler-use-dynamic-scope) - -(defvar js2-compiler-reserved-keywords-as-identifier nil) -(make-variable-buffer-local 'js2-compiler-reserved-keywords-as-identifier) - -(defvar js2-compiler-xml-available t) -(make-variable-buffer-local 'js2-compiler-xml-available) - -(defvar js2-compiler-optimization-level 0) -(make-variable-buffer-local 'js2-compiler-optimization-level) - -(defvar js2-compiler-generating-source t) -(make-variable-buffer-local 'js2-compiler-generating-source) - -(defvar js2-compiler-strict-mode nil) -(make-variable-buffer-local 'js2-compiler-strict-mode) - -(defvar js2-compiler-report-warning-as-error nil) -(make-variable-buffer-local 'js2-compiler-report-warning-as-error) - -(defvar js2-compiler-generate-observer-count nil) -(make-variable-buffer-local 'js2-compiler-generate-observer-count) - -(defvar js2-compiler-activation-names nil) -(make-variable-buffer-local 'js2-compiler-activation-names) - -;; SKIP: sourceURI - -;; There's a compileFunction method in Context.java - may need it. -(defvar js2-called-by-compile-function nil - "True if `js2-parse' was called by `js2-compile-function'. -Will only be used when we finish implementing the interpreter.") -(make-variable-buffer-local 'js2-called-by-compile-function) - -;; SKIP: ts (we just call `js2-init-scanner' and use its vars) - -(defvar js2-current-flagged-token js2-EOF) -(make-variable-buffer-local 'js2-current-flagged-token) - -(defvar js2-current-token js2-EOF) -(make-variable-buffer-local 'js2-current-token) - -;; SKIP: node factory - we're going to just call functions directly, -;; and eventually go to a unified AST format. - -(defvar js2-nesting-of-function 0) -(make-variable-buffer-local 'js2-nesting-of-function) - -(defvar js2-recorded-assignments nil) -(make-variable-buffer-local 'js2-assignments-from-parse) - -;; SKIP: decompiler -;; SKIP: encoded-source - -;;; These variables are per-function and should be saved/restored -;;; during function parsing. - -(defvar js2-current-script-or-fn nil) -(make-variable-buffer-local 'js2-current-script-or-fn) - -(defvar js2-current-scope nil) -(make-variable-buffer-local 'js2-current-scope) - -(defvar js2-nesting-of-with 0) -(make-variable-buffer-local 'js2-nesting-of-with) - -(defvar js2-label-set nil - "An alist mapping label names to nodes.") -(make-variable-buffer-local 'js2-label-set) - -(defvar js2-loop-set nil) -(make-variable-buffer-local 'js2-loop-set) - -(defvar js2-loop-and-switch-set nil) -(make-variable-buffer-local 'js2-loop-and-switch-set) - -(defvar js2-has-return-value nil) -(make-variable-buffer-local 'js2-has-return-value) - -(defvar js2-end-flags 0) -(make-variable-buffer-local 'js2-end-flags) - -;;; end of per function variables - -;; Without 2-token lookahead, labels are a problem. -;; These vars store the token info of the last matched name, -;; iff it wasn't the last matched token. Only valid in some contexts. -(defvar js2-prev-name-token-start nil) -(defvar js2-prev-name-token-string nil) - -(defsubst js2-save-name-token-data (pos name) - (setq js2-prev-name-token-start pos - js2-prev-name-token-string name)) - -;; These flags enumerate the possible ways a statement/function can -;; terminate. These flags are used by endCheck() and by the Parser to -;; detect inconsistent return usage. -;; -;; END_UNREACHED is reserved for code paths that are assumed to always be -;; able to execute (example: throw, continue) -;; -;; END_DROPS_OFF indicates if the statement can transfer control to the -;; next one. Statement such as return dont. A compound statement may have -;; some branch that drops off control to the next statement. -;; -;; END_RETURNS indicates that the statement can return (without arguments) -;; END_RETURNS_VALUE indicates that the statement can return a value. -;; -;; A compound statement such as -;; if (condition) { -;; return value; -;; } -;; Will be detected as (END_DROPS_OFF | END_RETURN_VALUE) by endCheck() - -(defconst js2-end-unreached #x0) -(defconst js2-end-drops-off #x1) -(defconst js2-end-returns #x2) -(defconst js2-end-returns-value #x4) -(defconst js2-end-yields #x8) - -;; Rhino awkwardly passes a statementLabel parameter to the -;; statementHelper() function, the main statement parser, which -;; is then used by quite a few of the sub-parsers. We just make -;; it a buffer-local variable and make sure it's cleaned up properly. -(defvar js2-labeled-stmt nil) ; type `js2-labeled-stmt-node' -(make-variable-buffer-local 'js2-labeled-stmt) - -;; Similarly, Rhino passes an inForInit boolean through about half -;; the expression parsers. We use a dynamically-scoped variable, -;; which makes it easier to funcall the parsers individually without -;; worrying about whether they take the parameter or not. -(defvar js2-in-for-init nil) -(make-variable-buffer-local 'js2-in-for-init) - -(defvar js2-temp-name-counter 0) -(make-variable-buffer-local 'js2-temp-name-counter) - -(defvar js2-parse-stmt-count 0) -(make-variable-buffer-local 'js2-parse-stmt-count) - -(defsubst js2-get-next-temp-name () - (format "$%d" (incf js2-temp-name-counter))) - -(defvar js2-parse-interruptable-p t - "Set this to nil to force parse to continue until finished. -This will mostly be useful for interpreters.") - -(defvar js2-statements-per-pause 50 - "Pause after this many statements to check for user input. -If user input is pending, stop the parse and discard the tree. -This makes for a smoother user experience for large files. -You may have to wait a second or two before the highlighting -and error-reporting appear, but you can always type ahead if -you wish. This appears to be more or less how Eclipse, IntelliJ -and other editors work.") - -(defvar js2-record-comments t - "Instructs the scanner to record comments in `js2-scanned-comments'.") -(make-variable-buffer-local 'js2-record-comments) - -(defvar js2-scanned-comments nil - "List of all comments from the current parse.") -(make-variable-buffer-local 'js2-scanned-comments) - -(defun js2-underline-color (color) - "Return a legal value for the :underline face attribute based on COLOR." - ;; In XEmacs the :underline attribute can only be a boolean. - ;; In GNU it can be the name of a colour. - (if (featurep 'xemacs) - (if color t nil) - color)) - -(defcustom js2-mode-indent-inhibit-undo nil - "Non-nil to disable collection of Undo information when indenting lines. -Some users have requested this behavior. It's nil by default because -other Emacs modes don't work this way." - :type 'boolean - :group 'js2-mode) - -(defcustom js2-mode-indent-ignore-first-tab nil - "If non-nil, ignore first TAB keypress if we look indented properly. -It's fairly common for users to navigate to an already-indented line -and press TAB for reassurance that it's been indented. For this class -of users, we want the first TAB press on a line to be ignored if the -line is already indented to one of the precomputed alternatives. - -This behavior is only partly implemented. If you TAB-indent a line, -navigate to another line, and then navigate back, it fails to clear -the last-indented variable, so it thinks you've already hit TAB once, -and performs the indent. A full solution would involve getting on the -point-motion hooks for the entire buffer. If we come across another -use cases that requires watching point motion, I'll consider doing it. - -If you set this variable to nil, then the TAB key will always change -the indentation of the current line, if more than one alternative -indentation spot exists." - :type 'boolean - :group 'js2-mode) - -(defvar js2-indent-hook nil - "A hook for user-defined indentation rules. - -Functions on this hook should expect two arguments: (LIST INDEX) -The LIST argument is the list of computed indentation points for -the current line. INDEX is the list index of the indentation point -that `js2-bounce-indent' plans to use. If INDEX is nil, then the -indent function is not going to change the current line indentation. - -If a hook function on this list returns a non-nil value, then -`js2-bounce-indent' assumes the hook function has performed its own -indentation, and will do nothing. If all hook functions on the list -return nil, then `js2-bounce-indent' will use its computed indentation -and reindent the line. - -When hook functions on this hook list are called, the variable -`js2-mode-ast' may or may not be set, depending on whether the -parse tree is available. If the variable is nil, you can pass a -callback to `js2-mode-wait-for-parse', and your callback will be -called after the new parse tree is built. This can take some time -in large files.") - -(defface js2-warning-face - `((((class color) (background light)) - (:underline ,(js2-underline-color "orange"))) - (((class color) (background dark)) - (:underline ,(js2-underline-color "orange"))) - (t (:underline t))) - "Face for JavaScript warnings." - :group 'js2-mode) - -(defface js2-error-face - `((((class color) (background light)) - (:foreground "red")) - (((class color) (background dark)) - (:foreground "red")) - (t (:foreground "red"))) - "Face for JavaScript errors." - :group 'js2-mode) - -(defface js2-jsdoc-tag-face - '((t :foreground "SlateGray")) - "Face used to highlight @whatever tags in jsdoc comments." - :group 'js2-mode) - -(defface js2-jsdoc-type-face - '((t :foreground "SteelBlue")) - "Face used to highlight {FooBar} types in jsdoc comments." - :group 'js2-mode) - -(defface js2-jsdoc-value-face - '((t :foreground "PeachPuff3")) - "Face used to highlight tag values in jsdoc comments." - :group 'js2-mode) - -(defface js2-function-param-face - '((t :foreground "SeaGreen")) - "Face used to highlight function parameters in javascript." - :group 'js2-mode) - -(defface js2-instance-member-face - '((t :foreground "DarkOrchid")) - "Face used to highlight instance variables in javascript. -Not currently used." - :group 'js2-mode) - -(defface js2-private-member-face - '((t :foreground "PeachPuff3")) - "Face used to highlight calls to private methods in javascript. -Not currently used." - :group 'js2-mode) - -(defface js2-private-function-call-face - '((t :foreground "goldenrod")) - "Face used to highlight calls to private functions in javascript. -Not currently used." - :group 'js2-mode) - -(defface js2-jsdoc-html-tag-name-face - (if js2-emacs22 - '((((class color) (min-colors 88) (background light)) - (:foreground "rosybrown")) - (((class color) (min-colors 8) (background dark)) - (:foreground "yellow")) - (((class color) (min-colors 8) (background light)) - (:foreground "magenta"))) - '((((type tty pc) (class color) (background light)) - (:foreground "magenta")) - (((type tty pc) (class color) (background dark)) - (:foreground "yellow")) - (t (:foreground "RosyBrown")))) - "Face used to highlight jsdoc html tag names" - :group 'js2-mode) - -(defface js2-jsdoc-html-tag-delimiter-face - (if js2-emacs22 - '((((class color) (min-colors 88) (background light)) - (:foreground "dark khaki")) - (((class color) (min-colors 8) (background dark)) - (:foreground "green")) - (((class color) (min-colors 8) (background light)) - (:foreground "green"))) - '((((type tty pc) (class color) (background light)) - (:foreground "green")) - (((type tty pc) (class color) (background dark)) - (:foreground "green")) - (t (:foreground "dark khaki")))) - "Face used to highlight brackets in jsdoc html tags." - :group 'js2-mode) - -(defface js2-external-variable-face - '((t :foreground "orange")) - "Face used to highlight assignments to undeclared variables. -An undeclared variable is any variable not declared with var or let -in the current scope or any lexically enclosing scope. If you assign -to such a variable, then you are either expecting it to originate from -another file, or you've got a potential bug." - :group 'js2-mode) - -(defcustom js2-highlight-external-variables t - "Non-nil to higlight assignments to undeclared variables." - :type 'boolean - :group 'js2-mode) - -(defvar js2-mode-map - (let ((map (make-sparse-keymap)) - keys) - (define-key map [mouse-1] #'js2-mode-show-node) - (define-key map "\C-m" #'js2-enter-key) - (when js2-rebind-eol-bol-keys - (define-key map "\C-a" #'js2-beginning-of-line) - (define-key map "\C-e" #'js2-end-of-line)) - (define-key map "\C-c\C-e" #'js2-mode-hide-element) - (define-key map "\C-c\C-s" #'js2-mode-show-element) - (define-key map "\C-c\C-a" #'js2-mode-show-all) - (define-key map "\C-c\C-f" #'js2-mode-toggle-hide-functions) - (define-key map "\C-c\C-t" #'js2-mode-toggle-hide-comments) - (define-key map "\C-c\C-o" #'js2-mode-toggle-element) - (define-key map "\C-c\C-w" #'js2-mode-toggle-warnings-and-errors) - (define-key map (kbd "C-c C-'") #'js2-next-error) - ;; also define user's preference for next-error, if available - (if (setq keys (where-is-internal #'next-error)) - (define-key map (car keys) #'js2-next-error)) - (define-key map (or (car (where-is-internal #'mark-defun)) - (kbd "M-C-h")) - #'js2-mark-defun) - (define-key map (or (car (where-is-internal #'narrow-to-defun)) - (kbd "C-x nd")) - #'js2-narrow-to-defun) - (define-key map [down-mouse-3] #'js2-mouse-3) - (when js2-auto-indent-flag - (mapc (lambda (key) - (define-key map key #'js2-insert-and-indent)) - js2-electric-keys)) - - (define-key map [menu-bar javascript] - (cons "JavaScript" (make-sparse-keymap "JavaScript"))) - - (define-key map [menu-bar javascript customize-js2-mode] - '(menu-item "Customize js2-mode" js2-mode-customize - :help "Customize the behavior of this mode")) - - (define-key map [menu-bar javascript js2-force-refresh] - '(menu-item "Force buffer refresh" js2-mode-reset - :help "Re-parse the buffer from scratch")) - - (define-key map [menu-bar javascript separator-2] - '("--")) - - (define-key map [menu-bar javascript next-error] - '(menu-item "Next warning or error" js2-next-error - :enabled (and js2-mode-ast - (or (js2-ast-root-errors js2-mode-ast) - (js2-ast-root-warnings js2-mode-ast))) - :help "Move to next warning or error")) - - (define-key map [menu-bar javascript display-errors] - '(menu-item "Show errors and warnings" js2-mode-display-warnings-and-errors - :visible (not js2-mode-show-parse-errors) - :help "Turn on display of warnings and errors")) - - (define-key map [menu-bar javascript hide-errors] - '(menu-item "Hide errors and warnings" js2-mode-hide-warnings-and-errors - :visible js2-mode-show-parse-errors - :help "Turn off display of warnings and errors")) - - (define-key map [menu-bar javascript separator-1] - '("--")) - - (define-key map [menu-bar javascript js2-toggle-function] - '(menu-item "Show/collapse element" js2-mode-toggle-element - :help "Hide or show function body or comment")) - - (define-key map [menu-bar javascript show-comments] - '(menu-item "Show block comments" js2-mode-toggle-hide-comments - :visible js2-mode-comments-hidden - :help "Expand all hidden block comments")) - - (define-key map [menu-bar javascript hide-comments] - '(menu-item "Hide block comments" js2-mode-toggle-hide-comments - :visible (not js2-mode-comments-hidden) - :help "Show block comments as /*...*/")) - - (define-key map [menu-bar javascript show-all-functions] - '(menu-item "Show function bodies" js2-mode-toggle-hide-functions - :visible js2-mode-functions-hidden - :help "Expand all hidden function bodies")) - - (define-key map [menu-bar javascript hide-all-functions] - '(menu-item "Hide function bodies" js2-mode-toggle-hide-functions - :visible (not js2-mode-functions-hidden) - :help "Show {...} for all top-level function bodies")) - - map) - "Keymap used in `js2-mode' buffers.") - -(defconst js2-mode-identifier-re "[a-zA-Z_$][a-zA-Z0-9_$]*") - -(defvar js2-mode-//-comment-re "^\\(\\s-*\\)//.+" - "Matches a //-comment line. Must be first non-whitespace on line. -First match-group is the leading whitespace.") - -(defvar js2-mode-ast nil "Private variable.") -(make-variable-buffer-local 'js2-mode-ast) - -(defvar js2-mode-hook nil) - -(defvar js2-mode-parse-timer nil "Private variable.") -(make-variable-buffer-local 'js2-mode-parse-timer) - -(defvar js2-mode-buffer-dirty-p nil "Private variable.") -(make-variable-buffer-local 'js2-mode-buffer-dirty-p) - -(defvar js2-mode-parsing nil "Private variable.") -(make-variable-buffer-local 'js2-mode-parsing) - -(defvar js2-mode-node-overlay nil) -(make-variable-buffer-local 'js2-mode-node-overlay) - -(defvar js2-mode-show-overlay js2-mode-dev-mode-p - "Debug: Non-nil to highlight AST nodes on mouse-down.") - -(defvar js2-mode-fontifications nil "Private variable") -(make-variable-buffer-local 'js2-mode-fontifications) - -(defvar js2-mode-deferred-properties nil "Private variable") -(make-variable-buffer-local 'js2-mode-deferred-properties) - -(defvar js2-imenu-recorder nil "Private variable") -(make-variable-buffer-local 'js2-imenu-recorder) - -(defvar js2-imenu-function-map nil "Private variable") -(make-variable-buffer-local 'js2-imenu-function-map) - -(defvar js2-paragraph-start - "\\(@[a-zA-Z]+\\>\\|$\\)") - -;; Note that we also set a 'c-in-sws text property in html comments, -;; so that `c-forward-sws' and `c-backward-sws' work properly. -(defvar js2-syntactic-ws-start - "\\s \\|/[*/]\\|[\n\r]\\|\\\\[\n\r]\\|\\s!\\|<!--\\|^\\s-*-->") - -(defvar js2-syntactic-ws-end - "\\s \\|[\n\r/]\\|\\s!") - -(defvar js2-syntactic-eol - (concat "\\s *\\(/\\*[^*\n\r]*" - "\\(\\*+[^*\n\r/][^*\n\r]*\\)*" - "\\*+/\\s *\\)*" - "\\(//\\|/\\*[^*\n\r]*" - "\\(\\*+[^*\n\r/][^*\n\r]*\\)*$" - "\\|\\\\$\\|$\\)") - "Copied from java-mode. Needed for some cc-engine functions.") - -(defvar js2-comment-prefix-regexp - "//+\\|\\**") - -(defvar js2-comment-start-skip - "\\(//+\\|/\\*+\\)\\s *") - -(defvar js2-mode-verbose-parse-p js2-mode-dev-mode-p - "Non-nil to emit status messages during parsing.") - -(defvar js2-mode-functions-hidden nil "private variable") -(defvar js2-mode-comments-hidden nil "private variable") - -(defvar js2-mode-syntax-table - (let ((table (make-syntax-table))) - (c-populate-syntax-table table) - table) - "Syntax table used in js2-mode buffers.") - -(defvar js2-mode-abbrev-table nil - "Abbrev table in use in `js2-mode' buffers.") -(define-abbrev-table 'js2-mode-abbrev-table ()) - -(defvar js2-mode-must-byte-compile (not js2-mode-dev-mode-p) - "Non-nil to have `js2-mode' signal an error if not byte-compiled.") - -(defvar js2-mode-pending-parse-callbacks nil - "List of functions waiting to be notified that parse is finished.") - -(defvar js2-mode-last-indented-line -1) - -(eval-when-compile - (defvar c-paragraph-start nil) - (defvar c-paragraph-separate nil) - (defvar c-syntactic-ws-start nil) - (defvar c-syntactic-ws-end nil) - (defvar c-syntactic-eol nil) - (defvar running-xemacs nil) - (defvar font-lock-mode nil) - (defvar font-lock-keywords nil)) - -(eval-when-compile - (if (< emacs-major-version 22) - (defun c-setup-paragraph-variables () nil))) - -(provide 'js2-vars) - -;;; js2-vars.el ends here -;;; js2-util.el -- JavaScript utilities - -;; Author: Steve Yegge (steve.yegge@gmail.com) -;; Keywords: javascript languages - -;;; Code - -(eval-when-compile - (require 'cl)) - - -;; Emacs21 compatibility, plus some stuff to avoid runtime dependency on CL - -(unless (fboundp #'looking-back) - (defun looking-back (regexp &optional limit greedy) - "Return non-nil if text before point matches regular expression REGEXP. -Like `looking-at' except matches before point, and is slower. -LIMIT if non-nil speeds up the search by specifying a minimum -starting position, to avoid checking matches that would start -before LIMIT. - -If GREEDY is non-nil, extend the match backwards as far as possible, -stopping when a single additional previous character cannot be part -of a match for REGEXP." - (let ((start (point)) - (pos - (save-excursion - (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t) - (point))))) - (if (and greedy pos) - (save-restriction - (narrow-to-region (point-min) start) - (while (and (> pos (point-min)) - (save-excursion - (goto-char pos) - (backward-char 1) - (looking-at (concat "\\(?:" regexp "\\)\\'")))) - (setq pos (1- pos))) - (save-excursion - (goto-char pos) - (looking-at (concat "\\(?:" regexp "\\)\\'"))))) - (not (null pos))))) - -(unless (fboundp #'copy-overlay) - (defun copy-overlay (o) - "Return a copy of overlay O." - (let ((o1 (make-overlay (overlay-start o) (overlay-end o) - ;; FIXME: there's no easy way to find the - ;; insertion-type of the two markers. - (overlay-buffer o))) - (props (overlay-properties o))) - (while props - (overlay-put o1 (pop props) (pop props))) - o1))) - -(unless (fboundp #'remove-overlays) - (defun remove-overlays (&optional beg end name val) - "Clear BEG and END of overlays whose property NAME has value VAL. -Overlays might be moved and/or split. -BEG and END default respectively to the beginning and end of buffer." - (unless beg (setq beg (point-min))) - (unless end (setq end (point-max))) - (if (< end beg) - (setq beg (prog1 end (setq end beg)))) - (save-excursion - (dolist (o (overlays-in beg end)) - (when (eq (overlay-get o name) val) - ;; Either push this overlay outside beg...end - ;; or split it to exclude beg...end - ;; or delete it entirely (if it is contained in beg...end). - (if (< (overlay-start o) beg) - (if (> (overlay-end o) end) - (progn - (move-overlay (copy-overlay o) - (overlay-start o) beg) - (move-overlay o end (overlay-end o))) - (move-overlay o (overlay-start o) beg)) - (if (> (overlay-end o) end) - (move-overlay o end (overlay-end o)) - (delete-overlay o)))))))) - -;; we don't want a runtime dependency on the CL package, so define -;; our own versions of these functions. - -(defun js2-delete-if (predicate list) - "Remove all items satisfying PREDICATE in LIST." - (loop for item in list - if (not (funcall predicate item)) - collect item)) - -(defun js2-position (element list) - "Find 0-indexed position of ELEMENT in LIST comparing with `eq'. -Returns nil if element is not found in the list." - (let ((count 0) - found) - (while (and list (not found)) - (if (eq element (car list)) - (setq found t) - (setq count (1+ count) - list (cdr list)))) - (if found count))) - -(defun js2-find-if (predicate list) - "Find first item satisfying PREDICATE in LIST." - (let (result) - (while (and list (not result)) - (if (funcall predicate (car list)) - (setq result (car list))) - (setq list (cdr list))) - result)) - -;;; end Emacs 21 compat - -(defmacro js2-time (form) - "Evaluate FORM, discard result, and return elapsed time in sec" - (let ((beg (make-symbol "--js2-time-beg--")) - (delta (make-symbol "--js2-time-end--"))) - `(let ((,beg (current-time)) - ,delta) - ,form - (/ (truncate (* (- (float-time (current-time)) - (float-time ,beg))) - 10000) - 10000.0)))) - -(def-edebug-spec js2-time t) - -(defsubst neq (expr1 expr2) - "Return (not (eq expr1 expr2))." - (not (eq expr1 expr2))) - -(defsubst js2-same-line (pos) - "Return t if POS is on the same line as current point." - (and (>= pos (point-at-bol)) - (<= pos (point-at-eol)))) - -(defsubst js2-same-line-2 (p1 p2) - "Return t if p1 is on the same line as p2." - (save-excursion - (goto-char p1) - (js2-same-line p2))) - -(defun js2-code-bug () - "Signal an error when we encounter an unexpected code path." - (error "failed assertion")) - -;; I'd like to associate errors with nodes, but for now the -;; easiest thing to do is get the context info from the last token. -(defsubst js2-record-parse-error (msg &optional arg pos len) - (push (list (list msg arg) - (or pos js2-token-beg) - (or len (- js2-token-end js2-token-beg))) - js2-parsed-errors)) - -(defsubst js2-report-error (msg &optional msg-arg pos len) - "Signal a syntax error or record a parse error." - (if js2-recover-from-parse-errors - (js2-record-parse-error msg msg-arg pos len) - (signal 'js2-syntax-error - (list msg - js2-ts-lineno - (save-excursion - (goto-char js2-ts-cursor) - (current-column)) - js2-ts-hit-eof)))) - -(defsubst js2-report-warning (msg &optional msg-arg pos len) - (if js2-compiler-report-warning-as-error - (js2-report-error msg msg-arg pos len) - (push (list (list msg msg-arg) - (or pos js2-token-beg) - (or len (- js2-token-end js2-token-beg))) - js2-parsed-warnings))) - -(defsubst js2-add-strict-warning (msg-id &optional msg-arg beg end) - (if js2-compiler-strict-mode - (js2-report-warning msg-id msg-arg beg - (and beg end (- end beg))))) - -(put 'js2-syntax-error 'error-conditions - '(error syntax-error js2-syntax-error)) -(put 'js2-syntax-error 'error-message "Syntax error") - -(put 'js2-parse-error 'error-conditions - '(error parse-error js2-parse-error)) -(put 'js2-parse-error 'error-message "Parse error") - -(defmacro js2-clear-flag (flags flag) - `(setq ,flags (logand ,flags (lognot ,flag)))) - -(defmacro js2-set-flag (flags flag) - "Logical-or FLAG into FLAGS." - `(setq ,flags (logior ,flags ,flag))) - -(defsubst js2-flag-set-p (flags flag) - (/= 0 (logand flags flag))) - -(defsubst js2-flag-not-set-p (flags flag) - (zerop (logand flags flag))) - -;; Stolen shamelessly from James Clark's nxml-mode. -(defmacro js2-with-unmodifying-text-property-changes (&rest body) - "Evaluate BODY without any text property changes modifying the buffer. -Any text properties changes happen as usual but the changes are not treated as -modifications to the buffer." - (let ((modified (make-symbol "modified"))) - `(let ((,modified (buffer-modified-p)) - (inhibit-read-only t) - (inhibit-modification-hooks t) - (buffer-undo-list t) - (deactivate-mark nil) - ;; Apparently these avoid file locking problems. - (buffer-file-name nil) - (buffer-file-truename nil)) - (unwind-protect - (progn ,@body) - (unless ,modified - (restore-buffer-modified-p nil)))))) - -(put 'js2-with-unmodifying-text-property-changes 'lisp-indent-function 0) -(def-edebug-spec js2-with-unmodifying-text-property-changes t) - -(defmacro js2-with-underscore-as-word-syntax (&rest body) - "Evaluate BODY with the _ character set to be word-syntax." - (let ((old-syntax (make-symbol "old-syntax"))) - `(let ((,old-syntax (string (char-syntax ?_)))) - (unwind-protect - (progn - (modify-syntax-entry ?_ "w" js2-mode-syntax-table) - ,@body) - (modify-syntax-entry ?_ ,old-syntax js2-mode-syntax-table))))) - -(put 'js2-with-underscore-as-word-syntax 'lisp-indent-function 0) -(def-edebug-spec js2-with-underscore-as-word-syntax t) - -(defmacro with-buffer (buf form) - "Executes FORM in buffer BUF. -BUF can be a buffer name or a buffer object. -If the buffer doesn't exist, it's created." - `(let ((buffer (gentemp))) - (setq buffer - (if (stringp ,buf) - (get-buffer-create ,buf) - ,buf)) - (save-excursion - (set-buffer buffer) - ,form))) - -(defsubst char-is-uppercase (c) - "Return t if C is an uppercase character. -Handles unicode and latin chars properly." - (/= c (downcase c))) - -(defsubst char-is-lowercase (c) - "Return t if C is an uppercase character. -Handles unicode and latin chars properly." - (/= c (upcase c))) - -(put 'with-buffer 'lisp-indent-function 1) -(def-edebug-spec with-buffer t) - -(provide 'js2-util) - -;;; js2-util.el ends here -;;; js2-scan.el --- JavaScript scanner - -;; Author: Steve Yegge (steve.yegge@gmail.com) -;; Keywords: javascript languages - -;;; Commentary: - -;; A port of Mozilla Rhino's scanner. -;; Corresponds to Rhino files Token.java and TokenStream.java. - -;;; Code: - - -(eval-when-compile - (require 'cl)) - -(defvar js2-tokens nil - "List of all defined token names.") ; intialized below - -(defvar js2-token-names - (let* ((names (make-vector js2-num-tokens -1)) - (case-fold-search nil) ; only match js2-UPPER_CASE - (syms (apropos-internal "^js2-\\(?:[A-Z_]+\\)"))) - (loop for sym in syms - for i from 0 - do - (unless (or (memq sym '(js2-EOF_CHAR js2-ERROR)) - (not (boundp sym))) - (aset names (symbol-value sym) ; code, e.g. 152 - (substring (symbol-name sym) 4)) ; name, e.g. "LET" - (push sym js2-tokens))) - names) - "Vector mapping int values to token string names, sans `js2-' prefix.") - -(defun js2-token-name (tok) - "Return a string name for TOK, a token symbol or code. -Signals an error if it's not a recognized token." - (let ((code tok)) - (if (symbolp tok) - (setq code (symbol-value tok))) - (if (eq code -1) - "ERROR" - (if (and (numberp code) - (not (minusp code)) - (< code js2-num-tokens)) - (aref js2-token-names code) - (error "Invalid token: %s" code))))) - -(defsubst js2-token-sym (tok) - "Return symbol for TOK given its code, e.g. 'js2-LP for code 86." - (intern (js2-token-name tok))) - -(defvar js2-token-codes - (let ((table (make-hash-table :test 'eq :size 256))) - (loop for name across js2-token-names - for sym = (intern (concat "js2-" name)) - do - (puthash sym (symbol-value sym) table)) - ;; clean up a few that are "wrong" in Rhino's token codes - (puthash 'js2-DELETE js2-DELPROP table) - table) - "Hashtable mapping token symbols to their bytecodes.") - -(defsubst js2-token-code (sym) - "Return code for token symbol SYM, e.g. 86 for 'js2-LP." - (or (gethash sym js2-token-codes) - (error "Invalid token symbol: %s " sym))) ; signal code bug - -(defsubst js2-report-scan-error (msg &optional no-throw beg len) - (setq js2-token-end js2-ts-cursor) - (js2-report-error msg nil - (or beg js2-token-beg) - (or len (- js2-token-end js2-token-beg))) - (unless no-throw - (throw 'return js2-ERROR))) - -(defsubst js2-get-string-from-buffer () - "Reverse the char accumulator and return it as a string." - (setq js2-token-end js2-ts-cursor) - (if js2-ts-string-buffer - (apply #'string (nreverse js2-ts-string-buffer)) - "")) - -;; TODO: could potentially avoid a lot of consing by allocating a -;; char buffer the way Rhino does. -(defsubst js2-add-to-string (c) - (push c js2-ts-string-buffer)) - -;; Note that when we "read" the end-of-file, we advance js2-ts-cursor -;; to (1+ (point-max)), which lets the scanner treat end-of-file like -;; any other character: when it's not part of the current token, we -;; unget it, allowing it to be read again by the following call. -(defsubst js2-unget-char () - (decf js2-ts-cursor)) - -;; Rhino distinguishes \r and \n line endings. We don't need to -;; because we only scan from Emacs buffers, which always use \n. -(defsubst js2-get-char () - "Read and return the next character from the input buffer. -Increments `js2-ts-lineno' if the return value is a newline char. -Updates `js2-ts-cursor' to the point after the returned char. -Returns `js2-EOF_CHAR' if we hit the end of the buffer. -Also updates `js2-ts-hit-eof' and `js2-ts-line-start' as needed." - (let (c) - ;; check for end of buffer - (if (>= js2-ts-cursor (point-max)) - (setq js2-ts-hit-eof t - js2-ts-cursor (1+ js2-ts-cursor) - c js2-EOF_CHAR) ; return value - - ;; otherwise read next char - (setq c (char-before (incf js2-ts-cursor))) - - ;; if we read a newline, update counters - (if (= c ?\n) - (setq js2-ts-line-start js2-ts-cursor - js2-ts-lineno (1+ js2-ts-lineno))) - - ;; TODO: skip over format characters - c))) - -(defsubst js2-read-unicode-escape () - "Read a \\uNNNN sequence from the input. -Assumes the ?\ and ?u have already been read. -Returns the unicode character, or nil if it wasn't a valid character. -Doesn't change the values of any scanner variables." - ;; I really wish I knew a better way to do this, but I can't - ;; find the Emacs function that takes a 16-bit int and converts - ;; it to a Unicode/utf-8 character. So I basically eval it with (read). - ;; Have to first check that it's 4 hex characters or it may stop - ;; the read early. - (ignore-errors - (let ((s (buffer-substring-no-properties js2-ts-cursor - (+ 4 js2-ts-cursor)))) - (if (string-match "[a-zA-Z0-9]\\{4\\}" s) - (read (concat "?\\u" s)))))) - -(defsubst js2-match-char (test) - "Consume and return next character if it matches TEST, a character. -Returns nil and consumes nothing if TEST is not the next character." - (let ((c (js2-get-char))) - (if (eq c test) - t - (js2-unget-char) - nil))) - -(defsubst js2-peek-char () - (prog1 - (js2-get-char) - (js2-unget-char))) - -(defsubst js2-java-identifier-start-p (c) - (or - (memq c '(?$ ?_)) - (char-is-uppercase c) - (char-is-lowercase c))) - -(defsubst js2-java-identifier-part-p (c) - "Implementation of java.lang.Character.isJavaIdentifierPart()" - ;; TODO: make me Unicode-friendly. See comments above. - (or - (memq c '(?$ ?_)) - (char-is-uppercase c) - (char-is-lowercase c) - (and (>= c ?0) (<= c ?9)))) - -(defsubst js2-alpha-p (c) - ;; Use 'Z' < 'a' - (if (<= c ?Z) - (<= ?A c) - (and (<= ?a c) - (<= c ?z)))) - -(defsubst js2-digit-p (c) - (and (<= ?0 c) (<= c ?9))) - -(defsubst js2-js-space-p (c) - (if (<= c 127) - (memq c '(#x20 #x9 #xC #xB)) - (or - (eq c #xA0) - ;; TODO: change this nil to check for Unicode space character - nil))) - -(defsubst js2-skip-line () - "Skip to end of line" - (let (c) - (while (and (/= js2-EOF_CHAR (setq c (js2-get-char))) - (/= c ?\n))) - (js2-unget-char) - (setq js2-token-end js2-ts-cursor))) - -(defun js2-init-scanner (&optional buf line) - "Create token stream for BUF starting on LINE. -BUF defaults to current-buffer and line defaults to 1. - -A buffer can only have one scanner active at a time, which yields -dramatically simpler code than using a defstruct. If you need to -have simultaneous scanners in a buffer, copy the regions to scan -into temp buffers." - (save-excursion - (when buf - (set-buffer buf)) - (setq js2-ts-dirty-line nil - js2-ts-regexp-flags nil - js2-ts-string "" - js2-ts-number nil - js2-ts-hit-eof nil - js2-ts-line-start 0 - js2-ts-lineno (or line 1) - js2-ts-line-end-char -1 - js2-ts-cursor (point-min) - js2-ts-is-xml-attribute nil - js2-ts-xml-is-tag-content nil - js2-ts-xml-open-tags-count 0 - js2-ts-string-buffer nil))) - -;; This function uses the cached op, string and number fields in -;; TokenStream; if getToken has been called since the passed token -;; was scanned, the op or string printed may be incorrect. -(defun js2-token-to-string (token) - ;; Not sure where this function is used in Rhino. Not tested. - (if (not js2-debug-print-trees) - "" - (let ((name (js2-token-name token))) - (cond - ((memq token (list js2-STRING js2-REGEXP js2-NAME)) - (concat name " `" js2-ts-string "'")) - ((eq token js2-NUMBER) - (format "NUMBER %g" js2-ts-number)) - (t - name))))) - -(defconst js2-keywords - '(break - case catch const continue - debugger default delete do - else enum - false finally for function - if in instanceof import - let - new null - return - switch - this throw true try typeof - var void - while with - yield)) - -;; Token names aren't exactly the same as the keywords, unfortunately. -;; E.g. enum isn't in the tokens, and delete is js2-DELPROP. -(defconst js2-kwd-tokens - (let ((table (make-vector js2-num-tokens nil)) - (tokens - (list js2-BREAK - js2-CASE js2-CATCH js2-CONST js2-CONTINUE - js2-DEBUGGER js2-DEFAULT js2-DELPROP js2-DO - js2-ELSE - js2-FALSE js2-FINALLY js2-FOR js2-FUNCTION - js2-IF js2-IN js2-INSTANCEOF js2-IMPORT - js2-LET - js2-NEW js2-NULL - js2-RETURN - js2-SWITCH - js2-THIS js2-THROW js2-TRUE js2-TRY js2-TYPEOF - js2-VAR - js2-WHILE js2-WITH - js2-YIELD))) - (dolist (i tokens) - (aset table i 'font-lock-keyword-face)) - (aset table js2-STRING 'font-lock-string-face) - (aset table js2-REGEXP 'font-lock-string-face) - (aset table js2-COMMENT 'font-lock-comment-face) - (aset table js2-THIS 'font-lock-builtin-face) - (aset table js2-VOID 'font-lock-constant-face) - (aset table js2-NULL 'font-lock-constant-face) - (aset table js2-TRUE 'font-lock-constant-face) - (aset table js2-FALSE 'font-lock-constant-face) - table) - "Vector whose values are non-nil for tokens that are keywords. -The values are default faces to use for highlighting the keywords.") - -(defconst js2-reserved-words - '(abstract - boolean byte - char class - double - enum extends - final float - goto - implements int interface - long - native - package private protected public - short static super synchronized - throws transient - volatile)) - -(defconst js2-keyword-names - (let ((table (make-hash-table :test 'equal))) - (loop for k in js2-keywords - do (puthash - (symbol-name k) ; instanceof - (intern (concat "js2-" - (upcase (symbol-name k)))) ; js2-INSTANCEOF - table)) - table) - "JavaScript keywords by name, mapped to their symbols.") - -(defconst js2-reserved-word-names - (let ((table (make-hash-table :test 'equal))) - (loop for k in js2-reserved-words - do - (puthash (symbol-name k) 'js2-RESERVED table)) - table) - "JavaScript reserved words by name, mapped to 'js2-RESERVED.") - -(defsubst js2-collect-string (buf) - "Convert BUF, a list of chars, to a string. -Reverses BUF before converting." - (cond - ((stringp buf) - buf) - ((null buf) ; for emacs21 compat - "") - (t - (if buf - (apply #'string (nreverse buf)) - "")))) - -(defun js2-string-to-keyword (s) - "Return token for S, a string, if S is a keyword or reserved word. -Returns a symbol such as 'js2-BREAK, or nil if not keyword/reserved." - (or (gethash s js2-keyword-names) - (gethash s js2-reserved-word-names))) - -(defsubst js2-ts-set-char-token-bounds () - "Used when next token is one character." - (setq js2-token-beg (1- js2-ts-cursor) - js2-token-end js2-ts-cursor)) - -(defsubst js2-ts-return (token) - "Return an N-character TOKEN from `js2-get-token'. -Updates `js2-token-end' accordingly." - (setq js2-token-end js2-ts-cursor) - (throw 'return token)) - -(defsubst js2-x-digit-to-int (c accumulator) - "Build up a hex number. -If C is a hexadecimal digit, return ACCUMULATOR * 16 plus -corresponding number. Otherwise return -1." - (catch 'return - (catch 'check - ;; Use 0..9 < A..Z < a..z - (cond - ((<= c ?9) - (decf c ?0) - (if (<= 0 c) - (throw 'check nil))) - ((<= c ?F) - (when (<= ?A c) - (decf c (- ?A 10)) - (throw 'check nil))) - ((<= c ?f) - (when (<= ?a c) - (decf c (- ?a 10)) - (throw 'check nil)))) - (throw 'return -1)) - (logior c (lsh accumulator 4)))) - -(defun js2-get-token () - "Return next JavaScript token, an int such as js2-RETURN." - (let (c - c1 - identifier-start - is-unicode-escape-start - contains-escape - escape-val - escape-start - str - result - base - is-integer - quote-char - val - look-for-slash - continue) - (catch 'return - (while t - ;; Eat whitespace, possibly sensitive to newlines. - (setq continue t) - (while continue - (setq c (js2-get-char)) - (cond - ((eq c js2-EOF_CHAR) - (js2-ts-set-char-token-bounds) - (throw 'return js2-EOF)) - ((eq c ?\n) - (js2-ts-set-char-token-bounds) - (setq js2-ts-dirty-line nil) - (throw 'return js2-EOL)) - ((not (js2-js-space-p c)) - (if (/= c ?-) ; in case end of HTML comment - (setq js2-ts-dirty-line t)) - (setq continue nil)))) - - ;; Assume the token will be 1 char - fixed up below. - (js2-ts-set-char-token-bounds) - - (when (eq c ?@) - (throw 'return js2-XMLATTR)) - - ;; identifier/keyword/instanceof? - ;; watch out for starting with a <backslash> - (cond - ((eq c ?\\) - (setq c (js2-get-char)) - (if (eq c ?u) - (setq identifier-start t - is-unicode-escape-start t - js2-ts-string-buffer nil) - (setq identifier-start nil) - (js2-unget-char) - (setq c ?\\))) - (t - (when (setq identifier-start (js2-java-identifier-start-p c)) - (setq js2-ts-string-buffer nil) - (js2-add-to-string c)))) - - (when identifier-start - (setq contains-escape is-unicode-escape-start) - (catch 'break - (while t - (if is-unicode-escape-start - ;; strictly speaking we should probably push-back - ;; all the bad characters if the <backslash>uXXXX - ;; sequence is malformed. But since there isn't a - ;; correct context(is there?) for a bad Unicode - ;; escape sequence in an identifier, we can report - ;; an error here. - (progn - (setq escape-val 0) - (dotimes (i 4) - (setq c (js2-get-char) - escape-val (js2-x-digit-to-int c escape-val)) - ;; Next check takes care of c < 0 and bad escape - (if (minusp escape-val) - (throw 'break nil))) - (if (minusp escape-val) - (js2-report-scan-error "msg.invalid.escape" t)) - (js2-add-to-string escape-val) - (setq is-unicode-escape-start nil)) - (setq c (js2-get-char)) - (cond - ((eq c ?\\) - (setq c (js2-get-char)) - (if (eq c ?u) - (setq is-unicode-escape-start t - contains-escape t) - (js2-report-scan-error "msg.illegal.character" t))) - (t - (if (or (eq c js2-EOF_CHAR) - (not (js2-java-identifier-part-p c))) - (throw 'break nil)) - (js2-add-to-string c)))))) - (js2-unget-char) - - (setq str (js2-get-string-from-buffer)) - (unless contains-escape - ;; OPT we shouldn't have to make a string (object!) to - ;; check if it's a keyword. - - ;; Return the corresponding token if it's a keyword - (when (setq result (js2-string-to-keyword str)) - (if (and (< js2-language-version 170) - (memq result '(js2-LET js2-YIELD))) - ;; LET and YIELD are tokens only in 1.7 and later - (setq result 'js2-NAME)) - (if (neq result js2-RESERVED) - (throw 'return (js2-token-code result))) - (js2-report-warning "msg.reserved.keyword" str))) - - ;; If we want to intern these as Rhino does, just use (intern str) - (setq js2-ts-string str) - (throw 'return js2-NAME)) ; end identifier/kwd check - - ;; is it a number? - (when (or (js2-digit-p c) - (and (eq c ?.) (js2-digit-p (js2-peek-char)))) - (setq js2-ts-string-buffer nil - base 10) - (when (eq c ?0) - (setq c (js2-get-char)) - (cond - ((or (eq c ?x) (eq c ?X)) - (setq base 16) - (setq c (js2-get-char))) - ((js2-digit-p c) - (setq base 8)) - (t - (js2-add-to-string ?0)))) - - (if (eq base 16) - (while (<= 0 (js2-x-digit-to-int c 0)) - (js2-add-to-string c) - (setq c (js2-get-char))) - (while (and (<= ?0 c) (<= c ?9)) - ;; We permit 08 and 09 as decimal numbers, which - ;; makes our behavior a superset of the ECMA - ;; numeric grammar. We might not always be so - ;; permissive, so we warn about it. - (when (and (eq base 8) (>= c ?8)) - (js2-report-warning "msg.bad.octal.literal" - (if (eq c ?8) "8" "9")) - (setq base 10)) - (js2-add-to-string c) - (setq c (js2-get-char)))) - - (setq is-integer t) - - (when (and (eq base 10) (memq c '(?. ?e ?E))) - (setq is-integer nil) - (when (eq c ?.) - (loop do - (js2-add-to-string c) - (setq c (js2-get-char)) - while (js2-digit-p c))) - (when (memq c '(?e ?E)) - (js2-add-to-string c) - (setq c (js2-get-char)) - (when (memq c '(?+ ?-)) - (js2-add-to-string c) - (setq c (js2-get-char))) - (unless (js2-digit-p c) - (js2-report-scan-error "msg.missing.exponent" t)) - (loop do - (js2-add-to-string c) - (setq c (js2-get-char)) - while (js2-digit-p c)))) - - (js2-unget-char) - (setq js2-ts-string (js2-get-string-from-buffer) - js2-ts-number - (if (and (eq base 10) (not is-integer)) - (string-to-number js2-ts-string) - ;; TODO: call runtime number-parser. Some of it is in - ;; js2-util.el, but I need to port ScriptRuntime.stringToNumber. - (string-to-number js2-ts-string))) - (throw 'return js2-NUMBER)) - - ;; is it a string? - (when (memq c '(?\" ?\')) - ;; We attempt to accumulate a string the fast way, by - ;; building it directly out of the reader. But if there - ;; are any escaped characters in the string, we revert to - ;; building it out of a string buffer. - (setq quote-char c - js2-ts-string-buffer nil - c (js2-get-char)) - (catch 'break - (while (/= c quote-char) - (catch 'continue - (when (or (eq c ?\n) (eq c js2-EOF_CHAR)) - (js2-unget-char) - (setq js2-token-end js2-ts-cursor) - (js2-report-error "msg.unterminated.string.lit") - (throw 'return js2-STRING)) - - (when (eq c ?\\) - ;; We've hit an escaped character - (setq c (js2-get-char)) - (case c - (?b (setq c ?\b)) - (?f (setq c ?\f)) - (?n (setq c ?\n)) - (?r (setq c ?\r)) - (?t (setq c ?\t)) - (?v (setq c ?\v)) - (?u - (setq c1 (js2-read-unicode-escape)) - (if js2-parse-ide-mode - (if c1 - (progn - ;; just copy the string in IDE-mode - (js2-add-to-string ?\\) - (js2-add-to-string ?u) - (dotimes (i 3) - (js2-add-to-string (js2-get-char))) - (setq c (js2-get-char))) ; added at end of loop - ;; flag it as an invalid escape - (js2-report-warning "msg.invalid.escape" - nil (- js2-ts-cursor 2) 6)) - ;; Get 4 hex digits; if the u escape is not - ;; followed by 4 hex digits, use 'u' + the - ;; literal character sequence that follows. - (js2-add-to-string ?u) - (setq escape-val 0) - (dotimes (i 4) - (setq c (js2-get-char) - escape-val (js2-x-digit-to-int c escape-val)) - (if (minusp escape-val) - (throw 'continue nil)) - (js2-add-to-string c)) - ;; prepare for replace of stored 'u' sequence by escape value - (setq js2-ts-string-buffer (nthcdr 5 js2-ts-string-buffer) - c escape-val))) - (?x - ;; Get 2 hex digits, defaulting to 'x'+literal - ;; sequence, as above. - (setq c (js2-get-char) - escape-val (js2-x-digit-to-int c 0)) - (if (minusp escape-val) - (progn - (js2-add-to-string ?x) - (throw 'continue nil)) - (setq c1 c - c (js2-get-char) - escape-val (js2-x-digit-to-int c escape-val)) - (if (minusp escape-val) - (progn - (js2-add-to-string ?x) - (js2-add-to-string c1) - (throw 'continue nil)) - ;; got 2 hex digits - (setq c escape-val)))) - (?\n - ;; Remove line terminator after escape to follow - ;; SpiderMonkey and C/C++ - (setq c (js2-get-char)) - (throw 'continue nil)) - (t - (when (and (<= ?0 c) (< c ?8)) - (setq val (- c ?0) - c (js2-get-char)) - (when (and (<= ?0 c) (< c ?8)) - (setq val (- (+ (* 8 val) c) ?0) - c (js2-get-char)) - (when (and (<= ?0 c) - (< c ?8) - (< val #o37)) - ;; c is 3rd char of octal sequence only - ;; if the resulting val <= 0377 - (setq val (- (+ (* 8 val) c) ?0) - c (js2-get-char)))) - (js2-unget-char) - (setq c val))))) - (js2-add-to-string c) - (setq c (js2-get-char))))) - (setq js2-ts-string (js2-get-string-from-buffer)) - (throw 'return js2-STRING)) - - (case c - (?\; - (throw 'return js2-SEMI)) - (?\[ - (throw 'return js2-LB)) - (?\] - (throw 'return js2-RB)) - (?{ - (throw 'return js2-LC)) - (?} - (throw 'return js2-RC)) - (?\( - (throw 'return js2-LP)) - (?\) - (throw 'return js2-RP)) - (?, - (throw 'return js2-COMMA)) - (?? - (throw 'return js2-HOOK)) - (?: - (if (js2-match-char ?:) - (js2-ts-return js2-COLONCOLON) - (throw 'return js2-COLON))) - (?. - (if (js2-match-char ?.) - (js2-ts-return js2-DOTDOT) - (if (js2-match-char ?\() - (js2-ts-return js2-DOTQUERY) - (throw 'return js2-DOT)))) - (?| - (if (js2-match-char ?|) - (throw 'return js2-OR) - (if (js2-match-char ?=) - (js2-ts-return js2-ASSIGN_BITOR) - (throw 'return js2-BITOR)))) - (?^ - (if (js2-match-char ?=) - (js2-ts-return js2-ASSIGN_BITOR) - (throw 'return js2-BITXOR))) - (?& - (if (js2-match-char ?&) - (throw 'return js2-AND) - (if (js2-match-char ?=) - (js2-ts-return js2-ASSIGN_BITAND) - (throw 'return js2-BITAND)))) - (?= - (if (js2-match-char ?=) - (if (js2-match-char ?=) - (js2-ts-return js2-SHEQ) - (throw 'return js2-EQ)) - (throw 'return js2-ASSIGN))) - (?! - (if (js2-match-char ?=) - (if (js2-match-char ?=) - (js2-ts-return js2-SHNE) - (js2-ts-return js2-NE)) - (throw 'return js2-NOT))) - (?< - ;; NB:treat HTML begin-comment as comment-till-eol - (when (js2-match-char ?!) - (when (js2-match-char ?-) - (when (js2-match-char ?-) - (js2-skip-line) - (setq js2-ts-comment-type 'html) - (throw 'return js2-COMMENT))) - (js2-unget-char)) - - (if (js2-match-char ?<) - (if (js2-match-char ?=) - (js2-ts-return js2-ASSIGN_LSH) - (js2-ts-return js2-LSH)) - (if (js2-match-char ?=) - (js2-ts-return js2-LE) - (throw 'return js2-LT)))) - (?> - (if (js2-match-char ?>) - (if (js2-match-char ?>) - (if (js2-match-char ?=) - (js2-ts-return js2-ASSIGN_URSH) - (js2-ts-return js2-URSH)) - (if (js2-match-char ?=) - (js2-ts-return js2-ASSIGN_RSH) - (js2-ts-return js2-RSH))) - (if (js2-match-char ?=) - (js2-ts-return js2-GE) - (throw 'return js2-GT)))) - (?* - (if (js2-match-char ?=) - (js2-ts-return js2-ASSIGN_MUL) - (throw 'return js2-MUL))) - - (?/ - ;; is it a // comment? - (when (js2-match-char ?/) - (setq js2-token-beg (- js2-ts-cursor 2)) - (js2-skip-line) - (setq js2-ts-comment-type 'line) - (throw 'return js2-COMMENT)) - - ;; is it a /* comment? - (when (js2-match-char ?*) - (setq look-for-slash nil - js2-token-beg (- js2-ts-cursor 2) - js2-ts-comment-type - (if (js2-match-char ?*) - (progn - (setq look-for-slash t) - 'jsdoc) - 'block)) - (while t - (setq c (js2-get-char)) - (cond - ((eq c js2-EOF_CHAR) - (setq js2-token-end (1- js2-ts-cursor)) - (js2-report-error "msg.unterminated.comment") - (throw 'return js2-COMMENT)) - ((eq c ?*) - (setq look-for-slash t)) - ((eq c ?/) - (if look-for-slash - (js2-ts-return js2-COMMENT))) - (t - (setq look-for-slash nil - js2-token-end js2-ts-cursor))))) - - (if (js2-match-char ?=) - (js2-ts-return js2-ASSIGN_DIV) - (throw 'return js2-DIV))) - - (?# - (when js2-skip-preprocessor-directives - (js2-skip-line) - (setq js2-ts-comment-type 'preprocessor - js2-token-end js2-ts-cursor) - (throw 'return js2-COMMENT)) - (throw 'return js2-ERROR)) - - (?% - (if (js2-match-char ?=) - (js2-ts-return js2-ASSIGN_MOD) - (throw 'return js2-MOD))) - (?~ - (throw 'return js2-BITNOT)) - (?+ - (if (js2-match-char ?=) - (js2-ts-return js2-ASSIGN_ADD) - (if (js2-match-char ?+) - (js2-ts-return js2-INC) - (throw 'return js2-ADD)))) - (?- - (cond - ((js2-match-char ?=) - (setq c js2-ASSIGN_SUB)) - ((js2-match-char ?-) - (unless js2-ts-dirty-line - ;; treat HTML end-comment after possible whitespace - ;; after line start as comment-until-eol - (when (js2-match-char ?>) - (js2-skip-line) - (setq js2-ts-comment-type 'html) - (throw 'return js2-COMMENT))) - (setq c js2-DEC)) - (t - (setq c js2-SUB))) - (setq js2-ts-dirty-line t) - (js2-ts-return c)) - - (otherwise - (js2-report-scan-error "msg.illegal.character"))))))) - -(defun js2-read-regexp (start-token) - "Called by parser when it gets / or /= in literal context." - (let (c - err - in-class ; inside a '[' .. ']' character-class - flags - (continue t)) - (setq js2-token-beg js2-ts-cursor - js2-ts-string-buffer nil - js2-ts-regexp-flags nil) - - (if (eq start-token js2-ASSIGN_DIV) - ;; mis-scanned /= - (js2-add-to-string ?=) - (if (neq start-token js2-DIV) - (error "failed assertion"))) - - (while (and (not err) - (or (/= (setq c (js2-get-char)) ?/) - in-class)) - (cond - ((or (= c ?\n) - (= c js2-EOF_CHAR)) - (setq js2-token-end (1- js2-ts-cursor) - err t - js2-ts-string (js2-collect-string js2-ts-string-buffer)) - (js2-report-error "msg.unterminated.re.lit")) - (t (cond - ((= c ?\\) - (js2-add-to-string c) - (setq c (js2-get-char))) - - ((= c ?\[) - (setq in-class t)) - - ((= c ?\]) - (setq in-class nil))) - (js2-add-to-string c)))) - - (unless err - (while continue - (cond - ((js2-match-char ?g) - (push ?g flags)) - ((js2-match-char ?i) - (push ?i flags)) - ((js2-match-char ?m) - (push ?m flags)) - (t - (setq continue nil)))) - (if (js2-alpha-p (js2-peek-char)) - (js2-report-scan-error "msg.invalid.re.flag" t - js2-ts-cursor 1)) - (setq js2-ts-string (js2-collect-string js2-ts-string-buffer) - js2-ts-regexp-flags (js2-collect-string flags) - js2-token-end js2-ts-cursor) - ;; tell `parse-partial-sexp' to ignore this range of chars - (put-text-property js2-token-beg js2-token-end 'syntax-class '(2))))) - -(defun js2-get-first-xml-token () - (setq js2-ts-xml-open-tags-count 0 - js2-ts-is-xml-attribute nil - js2-ts-xml-is-tag-content nil) - (js2-unget-char) - (js2-get-next-xml-token)) - -(defsubst js2-xml-discard-string () - "Throw away the string in progress and flag an XML parse error." - (setq js2-ts-string-buffer nil - js2-ts-string nil) - (js2-report-scan-error "msg.XML.bad.form" t)) - -(defun js2-get-next-xml-token () - (setq js2-ts-string-buffer nil ; for recording the XML - js2-token-beg js2-ts-cursor) - (let (c result) - (setq result - (catch 'return - (while t - (setq c (js2-get-char)) - (cond - ((= c js2-EOF_CHAR) - (throw 'return js2-ERROR)) - - (js2-ts-xml-is-tag-content - (case c - (?> - (js2-add-to-string c) - (setq js2-ts-xml-is-tag-content nil - js2-ts-is-xml-attribute nil)) - (?/ - (js2-add-to-string c) - (when (eq ?> (js2-peek-char)) - (setq c (js2-get-char)) - (js2-add-to-string c) - (setq js2-ts-xml-is-tag-content nil) - (decf js2-ts-xml-open-tags-count))) - (?{ - (js2-unget-char) - (setq js2-ts-string (js2-get-string-from-buffer)) - (throw 'return js2-XML)) - ((?\' ?\") - (js2-add-to-string c) - (unless (js2-read-quoted-string c) - (throw 'return js2-ERROR))) - (?= - (js2-add-to-string c) - (setq js2-ts-is-xml-attribute t)) - ((? ?\t ?\r ?\n) - (js2-add-to-string c)) - (t - (js2-add-to-string c) - (setq js2-ts-is-xml-attribute nil))) - (when (and (not js2-ts-xml-is-tag-content) - (zerop js2-ts-xml-open-tags-count)) - (setq js2-ts-string (js2-get-string-from-buffer)) - (throw 'return js2-XMLEND))) - - (t - ;; else not tag content - (case c - (?< - (js2-add-to-string c) - (setq c (js2-peek-char)) - (case c - (?! - (setq c (js2-get-char)) ;; skip ! - (js2-add-to-string c) - (setq c (js2-peek-char)) - (case c - (?- - (setq c (js2-get-char)) ;; skip - - (js2-add-to-string c) - (if (eq c ?-) - (progn - (js2-add-to-string c) - (unless (js2-read-xml-comment) - (throw 'return js2-ERROR))) - (js2-xml-discard-string) - (throw 'return js2-ERROR))) - (?\[ - (setq c (js2-get-char)) ;; skip [ - (js2-add-to-string c) - (if (and (= (js2-get-char) ?C) - (= (js2-get-char) ?D) - (= (js2-get-char) ?A) - (= (js2-get-char) ?T) - (= (js2-get-char) ?A) - (= (js2-get-char) ?\[)) - (progn - (js2-add-to-string ?C) - (js2-add-to-string ?D) - (js2-add-to-string ?A) - (js2-add-to-string ?T) - (js2-add-to-string ?A) - (js2-add-to-string ?\[) - (unless (js2-read-cdata) - (throw 'return js2-ERROR))) - (js2-xml-discard-string) - (throw 'return js2-ERROR))) - (t - (unless (js2-read-entity) - (throw 'return js2-ERROR))))) - (?? - (setq c (js2-get-char)) ;; skip ? - (js2-add-to-string c) - (unless (js2-read-PI) - (throw 'return js2-ERROR))) - (?/ - ;; end tag - (setq c (js2-get-char)) ;; skip / - (js2-add-to-string c) - (when (zerop js2-ts-xml-open-tags-count) - (js2-xml-discard-string) - (throw 'return js2-ERROR)) - (setq js2-ts-xml-is-tag-content t) - (decf js2-ts-xml-open-tags-count)) - (t - ;; start tag - (setq js2-ts-xml-is-tag-content t) - (incf js2-ts-xml-open-tags-count)))) - (?{ - (js2-unget-char) - (setq js2-ts-string (js2-get-string-from-buffer)) - (throw 'return js2-XML)) - (t - (js2-add-to-string c)))))))) - (setq js2-token-end js2-ts-cursor) - result)) - -(defun js2-read-quoted-string (quote) - (let (c) - (catch 'return - (while (/= (setq c (js2-get-char)) js2-EOF_CHAR) - (js2-add-to-string c) - (if (eq c quote) - (throw 'return t))) - (js2-xml-discard-string) ;; throw away string in progress - nil))) - -(defun js2-read-xml-comment () - (let ((c (js2-get-char))) - (catch 'return - (while (/= c js2-EOF_CHAR) - (catch 'continue - (js2-add-to-string c) - (when (and (eq c ?-) (eq ?- (js2-peek-char))) - (setq c (js2-get-char)) - (js2-add-to-string c) - (if (eq (js2-peek-char) ?>) - (progn - (setq c (js2-get-char)) ;; skip > - (js2-add-to-string c) - (throw 'return t)) - (throw 'continue nil))) - (setq c (js2-get-char)))) - (js2-xml-discard-string) - nil))) - -(defun js2-read-cdata () - (let ((c (js2-get-char))) - (catch 'return - (while (/= c js2-EOF_CHAR) - (catch 'continue - (js2-add-to-string c) - (when (and (eq c ?\]) (eq (js2-peek-char) ?\])) - (setq c (js2-get-char)) - (js2-add-to-string c) - (if (eq (js2-peek-char) ?>) - (progn - (setq c (js2-get-char)) ;; Skip > - (js2-add-to-string c) - (throw 'return t)) - (throw 'continue nil))) - (setq c (js2-get-char)))) - (js2-xml-discard-string) - nil))) - -(defun js2-read-entity () - (let ((decl-tags 1) - c) - (catch 'return - (while (/= js2-EOF_CHAR (setq c (js2-get-char))) - (js2-add-to-string c) - (case c - (?< - (incf decl-tags)) - (?> - (decf decl-tags) - (if (zerop decl-tags) - (throw 'return t))))) - (js2-xml-discard-string) - nil))) - -(defun js2-read-PI () - "Scan an XML processing instruction." - (let (c) - (catch 'return - (while (/= js2-EOF_CHAR (setq c (js2-get-char))) - (js2-add-to-string c) - (when (and (eq c ??) (eq (js2-peek-char) ?>)) - (setq c (js2-get-char)) ;; Skip > - (js2-add-to-string c) - (throw 'return t))) - (js2-xml-discard-string) - nil))) - -(defun js2-scanner-get-line () - "Return the text of the current scan line." - (buffer-substring (point-at-bol) (point-at-eol))) - -(provide 'js2-scan) - -;;; js2-scan.el ends here -;;; js2-messages: localizable messages for js2-mode - -;; Author: Steve Yegge (steve.yegge@gmail.com) -;; Keywords: javascript languages - -;;; Commentary: - -;; Messages are copied from Rhino's Messages.properties. -;; Many of the Java-specific messages have been elided. -;; Add any js2-specific ones at the end, so we can keep -;; this file synced with changes to Rhino's. -;; -;; TODO: -;; - move interpreter messages into separate file - -;;; Code: - -(defvar js2-message-table - (make-hash-table :test 'equal :size 250) - "Contains localized messages for js2-mode.") - -;; TODO: construct this hashtable at compile-time. -(defmacro js2-msg (key &rest strings) - `(puthash ,key (funcall #'concat ,@strings) - js2-message-table)) - -(defun js2-get-msg (msg-key) - "Look up a localized message. -MSG-KEY is a list of (MSG ARGS). If the message takes parameters, -the correct number of ARGS must be provided." - (let* ((key (if (listp msg-key) (car msg-key) msg-key)) - (args (if (listp msg-key) (cdr msg-key))) - (msg (gethash key js2-message-table))) - (if msg - (apply #'format msg args) - key))) ; default to showing the key - -(js2-msg "msg.dup.parms" - "Duplicate parameter name '%s'.") - -(js2-msg "msg.too.big.jump" - "Program too complex: jump offset too big.") - -(js2-msg "msg.too.big.index" - "Program too complex: internal index exceeds 64K limit.") - -(js2-msg "msg.while.compiling.fn" - "Encountered code generation error while compiling function '%s': %s") - -(js2-msg "msg.while.compiling.script" - "Encountered code generation error while compiling script: %s") - -;; Context -(js2-msg "msg.ctor.not.found" - "Constructor for '%s' not found.") - -(js2-msg "msg.not.ctor" - "'%s' is not a constructor.") - -;; FunctionObject -(js2-msg "msg.varargs.ctor" - "Method or constructor '%s' must be static " - "with the signature (Context cx, Object[] args, " - "Function ctorObj, boolean inNewExpr) " - "to define a variable arguments constructor.") - -(js2-msg "msg.varargs.fun" - "Method '%s' must be static with the signature " - "(Context cx, Scriptable thisObj, Object[] args, Function funObj) " - "to define a variable arguments function.") - -(js2-msg "msg.incompat.call" - "Method '%s' called on incompatible object.") - -(js2-msg "msg.bad.parms" - "Unsupported parameter type '%s' in method '%s'.") - -(js2-msg "msg.bad.method.return" - "Unsupported return type '%s' in method '%s'.") - -(js2-msg "msg.bad.ctor.return" - "Construction of objects of type '%s' is not supported.") - -(js2-msg "msg.no.overload" - "Method '%s' occurs multiple times in class '%s'.") - -(js2-msg "msg.method.not.found" - "Method '%s' not found in '%s'.") - -;; IRFactory - -(js2-msg "msg.bad.for.in.lhs" - "Invalid left-hand side of for..in loop.") - -(js2-msg "msg.mult.index" - "Only one variable allowed in for..in loop.") - -(js2-msg "msg.bad.for.in.destruct" - "Left hand side of for..in loop must be an array of " - "length 2 to accept key/value pair.") - -(js2-msg "msg.cant.convert" - "Can't convert to type '%s'.") - -(js2-msg "msg.bad.assign.left" - "Invalid assignment left-hand side.") - -(js2-msg "msg.bad.decr" - "Invalid decerement operand.") - -(js2-msg "msg.bad.incr" - "Invalid increment operand.") - -(js2-msg "msg.bad.yield" - "yield must be in a function.") - -(js2-msg "msg.yield.parenthesized" - "yield expression must be parenthesized.") - -;; NativeGlobal -(js2-msg "msg.cant.call.indirect" - "Function '%s' must be called directly, and not by way of a " - "function of another name.") - -(js2-msg "msg.eval.nonstring" - "Calling eval() with anything other than a primitive " - "string value will simply return the value. " - "Is this what you intended?") - -(js2-msg "msg.eval.nonstring.strict" - "Calling eval() with anything other than a primitive " - "string value is not allowed in strict mode.") - -(js2-msg "msg.bad.destruct.op" - "Invalid destructuring assignment operator") - -;; NativeCall -(js2-msg "msg.only.from.new" - "'%s' may only be invoked from a `new' expression.") - -(js2-msg "msg.deprec.ctor" - "The '%s' constructor is deprecated.") - -;; NativeFunction -(js2-msg "msg.no.function.ref.found" - "no source found to decompile function reference %s") - -(js2-msg "msg.arg.isnt.array" - "second argument to Function.prototype.apply must be an array") - -;; NativeGlobal -(js2-msg "msg.bad.esc.mask" - "invalid string escape mask") - -;; NativeRegExp -(js2-msg "msg.bad.quant" - "Invalid quantifier %s") - -(js2-msg "msg.overlarge.backref" - "Overly large back reference %s") - -(js2-msg "msg.overlarge.min" - "Overly large minimum %s") - -(js2-msg "msg.overlarge.max" - "Overly large maximum %s") - -(js2-msg "msg.zero.quant" - "Zero quantifier %s") - -(js2-msg "msg.max.lt.min" - "Maximum %s less than minimum") - -(js2-msg "msg.unterm.quant" - "Unterminated quantifier %s") - -(js2-msg "msg.unterm.paren" - "Unterminated parenthetical %s") - -(js2-msg "msg.unterm.class" - "Unterminated character class %s") - -(js2-msg "msg.bad.range" - "Invalid range in character class.") - -(js2-msg "msg.trail.backslash" - "Trailing \\ in regular expression.") - -(js2-msg "msg.re.unmatched.right.paren" - "unmatched ) in regular expression.") - -(js2-msg "msg.no.regexp" - "Regular expressions are not available.") - -(js2-msg "msg.bad.backref" - "back-reference exceeds number of capturing parentheses.") - -(js2-msg "msg.bad.regexp.compile" - "Only one argument may be specified if the first " - "argument to RegExp.prototype.compile is a RegExp object.") - -;; Parser -(js2-msg "msg.got.syntax.errors" - "Compilation produced %s syntax errors.") - -(js2-msg "msg.var.redecl" - "TypeError: redeclaration of var %s.") - -(js2-msg "msg.const.redecl" - "TypeError: redeclaration of const %s.") - -(js2-msg "msg.let.redecl" - "TypeError: redeclaration of variable %s.") - -(js2-msg "msg.parm.redecl" - "TypeError: redeclaration of formal parameter %s.") - -(js2-msg "msg.fn.redecl" - "TypeError: redeclaration of function %s.") - -(js2-msg "msg.let.decl.not.in.block" - "SyntaxError: let declaration not directly within block") - -;; NodeTransformer -(js2-msg "msg.dup.label" - "duplicated label") - -(js2-msg "msg.undef.label" - "undefined label") - -(js2-msg "msg.bad.break" - "unlabelled break must be inside loop or switch") - -(js2-msg "msg.continue.outside" - "continue must be inside loop") - -(js2-msg "msg.continue.nonloop" - "continue can only use labels of iteration statements") - -(js2-msg "msg.bad.throw.eol" - "Line terminator is not allowed between the throw " - "keyword and throw expression.") - -(js2-msg "msg.no.paren.parms" - "missing ( before function parameters.") - -(js2-msg "msg.no.parm" - "missing formal parameter") - -(js2-msg "msg.no.paren.after.parms" - "missing ) after formal parameters") - -(js2-msg "msg.no.brace.body" - "missing '{' before function body") - -(js2-msg "msg.no.brace.after.body" - "missing } after function body") - -(js2-msg "msg.no.paren.cond" - "missing ( before condition") - -(js2-msg "msg.no.paren.after.cond" - "missing ) after condition") - -(js2-msg "msg.no.semi.stmt" - "missing ; before statement") - -(js2-msg "msg.missing.semi" - "missing ; after statement") - -(js2-msg "msg.no.name.after.dot" - "missing name after . operator") - -(js2-msg "msg.no.name.after.coloncolon" - "missing name after :: operator") - -(js2-msg "msg.no.name.after.dotdot" - "missing name after .. operator") - -(js2-msg "msg.no.name.after.xmlAttr" - "missing name after .@") - -(js2-msg "msg.no.bracket.index" - "missing ] in index expression") - -(js2-msg "msg.no.paren.switch" - "missing ( before switch expression") - -(js2-msg "msg.no.paren.after.switch" - "missing ) after switch expression") - -(js2-msg "msg.no.brace.switch" - "missing '{' before switch body") - -(js2-msg "msg.bad.switch" - "invalid switch statement") - -(js2-msg "msg.no.colon.case" - "missing : after case expression") - -(js2-msg "msg.double.switch.default" - "double default label in the switch statement") - -(js2-msg "msg.no.while.do" - "missing while after do-loop body") - -(js2-msg "msg.no.paren.for" - "missing ( after for") - -(js2-msg "msg.no.semi.for" - "missing ; after for-loop initializer") - -(js2-msg "msg.no.semi.for.cond" - "missing ; after for-loop condition") - -(js2-msg "msg.in.after.for.name" - "missing in after for") - -(js2-msg "msg.no.paren.for.ctrl" - "missing ) after for-loop control") - -(js2-msg "msg.no.paren.with" - "missing ( before with-statement object") - -(js2-msg "msg.no.paren.after.with" - "missing ) after with-statement object") - -(js2-msg "msg.no.paren.after.let" - "missing ( after let") - -(js2-msg "msg.no.paren.let" - "missing ) after variable list") - -(js2-msg "msg.no.curly.let" - "missing } after let statement") - -(js2-msg "msg.bad.return" - "invalid return") - -(js2-msg "msg.no.brace.block" - "missing } in compound statement") - -(js2-msg "msg.bad.label" - "invalid label") - -(js2-msg "msg.bad.var" - "missing variable name") - -(js2-msg "msg.bad.var.init" - "invalid variable initialization") - -(js2-msg "msg.no.colon.cond" - "missing : in conditional expression") - -(js2-msg "msg.no.paren.arg" - "missing ) after argument list") - -(js2-msg "msg.no.bracket.arg" - "missing ] after element list") - -(js2-msg "msg.bad.prop" - "invalid property id") - -(js2-msg "msg.no.colon.prop" - "missing : after property id") - -(js2-msg "msg.no.brace.prop" - "missing } after property list") - -(js2-msg "msg.no.paren" - "missing ) in parenthetical") - -(js2-msg "msg.reserved.id" - "identifier is a reserved word") - -(js2-msg "msg.no.paren.catch" - "missing ( before catch-block condition") - -(js2-msg "msg.bad.catchcond" - "invalid catch block condition") - -(js2-msg "msg.catch.unreachable" - "any catch clauses following an unqualified catch are unreachable") - -(js2-msg "msg.no.brace.try" - "missing '{' before try block") - -(js2-msg "msg.no.brace.catchblock" - "missing '{' before catch-block body") - -(js2-msg "msg.try.no.catchfinally" - "'try' without 'catch' or 'finally'") - -(js2-msg "msg.no.return.value" - "function %s does not always return a value") - -(js2-msg "msg.anon.no.return.value" - "anonymous function does not always return a value") - -(js2-msg "msg.return.inconsistent" - "return statement is inconsistent with previous usage") - -(js2-msg "msg.generator.returns" - "TypeError: generator function '%s' returns a value") - -(js2-msg "msg.anon.generator.returns" - "TypeError: anonymous generator function returns a value") - -(js2-msg "msg.syntax" - "syntax error") - -(js2-msg "msg.unexpected.eof" - "Unexpected end of file") - -(js2-msg "msg.XML.bad.form" - "illegally formed XML syntax") - -(js2-msg "msg.XML.not.available" - "XML runtime not available") - -(js2-msg "msg.too.deep.parser.recursion" - "Too deep recursion while parsing") - -(js2-msg "msg.no.side.effects" - "Code has no side effects") - -(js2-msg "msg.extra.trailing.comma" - "Trailing comma is not legal in an ECMA-262 object initializer") - -(js2-msg "msg.array.trailing.comma" - "Trailing comma yields different behavior across browsers") - -(js2-msg "msg.equal.as.assign" - (concat "Test for equality (==) mistyped as assignment (=)?" - " (parenthesize to suppress warning)")) - -(js2-msg "msg.var.hides.arg" - "Variable %s hides argument") - -(js2-msg "msg.destruct.assign.no.init" - "Missing = in destructuring declaration") - -;; ScriptRuntime -(js2-msg "msg.no.properties" - "%s has no properties.") - -(js2-msg "msg.invalid.iterator" - "Invalid iterator value") - -(js2-msg "msg.iterator.primitive" - "__iterator__ returned a primitive value") - -(js2-msg "msg.assn.create.strict" - "Assignment to undeclared variable %s") - -(js2-msg "msg.ref.undefined.prop" - "Reference to undefined property '%s'") - -(js2-msg "msg.prop.not.found" - "Property %s not found.") - -(js2-msg "msg.invalid.type" - "Invalid JavaScript value of type %s") - -(js2-msg "msg.primitive.expected" - "Primitive type expected (had %s instead)") - -(js2-msg "msg.namespace.expected" - "Namespace object expected to left of :: (found %s instead)") - -(js2-msg "msg.null.to.object" - "Cannot convert null to an object.") - -(js2-msg "msg.undef.to.object" - "Cannot convert undefined to an object.") - -(js2-msg "msg.cyclic.value" - "Cyclic %s value not allowed.") - -(js2-msg "msg.is.not.defined" - "'%s' is not defined.") - -(js2-msg "msg.undef.prop.read" - "Cannot read property '%s' from %s") - -(js2-msg "msg.undef.prop.write" - "Cannot set property '%s' of %s to '%s'") - -(js2-msg "msg.undef.prop.delete" - "Cannot delete property '%s' of %s") - -(js2-msg "msg.undef.method.call" - "Cannot call method '%s' of %s") - -(js2-msg "msg.undef.with" - "Cannot apply 'with' to %s") - -(js2-msg "msg.isnt.function" - "%s is not a function, it is %s.") - -(js2-msg "msg.isnt.function.in" - "Cannot call property %s in object %s. " - "It is not a function, it is '%s'.") - -(js2-msg "msg.function.not.found" - "Cannot find function %s.") - -(js2-msg "msg.function.not.found.in" - "Cannot find function %s in object %s.") - -(js2-msg "msg.isnt.xml.object" - "%s is not an xml object.") - -(js2-msg "msg.no.ref.to.get" - "%s is not a reference to read reference value.") - -(js2-msg "msg.no.ref.to.set" - "%s is not a reference to set reference value to %s.") - -(js2-msg "msg.no.ref.from.function" - "Function %s can not be used as the left-hand " - "side of assignment or as an operand of ++ or -- operator.") - -(js2-msg "msg.bad.default.value" - "Object's getDefaultValue() method returned an object.") - -(js2-msg "msg.instanceof.not.object" - "Can't use instanceof on a non-object.") - -(js2-msg "msg.instanceof.bad.prototype" - "'prototype' property of %s is not an object.") - -(js2-msg "msg.bad.radix" - "illegal radix %s.") - -;; ScriptableObject -(js2-msg "msg.default.value" - "Cannot find default value for object.") - -(js2-msg "msg.zero.arg.ctor" - "Cannot load class '%s' which has no zero-parameter constructor.") - -(js2-msg "msg.ctor.multiple.parms" - "Can't define constructor or class %s since more than " - "one constructor has multiple parameters.") - -(js2-msg "msg.extend.scriptable" - "%s must extend ScriptableObject in order to define property %s.") - -(js2-msg "msg.bad.getter.parms" - "In order to define a property, getter %s must have zero " - "parameters or a single ScriptableObject parameter.") - -(js2-msg "msg.obj.getter.parms" - "Expected static or delegated getter %s to take " - "a ScriptableObject parameter.") - -(js2-msg "msg.getter.static" - "Getter and setter must both be static or neither be static.") - -(js2-msg "msg.setter.return" - "Setter must have void return type: %s") - -(js2-msg "msg.setter2.parms" - "Two-parameter setter must take a ScriptableObject as " - "its first parameter.") - -(js2-msg "msg.setter1.parms" - "Expected single parameter setter for %s") - -(js2-msg "msg.setter2.expected" - "Expected static or delegated setter %s to take two parameters.") - -(js2-msg "msg.setter.parms" - "Expected either one or two parameters for setter.") - -(js2-msg "msg.setter.bad.type" - "Unsupported parameter type '%s' in setter '%s'.") - -(js2-msg "msg.add.sealed" - "Cannot add a property to a sealed object: %s.") - -(js2-msg "msg.remove.sealed" - "Cannot remove a property from a sealed object: %s.") - -(js2-msg "msg.modify.sealed" - "Cannot modify a property of a sealed object: %s.") - -(js2-msg "msg.modify.readonly" - "Cannot modify readonly property: %s.") - -;; TokenStream -(js2-msg "msg.missing.exponent" - "missing exponent") - -(js2-msg "msg.caught.nfe" - "number format error") - -(js2-msg "msg.unterminated.string.lit" - "unterminated string literal") - -(js2-msg "msg.unterminated.comment" - "unterminated comment") - -(js2-msg "msg.unterminated.re.lit" - "unterminated regular expression literal") - -(js2-msg "msg.invalid.re.flag" - "invalid flag after regular expression") - -(js2-msg "msg.no.re.input.for" - "no input for %s") - -(js2-msg "msg.illegal.character" - "illegal character") - -(js2-msg "msg.invalid.escape" - "invalid Unicode escape sequence") - -(js2-msg "msg.bad.namespace" - "not a valid default namespace statement. " - "Syntax is: default xml namespace = EXPRESSION;") - -;; TokensStream warnings -(js2-msg "msg.bad.octal.literal" - "illegal octal literal digit %s; " - "interpreting it as a decimal digit") - -(js2-msg "msg.reserved.keyword" - "illegal usage of future reserved keyword %s; " - "interpreting it as ordinary identifier") - -(js2-msg "msg.script.is.not.constructor" - "Script objects are not constructors.") - -;; Arrays -(js2-msg "msg.arraylength.bad" - "Inappropriate array length.") - -;; Arrays -(js2-msg "msg.arraylength.too.big" - "Array length %s exceeds supported capacity limit.") - -;; URI -(js2-msg "msg.bad.uri" - "Malformed URI sequence.") - -;; Number -(js2-msg "msg.bad.precision" - "Precision %s out of range.") - -;; NativeGenerator -(js2-msg "msg.send.newborn" - "Attempt to send value to newborn generator") - -(js2-msg "msg.already.exec.gen" - "Already executing generator") - -(js2-msg "msg.StopIteration.invalid" - "StopIteration may not be changed to an arbitrary object.") - -;; Interpreter -(js2-msg "msg.yield.closing" - "Yield from closing generator") - -(provide 'js2-messages) -;;; js2-ast.el --- JavaScript syntax tree node definitions - -;; Author: Steve Yegge (steve.yegge@gmail.com) -;; Keywords: javascript languages - -;;; Code: - -(eval-and-compile - (require 'cl)) - - -;; flags for ast node property 'member-type (used for e4x operators) -(defvar js2-property-flag #x1 "property access: element is valid name") -(defvar js2-attribute-flag #x2 "x.@y or x..@y") -(defvar js2-descendants-flag #x4 "x..y or x..@i") - -(defsubst js2-relpos (pos anchor) - "Convert POS to be relative to ANCHOR. -If POS is nil, returns nil." - (and pos (- pos anchor))) - -(defsubst js2-make-pad (indent) - (if (zerop indent) - "" - (make-string (* indent js2-basic-offset) ? ))) - -(defsubst js2-visit-ast (node callback) - "Visit every node in ast NODE with visitor CALLBACK. - -CALLBACK is a function that takes two arguments: (NODE END-P). It is -called twice: once to visit the node, and again after all the node's -children have been processed. The END-P argument is nil on the first -call and non-nil on the second call. The return value of the callback -affects the traversal: if non-nil, the children of NODE are processed. -If the callback returns nil, or if the node has no children, then the -callback is called immediately with a non-nil END-P argument. - -The node traversal is approximately lexical-order, although there -are currently no guarantees around this." - (let ((vfunc (get (aref node 0) 'js2-visitor))) - ;; visit the node - (when (funcall callback node nil) - ;; visit the kids - (cond - ((eq vfunc 'js2-visit-none) - nil) ; don't even bother calling it - ;; Each AST node type has to define a `js2-visitor' function - ;; that takes a node and a callback, and calls `js2-visit-ast' - ;; on each child of the node. - (vfunc - (funcall vfunc node callback)) - (t - (error "%s does not define a visitor-traversal function" - (aref node 0))))) - ;; call the end-visit - (funcall callback node t))) - -(defstruct (js2-node - (:constructor nil)) ; abstract - "Base AST node type." - (type -1) ; token type - (pos -1) ; start position of this AST node in parsed input - (len 1) ; num characters spanned by the node - props ; optional node property list (an alist) - parent) ; link to parent node; null for root - -(defsubst js2-node-get-prop (node prop &optional default) - (or (cadr (assoc prop (js2-node-props node))) default)) - -(defsubst js2-node-set-prop (node prop value) - (setf (js2-node-props node) - (cons (list prop value) (js2-node-props node)))) - -(defsubst js2-fixup-starts (n nodes) - "Adjust the start positions of NODES to be relative to N. -Any node in the list may be nil, for convenience." - (dolist (node nodes) - (when node - (setf (js2-node-pos node) (- (js2-node-pos node) - (js2-node-pos n)))))) - -(defsubst js2-node-add-children (parent &rest nodes) - "Set parent node of NODES to PARENT, and return PARENT. -Does nothing if we're not recording parent links. -If any given node in NODES is nil, doesn't record that link." - (js2-fixup-starts parent nodes) - (dolist (node nodes) - (and node - (setf (js2-node-parent node) parent)))) - -;; Non-recursive since it's called a frightening number of times. -(defsubst js2-node-abs-pos (n) - (let ((pos (js2-node-pos n))) - (while (setq n (js2-node-parent n)) - (setq pos (+ pos (js2-node-pos n)))) - pos)) - -(defsubst js2-node-abs-end (n) - "Return absolute buffer position of end of N." - (+ (js2-node-abs-pos n) (js2-node-len n))) - -;; It's important to make sure block nodes have a lisp list for the -;; child nodes, to limit printing recursion depth in an AST that -;; otherwise consists of defstruct vectors. Emacs will crash printing -;; a sufficiently large vector tree. - -(defstruct (js2-block-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-block-node (&key (type js2-BLOCK) - (pos js2-token-beg) - len - props - kids))) - "A block of statements." - kids) ; a lisp list of the child statement nodes - -(put 'cl-struct-js2-block-node 'js2-visitor 'js2-visit-block) -(put 'cl-struct-js2-block-node 'js2-printer 'js2-print-block) - -(defsubst js2-visit-block (ast callback) - "Visit the `js2-block-node' children of AST." - (dolist (kid (js2-block-node-kids ast)) - (js2-visit-ast kid callback))) - -(defun js2-print-block (n i) - (let ((pad (js2-make-pad i))) - (insert pad "{\n") - (dolist (kid (js2-block-node-kids n)) - (js2-print-ast kid (1+ i))) - (insert pad "}"))) - -(defstruct (js2-scope - (:include js2-block-node) - (:constructor nil) - (:constructor make-js2-scope (&key (type js2-BLOCK) - (pos js2-token-beg) - len - kids))) - ;; The symbol-table is a LinkedHashMap<String,Symbol> in Rhino. - ;; I don't have one of those handy, so I'll use an alist for now. - ;; It's as fast as an emacs hashtable for up to about 50 elements, - ;; and is much lighter-weight to construct (both CPU and mem). - ;; The keys are interned strings (symbols) for faster lookup. - ;; Should switch to hybrid alist/hashtable eventually. - symbol-table ; an alist of (symbol . js2-symbol) - parent-scope ; a `js2-scope' - top) ; top-level `js2-scope' (script/function) - -(put 'cl-struct-js2-scope 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-scope 'js2-printer 'js2-print-none) - -(defun js2-scope-set-parent-scope (scope parent) - (setf (js2-scope-parent-scope scope) parent - (js2-scope-top scope) (if (null parent) - scope - (js2-scope-top parent)))) - -(defun js2-node-get-enclosing-scope (node) - "Return the innermost `js2-scope' node surrounding NODE. -Returns nil if there is no enclosing scope node." - (let ((parent (js2-node-parent node))) - (while (not (js2-scope-p parent)) - (setq parent (js2-node-parent parent))) - parent)) - -(defun js2-get-defining-scope (scope name) - "Search up scope chain from SCOPE looking for NAME, a string or symbol. -Returns `js2-scope' in which NAME is defined, or nil if not found." - (let ((sym (if (symbolp name) - name - (intern name))) - table - result - (continue t)) - (while (and scope continue) - (if (and (setq table (js2-scope-symbol-table scope)) - (assq sym table)) - (setq continue nil - result scope) - (setq scope (js2-scope-parent-scope scope)))) - result)) - -(defsubst js2-scope-get-symbol (scope name) - "Return symbol table entry for NAME in SCOPE. -NAME can be a string or symbol. Returns a `js2-symbol' or nil if not found." - (and (js2-scope-symbol-table scope) - (cdr (assq (if (symbolp name) - name - (intern name)) - (js2-scope-symbol-table scope))))) - -(defsubst js2-scope-put-symbol (scope name symbol) - "Enter SYMBOL into symbol-table for SCOPE under NAME. -NAME can be a lisp symbol or string. SYMBOL is a `js2-symbol'." - (let* ((table (js2-scope-symbol-table scope)) - (sym (if (symbolp name) name (intern name))) - (entry (assq sym table))) - (if entry - (setcdr entry symbol) - (push (cons sym symbol) - (js2-scope-symbol-table scope))))) - -(defstruct (js2-symbol - (:constructor nil) - (:constructor make-js2-symbol (decl-type name &optional ast-node))) - "A symbol table entry." - ;; One of js2-FUNCTION, js2-LP (for parameters), js2-VAR, - ;; js2-LET, or js2-CONST - decl-type - name ; string - ast-node) ; a `js2-node' - -(defstruct (js2-error-node - (:include js2-node) - (:constructor nil) ; silence emacs21 byte-compiler - (:constructor make-js2-error-node (&key (type js2-ERROR) - (pos js2-token-beg) - len))) - "AST node representing a parse error.") - -(put 'cl-struct-js2-error-node 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-error-node 'js2-printer 'js2-print-none) - -(defstruct (js2-script-node - (:include js2-scope) - (:constructor nil) - (:constructor make-js2-script-node (&key (type js2-SCRIPT) - (pos js2-token-beg) - len - var-decls - fun-decls))) - functions ; lisp list of nested functions - regexps ; lisp list of (string . flags) - symbols ; alist (every symbol gets unique index) - (param-count 0) - var-names ; vector of string names - consts ; bool-vector matching var-decls - (temp-number 0)) ; for generating temp variables - -(put 'cl-struct-js2-script-node 'js2-visitor 'js2-visit-block) -(put 'cl-struct-js2-script-node 'js2-printer 'js2-print-script) - -(defun js2-print-script (node indent) - (dolist (kid (js2-block-node-kids node)) - (js2-print-ast kid indent))) - -(defstruct (js2-ast-root - (:include js2-script-node) - (:constructor nil) - (:constructor make-js2-ast-root (&key (type js2-SCRIPT) - (pos js2-token-beg) - len - buffer))) - "The root node of a js2 AST." - buffer ; the source buffer from which the code was parsed - comments ; a lisp list of comments, ordered by start position - errors ; a lisp list of errors found during parsing - warnings ; a lisp list of warnings found during parsing - node-count) ; number of nodes in the tree, including the root - -(put 'cl-struct-js2-ast-root 'js2-visitor 'js2-visit-ast-root) -(put 'cl-struct-js2-ast-root 'js2-printer 'js2-print-script) - -(defun js2-visit-ast-root (ast callback) - (dolist (kid (js2-ast-root-kids ast)) - (js2-visit-ast kid callback)) - (dolist (comment (js2-ast-root-comments ast)) - (js2-visit-ast comment callback))) - -(defstruct (js2-comment-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-comment-node (&key (type js2-COMMENT) - (pos js2-token-beg) - len - (format js2-ts-comment-type)))) - format) ; 'line, 'block, 'jsdoc or 'html - -(put 'cl-struct-js2-comment-node 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-comment-node 'js2-printer 'js2-print-comment) - -(defun js2-print-comment (n i) - ;; We really ought to link end-of-line comments to their nodes. - ;; Or maybe we could add a new comment type, 'endline. - (insert (js2-make-pad i) - (js2-node-string n))) - -(defstruct (js2-expr-stmt-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-expr-stmt-node (&key (type js2-EXPR_VOID) - (pos js2-ts-cursor) - len - expr))) - "An expression statement." - expr) - -(defsubst js2-expr-stmt-node-set-has-result (node) - "Change the node type to `js2-EXPR_RESULT'. Used for code generation." - (setf (js2-node-type node) js2-EXPR_RESULT)) - -(put 'cl-struct-js2-expr-stmt-node 'js2-visitor 'js2-visit-expr-stmt-node) -(put 'cl-struct-js2-expr-stmt-node 'js2-printer 'js2-print-expr-stmt-node) - -(defun js2-visit-expr-stmt-node (n v) - (js2-visit-ast (js2-expr-stmt-node-expr n) v)) - -(defun js2-print-expr-stmt-node (n indent) - (js2-print-ast (js2-expr-stmt-node-expr n) indent) - (insert ";\n")) - -(defstruct (js2-loop-node - (:include js2-scope) - (:constructor nil)) - "Abstract supertype of loop nodes." - body ; a `js2-block-node' - lp ; position of left-paren, nil if omitted - rp) ; position of right-paren, nil if omitted - -(defstruct (js2-do-node - (:include js2-loop-node) - (:constructor nil) - (:constructor make-js2-do-node (&key (type js2-DO) - (pos js2-token-beg) - len - body - condition - while-pos - lp - rp))) - "AST node for do-loop." - condition ; while (expression) - while-pos) ; buffer position of 'while' keyword - -(put 'cl-struct-js2-do-node 'js2-visitor 'js2-visit-do-node) -(put 'cl-struct-js2-do-node 'js2-printer 'js2-print-do-node) - -(defun js2-visit-do-node (n v) - (js2-visit-ast (js2-do-node-body n) v) - (js2-visit-ast (js2-do-node-condition n) v)) - -(defun js2-print-do-node (n i) - (let ((pad (js2-make-pad i))) - (insert pad "do {\n") - (dolist (kid (js2-block-node-kids (js2-do-node-body n))) - (js2-print-ast kid (1+ i))) - (insert pad "} while (") - (js2-print-ast (js2-do-node-condition n) 0) - (insert ");\n"))) - -(defstruct (js2-while-node - (:include js2-loop-node) - (:constructor nil) - (:constructor make-js2-while-node (&key (type js2-WHILE) - (pos js2-token-beg) - len - body - condition - lp - rp))) - "AST node for while-loop." - condition) ; while-condition - -(put 'cl-struct-js2-while-node 'js2-visitor 'js2-visit-while-node) -(put 'cl-struct-js2-while-node 'js2-printer 'js2-print-while-node) - -(defun js2-visit-while-node (n v) - (js2-visit-ast (js2-while-node-condition n) v) - (js2-visit-ast (js2-while-node-body n) v)) - -(defun js2-print-while-node (n i) - (let ((pad (js2-make-pad i))) - (insert pad "while (") - (js2-print-ast (js2-while-node-condition n) 0) - (insert ") {\n") - (js2-print-body (js2-while-node-body n) (1+ i)) - (insert pad "}\n"))) - -(defstruct (js2-for-node - (:include js2-loop-node) - (:constructor nil) - (:constructor make-js2-for-node (&key (type js2-FOR) - (pos js2-ts-cursor) - len - body - init - condition - update - lp - rp))) - "AST node for a C-style for-loop." - init ; initialization expression - condition ; loop condition - update) ; update clause - -(put 'cl-struct-js2-for-node 'js2-visitor 'js2-visit-for-node) -(put 'cl-struct-js2-for-node 'js2-printer 'js2-print-for-node) - -(defun js2-visit-for-node (n v) - (js2-visit-ast (js2-for-node-init n) v) - (js2-visit-ast (js2-for-node-condition n) v) - (js2-visit-ast (js2-for-node-update n) v) - (js2-visit-ast (js2-for-node-body n) v)) - -(defun js2-print-for-node (n i) - (let ((pad (js2-make-pad i))) - (insert pad "for (") - (js2-print-ast (js2-for-node-init n) 0) - (insert "; ") - (js2-print-ast (js2-for-node-condition n) 0) - (insert "; ") - (js2-print-ast (js2-for-node-update n) 0) - (insert ") {\n") - (js2-print-body (js2-for-node-body n) (1+ i)) - (insert pad "}\n"))) - -(defstruct (js2-for-in-node - (:include js2-loop-node) - (:constructor nil) - (:constructor make-js2-for-in-node (&key (type js2-FOR) - (pos js2-ts-cursor) - len - body - iterator - object - in-pos - each-pos - foreach-p - lp - rp))) - "AST node for a for..in loop." - iterator ; [var] foo in ... - object ; object over which we're iterating - in-pos ; buffer position of 'in' keyword - each-pos ; buffer position of 'each' keyword, if foreach-p - foreach-p) ; t if it's a for-each loop - -(put 'cl-struct-js2-for-in-node 'js2-visitor 'js2-visit-for-in-node) -(put 'cl-struct-js2-for-in-node 'js2-printer 'js2-print-for-in-node) - -(defun js2-visit-for-in-node (n v) - (js2-visit-ast (js2-for-in-node-iterator n) v) - (js2-visit-ast (js2-for-in-node-object n) v) - (js2-visit-ast (js2-for-in-node-body n) v)) - -(defun js2-print-for-in-node (n i) - (let ((pad (js2-make-pad i)) - (foreach (js2-for-in-node-foreach-p n))) - (insert pad "for ") - (if foreach - (insert "each ")) - (insert "(") - (js2-print-ast (js2-for-in-node-iterator n) 0) - (insert " in ") - (js2-print-ast (js2-for-in-node-object n) 0) - (insert ") {\n") - (js2-print-body (js2-for-in-node-body n) (1+ i)) - (insert pad "}\n"))) - -(defstruct (js2-return-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-return-node (&key (type js2-RETURN) - (pos js2-ts-cursor) - len - retval))) - "AST node for a return statement." - retval) ; expression to return, or 'undefined - -(put 'cl-struct-js2-return-node 'js2-visitor 'js2-visit-return-node) -(put 'cl-struct-js2-return-node 'js2-printer 'js2-print-return-node) - -(defun js2-visit-return-node (n v) - (if (js2-return-node-retval n) - (js2-visit-ast (js2-return-node-retval n) v))) - -(defun js2-print-return-node (n i) - (insert (js2-make-pad i) "return") - (when (js2-return-node-retval n) - (insert " ") - (js2-print-ast (js2-return-node-retval n) 0)) - (insert ";\n")) - -(defstruct (js2-if-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-if-node (&key (type js2-IF) - (pos js2-ts-cursor) - len - condition - then-part - else-pos - else-part - lp - rp))) - "AST node for an if-statement." - condition ; expression - then-part ; statement or block - else-pos ; optional buffer position of 'else' keyword - else-part ; optional statement or block - lp ; position of left-paren, nil if omitted - rp) ; position of right-paren, nil if omitted - -(put 'cl-struct-js2-if-node 'js2-visitor 'js2-visit-if-node) -(put 'cl-struct-js2-if-node 'js2-printer 'js2-print-if-node) - -(defun js2-visit-if-node (n v) - (js2-visit-ast (js2-if-node-condition n) v) - (js2-visit-ast (js2-if-node-then-part n) v) - (if (js2-if-node-else-part n) - (js2-visit-ast (js2-if-node-else-part n) v))) - -(defun js2-print-if-node (n i) - (let ((pad (js2-make-pad i)) - (then-part (js2-if-node-then-part n)) - (else-part (js2-if-node-else-part n))) - (insert pad "if (") - (js2-print-ast (js2-if-node-condition n) 0) - (insert ") {\n") - (js2-print-body then-part (1+ i)) - (insert pad "}") - (cond - ((not else-part) - (insert "\n")) - ((js2-if-node-p else-part) - (insert " else ") - (js2-print-body else-part i)) - (t - (insert " else {\n") - (js2-print-body else-part (1+ i)) - (insert pad "}\n"))))) - -(defstruct (js2-try-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-try-node (&key (type js2-TRY) - (pos js2-ts-cursor) - len - try-block - catch-clauses - finally-block))) - "AST node for a try-statement." - try-block - catch-clauses ; a lisp list of `js2-catch-node' - finally-block) ; a `js2-finally-node' - -(put 'cl-struct-js2-try-node 'js2-visitor 'js2-visit-try-node) -(put 'cl-struct-js2-try-node 'js2-printer 'js2-print-try-node) - -(defun js2-visit-try-node (n v) - (js2-visit-ast (js2-try-node-try-block n) v) - (dolist (clause (js2-try-node-catch-clauses n)) - (js2-visit-ast clause v)) - (if (js2-try-node-finally-block n) - (js2-visit-ast (js2-try-node-finally-block n) v))) - -(defun js2-print-try-node (n i) - (let ((pad (js2-make-pad i)) - (catches (js2-try-node-catch-clauses n)) - (finally (js2-try-node-finally-block n))) - (insert pad "try {\n") - (js2-print-body (js2-try-node-try-block n) (1+ i)) - (insert pad "}") - (when catches - (dolist (catch catches) - (js2-print-ast catch i))) - (if finally - (js2-print-ast finally i) - (insert "\n")))) - -(defstruct (js2-catch-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-catch-node (&key (type js2-CATCH) - (pos js2-ts-cursor) - len - var-name - guard-kwd - guard-expr - block - lp - rp))) - "AST node for a catch clause." - var-name ; a `js2-name-node' - guard-kwd ; relative buffer position of "if" in "catch (x if ...)" - guard-expr ; catch condition, a `js2-node' - block ; statements, a `js2-block-node' - lp ; buffer position of left-paren, nil if omitted - rp) ; buffer position of right-paren, nil if omitted - -(put 'cl-struct-js2-catch-node 'js2-visitor 'js2-visit-catch-node) -(put 'cl-struct-js2-catch-node 'js2-printer 'js2-print-catch-node) - -(defun js2-visit-catch-node (n v) - (js2-visit-ast (js2-catch-node-var-name n) v) - (when (js2-catch-node-guard-kwd n) - (js2-visit-ast (js2-catch-node-guard-expr n) v)) - (js2-visit-ast (js2-catch-node-block n) v)) - -(defun js2-print-catch-node (n i) - (let ((pad (js2-make-pad i)) - (guard-kwd (js2-catch-node-guard-kwd n)) - (guard-expr (js2-catch-node-guard-expr n))) - (insert " catch (") - (js2-print-ast (js2-catch-node-var-name n) 0) - (when guard-kwd - (insert " if ") - (js2-print-ast guard-expr 0)) - (insert ") {\n") - (js2-print-body (js2-catch-node-block n) (1+ i)) - (insert pad "}"))) - -(defstruct (js2-finally-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-finally-node (&key (type js2-FINALLY) - (pos js2-ts-cursor) - len - body))) - "AST node for a finally clause." - body) ; a `js2-node', often but not always a block node - -(put 'cl-struct-js2-finally-node 'js2-visitor 'js2-visit-finally-node) -(put 'cl-struct-js2-finally-node 'js2-printer 'js2-print-finally-node) - -(defun js2-visit-finally-node (n v) - (js2-visit-ast (js2-finally-node-body n) v)) - -(defun js2-print-finally-node (n i) - (let ((pad (js2-make-pad i))) - (insert " finally {\n") - (js2-print-body (js2-finally-node-body n) (1+ i)) - (insert pad "}\n"))) - -(defstruct (js2-switch-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-switch-node (&key (type js2-SWITCH) - (pos js2-ts-cursor) - len - discriminant - cases - lp - rp))) - "AST node for a switch statement." - discriminant ; a `js2-node' (switch expression) - cases ; a lisp list of `js2-case-node' - lp ; position of open-paren for discriminant, nil if omitted - rp) ; position of close-paren for discriminant, nil if omitted - -(put 'cl-struct-js2-switch-node 'js2-visitor 'js2-visit-switch-node) -(put 'cl-struct-js2-switch-node 'js2-printer 'js2-print-switch-node) - -(defun js2-visit-switch-node (n v) - (js2-visit-ast (js2-switch-node-discriminant n) v) - (dolist (c (js2-switch-node-cases n)) - (js2-visit-ast c v))) - -(defun js2-print-switch-node (n i) - (let ((pad (js2-make-pad i)) - (cases (js2-switch-node-cases n))) - (insert pad "switch (") - (js2-print-ast (js2-switch-node-discriminant n) 0) - (insert ") {\n") - (dolist (case cases) - (js2-print-ast case i)) - (insert pad "}\n"))) - -(defstruct (js2-case-node - (:include js2-block-node) - (:constructor nil) - (:constructor make-js2-case-node (&key (type js2-CASE) - (pos js2-ts-cursor) - len - kids - expr))) - "AST node for a case clause of a switch statement." - expr) ; the case expression (nil for default) - -(put 'cl-struct-js2-case-node 'js2-visitor 'js2-visit-case-node) -(put 'cl-struct-js2-case-node 'js2-printer 'js2-print-case-node) - -(defun js2-visit-case-node (n v) - (if (js2-case-node-expr n) ; nil for default: case - (js2-visit-ast (js2-case-node-expr n) v)) - (js2-visit-block n v)) - -(defun js2-print-case-node (n i) - (let ((pad (js2-make-pad i)) - (expr (js2-case-node-expr n))) - (insert pad) - (if (null expr) - (insert "default:\n") - (insert "case ") - (js2-print-ast expr 0) - (insert ":\n")) - (dolist (kid (js2-case-node-kids n)) - (js2-print-ast kid (1+ i))))) - -(defstruct (js2-throw-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-throw-node (&key (type js2-THROW) - (pos js2-ts-cursor) - len - expr))) - "AST node for a throw statement." - expr) ; the expression to throw - -(put 'cl-struct-js2-throw-node 'js2-visitor 'js2-visit-throw-node) -(put 'cl-struct-js2-throw-node 'js2-printer 'js2-print-throw-node) - -(defun js2-visit-throw-node (n v) - (js2-visit-ast (js2-throw-node-expr n) v)) - -(defun js2-print-throw-node (n i) - (insert (js2-make-pad i) "throw ") - (js2-print-ast (js2-throw-node-expr n) 0) - (insert ";\n")) - -(defstruct (js2-with-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-with-node (&key (type js2-WITH) - (pos js2-ts-cursor) - len - object - body - lp - rp))) - "AST node for a with-statement." - object - body - lp ; buffer position of left-paren around object, nil if omitted - rp) ; buffer position of right-paren around object, nil if omitted - -(put 'cl-struct-js2-with-node 'js2-visitor 'js2-visit-with-node) -(put 'cl-struct-js2-with-node 'js2-printer 'js2-print-with-node) - -(defun js2-visit-with-node (n v) - (js2-visit-ast (js2-with-node-object n) v) - (js2-visit-ast (js2-with-node-body n) v)) - -(defun js2-print-with-node (n i) - (let ((pad (js2-make-pad i))) - (insert pad "with (") - (js2-print-ast (js2-with-node-object n) 0) - (insert ") {\n") - (js2-print-body (js2-with-node-body n) (1+ i)) - (insert pad "}\n"))) - -(defstruct (js2-label-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-label-node (&key (type js2-LABEL) - (pos js2-ts-cursor) - len - name))) - "AST node for a statement label or case label." - name ; a string - loop) ; for validating and code-generating continue-to-label - -(put 'cl-struct-js2-label-node 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-label-node 'js2-printer 'js2-print-label) - -(defun js2-print-label (n i) - (insert (js2-make-pad i) - (js2-label-node-name n) - ":\n")) - -(defstruct (js2-labeled-stmt-node - (:include js2-node) - (:constructor nil) - ;; type needs to be in `js2-side-effecting-tokens' to avoid spurious - ;; no-side-effects warnings, hence js2-EXPR_RESULT. - (:constructor make-js2-labeled-stmt-node (&key (type js2-EXPR_RESULT) - (pos js2-ts-cursor) - len - labels - stmt))) - "AST node for a statement with one or more labels. -Multiple labels for a statement are collapsed into the labels field." - labels ; lisp list of `js2-label-node' - stmt) ; the statement these labels are for - -(put 'cl-struct-js2-labeled-stmt-node 'js2-visitor 'js2-visit-labeled-stmt) -(put 'cl-struct-js2-labeled-stmt-node 'js2-printer 'js2-print-labeled-stmt) - -(defun js2-get-label-by-name (lbl-stmt name) - "Return a `js2-label-node' by NAME from LBL-STMT's labels list. -Returns nil if no such label is in the list." - (let ((label-list (js2-labeled-stmt-node-labels lbl-stmt)) - result) - (while (and label-list (not result)) - (if (string= (js2-label-node-name (car label-list)) name) - (setq result (car label-list)) - (setq label-list (cdr label-list)))) - result)) - -(defun js2-visit-labeled-stmt (n v) - (dolist (label (js2-labeled-stmt-node-labels n)) - (js2-visit-ast label v)) - (js2-visit-ast (js2-labeled-stmt-node-stmt n) v)) - -(defun js2-print-labeled-stmt (n i) - (dolist (label (js2-labeled-stmt-node-labels n)) - (js2-print-ast label i)) - (js2-print-ast (js2-labeled-stmt-node-stmt n) (1+ i))) - -(defun js2-labeled-stmt-node-contains (node label) - "Return t if NODE contains LABEL in its label set. -NODE is a `js2-labels-node'. LABEL is an identifier." - (loop for nl in (js2-labeled-stmt-node-labels node) - if (string= label (js2-label-node-name nl)) - return t - finally return nil)) - -(defsubst js2-labeled-stmt-node-add-label (node label) - "Add a `js2-label-node' to the label set for this statement." - (setf (js2-labeled-stmt-node-labels node) - (nconc (js2-labeled-stmt-node-labels node) (list label)))) - -(defstruct (js2-jump-node - (:include js2-node) - (:constructor nil)) - "Abstract supertype of break and continue nodes." - label ; `js2-name-node' for location of label identifier, if present - target) ; target js2-labels-node or loop/switch statement - -(defun js2-visit-jump-node (n v) - ;; we don't visit the target, since it's a back-link - (if (js2-jump-node-label n) - (js2-visit-ast (js2-jump-node-label n) v))) - -(defstruct (js2-break-node - (:include js2-jump-node) - (:constructor nil) - (:constructor make-js2-break-node (&key (type js2-BREAK) - (pos js2-ts-cursor) - len - label - target))) - "AST node for a break statement. -The label field is a `js2-name-node', possibly nil, for the named label -if provided. E.g. in 'break foo', it represents 'foo'. The target field -is the target of the break - a label node or enclosing loop/switch statement.") - -(put 'cl-struct-js2-break-node 'js2-visitor 'js2-visit-jump-node) -(put 'cl-struct-js2-break-node 'js2-printer 'js2-print-break-node) - -(defun js2-print-break-node (n i) - (insert (js2-make-pad i) "break") - (when (js2-break-node-label n) - (insert " ") - (js2-print-ast (js2-break-node-label n) 0)) - (insert ";\n")) - -(defstruct (js2-continue-node - (:include js2-jump-node) - (:constructor nil) - (:constructor make-js2-continue-node (&key (type js2-CONTINUE) - (pos js2-ts-cursor) - len - label - target))) - "AST node for a continue statement. -The label field is the user-supplied enclosing label name, a `js2-name-node'. -It is nil if continue specifies no label. The target field is the jump target: -a `js2-label-node' or the innermost enclosing loop.") - -(put 'cl-struct-js2-continue-node 'js2-visitor 'js2-visit-jump-node) -(put 'cl-struct-js2-continue-node 'js2-printer 'js2-print-continue-node) - -(defun js2-print-continue-node (n i) - (insert (js2-make-pad i) "continue") - (when (js2-continue-node-label n) - (insert " ") - (js2-print-ast (js2-continue-node-label n) 0)) - (insert ";\n")) - -(defstruct (js2-function-node - (:include js2-script-node) - (:constructor nil) - (:constructor make-js2-function-node (&key (type js2-FUNCTION) - (pos js2-ts-cursor) - len - (ftype 'FUNCTION) - (form 'FUNCTION_STATEMENT) - (name "") - params - body - lp - rp))) - "AST node for a function declaration. -The `params' field is a lisp list of nodes. Each node is either a simple -`js2-name-node', or if it's a destructuring-assignment parameter, a -`js2-array-node' or `js2-object-node'." - ftype ; FUNCTION, GETTER or SETTER - form ; FUNCTION_{STATEMENT|EXPRESSION|EXPRESSION_STATEMENT} - name ; function name (a `js2-name-node', or nil if anonymous) - params ; a lisp list of destructuring forms or simple name nodes - body ; a `js2-block-node' - lp ; position of arg-list open-paren, or nil if omitted - rp ; position of arg-list close-paren, or nil if omitted - ignore-dynamic ; ignore value of the dynamic-scope flag (interpreter only) - needs-activation ; t if we need an activation object for this frame - is-generator ; t if this function contains a yield - member-expr) ; nonstandard Ecma extension from Rhino - -(put 'cl-struct-js2-function-node 'js2-visitor 'js2-visit-function-node) -(put 'cl-struct-js2-function-node 'js2-printer 'js2-print-function-node) - -(defun js2-visit-function-node (n v) - (if (js2-function-node-name n) - (js2-visit-ast (js2-function-node-name n) v)) - (dolist (p (js2-function-node-params n)) - (js2-visit-ast p v)) - (js2-visit-ast (js2-function-node-body n) v)) - -(defun js2-print-function-node (n i) - (let ((pad (js2-make-pad i)) - (getter (js2-node-get-prop n 'GETTER_SETTER)) - (name (js2-function-node-name n)) - (params (js2-function-node-params n)) - (body (js2-function-node-body n)) - (expr (eq (js2-function-node-form n) 'FUNCTION_EXPRESSION))) - (unless getter - (insert pad "function")) - (when name - (insert " ") - (js2-print-ast name 0)) - (insert "(") - (loop with len = (length params) - for param in params - for count from 1 - do - (js2-print-ast param 0) - (if (< count len) - (insert ", "))) - (insert ") {") - (unless expr - (insert "\n")) - ;; TODO: fix this to be smarter about indenting, etc. - (js2-print-body body (1+ i)) - (insert pad "}") - (unless expr - (insert "\n")))) - -(defsubst js2-function-name (node) - "Return function name for NODE, a `js2-function-node', or nil if anonymous." - (and (js2-function-node-name node) - (js2-name-node-name (js2-function-node-name node)))) - -;; Having this be an expression node makes it more flexible. -;; There are IDE contexts, such as indentation in a for-loop initializer, -;; that work better if you assume it's an expression. Whenever we have -;; a standalone var/const declaration, we just wrap with an expr stmt. -;; Eclipse apparently screwed this up and now has two versions, expr and stmt. -(defstruct (js2-var-decl-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-var-decl-node (&key (type js2-VAR) - (pos js2-token-beg) - len - kids - decl-type))) - "AST node for a variable declaration list (VAR, CONST or LET). -The node bounds differ depending on the declaration type. For VAR or -CONST declarations, the bounds include the var/const keyword. For LET -declarations, the node begins at the position of the first child." - kids ; a lisp list of `js2-var-init-node' structs. - decl-type) ; js2-VAR, js2-CONST or js2-LET - -(put 'cl-struct-js2-var-decl-node 'js2-visitor 'js2-visit-var-decl) -(put 'cl-struct-js2-var-decl-node 'js2-printer 'js2-print-var-decl) - -(defun js2-visit-var-decl (n v) - (dolist (kid (js2-var-decl-node-kids n)) - (js2-visit-ast kid v))) - -(defun js2-print-var-decl (n i) - (let ((pad (js2-make-pad i)) - (tt (js2-var-decl-node-decl-type n))) - (insert pad) - (insert (cond - ((= tt js2-VAR) "var ") - ((= tt js2-LET) "") ; handled by parent let-{expr/stmt} - ((= tt js2-CONST) "const ") - (t - (error "malformed var-decl node")))) - (loop with kids = (js2-var-decl-node-kids n) - with len = (length kids) - for kid in kids - for count from 1 - do - (js2-print-ast kid 0) - (if (< count len) - (insert ", "))))) - -(defstruct (js2-var-init-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-var-init-node (&key (type js2-VAR) - (pos js2-ts-cursor) - len - target - initializer))) - "AST node for a variable declaration. -The type field will be js2-CONST for a const decl." - target ; `js2-name-node', `js2-object-node', or `js2-array-node' - initializer) ; initializer expression, a `js2-node' - -(put 'cl-struct-js2-var-init-node 'js2-visitor 'js2-visit-var-init-node) -(put 'cl-struct-js2-var-init-node 'js2-printer 'js2-print-var-init-node) - -(defun js2-visit-var-init-node (n v) - (js2-visit-ast (js2-var-init-node-target n) v) - (if (js2-var-init-node-initializer n) - (js2-visit-ast (js2-var-init-node-initializer n) v))) - -(defun js2-print-var-init-node (n i) - (let ((pad (js2-make-pad i)) - (name (js2-var-init-node-target n)) - (init (js2-var-init-node-initializer n))) - (insert pad) - (js2-print-ast name 0) - (when init - (insert " = ") - (js2-print-ast init 0)))) - -(defstruct (js2-cond-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-cond-node (&key (type js2-HOOK) - (pos js2-ts-cursor) - len - test-expr - true-expr - false-expr - q-pos - c-pos))) - "AST node for the ternary operator" - test-expr - true-expr - false-expr - q-pos ; buffer position of ? - c-pos) ; buffer position of : - -(put 'cl-struct-js2-cond-node 'js2-visitor 'js2-visit-cond-node) -(put 'cl-struct-js2-cond-node 'js2-printer 'js2-print-cond-node) - -(defun js2-visit-cond-node (n v) - (js2-visit-ast (js2-cond-node-test-expr n) v) - (js2-visit-ast (js2-cond-node-true-expr n) v) - (js2-visit-ast (js2-cond-node-false-expr n) v)) - -(defun js2-print-cond-node (n i) - (let ((pad (js2-make-pad i))) - (insert pad) - (js2-print-ast (js2-cond-node-test-expr n) 0) - (insert " ? ") - (js2-print-ast (js2-cond-node-true-expr n) 0) - (insert " : ") - (js2-print-ast (js2-cond-node-false-expr n) 0))) - -(defstruct (js2-infix-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-infix-node (&key type - (pos js2-ts-cursor) - len - op-pos - left - right))) - "Represents infix expressions. -Includes assignment ops like `|=', and the comma operator. -The type field inherited from `js2-node' holds the operator." - op-pos ; buffer position where operator begins - left ; any `js2-node' - right) ; any `js2-node' - -(put 'cl-struct-js2-infix-node 'js2-visitor 'js2-visit-infix-node) -(put 'cl-struct-js2-infix-node 'js2-printer 'js2-print-infix-node) - -(defun js2-visit-infix-node (n v) - (when (js2-infix-node-left n) - (js2-visit-ast (js2-infix-node-left n) v)) - (when (js2-infix-node-right n) - (js2-visit-ast (js2-infix-node-right n) v))) - -(defconst js2-operator-tokens - (let ((table (make-hash-table :test 'eq)) - (tokens - (list (cons js2-IN "in") - (cons js2-TYPEOF "typeof") - (cons js2-INSTANCEOF "instanceof") - (cons js2-DELPROP "delete") - (cons js2-COMMA ",") - (cons js2-COLON ":") - (cons js2-OR "||") - (cons js2-AND "&&") - (cons js2-INC "++") - (cons js2-DEC "--") - (cons js2-BITOR "|") - (cons js2-BITXOR "^") - (cons js2-BITAND "&") - (cons js2-EQ "==") - (cons js2-NE "!=") - (cons js2-LT "<") - (cons js2-LE "<=") - (cons js2-GT ">") - (cons js2-GE ">=") - (cons js2-LSH "<<") - (cons js2-RSH ">>") - (cons js2-URSH ">>>") - (cons js2-ADD "+") ; infix plus - (cons js2-SUB "-") ; infix minus - (cons js2-MUL "*") - (cons js2-DIV "/") - (cons js2-MOD "%") - (cons js2-NOT "!") - (cons js2-BITNOT "~") - (cons js2-POS "+") ; unary plus - (cons js2-NEG "-") ; unary minus - (cons js2-SHEQ "===") ; shallow equality - (cons js2-SHNE "!==") ; shallow inequality - (cons js2-ASSIGN "=") - (cons js2-ASSIGN_BITOR "|=") - (cons js2-ASSIGN_BITXOR "^=") - (cons js2-ASSIGN_BITAND "&=") - (cons js2-ASSIGN_LSH "<<=") - (cons js2-ASSIGN_RSH ">>=") - (cons js2-ASSIGN_URSH ">>>=") - (cons js2-ASSIGN_ADD "+=") - (cons js2-ASSIGN_SUB "-=") - (cons js2-ASSIGN_MUL "*=") - (cons js2-ASSIGN_DIV "/=") - (cons js2-ASSIGN_MOD "%=")))) - (loop for (k . v) in tokens do - (puthash k v table)) - table)) - -(defun js2-print-infix-node (n i) - (let* ((tt (js2-node-type n)) - (op (gethash tt js2-operator-tokens))) - (unless op - (error "unrecognized infix operator %s" (js2-node-type n))) - (insert (js2-make-pad i)) - (js2-print-ast (js2-infix-node-left n) 0) - (unless (= tt js2-COMMA) - (insert " ")) - (insert op) - (insert " ") - (js2-print-ast (js2-infix-node-right n) 0))) - -(defstruct (js2-assign-node - (:include js2-infix-node) - (:constructor nil) - (:constructor make-js2-assign-node (&key type - (pos js2-ts-cursor) - len - op-pos - left - right))) - "Represents any assignment. -The type field holds the actual assignment operator.") - -(put 'cl-struct-js2-assign-node 'js2-visitor 'js2-visit-infix-node) -(put 'cl-struct-js2-assign-node 'js2-printer 'js2-print-infix-node) - -(defstruct (js2-unary-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-unary-node (&key type ; required - (pos js2-ts-cursor) - len - operand))) - "AST node type for unary operator nodes. -The type field can be NOT, BITNOT, POS, NEG, INC, DEC, -TYPEOF, or DELPROP. For INC or DEC, a 'postfix node -property is added if the operator follows the operand." - operand) ; a `js2-node' expression - -(put 'cl-struct-js2-unary-node 'js2-visitor 'js2-visit-unary-node) -(put 'cl-struct-js2-unary-node 'js2-printer 'js2-print-unary-node) - -(defun js2-visit-unary-node (n v) - (js2-visit-ast (js2-unary-node-operand n) v)) - -(defun js2-print-unary-node (n i) - (let* ((tt (js2-node-type n)) - (op (gethash tt js2-operator-tokens)) - (postfix (js2-node-get-prop n 'postfix))) - (unless op - (error "unrecognized unary operator %s" tt)) - (insert (js2-make-pad i)) - (unless postfix - (insert op)) - (if (or (= tt js2-TYPEOF) - (= tt js2-DELPROP)) - (insert " ")) - (js2-print-ast (js2-unary-node-operand n) 0) - (when postfix - (insert op)))) - -(defstruct (js2-let-node - (:include js2-scope) - (:constructor nil) - (:constructor make-js2-let-node (&key (type js2-LETEXPR) - (pos js2-token-beg) - len - vars - body - lp - rp))) - "AST node for a let expression or a let statement. -Note that a let declaration such as let x=6, y=7 is a `js2-var-decl-node'." - vars ; a `js2-var-decl-node' - body ; a `js2-node' representing the expression or body block - lp - rp) - -(put 'cl-struct-js2-let-node 'js2-visitor 'js2-visit-let-node) -(put 'cl-struct-js2-let-node 'js2-printer 'js2-print-let-node) - -(defun js2-visit-let-node (n v) - (when (js2-let-node-vars n) - (js2-visit-ast (js2-let-node-vars n) v)) - (when (js2-let-node-body n) - (js2-visit-ast (js2-let-node-body n) v))) - -(defun js2-print-let-node (n i) - (insert (js2-make-pad i) "let (") - (js2-print-ast (js2-let-node-vars n) 0) - (insert ") ") - (js2-print-ast (js2-let-node-body n) i)) - -(defstruct (js2-keyword-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-keyword-node (&key type - (pos js2-token-beg) - (len (- js2-ts-cursor pos))))) - "AST node representing a literal keyword such as `null'. -Used for `null', `this', `true', `false' and `debugger'. -The node type is set to js2-NULL, js2-THIS, etc.") - -(put 'cl-struct-js2-keyword-node 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-keyword-node 'js2-printer 'js2-print-keyword-node) - -(defun js2-print-keyword-node (n i) - (insert (js2-make-pad i) - (let ((tt (js2-node-type n))) - (cond - ((= tt 'js2-THIS) "this") - ((= tt 'js2-NULL) "null") - ((= tt 'js2-TRUE) "true") - ((= tt 'js2-FALSE) "false") - ((= tt 'js2-DEBUGGER) "debugger") - (t (error "Invalid keyword literal type: %d" tt)))))) - -(defsubst js2-this-node-p (node) - "Return t if this node is a `js2-literal-node' of type js2-THIS." - (eq (js2-node-type node) js2-THIS)) - -(defstruct (js2-new-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-new-node (&key (type js2-NEW) - (pos js2-token-beg) - len - target - args - initializer - lp - rp))) - "AST node for new-expression such as new Foo()." - target ; an identifier or reference - args ; a lisp list of argument nodes - lp ; position of left-paren, nil if omitted - rp ; position of right-paren, nil if omitted - initializer) ; experimental Rhino syntax: optional `js2-object-node' - -(put 'cl-struct-js2-new-node 'js2-visitor 'js2-visit-new-node) -(put 'cl-struct-js2-new-node 'js2-printer 'js2-print-new-node) - -(defun js2-visit-new-node (n v) - (js2-visit-ast (js2-new-node-target n) v) - (dolist (arg (js2-new-node-args n)) - (js2-visit-ast arg v)) - (when (js2-new-node-initializer n) - (js2-visit-ast (js2-new-node-initializer n) v))) - -(defun js2-print-new-node (n i) - (insert (js2-make-pad i) "new ") - (js2-print-ast (js2-new-node-target n)) - (insert "(") - (js2-print-list (js2-new-node-args n)) - (insert ")") - (when (js2-new-node-initializer n) - (insert " ") - (js2-print-ast (js2-new-node-initializer n)))) - -(defstruct (js2-name-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-name-node (&key (type js2-NAME) - (pos js2-token-beg) - (len (- js2-ts-cursor - js2-token-beg)) - (name js2-ts-string)))) - "AST node for a JavaScript identifier" - name ; a string - scope) ; a `js2-scope' (optional, used for codegen) - -(put 'cl-struct-js2-name-node 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-name-node 'js2-printer 'js2-print-name-node) - -(defun js2-print-name-node (n i) - (insert (js2-make-pad i) - (js2-name-node-name n))) - -(defsubst js2-name-node-length (node) - "Return identifier length of NODE, a `js2-name-node'. -Returns 0 if NODE is nil or its identifier field is nil." - (if node - (length (js2-name-node-name node)) - 0)) - -(defstruct (js2-number-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-number-node (&key (type js2-NUMBER) - (pos js2-token-beg) - (len (- js2-ts-cursor - js2-token-beg)) - (value js2-ts-string) - (num-value js2-ts-number)))) - "AST node for a number literal." - value ; the original string, e.g. "6.02e23" - num-value) ; the parsed number value - -(put 'cl-struct-js2-number-node 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-number-node 'js2-printer 'js2-print-number-node) - -(defun js2-print-number-node (n i) - (insert (js2-make-pad i) - (number-to-string (js2-number-node-value n)))) - -(defstruct (js2-regexp-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-regexp-node (&key (type js2-REGEXP) - (pos js2-token-beg) - (len (- js2-ts-cursor - js2-token-beg)) - value - flags))) - "AST node for a regular expression literal." - value ; the regexp string, without // delimiters - flags) ; a string of flags, e.g. `mi'. - -(put 'cl-struct-js2-regexp-node 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-regexp-node 'js2-printer 'js2-print-regexp) - -(defun js2-print-regexp (n i) - (insert (js2-make-pad i) - "/" - (js2-regexp-node-value n) - "/") - (if (js2-regexp-node-flags n) - (insert (js2-regexp-node-flags n)))) - -(defstruct (js2-string-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-string-node (&key (type js2-STRING) - (pos js2-token-beg) - (len (- js2-ts-cursor - js2-token-beg)) - (value js2-ts-string)))) - "String literal. -Escape characters are not evaluated; e.g. \n is 2 chars in value field. -You can tell the quote type by looking at the first character." - value) ; the characters of the string, including the quotes - -(put 'cl-struct-js2-string-node 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-string-node 'js2-printer 'js2-print-string-node) - -(defun js2-print-string-node (n i) - (insert (js2-make-pad i) - (js2-node-string n))) - -(defstruct (js2-array-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-array-node (&key (type js2-ARRAYLIT) - (pos js2-ts-cursor) - len - elems))) - "AST node for an array literal." - elems) ; list of expressions. [foo,,bar] yields a nil middle element. - -(put 'cl-struct-js2-array-node 'js2-visitor 'js2-visit-array-node) -(put 'cl-struct-js2-array-node 'js2-printer 'js2-print-array-node) - -(defun js2-visit-array-node (n v) - (dolist (e (js2-array-node-elems n)) - (when e ; can be nil, e.g. [a, ,b] - (js2-visit-ast e v)))) - -(defun js2-print-array-node (n i) - (insert (js2-make-pad i) "[") - (js2-print-list (js2-array-node-elems n)) - (insert "]")) - -(defstruct (js2-object-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-object-node (&key (type js2-OBJECTLIT) - (pos js2-ts-cursor) - len - elems))) - "AST node for an object literal expression." - elems) ; a lisp list of `js2-object-prop-node' - -(put 'cl-struct-js2-object-node 'js2-visitor 'js2-visit-object-node) -(put 'cl-struct-js2-object-node 'js2-printer 'js2-print-object-node) - -(defun js2-visit-object-node (n v) - (dolist (e (js2-object-node-elems n)) - (js2-visit-ast e v))) - -(defun js2-print-object-node (n i) - (insert (js2-make-pad i) "{") - (js2-print-list (js2-object-node-elems n)) - (insert "}")) - -(defstruct (js2-object-prop-node - (:include js2-infix-node) - (:constructor nil) - (:constructor make-js2-object-prop-node (&key (type js2-COLON) - (pos js2-ts-cursor) - len - left - right - op-pos))) - "AST node for an object literal prop:value entry. -The `left' field is the property: a name node, string node or number node. -The `right' field is a `js2-node' representing the initializer value.") - -(put 'cl-struct-js2-object-prop-node 'js2-visitor 'js2-visit-infix-node) -(put 'cl-struct-js2-object-prop-node 'js2-printer 'js2-print-object-prop-node) - -(defun js2-print-object-prop-node (n i) - (insert (js2-make-pad i)) - (js2-print-ast (js2-object-prop-node-left n) 0) - (insert ":") - (js2-print-ast (js2-object-prop-node-right n) 0)) - -(defstruct (js2-getter-setter-node - (:include js2-infix-node) - (:constructor nil) - (:constructor make-js2-getter-setter-node (&key type ; GET or SET - (pos js2-ts-cursor) - len - left - right))) - "AST node for a getter/setter property in an object literal. -The `left' field is the `js2-name-node' naming the getter/setter prop. -The `right' field is always an anonymous `js2-function-node' with a node -property `GETTER_SETTER' set to js2-GET or js2-SET. ") - -(put 'cl-struct-js2-getter-setter-node 'js2-visitor 'js2-visit-infix-node) -(put 'cl-struct-js2-getter-setter-node 'js2-printer 'js2-print-getter-setter) - -(defun js2-print-getter-setter (n i) - (let ((pad (js2-make-pad i)) - (left (js2-getter-setter-node-left n)) - (right (js2-getter-setter-node-right n))) - (insert pad) - (insert (if (= (js2-node-type n) js2-GET) "get " "set ")) - (js2-print-ast left 0) - (js2-print-ast right 0))) - -(defstruct (js2-prop-get-node - (:include js2-infix-node) - (:constructor nil) - (:constructor make-js2-prop-get-node (&key (type js2-GETPROP) - (pos js2-ts-cursor) - len - left - right))) - "AST node for a dotted property reference, e.g. foo.bar or foo().bar") - -(put 'cl-struct-js2-prop-get-node 'js2-visitor 'js2-visit-prop-get-node) -(put 'cl-struct-js2-prop-get-node 'js2-printer 'js2-print-prop-get-node) - -(defun js2-visit-prop-get-node (n v) - (when (js2-prop-get-node-left n) - (js2-visit-ast (js2-prop-get-node-left n) v)) - (when (js2-prop-get-node-right n) - (js2-visit-ast (js2-prop-get-node-right n) v))) - -(defun js2-print-prop-get-node (n i) - (insert (js2-make-pad i)) - (js2-print-ast (js2-prop-get-node-left n) 0) - (insert ".") - (js2-print-ast (js2-prop-get-node-right n) 0)) - -(defstruct (js2-elem-get-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-elem-get-node (&key (type js2-GETELEM) - (pos js2-ts-cursor) - len - target - element - lb - rb))) - "AST node for an array index expression such as foo[bar]." - target ; a `js2-node' - the expression preceding the "." - element ; a `js2-node' - the expression in brackets - lb ; position of left-bracket, nil if omitted - rb) ; position of right-bracket, nil if omitted - -(put 'cl-struct-js2-elem-get-node 'js2-visitor 'js2-visit-elem-get-node) -(put 'cl-struct-js2-elem-get-node 'js2-printer 'js2-print-elem-get-node) - -(defun js2-visit-elem-get-node (n v) - (when (js2-elem-get-node-target n) - (js2-visit-ast (js2-elem-get-node-target n) v)) - (when (js2-elem-get-node-element n) - (js2-visit-ast (js2-elem-get-node-element n) v))) - -(defun js2-print-elem-get-node (n i) - (insert (js2-make-pad i)) - (js2-print-ast (js2-elem-get-node-target n) 0) - (insert "[") - (js2-print-ast (js2-elem-get-node-element n) 0) - (insert "]")) - -(defstruct (js2-call-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-call-node (&key (type js2-CALL) - (pos js2-ts-cursor) - len - target - args - lp - rp))) - "AST node for a JavaScript function call." - target ; a `js2-node' evaluating to the function to call - args ; a lisp list of `js2-node' arguments - lp ; position of open-paren, or nil if missing - rp) ; position of close-paren, or nil if missing - -(put 'cl-struct-js2-call-node 'js2-visitor 'js2-visit-call-node) -(put 'cl-struct-js2-call-node 'js2-printer 'js2-print-call-node) - -(defun js2-visit-call-node (n v) - (js2-visit-ast (js2-call-node-target n) v) - (dolist (arg (js2-call-node-args n)) - (js2-visit-ast arg v))) - -(defun js2-print-call-node (n i) - (insert (js2-make-pad i)) - (js2-print-ast (js2-call-node-target n) 0) - (insert "(") - (js2-print-list (js2-call-node-args n)) - (insert ")")) - -(defstruct (js2-yield-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-yield-node (&key (type js2-YIELD) - (pos js2-ts-cursor) - len - value))) - "AST node for yield statement or expression." - value) ; optional: value to be yielded - -(put 'cl-struct-js2-yield-node 'js2-visitor 'js2-visit-yield-node) -(put 'cl-struct-js2-yield-node 'js2-printer 'js2-print-yield-node) - -(defun js2-visit-yield-node (n v) - (js2-visit-ast (js2-yield-node-value n) v)) - -(defun js2-print-yield-node (n i) - (insert (js2-make-pad i)) - (insert "yield") - (when (js2-yield-node-value n) - (insert " ") - (js2-print-ast (js2-yield-node-value n) 0))) - -(defstruct (js2-paren-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-paren-node (&key (type js2-LP) - (pos js2-ts-cursor) - len - expr))) - "AST node for a parenthesized expression. -In particular, used when the parens are syntactically optional, -as opposed to required parens such as those enclosing an if-conditional." - expr) ; `js2-node' - -(put 'cl-struct-js2-paren-node 'js2-visitor 'js2-visit-paren-node) -(put 'cl-struct-js2-paren-node 'js2-printer 'js2-print-paren-node) - -(defun js2-visit-paren-node (n v) - (js2-visit-ast (js2-paren-node-expr n) v)) - -(defun js2-print-paren-node (n i) - (insert (js2-make-pad i)) - (insert "(") - (js2-print-ast (js2-paren-node-expr n) 0) - (insert ")")) - -(defstruct (js2-array-comp-node - (:include js2-scope) - (:constructor nil) - (:constructor make-js2-array-comp-node (&key (type js2-ARRAYCOMP) - (pos js2-ts-cursor) - len - result - loops - filter - if-pos - lp - rp))) - "AST node for an Array comprehension such as [[x,y] for (x in foo) for (y in bar)]." - result ; result expression (just after left-bracket) - loops ; a lisp list of `js2-array-comp-loop-node' - filter ; guard/filter expression - if-pos ; buffer pos of 'if' keyword, if present, else nil - lp ; buffer position of if-guard left-paren, or nil if not present - rp) ; buffer position of if-guard right-paren, or nil if not present - -(put 'cl-struct-js2-array-comp-node 'js2-visitor 'js2-visit-array-comp-node) -(put 'cl-struct-js2-array-comp-node 'js2-printer 'js2-print-array-comp-node) - -(defun js2-visit-array-comp-node (n v) - (js2-visit-ast (js2-array-comp-node-result n) v) - (dolist (l (js2-array-comp-node-loops n)) - (js2-visit-ast l v)) - (if (js2-array-comp-node-filter n) - (js2-visit-ast (js2-array-comp-node-filter n) v))) - -(defun js2-print-array-comp-node (n i) - (let ((pad (js2-make-pad i)) - (result (js2-array-comp-node-result n)) - (loops (js2-array-comp-node-loops n)) - (filter (js2-array-comp-node-filter n))) - (insert pad "[") - (js2-print-ast result 0) - (dolist (l loops) - (insert " ") - (js2-print-ast l 0)) - (when filter - (insert " if (") - (js2-print-ast filter 0)) - (insert ")]"))) - -(defstruct (js2-array-comp-loop-node - (:include js2-for-in-node) - (:constructor nil) - (:constructor make-js2-array-comp-loop-node (&key (type js2-FOR) - (pos js2-ts-cursor) - len - iterator - object - in-pos - foreach-p - each-pos - lp - rp))) - "AST subtree for each 'for (foo in bar)' loop in an array comprehension.") - -(put 'cl-struct-js2-array-comp-loop-node 'js2-visitor 'js2-visit-array-comp-loop) -(put 'cl-struct-js2-array-comp-loop-node 'js2-printer 'js2-print-array-comp-loop) - -(defun js2-visit-array-comp-loop (n v) - (js2-visit-ast (js2-array-comp-loop-node-iterator n) v) - (js2-visit-ast (js2-array-comp-loop-node-object n) v)) - -(defun js2-print-array-comp-loop (n i) - (insert "for (") - (js2-print-ast (js2-array-comp-loop-node-iterator n) 0) - (insert " in ") - (js2-print-ast (js2-array-comp-loop-node-object n) 0) - (insert ")")) - -(defstruct (js2-empty-expr-node - (:include js2-node) - (:constructor nil) - (:constructor make-js2-empty-expr-node (&key (type js2-EMPTY) - (pos js2-token-beg) - len))) - "AST node for an empty expression.") - -(put 'cl-struct-js2-empty-expr-node 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-empty-expr-node 'js2-printer 'js2-print-none) - -(defstruct (js2-xml-node - (:include js2-block-node) - (:constructor nil) - (:constructor make-js2-xml-node (&key (type js2-XML) - (pos js2-token-beg) - len - kids))) - "AST node for initial parse of E4X literals. -The kids field is a list of XML fragments, each a `js2-string-node' or -a `js2-xml-js-expr-node'. Equivalent to Rhino's XmlLiteral node.") - -(put 'cl-struct-js2-xml-node 'js2-visitor 'js2-visit-block) -(put 'cl-struct-js2-xml-node 'js2-printer 'js2-print-xml-node) - -(defun js2-print-xml-node (n i) - (dolist (kid (js2-xml-node-kids n)) - (js2-print-ast kid i))) - -(defstruct (js2-xml-js-expr-node - (:include js2-xml-node) - (:constructor nil) - (:constructor make-js2-xml-js-expr-node (&key (type js2-XML) - (pos js2-ts-cursor) - len - expr))) - "AST node for an embedded JavaScript {expression} in an E4X literal. -The start and end fields correspond to the curly-braces." - expr) ; a `js2-expr-node' of some sort - -(put 'cl-struct-js2-xml-js-expr-node 'js2-visitor 'js2-visit-xml-js-expr) -(put 'cl-struct-js2-xml-js-expr-node 'js2-printer 'js2-print-xml-js-expr) - -(defun js2-visit-xml-js-expr (n v) - (js2-visit-ast (js2-xml-js-expr-node-expr n) v)) - -(defun js2-print-xml-js-expr (n i) - (insert (js2-make-pad i)) - (insert "{") - (js2-print-ast (js2-xml-js-expr-node-expr n) 0) - (insert "}")) - -(defstruct (js2-xml-dot-query-node - (:include js2-infix-node) - (:constructor nil) - (:constructor make-js2-xml-dot-query-node (&key (type js2-DOTQUERY) - (pos js2-ts-cursor) - op-pos - len - left - right - rp))) - "AST node for an E4X foo.(bar) filter expression. -Note that the left-paren is automatically the character immediately -following the dot (.) in the operator. No whitespace is permitted -between the dot and the lp by the scanner." - rp) - -(put 'cl-struct-js2-xml-dot-query-node 'js2-visitor 'js2-visit-infix-node) -(put 'cl-struct-js2-xml-dot-query-node 'js2-printer 'js2-print-xml-dot-query) - -(defun js2-print-xml-dot-query (n i) - (insert (js2-make-pad i)) - (js2-print-ast (js2-xml-dot-query-node-left n) 0) - (insert ".(") - (js2-print-ast (js2-xml-dot-query-node-right n) 0) - (insert ")")) - -(defstruct (js2-xml-ref-node - (:include js2-node) - (:constructor nil)) ; abstract - "Base type for E4X XML attribute-access or property-get expressions. -Such expressions can take a variety of forms. The general syntax has -three parts: - - - (optional) an @ (specifying an attribute access) - - (optional) a namespace (a `js2-name-node') and double-colon - - (required) either a `js2-name-node' or a bracketed [expression] - -The property-name expressions (examples: ns::name, @name) are -represented as `js2-xml-prop-ref' nodes. The bracketed-expression -versions (examples: ns::[name], @[name]) become `js2-xml-elem-ref' nodes. - -This node type (or more specifically, its subclasses) will sometimes -be the right-hand child of a `js2-prop-get-node' or a -`js2-infix-node' of type `js2-DOTDOT', the .. xml-descendants operator. -The `js2-xml-ref-node' may also be a standalone primary expression with -no explicit target, which is valid in certain expression contexts such as - - company..employee.(@id < 100) - -in this case, the @id is a `js2-xml-ref' that is part of an infix '<' -expression whose parent is a `js2-xml-dot-query-node'." - namespace - at-pos - colon-pos) - -(defsubst js2-xml-ref-node-attr-access-p (node) - "Return non-nil if this expression began with an @-token." - (and (numberp (js2-xml-ref-node-at-pos node)) - (plusp (js2-xml-ref-node-at-pos node)))) - -(defstruct (js2-xml-prop-ref-node - (:include js2-xml-ref-node) - (:constructor nil) - (:constructor make-js2-xml-prop-ref-node (&key (type js2-REF_NAME) - (pos js2-token-beg) - len - propname - namespace - at-pos - colon-pos))) - "AST node for an E4X XML [expr] property-ref expression. -The JavaScript syntax is an optional @, an optional ns::, and a name. - - [ '@' ] [ name '::' ] name - -Examples include name, ns::name, ns::*, *::name, *::*, @attr, @ns::attr, -@ns::*, @*::attr, @*::*, and @*. - -The node starts at the @ token, if present. Otherwise it starts at the -namespace name. The node bounds extend through the closing right-bracket, -or if it is missing due to a syntax error, through the end of the index -expression." - propname) - -(put 'cl-struct-js2-xml-prop-ref-node 'js2-visitor 'js2-visit-xml-prop-ref-node) -(put 'cl-struct-js2-xml-prop-ref-node 'js2-printer 'js2-print-xml-prop-ref-node) - -(defun js2-visit-xml-prop-ref-node (n v) - (if (js2-xml-prop-ref-node-namespace n) - (js2-visit-ast (js2-xml-prop-ref-node-namespace n) v)) - (if (js2-xml-prop-ref-node-propname n) - (js2-visit-ast (js2-xml-prop-ref-node-propname n) v))) - -(defun js2-print-xml-prop-ref-node (n i) - (insert (js2-make-pad i)) - (if (js2-xml-ref-node-attr-access-p n) - (insert "@")) - (when (js2-xml-prop-ref-node-namespace n) - (js2-print-ast (js2-xml-prop-ref-node-namespace n) 0) - (insert "::")) - (if (js2-xml-prop-ref-node-propname n) - (js2-print-ast (js2-xml-prop-ref-node-propname n) 0))) - -(defstruct (js2-xml-elem-ref-node - (:include js2-xml-ref-node) - (:constructor nil) - (:constructor make-js2-xml-elem-ref-node (&key (type js2-REF_MEMBER) - (pos js2-token-beg) - len - expr - lb - rb - namespace - at-pos - colon-pos))) - "AST node for an E4X XML [expr] member-ref expression. -Syntax: - - [ '@' ] [ name '::' ] '[' expr ']' - -Examples include ns::[expr], @ns::[expr], @[expr], *::[expr] and @*::[expr]. - -Note that the form [expr] (i.e. no namespace or attribute-qualifier) -is not a legal E4X XML element-ref expression, since it's already used -for standard JavaScript element-get array indexing. Hence, a -`js2-xml-elem-ref-node' always has either the attribute-qualifier, a -non-nil namespace node, or both. - -The node starts at the @ token, if present. Otherwise it starts -at the namespace name. The node bounds extend through the closing -right-bracket, or if it is missing due to a syntax error, through the -end of the index expression." - expr ; the bracketed index expression - lb - rb) - -(put 'cl-struct-js2-xml-elem-ref-node 'js2-visitor 'js2-visit-xml-elem-ref-node) -(put 'cl-struct-js2-xml-elem-ref-node 'js2-printer 'js2-print-xml-elem-ref-node) - -(defun js2-visit-xml-elem-ref-node (n v) - (if (js2-xml-elem-ref-node-namespace n) - (js2-visit-ast (js2-xml-elem-ref-node-namespace n) v)) - (if (js2-xml-elem-ref-node-expr n) - (js2-visit-ast (js2-xml-elem-ref-node-expr n) v))) - -(defun js2-print-xml-elem-ref-node (n i) - (insert (js2-make-pad i)) - (if (js2-xml-ref-node-attr-access-p n) - (insert "@")) - (when (js2-xml-elem-ref-node-namespace n) - (js2-print-ast (js2-xml-elem-ref-node-namespace n) 0) - (insert "::")) - (insert "[") - (if (js2-xml-elem-ref-node-expr n) - (js2-print-ast (js2-xml-elem-ref-node-expr n) 0)) - (insert "]")) - -;;; Placeholder nodes for when we try parsing the XML literals structurally. - -(defstruct (js2-xml-start-tag-node - (:include js2-xml-node) - (:constructor nil) - (:constructor make-js2-xml-start-tag-node (&key (type js2-XML) - (pos js2-ts-cursor) - len - name - attrs - kids - empty-p))) - "AST node for an XML start-tag. Not currently used. -The `kids' field is a lisp list of child content nodes." - name ; a `js2-xml-name-node' - attrs ; a lisp list of `js2-xml-attr-node' - empty-p) ; t if this is an empty element such as <foo bar="baz"/> - -(put 'cl-struct-js2-xml-start-tag-node 'js2-visitor 'js2-visit-xml-start-tag) -(put 'cl-struct-js2-xml-start-tag-node 'js2-printer 'js2-print-xml-start-tag) - -(defun js2-visit-xml-start-tag (n v) - (js2-visit-ast (js2-xml-start-tag-node-name n) v) - (dolist (attr (js2-xml-start-tag-node-attrs n)) - (js2-visit-ast attr v)) - (js2-visit-block n v)) - -(defun js2-print-xml-start-tag (n i) - (insert (js2-make-pad i) "<") - (js2-print-ast (js2-xml-start-tag-node-name n) 0) - (when (js2-xml-start-tag-node-attrs n) - (insert " ") - (js2-print-list (js2-xml-start-tag-node-attrs n) " ")) - (insert ">")) - -;; I -think- I'm going to make the parent node the corresponding start-tag, -;; and add the end-tag to the kids list of the parent as well. -(defstruct (js2-xml-end-tag-node - (:include js2-xml-node) - (:constructor nil) - (:constructor make-js2-xml-end-tag-node (&key (type js2-XML) - (pos js2-ts-cursor) - len - name))) - "AST node for an XML end-tag. Not currently used." - name) ; a `js2-xml-name-node' - -(put 'cl-struct-js2-xml-end-tag-node 'js2-visitor 'js2-visit-xml-end-tag) -(put 'cl-struct-js2-xml-end-tag-node 'js2-printer 'js2-print-xml-end-tag) - -(defun js2-visit-xml-end-tag (n v) - (js2-visit-ast (js2-xml-end-tag-node-name n) v)) - -(defun js2-print-xml-end-tag (n i) - (insert (js2-make-pad i)) - (insert "</") - (js2-print-ast (js2-xml-end-tag-node-name n) 0) - (insert ">")) - -(defstruct (js2-xml-name-node - (:include js2-xml-node) - (:constructor nil) - (:constructor make-js2-xml-name-node (&key (type js2-XML) - (pos js2-ts-cursor) - len - namespace - kids))) - "AST node for an E4X XML name. Not currently used. -Any XML name can be qualified with a namespace, hence the namespace field. -Further, any E4X name can be comprised of arbitrary JavaScript {} expressions. -The kids field is a list of `js2-name-node' and `js2-xml-js-expr-node'. -For a simple name, the kids list has exactly one node, a `js2-name-node'." - namespace) ; a `js2-string-node' - -(put 'cl-struct-js2-xml-name-node 'js2-visitor 'js2-visit-xml-name-node) -(put 'cl-struct-js2-xml-name-node 'js2-printer 'js2-print-xml-name-node) - -(defun js2-visit-xml-name-node (n v) - (js2-visit-ast (js2-xml-name-node-namespace n) v)) - -(defun js2-print-xml-name-node (n i) - (insert (js2-make-pad i)) - (when (js2-xml-name-node-namespace n) - (js2-print-ast (js2-xml-name-node-namespace n) 0) - (insert "::")) - (dolist (kid (js2-xml-name-node-kids n)) - (js2-print-ast kid 0))) - -(defstruct (js2-xml-pi-node - (:include js2-xml-node) - (:constructor nil) - (:constructor make-js2-xml-pi-node (&key (type js2-XML) - (pos js2-ts-cursor) - len - name - attrs))) - "AST node for an E4X XML processing instruction. Not currently used." - name ; a `js2-xml-name-node' - attrs) ; a list of `js2-xml-attr-node' - -(put 'cl-struct-js2-xml-pi-node 'js2-visitor 'js2-visit-xml-pi-node) -(put 'cl-struct-js2-xml-pi-node 'js2-printer 'js2-print-xml-pi-node) - -(defun js2-visit-xml-pi-node (n v) - (js2-visit-ast (js2-xml-pi-node-name n) v) - (dolist (attr (js2-xml-pi-node-attrs n)) - (js2-visit-ast attr v))) - -(defun js2-print-xml-pi-node (n i) - (insert (js2-make-pad i) "<?") - (js2-print-ast (js2-xml-pi-node-name n)) - (when (js2-xml-pi-node-attrs n) - (insert " ") - (js2-print-list (js2-xml-pi-node-attrs n))) - (insert "?>")) - -(defstruct (js2-xml-cdata-node - (:include js2-xml-node) - (:constructor nil) - (:constructor make-js2-xml-cdata-node (&key (type js2-XML) - (pos js2-ts-cursor) - len - content))) - "AST node for a CDATA escape section. Not currently used." - content) ; a `js2-string-node' with node-property 'quote-type 'cdata - -(put 'cl-struct-js2-xml-cdata-node 'js2-visitor 'js2-visit-xml-cdata-node) -(put 'cl-struct-js2-xml-cdata-node 'js2-printer 'js2-print-xml-cdata-node) - -(defun js2-visit-xml-cdata-node (n v) - (js2-visit-ast (js2-xml-cdata-node-content n) v)) - -(defun js2-print-xml-cdata-node (n i) - (insert (js2-make-pad i)) - (js2-print-ast (js2-xml-cdata-node-content n))) - -(defstruct (js2-xml-attr-node - (:include js2-xml-node) - (:constructor nil) - (:constructor make-js2-attr-node (&key (type js2-XML) - (pos js2-ts-cursor) - len - name - value - eq-pos - quote-type))) - "AST node representing a foo='bar' XML attribute value. Not yet used." - name ; a `js2-xml-name-node' - value ; a `js2-xml-name-node' - eq-pos ; buffer position of "=" sign - quote-type) ; 'single or 'double - -(put 'cl-struct-js2-xml-attr-node 'js2-visitor 'js2-visit-xml-attr-node) -(put 'cl-struct-js2-xml-attr-node 'js2-printer 'js2-print-xml-attr-node) - -(defun js2-visit-xml-attr-node (n v) - (js2-visit-ast (js2-xml-attr-node-name n) v) - (js2-visit-ast (js2-xml-attr-node-value n) v)) - -(defun js2-print-xml-attr-node (n i) - (let ((quote (if (eq (js2-xml-attr-node-quote-type n) 'single) - "'" - "\""))) - (insert (js2-make-pad i)) - (js2-print-ast (js2-xml-attr-node-name n) 0) - (insert "=" quote) - (js2-print-ast (js2-xml-attr-node-value n) 0) - (insert quote))) - -(defstruct (js2-xml-text-node - (:include js2-xml-node) - (:constructor nil) - (:constructor make-js2-text-node (&key (type js2-XML) - (pos js2-ts-cursor) - len - content))) - "AST node for an E4X XML text node. Not currently used." - content) ; a lisp list of `js2-string-node' and `js2-xml-js-expr-node' - -(put 'cl-struct-js2-xml-text-node 'js2-visitor 'js2-visit-xml-text-node) -(put 'cl-struct-js2-xml-text-node 'js2-printer 'js2-print-xml-text-node) - -(defun js2-visit-xml-text-node (n v) - (js2-visit-ast (js2-xml-text-node-content n) v)) - -(defun js2-print-xml-text-node (n i) - (insert (js2-make-pad i)) - (dolist (kid (js2-xml-text-node-content n)) - (js2-print-ast kid))) - -(defstruct (js2-xml-comment-node - (:include js2-xml-node) - (:constructor nil) - (:constructor make-js2-xml-comment-node (&key (type js2-XML) - (pos js2-ts-cursor) - len))) - "AST node for E4X XML comment. Not currently used.") - -(put 'cl-struct-js2-xml-comment-node 'js2-visitor 'js2-visit-none) -(put 'cl-struct-js2-xml-comment-node 'js2-printer 'js2-print-xml-comment) - -(defun js2-print-xml-comment (n i) - (insert (js2-make-pad i) - (js2-node-string n))) - -;;; Node utilities - -(defsubst js2-node-line (n) - "Fetch the source line number at the start of node N. -This is O(n) in the length of the source buffer; use prudently." - (1+ (count-lines (point-min) (js2-node-abs-pos n)))) - -(defsubst js2-block-node-kid (n i) - "Return child I of node N, or nil if there aren't that many." - (nth i (js2-block-node-kids n))) - -(defsubst js2-block-node-first (n) - "Return first child of block node N, or nil if there is none." - (first (js2-block-node-kids n))) - -(defun js2-node-root (n) - "Return the root of the AST containing N. -If N has no parent pointer, returns N." - (let ((parent (js2-node-parent n))) - (if parent - (js2-node-root parent) - n))) - -(defun js2-node-position-in-parent (node &optional parent) - "Return the position of NODE in parent's block-kids list. -PARENT can be supplied if known. Positioned returned is zero-indexed. -Returns 0 if NODE is not a child of a block statement, or if NODE -is not a statement node." - (let ((p (or parent (js2-node-parent node))) - (i 0)) - (if (not (js2-block-node-p p)) - i - (or (js2-position node (js2-block-node-kids p)) - 0)))) - -(defsubst js2-node-short-name (n) - "Return the short name of node N as a string, e.g. `js2-if-node'." - (substring (symbol-name (aref n 0)) - (length "cl-struct-"))) - -(defsubst js2-node-child-list (node) - "Return the child list for NODE, a lisp list of nodes. -Works for block nodes, array nodes, obj literals, funarg lists, -var decls and try nodes (for catch clauses). Note that you should call -`js2-block-node-kids' on the function body for the body statements. -Returns nil for zero-length child lists or unsupported nodes." - (cond - ((js2-function-node-p node) - (js2-function-node-params node)) - ((js2-block-node-p node) - (js2-block-node-kids node)) - ((js2-try-node-p node) - (js2-try-node-catch-clauses node)) - ((js2-array-node-p node) - (js2-array-node-elems node)) - ((js2-object-node-p node) - (js2-object-node-elems node)) - ((js2-call-node-p node) - (js2-call-node-args node)) - ((js2-new-node-p node) - (js2-new-node-args node)) - ((js2-var-decl-node-p node) - (js2-var-decl-node-kids node)) - (t - nil))) - -(defsubst js2-node-set-child-list (node kids) - "Set the child list for NODE to KIDS." - (cond - ((js2-function-node-p node) - (setf (js2-function-node-params node) kids)) - ((js2-block-node-p node) - (setf (js2-block-node-kids node) kids)) - ((js2-try-node-p node) - (setf (js2-try-node-catch-clauses node) kids)) - ((js2-array-node-p node) - (setf (js2-array-node-elems node) kids)) - ((js2-object-node-p node) - (setf (js2-object-node-elems node) kids)) - ((js2-call-node-p node) - (setf (js2-call-node-args node) kids)) - ((js2-new-node-p node) - (setf (js2-new-node-args node) kids)) - ((js2-var-decl-node-p node) - (setf (js2-var-decl-node-kids node) kids)) - (t - (error "Unsupported node type: %s" (js2-node-short-name node)))) - kids) - -;; All because Common Lisp doesn't support multiple inheritance for defstructs. -(defconst js2-paren-expr-nodes - '(cl-struct-js2-array-comp-loop-node - cl-struct-js2-array-comp-node - cl-struct-js2-call-node - cl-struct-js2-catch-node - cl-struct-js2-do-node - cl-struct-js2-elem-get-node - cl-struct-js2-for-in-node - cl-struct-js2-for-node - cl-struct-js2-function-node - cl-struct-js2-if-node - cl-struct-js2-let-node - cl-struct-js2-new-node - cl-struct-js2-paren-node - cl-struct-js2-switch-node - cl-struct-js2-while-node - cl-struct-js2-with-node - cl-struct-js2-xml-dot-query-node) - "Node types that can have a parenthesized child expression. -In particular, nodes that respond to `js2-node-lp' and `js2-node-rp'.") - -(defsubst js2-paren-expr-node-p (node) - "Return t for nodes that typically have a parenthesized child expression. -Useful for computing the indentation anchors for arg-lists and conditions. -Note that it may return a false positive, for instance when NODE is -a `js2-new-node' and there are no arguments or parentheses." - (memq (aref node 0) js2-paren-expr-nodes)) - -;; Fake polymorphism... yech. -(defsubst js2-node-lp (node) - "Return relative left-paren position for NODE, if applicable. -For `js2-elem-get-node' structs, returns left-bracket position. -Note that the position may be nil in the case of a parse error." - (cond - ((js2-elem-get-node-p node) - (js2-elem-get-node-lb node)) - ((js2-loop-node-p node) - (js2-loop-node-lp node)) - ((js2-function-node-p node) - (js2-function-node-lp node)) - ((js2-if-node-p node) - (js2-if-node-lp node)) - ((js2-new-node-p node) - (js2-new-node-lp node)) - ((js2-call-node-p node) - (js2-call-node-lp node)) - ((js2-paren-node-p node) - (js2-node-pos node)) - ((js2-switch-node-p node) - (js2-switch-node-lp node)) - ((js2-catch-node-p node) - (js2-catch-node-lp node)) - ((js2-let-node-p node) - (js2-let-node-lp node)) - ((js2-array-comp-node-p node) - (js2-array-comp-node-lp node)) - ((js2-with-node-p node) - (js2-with-node-lp node)) - ((js2-xml-dot-query-node-p node) - (1+ (js2-infix-node-op-pos node))) - (t - (error "Unsupported node type: %s" (js2-node-short-name node))))) - -;; Fake polymorphism... blech. -(defsubst js2-node-rp (node) - "Return relative right-paren position for NODE, if applicable. -For `js2-elem-get-node' structs, returns right-bracket position. -Note that the position may be nil in the case of a parse error." - (cond - ((js2-elem-get-node-p node) - (js2-elem-get-node-lb node)) - ((js2-loop-node-p node) - (js2-loop-node-rp node)) - ((js2-function-node-p node) - (js2-function-node-rp node)) - ((js2-if-node-p node) - (js2-if-node-rp node)) - ((js2-new-node-p node) - (js2-new-node-rp node)) - ((js2-call-node-p node) - (js2-call-node-rp node)) - ((js2-paren-node-p node) - (+ (js2-node-pos node) (js2-node-len node))) - ((js2-switch-node-p node) - (js2-switch-node-rp node)) - ((js2-catch-node-p node) - (js2-catch-node-rp node)) - ((js2-let-node-p node) - (js2-let-node-rp node)) - ((js2-array-comp-node-p node) - (js2-array-comp-node-rp node)) - ((js2-with-node-p node) - (js2-with-node-rp node)) - ((js2-xml-dot-query-node-p node) - (1+ (js2-xml-dot-query-node-rp node))) - (t - (error "Unsupported node type: %s" (js2-node-short-name node))))) - -(defsubst js2-node-first-child (node) - "Returns the first element of `js2-node-child-list' for NODE." - (car (js2-node-child-list node))) - -(defsubst js2-node-last-child (node) - "Returns the last element of `js2-node-last-child' for NODE." - (car (last (js2-node-child-list node)))) - -(defun js2-node-prev-sibling (node) - "Return the previous statement in parent. -Works for parents supported by `js2-node-child-list'. -Returns nil if NODE is not in the parent, or PARENT is -not a supported node, or if NODE is the first child." - (let* ((p (js2-node-parent node)) - (kids (js2-node-child-list p)) - (sib (car kids))) - (while (and kids - (neq node (cadr kids))) - (setq kids (cdr kids) - sib (car kids))) - sib)) - -(defun js2-node-next-sibling (node) - "Return the next statement in parent block. -Returns nil if NODE is not in the block, or PARENT is not -a block node, or if NODE is the last statement." - (let* ((p (js2-node-parent node)) - (kids (js2-node-child-list p))) - (while (and kids - (neq node (car kids))) - (setq kids (cdr kids))) - (cadr kids))) - -(defun js2-node-find-child-before (pos parent &optional after) - "Find the last child that starts before POS in parent. -If AFTER is non-nil, returns first child starting after POS. -POS is an absolute buffer position. PARENT is any node -supported by `js2-node-child-list'. -Returns nil if no applicable child is found." - (let ((kids (if (js2-function-node-p parent) - (js2-block-node-kids (js2-function-node-body parent)) - (js2-node-child-list parent))) - (beg (if (js2-function-node-p parent) - (js2-node-abs-pos (js2-function-node-body parent)) - (js2-node-abs-pos parent))) - kid - result - fn - (continue t)) - (setq fn (if after '> '<)) - (while (and kids continue) - (setq kid (car kids)) - (if (funcall fn (+ beg (js2-node-pos kid)) pos) - (setq result kid - continue (if after nil t)) - (setq continue (if after t nil))) - (setq kids (cdr kids))) - result)) - -(defun js2-node-find-child-after (pos parent) - "Find first child that starts after POS in parent. -POS is an absolute buffer position. PARENT is any node -supported by `js2-node-child-list'. -Returns nil if no applicable child is found." - (js2-node-find-child-before pos parent 'after)) - -(defun js2-node-replace-child (pos parent new-node) - "Replace node at index POS in PARENT with NEW-NODE. -Only works for parents supported by `js2-node-child-list'." - (let ((kids (js2-node-child-list parent)) - (i 0)) - (while (< i pos) - (setq kids (cdr kids) - i (1+ i))) - (setcar kids new-node) - (js2-node-add-children parent new-node))) - -(defun js2-node-buffer (n) - "Return the buffer associated with AST N. -Returns nil if the buffer is not set as a property on the root -node, or if parent links were not recorded during parsing." - (let ((root (js2-node-root n))) - (and root - (js2-ast-root-p root) - (js2-ast-root-buffer root)))) - -(defsubst js2-block-node-push (n kid) - "Push js2-node KID onto the end of js2-block-node N's child list. -KID is always added to the -end- of the kids list. -Function also calls `js2-node-add-children' to add the parent link." - (let ((kids (js2-node-child-list n))) - (if kids - (setcdr kids (nconc (cdr kids) (list kid))) - (js2-node-set-child-list n (list kid))) - (js2-node-add-children n kid))) - -(defun js2-node-string (node) - (let ((buf (js2-node-buffer node)) - pos) - (unless buf - (error "No buffer available for node %s" node)) - (save-excursion - (set-buffer buf) - (buffer-substring-no-properties (setq pos (js2-node-abs-pos node)) - (+ pos (js2-node-len node)))))) - -;; Container for storing the node we're looking for in a traversal. -(defvar js2-discovered-node nil) -(make-variable-buffer-local 'js2-discovered-node) - -;; Keep track of absolute node position during traversals. -(defvar js2-visitor-offset nil) -(make-variable-buffer-local 'js2-visitor-offset) - -(defvar js2-node-search-point nil) -(make-variable-buffer-local 'js2-node-search-point) - -(when js2-mode-dev-mode-p - (defun js2-find-node-at-point () - (interactive) - (let ((node (js2-node-at-point))) - (message "%s" (or node "No node found at point")))) - (defun js2-node-name-at-point () - (interactive) - (let ((node (js2-node-at-point))) - (message "%s" (if node - (js2-node-short-name node) - "No node found at point."))))) - -(defun js2-node-at-point (&optional pos skip-comments) - "Return AST node at POS, a buffer position, defaulting to current point. -The `js2-mode-ast' variable must be set to the current parse tree. -Signals an error if the AST (`js2-mode-ast') is nil. -Always returns a node - if it can't find one, it returns the root. -If SKIP-COMMENTS is non-nil, comment nodes are ignored." - (let ((ast js2-mode-ast) - result) - (unless ast - (error "No JavaScript AST available")) - ;; Look through comments first, since they may be inside nodes that - ;; would otherwise report a match. - (setq pos (or pos (point)) - result (if (> pos (js2-node-abs-end ast)) - ast - (if (not skip-comments) - (js2-comment-at-point pos)))) - (unless result - (setq js2-discovered-node nil - js2-visitor-offset 0 - js2-node-search-point pos) - (unwind-protect - (catch 'js2-visit-done - (js2-visit-ast ast #'js2-node-at-point-visitor)) - (setq js2-visitor-offset nil - js2-node-search-point nil)) - (setq result js2-discovered-node)) - ;; may have found a comment beyond end of last child node, - ;; since visiting the ast-root looks at the comment-list last. - (if (and skip-comments - (js2-comment-node-p result)) - (setq result nil)) - (or result js2-mode-ast))) - -(defun js2-node-at-point-visitor (node end-p) - (let ((rel-pos (js2-node-pos node)) - abs-pos - abs-end - (point js2-node-search-point)) - (cond - (end-p - ;; this evaluates to a non-nil return value, even if it's zero - (decf js2-visitor-offset rel-pos)) - ;; we already looked for comments before visiting, and don't want them now - ((js2-comment-node-p node) - nil) - (t - (setq abs-pos (incf js2-visitor-offset rel-pos) - ;; we only want to use the node if the point is before - ;; the last character position in the node, so we decrement - ;; the absolute end by 1. - abs-end (+ abs-pos (js2-node-len node) -1)) - (cond - ;; If this node starts after search-point, stop the search. - ((> abs-pos point) - (throw 'js2-visit-done nil)) - ;; If this node ends before the search-point, don't check kids. - ((> point abs-end) - nil) - (t - ;; Otherwise point is within this node, possibly in a child. - (setq js2-discovered-node node) - t)))))) ; keep processing kids to look for more specific match - -(defsubst js2-block-comment-p (node) - "Return non-nil if NODE is a comment node of format `jsdoc' or `block'." - (and (js2-comment-node-p node) - (memq (js2-comment-node-format node) '(jsdoc block)))) - -;; TODO: put the comments in a vector and binary-search them instead -(defun js2-comment-at-point (&optional pos) - "Look through scanned comment nodes for one containing POS. -POS is a buffer position that defaults to current point. -Function returns nil if POS was not in any comment node." - (let ((ast js2-mode-ast) - (x (or pos (point))) - beg - end) - (unless ast - (error "No JavaScript AST available")) - (catch 'done - ;; Comments are stored in lexical order. - (dolist (comment (js2-ast-root-comments ast) nil) - (setq beg (js2-node-abs-pos comment) - end (+ beg (js2-node-len comment))) - (if (and (>= x beg) - (<= x end)) - (throw 'done comment)))))) - -(defun js2-mode-find-parent-fn (node) - "Find function enclosing NODE. -Returns nil if NODE is not inside a function." - (setq node (js2-node-parent node)) - (while (and node (not (js2-function-node-p node))) - (setq node (js2-node-parent node))) - (and (js2-function-node-p node) node)) - -(defun js2-mode-find-enclosing-fn (node) - "Find function or root enclosing NODE." - (if (js2-ast-root-p node) - node - (setq node (js2-node-parent node)) - (while (not (or (js2-ast-root-p node) - (js2-function-node-p node))) - (setq node (js2-node-parent node))) - node)) - -(defun js2-mode-find-enclosing-node (beg end) - "Find script or function fully enclosing BEG and END." - (let ((node (js2-node-at-point beg)) - pos - (continue t)) - (while continue - (if (or (js2-ast-root-p node) - (and (js2-function-node-p node) - (<= (setq pos (js2-node-abs-pos node)) beg) - (>= (+ pos (js2-node-len node)) end))) - (setq continue nil) - (setq node (js2-node-parent node)))) - node)) - -(defun js2-node-parent-script-or-fn (node) - "Find script or function immediately enclosing NODE. -If NODE is the ast-root, returns nil." - (if (js2-ast-root-p node) - nil - (setq node (js2-node-parent node)) - (while (and node (not (or (js2-function-node-p node) - (js2-script-node-p node)))) - (setq node (js2-node-parent node))) - node)) - -(defsubst js2-nested-function-p (node) - "Return t if NODE is a nested function, or is inside a nested function." - (js2-function-node-p (if (js2-function-node-p node) - (js2-node-parent-script-or-fn node) - (js2-node-parent-script-or-fn - (js2-node-parent-script-or-fn node))))) - -(defsubst js2-mode-shift-kids (kids start offset) - (dolist (kid kids) - (if (> (js2-node-pos kid) start) - (incf (js2-node-pos kid) offset)))) - -(defsubst js2-mode-shift-children (parent start offset) - "Update start-positions of all children of PARENT beyond START." - (let ((root (js2-node-root parent))) - (js2-mode-shift-kids (js2-node-child-list parent) start offset) - (js2-mode-shift-kids (js2-ast-root-comments root) start offset))) - -(defsubst js2-node-is-descendant (node ancestor) - "Return t if NODE is a descendant of ANCESTOR." - (while (and node - (neq node ancestor)) - (setq node (js2-node-parent node))) - node) - -;;; visitor infrastructure - -(defun js2-visit-none (node callback) - "Visitor for AST node that have no node children." - nil) - -(defun js2-print-none (node indent) - "Visitor for AST node with no printed representation.") - -(defun js2-print-body (node indent) - "Print a statement, or a block without braces." - (if (js2-block-node-p node) - (dolist (kid (js2-block-node-kids node)) - (js2-print-ast kid indent)) - (js2-print-ast node indent))) - -(defun js2-print-list (args &optional delimiter) - (loop with len = (length args) - for arg in args - for count from 1 - do - (js2-print-ast arg 0) - (if (< count len) - (insert (or delimiter ", "))))) - -(defun js2-print-tree (ast) - "Prints an AST to the current buffer. -Makes `js2-ast-parent-nodes' available to the printer functions." - (let ((max-lisp-eval-depth (max max-lisp-eval-depth 1500))) - (js2-print-ast ast))) - -(defun js2-print-ast (node &optional indent) - "Helper function for printing AST nodes. -Requires `js2-ast-parent-nodes' to be non-nil. -You should use `js2-print-tree' instead of this function." - (let ((printer (get (aref node 0) 'js2-printer)) - (i (or indent 0)) - (pos (js2-node-abs-pos node))) - ;; TODO: wedge comments in here somewhere - (if printer - (funcall printer node i)))) - -(defconst js2-side-effecting-tokens - (let ((tokens (make-bool-vector js2-num-tokens nil))) - (dolist (tt (list js2-ASSIGN - js2-ASSIGN_ADD - js2-ASSIGN_BITAND - js2-ASSIGN_BITOR - js2-ASSIGN_BITXOR - js2-ASSIGN_DIV - js2-ASSIGN_LSH - js2-ASSIGN_MOD - js2-ASSIGN_MUL - js2-ASSIGN_RSH - js2-ASSIGN_SUB - js2-ASSIGN_URSH - js2-BLOCK - js2-BREAK - js2-CALL - js2-CATCH - js2-CATCH_SCOPE - js2-CONST - js2-CONTINUE - js2-DEBUGGER - js2-DEC - js2-DELPROP - js2-DEL_REF - js2-DO - js2-ELSE - js2-EMPTY - js2-ENTERWITH - js2-EXPORT - js2-EXPR_RESULT - js2-FINALLY - js2-FOR - js2-FUNCTION - js2-GOTO - js2-IF - js2-IFEQ - js2-IFNE - js2-IMPORT - js2-INC - js2-JSR - js2-LABEL - js2-LEAVEWITH - js2-LET - js2-LETEXPR - js2-LOCAL_BLOCK - js2-LOOP - js2-NEW - js2-REF_CALL - js2-RETHROW - js2-RETURN - js2-RETURN_RESULT - js2-SEMI - js2-SETELEM - js2-SETELEM_OP - js2-SETNAME - js2-SETPROP - js2-SETPROP_OP - js2-SETVAR - js2-SET_REF - js2-SET_REF_OP - js2-SWITCH - js2-TARGET - js2-THROW - js2-TRY - js2-VAR - js2-WHILE - js2-WITH - js2-WITHEXPR - js2-YIELD)) - (aset tokens tt t)) - (if js2-instanceof-has-side-effects - (aset tokens js2-INSTANCEOF t)) - tokens)) - -(defun js2-node-has-side-effects (node) - "Return t if NODE has side effects." - (when node ; makes it easier to handle malformed expressions - (let ((tt (js2-node-type node))) - (cond - ;; This doubtless needs some work, since EXPR_VOID is used - ;; in several ways in Rhino, and I may not have caught them all. - ;; I'll wait for people to notice incorrect warnings. - ((and (= tt js2-EXPR_VOID) - (js2-expr-stmt-node-p node)) ; but not if EXPR_RESULT - (js2-node-has-side-effects (js2-expr-stmt-node-expr node))) - - ((= tt js2-COMMA) - (js2-node-has-side-effects (js2-infix-node-right node))) - - ((or (= tt js2-AND) - (= tt js2-OR)) - (or (js2-node-has-side-effects (js2-infix-node-right node)) - (js2-node-has-side-effects (js2-infix-node-left node)))) - - ((= tt js2-HOOK) - (and (js2-node-has-side-effects (js2-cond-node-true-expr node)) - (js2-node-has-side-effects (js2-cond-node-false-expr node)))) - - ((js2-paren-node-p node) - (js2-node-has-side-effects (js2-paren-node-expr node))) - - ((= tt js2-ERROR) ; avoid cascaded error messages - nil) - (t - (aref js2-side-effecting-tokens tt)))))) - -(defun js2-member-expr-leftmost-name (node) - "For an expr such as foo.bar.baz, return leftmost node foo. -NODE is any `js2-node' object. If it represents a member expression, -which is any sequence of property gets, element-gets, function calls, -or xml descendants/filter operators, then we look at the lexically -leftmost (first) node in the chain. If it is a name-node we return it. -Note that NODE can be a raw name-node and it will be returned as well. -If NODE is not a name-node or member expression, or if it is a member -expression whose leftmost target is not a name node, returns nil." - (let ((continue t) - result) - (while (and continue (not result)) - (cond - ((js2-name-node-p node) - (setq result node)) - ((js2-prop-get-node-p node) - (setq node (js2-prop-get-node-left node))) - ;; TODO: handle call-nodes, xml-nodes, others? - (t - (setq continue nil)))) - result)) - -(defconst js2-stmt-node-types - (list js2-BLOCK - js2-BREAK - js2-CONTINUE - js2-DEFAULT ; e4x "default xml namespace" statement - js2-DO - js2-EXPR_RESULT - js2-EXPR_VOID - js2-FOR - js2-IF - js2-RETURN - js2-SWITCH - js2-THROW - js2-TRY - js2-WHILE - js2-WITH) - "Node types that only appear in statement contexts. -The list does not include nodes that always appear as the child -of another specific statement type, such as switch-cases, -catch and finally blocks, and else-clauses. The list also excludes -nodes like yield, let and var, which may appear in either expression -or statement context, and in the latter context always have a -`js2-expr-stmt-node' parent. Finally, the list does not include -functions or scripts, which are treated separately from statements -by the JavaScript parser and runtime.") - -(defun js2-stmt-node-p (node) - "Heuristic for figuring out if NODE is a statement. -Some node types can appear in either an expression context or a -statement context, e.g. let-nodes, yield-nodes, and var-decl nodes. -For these node types in a statement context, the parent will be a -`js2-expr-stmt-node'. -Functions aren't included in the check." - (memq (js2-node-type node) js2-stmt-node-types)) - -(defsubst js2-mode-find-first-stmt (node) - "Search upward starting from NODE looking for a statement. -For purposes of this function, a `js2-function-node' counts." - (while (not (or (js2-stmt-node-p node) - (js2-function-node-p node))) - (setq node (js2-node-parent node))) - node) - -(defun js2-node-parent-stmt (node) - "Return the node's first ancestor that is a statement. -Returns nil if NODE is a `js2-ast-root'. Note that any expression -appearing in a statement context will have a parent that is a -`js2-expr-stmt-node' that will be returned by this function." - (let ((parent (js2-node-parent node))) - (if (or (null parent) - (js2-stmt-node-p parent) - (and (js2-function-node-p parent) - (neq (js2-function-node-form parent) 'FUNCTION_EXPRESSION))) - parent - (js2-node-parent-stmt parent)))) - -;; Roshan James writes: -;; Does consistent-return analysis on the function body when strict mode is -;; enabled. -;; -;; function (x) { return (x+1) } -;; -;; is ok, but -;; -;; function (x) { if (x < 0) return (x+1); } -;; -;; is not because the function can potentially return a value when the -;; condition is satisfied and if not, the function does not explicitly -;; return a value. -;; -;; This extends to checking mismatches such as "return" and "return <value>" -;; used in the same function. Warnings are not emitted if inconsistent -;; returns exist in code that can be statically shown to be unreachable. -;; Ex. -;; function (x) { while (true) { ... if (..) { return value } ... } } -;; -;; emits no warning. However if the loop had a break statement, then a -;; warning would be emitted. -;; -;; The consistency analysis looks at control structures such as loops, ifs, -;; switch, try-catch-finally blocks, examines the reachable code paths and -;; warns the user about an inconsistent set of termination possibilities. -;; -;; These flags enumerate the possible ways a statement/function can -;; terminate. These flags are used by endCheck() and by the Parser to -;; detect inconsistent return usage. -;; -;; END_UNREACHED is reserved for code paths that are assumed to always be -;; able to execute (example: throw, continue) -;; -;; END_DROPS_OFF indicates if the statement can transfer control to the -;; next one. Statement such as return dont. A compound statement may have -;; some branch that drops off control to the next statement. -;; -;; END_RETURNS indicates that the statement can return with no value. -;; END_RETURNS_VALUE indicates that the statement can return a value. -;; -;; A compound statement such as -;; if (condition) { -;; return value; -;; } -;; Will be detected as (END_DROPS_OFF | END_RETURN_VALUE) by endCheck() - -(defconst js2-END_UNREACHED 0) -(defconst js2-END_DROPS_OFF 1) -(defconst js2-END_RETURNS 2) -(defconst js2-END_RETURNS_VALUE 4) -(defconst js2-END_YIELDS 8) - -(defun js2-has-consistent-return-usage (node) - "Check that every return usage in a function body is consistent. -Returns t if the function satisfies strict mode requirement." - (let ((n (js2-end-check node))) - ;; either it doesn't return a value in any branch... - (or (js2-flag-not-set-p n js2-END_RETURNS_VALUE) - ;; or it returns a value (or is unreached) at every branch - (js2-flag-not-set-p n (logior js2-END_DROPS_OFF - js2-END_RETURNS - js2-END_YIELDS))))) - -(defun js2-end-check-if (node) - "Returns in the then and else blocks must be consistent with each other. -If there is no else block, then the return statement can fall through. -Returns logical OR of END_* flags" - (let ((th (js2-if-node-then-part node)) - (el (js2-if-node-else-part node))) - (if (null th) - js2-END_UNREACHED - (logior (js2-end-check th) (if el - (js2-end-check el) - js2-END_DROPS_OFF))))) - -(defun js2-end-check-switch (node) - "Consistency of return statements is checked between the case statements. -If there is no default, then the switch can fall through. If there is a -default, we check to see if all code paths in the default return or if -there is a code path that can fall through. -Returns logical OR of END_* flags." - (let ((rv js2-END_UNREACHED) - default-case) - ;; examine the cases - (catch 'break - (dolist (c (js2-switch-node-cases node)) - (if (js2-case-node-expr c) - (js2-set-flag rv (js2-end-check-block c)) - (setq default-case c) - (throw 'break nil)))) - - ;; we don't care how the cases drop into each other - (js2-clear-flag rv js2-END_DROPS_OFF) - - ;; examine the default - (js2-set-flag rv (if default-case - (js2-end-check default-case) - js2-END_DROPS_OFF)) - rv)) - -(defun js2-end-check-try (node) - "If the block has a finally, return consistency is checked in the -finally block. If all code paths in the finally return, then the -returns in the try-catch blocks don't matter. If there is a code path -that does not return or if there is no finally block, the returns -of the try and catch blocks are checked for mismatch. -Returns logical OR of END_* flags." - (let ((finally (js2-try-node-finally-block node)) - rv) - ;; check the finally if it exists - (setq rv (if finally - (js2-end-check (js2-finally-node-body finally)) - js2-END_DROPS_OFF)) - - ;; If the finally block always returns, then none of the returns - ;; in the try or catch blocks matter. - (when (js2-flag-set-p rv js2-END_DROPS_OFF) - (js2-clear-flag rv js2-END_DROPS_OFF) - - ;; examine the try block - (js2-set-flag rv (js2-end-check (js2-try-node-try-block node))) - - ;; check each catch block - (dolist (cb (js2-try-node-catch-clauses node)) - (js2-set-flag rv (js2-end-check (js2-catch-node-block cb))))) - rv)) - -(defun js2-end-check-loop (node) - "Return statement in the loop body must be consistent. The default -assumption for any kind of a loop is that it will eventually terminate. -The only exception is a loop with a constant true condition. Code that -follows such a loop is examined only if one can statically determine -that there is a break out of the loop. - - for(... ; ... ; ...) {} - for(... in ... ) {} - while(...) { } - do { } while(...) - -Returns logical OR of END_* flags." - (let ((rv (js2-end-check (js2-loop-node-body node))) - (condition (cond - ((js2-while-node-p node) - (js2-while-node-condition node)) - ((js2-do-node-p node) - (js2-do-node-condition node)) - ((js2-for-node-p node) - (js2-for-node-condition node))))) - - ;; check to see if the loop condition is always true - (if (and condition - (eq (js2-always-defined-boolean-p condition) 'ALWAYS_TRUE)) - (js2-clear-flag rv js2-END_DROPS_OFF)) - - ;; look for effect of breaks - (js2-set-flag rv (js2-node-get-prop node - 'CONTROL_BLOCK_PROP - js2-END_UNREACHED)) - rv)) - -(defun js2-end-check-block (node) - "A general block of code is examined statement by statement. -If any statement (even a compound one) returns in all branches, then -subsequent statements are not examined. -Returns logical OR of END_* flags." - (let* ((rv js2-END_DROPS_OFF) - (kids (js2-block-node-kids node)) - (n (car kids))) - ;; Check each statment. If the statement can continue onto the next - ;; one (i.e. END_DROPS_OFF is set), then check the next statement. - (while (and n (js2-flag-set-p rv js2-END_DROPS_OFF)) - (js2-clear-flag rv js2-END_DROPS_OFF) - (js2-set-flag rv (js2-end-check n)) - (setq kids (cdr kids) - n (car kids))) - rv)) - -(defun js2-end-check-label (node) - "A labeled statement implies that there may be a break to the label. -The function processes the labeled statement and then checks the -CONTROL_BLOCK_PROP property to see if there is ever a break to the -particular label. -Returns logical OR of END_* flags." - (let ((rv (js2-end-check (js2-labeled-stmt-node-stmt node)))) - (logior rv (js2-node-get-prop node - 'CONTROL_BLOCK_PROP - js2-END_UNREACHED)))) - -(defun js2-end-check-break (node) - "When a break is encountered annotate the statement being broken -out of by setting its CONTROL_BLOCK_PROP property. -Returns logical OR of END_* flags." - (and (js2-break-node-target node) - (js2-node-set-prop (js2-break-node-target node) - 'CONTROL_BLOCK_PROP - js2-END_DROPS_OFF)) - js2-END_UNREACHED) - -(defun js2-end-check (node) - "Examine the body of a function, doing a basic reachability analysis. -Returns a combination of flags END_* flags that indicate -how the function execution can terminate. These constitute only the -pessimistic set of termination conditions. It is possible that at -runtime certain code paths will never be actually taken. Hence this -analysis will flag errors in cases where there may not be errors. -Returns logical OR of END_* flags" - (let (kid) - (cond - ((js2-break-node-p node) - (js2-end-check-break node)) - - ((js2-expr-stmt-node-p node) - (if (setq kid (js2-expr-stmt-node-expr node)) - (js2-end-check kid) - js2-END_DROPS_OFF)) - - ((or (js2-continue-node-p node) - (js2-throw-node-p node)) - js2-END_UNREACHED) - - ((js2-return-node-p node) - (if (setq kid (js2-return-node-retval node)) - js2-END_RETURNS_VALUE - js2-END_RETURNS)) - - ((js2-loop-node-p node) - (js2-end-check-loop node)) - - ((js2-switch-node-p node) - (js2-end-check-switch node)) - - ((js2-labeled-stmt-node-p node) - (js2-end-check-label node)) - - ((js2-if-node-p node) - (js2-end-check-if node)) - - ((js2-try-node-p node) - (js2-end-check-try node)) - - ((js2-block-node-p node) - (if (null (js2-block-node-kids node)) - js2-END_DROPS_OFF - (js2-end-check-block node))) - - ((js2-yield-node-p node) - js2-END_YIELDS) - - (t - js2-END_DROPS_OFF)))) - -(defun js2-always-defined-boolean-p (node) - "Check if NODE always evaluates to true or false in boolean context. -Returns 'ALWAYS_TRUE, 'ALWAYS_FALSE, or nil if it's neither always true -nor always false." - (let ((tt (js2-node-type node)) - num) - (cond - ((or (= tt js2-FALSE) (= tt js2-NULL)) - 'ALWAYS_FALSE) - ((= tt js2-TRUE) - 'ALWAYS_TRUE) - ((= tt js2-NUMBER) - (setq num (js2-number-node-num-value node)) - (if (and (not (eq num 0.0e+NaN)) - (not (zerop num))) - 'ALWAYS_TRUE - 'ALWAYS_FALSE)) - (t - nil)))) - -(provide 'js2-ast) - -;;; js2-ast.el ends here -;;; js2-highlight.el --- JavaScript syntax coloring support - -;; Author: Steve Yegge (steve.yegge@gmail.com) -;; Keywords: javascript languages - -;;; Code: - - -(defsubst js2-set-face (beg end face &optional record) - "Fontify a region. If RECORD is non-nil, record for later." - (when (plusp js2-highlight-level) - (setq beg (min (point-max) beg) - beg (max (point-min) beg) - end (min (point-max) end) - end (max (point-min) end)) - (if record - (push (list beg end face) js2-mode-fontifications) - (put-text-property beg end 'face face)))) - -(defsubst js2-set-kid-face (pos kid len face) - "Set-face on a child node. -POS is absolute buffer position of parent. -KID is the child node. -LEN is the length to fontify. -FACE is the face to fontify with." - (js2-set-face (+ pos (js2-node-pos kid)) - (+ pos (js2-node-pos kid) (js2-node-len kid)) - face)) - -(defsubst js2-fontify-kwd (start length) - (js2-set-face start (+ start length) 'font-lock-keyword-face)) - -(defsubst js2-clear-face (beg end) - (remove-text-properties beg end '(face nil - help-echo nil - point-entered nil - c-in-sws nil))) - -(defsubst js2-record-text-property (beg end prop value) - "Record a text property to set when parsing finishes." - (push (list beg end prop value) js2-mode-deferred-properties)) - -(defconst js2-ecma-global-props - (concat "^" - (regexp-opt - '("Infinity" "NaN" "undefined" "arguments") t) - "$") - "Value properties of the Ecma-262 Global Object. -Shown at or above `js2-highlight-level' 2.") - -;; might want to add the name "arguments" to this list? -(defconst js2-ecma-object-props - (concat "^" - (regexp-opt - '("prototype" "__proto__" "__parent__") t) - "$") - "Value properties of the Ecma-262 Object constructor. -Shown at or above `js2-highlight-level' 2.") - -(defconst js2-ecma-global-funcs - (concat - "^" - (regexp-opt - '("decodeURI" "decodeURIComponent" "encodeURI" "encodeURIComponent" - "eval" "isFinite" "isNaN" "parseFloat" "parseInt") t) - "$") - "Function properties of the Ecma-262 Global object. -Shown at or above `js2-highlight-level' 2.") - -(defconst js2-ecma-number-props - (concat "^" - (regexp-opt '("MAX_VALUE" "MIN_VALUE" "NaN" - "NEGATIVE_INFINITY" - "POSITIVE_INFINITY") t) - "$") - "Properties of the Ecma-262 Number constructor. -Shown at or above `js2-highlight-level' 2.") - -(defconst js2-ecma-date-props "^\\(parse\\|UTC\\)$" - "Properties of the Ecma-262 Date constructor. -Shown at or above `js2-highlight-level' 2.") - - -(defconst js2-ecma-math-props - (concat "^" - (regexp-opt - '("E" "LN10" "LN2" "LOG2E" "LOG10E" "PI" "SQRT1_2" "SQRT2") - t) - "$") - "Properties of the Ecma-262 Math object. -Shown at or above `js2-highlight-level' 2.") - - -(defconst js2-ecma-math-funcs - (concat "^" - (regexp-opt - '("abs" "acos" "asin" "atan" "atan2" "ceil" "cos" "exp" "floor" - "log" "max" "min" "pow" "random" "round" "sin" "sqrt" "tan") t) - "$") - "Function properties of the Ecma-262 Math object. -Shown at or above `js2-highlight-level' 2.") - -(defconst js2-ecma-function-props - (concat - "^" - (regexp-opt - '(;; properties of the Object prototype object - "hasOwnProperty" "isPrototypeOf" "propertyIsEnumerable" - "toLocaleString" "toString" "valueOf" - ;; properties of the Function prototype object - "apply" "call" - ;; properties of the Array prototype object - "concat" "join" "pop" "push" "reverse" "shift" "slice" "sort" - "splice" "unshift" - ;; properties of the String prototype object - "charAt" "charCodeAt" "fromCharCode" "indexOf" "lastIndexOf" - "localeCompare" "match" "replace" "search" "split" "substring" - "toLocaleLowerCase" "toLocaleUpperCase" "toLowerCase" - "toUpperCase" - ;; properties of the Number prototype object - "toExponential" "toFixed" "toPrecision" - ;; properties of the Date prototype object - "getDate" "getDay" "getFullYear" "getHours" "getMilliseconds" - "getMinutes" "getMonth" "getSeconds" "getTime" - "getTimezoneOffset" "getUTCDate" "getUTCDay" "getUTCFullYear" - "getUTCHours" "getUTCMilliseconds" "getUTCMinutes" "getUTCMonth" - "getUTCSeconds" "setDate" "setFullYear" "setHours" - "setMilliseconds" "setMinutes" "setMonth" "setSeconds" "setTime" - "setUTCDate" "setUTCFullYear" "setUTCHours" "setUTCMilliseconds" - "setUTCMinutes" "setUTCMonth" "setUTCSeconds" "toDateString" - "toLocaleDateString" "toLocaleString" "toLocaleTimeString" - "toTimeString" "toUTCString" - ;; properties of the RegExp prototype object - "exec" "test" - ;; SpiderMonkey/Rhino extensions, versions 1.5+ - "toSource" "__defineGetter__" "__defineSetter__" - "__lookupGetter__" "__lookupSetter__" "__noSuchMethod__" - "every" "filter" "forEach" "lastIndexOf" "map" "some") - t) - "$") - "Built-in functions defined by Ecma-262 and SpiderMonkey extensions. -Shown at or above `js2-highlight-level' 3.") - -(defsubst js2-parse-highlight-prop-get (parent target prop call-p) - (let ((target-name (and target - (js2-name-node-p target) - (js2-name-node-name target))) - (prop-name (if prop (js2-name-node-name prop))) - (level1 (>= js2-highlight-level 1)) - (level2 (>= js2-highlight-level 2)) - (level3 (>= js2-highlight-level 3)) - pos - face) - (when level2 - (if call-p - (cond - ((and target prop) - (cond - ((and level3 (string-match js2-ecma-function-props prop-name)) - (setq face 'font-lock-builtin-face)) - ((and target-name prop) - (cond - ((string= target-name "Date") - (if (string-match js2-ecma-date-props prop-name) - (setq face 'font-lock-builtin-face))) - ((string= target-name "Math") - (if (string-match js2-ecma-math-funcs prop-name) - (setq face 'font-lock-builtin-face))))))) - (prop - (if (string-match js2-ecma-global-funcs prop-name) - (setq face 'font-lock-builtin-face)))) - (cond - ((and target prop) - (cond - ((string= target-name "Number") - (if (string-match js2-ecma-number-props prop-name) - (setq face 'font-lock-constant-face))) - ((string= target-name "Math") - (if (string-match js2-ecma-math-props prop-name) - (setq face 'font-lock-constant-face))))) - (prop - (if (string-match js2-ecma-object-props prop-name) - (setq face 'font-lock-constant-face))))) - (when face - (js2-set-face (setq pos (+ (js2-node-pos parent) ; absolute - (js2-node-pos prop))) ; relative - (+ pos (js2-node-len prop)) - face))))) - -(defun js2-parse-highlight-member-expr-node (node) - "Perform syntax highlighting of EcmaScript built-in properties. -The variable `js2-highlight-level' governs this highighting." - (let (face target prop name pos end parent call-p callee) - (cond - ;; case 1: simple name, e.g. foo - ((js2-name-node-p node) - (setq name (js2-name-node-name node)) - ;; possible for name to be nil in rare cases - saw it when - ;; running js2-mode on an elisp buffer. Might as well try to - ;; make it so js2-mode never barfs. - (when name - (setq face (if (string-match js2-ecma-global-props name) - 'font-lock-constant-face)) - (when face - (setq pos (js2-node-pos node) - end (+ pos (js2-node-len node))) - (js2-set-face pos end face)))) - - ;; case 2: property access or function call - ((or (js2-prop-get-node-p node) - ;; highlight function call if expr is a prop-get node - ;; or a plain name (i.e. unqualified function call) - (and (setq call-p (js2-call-node-p node)) - (setq callee (js2-call-node-target node)) ; separate setq! - (or (js2-prop-get-node-p callee) - (js2-name-node-p callee)))) - (setq parent node - node (if call-p callee node)) - (if (and call-p (js2-name-node-p callee)) - (setq prop callee) - (setq target (js2-prop-get-node-left node) - prop (js2-prop-get-node-right node))) - (cond - ((js2-name-node-p target) - (if (js2-name-node-p prop) - ;; case 2a: simple target, simple prop name, e.g. foo.bar - (js2-parse-highlight-prop-get parent target prop call-p) - ;; case 2b: simple target, complex name, e.g. foo.x[y] - (js2-parse-highlight-prop-get parent target nil call-p))) - ((js2-name-node-p prop) - ;; case 2c: complex target, simple name, e.g. x[y].bar - (js2-parse-highlight-prop-get parent target prop call-p))))))) - -(defun js2-parse-highlight-member-expr-fn-name (expr) - "Highlight the `baz' in function foo.bar.baz(args) {...}. -This is experimental Rhino syntax. EXPR is the foo.bar.baz member expr. -We currently only handle the case where the last component is a prop-get -of a simple name. Called before EXPR has a parent node." - (let (pos - (name (and (js2-prop-get-node-p expr) - (js2-prop-get-node-right expr)))) - (when (js2-name-node-p name) - (js2-set-face (setq pos (+ (js2-node-pos expr) ; parent is absolute - (js2-node-pos name))) - (+ pos (js2-node-len name)) - 'font-lock-function-name-face - 'record)))) - -;; source: http://jsdoc.sourceforge.net/ -;; Note - this syntax is for Google's enhanced jsdoc parser that -;; allows type specifications, and needs work before entering the wild. - -(defconst js2-jsdoc-param-tag-regexp - (concat "^\\s-*\\*+\\s-*\\(@" - "\\(?:param\\|argument\\)" - "\\)" - "\\s-*\\({[^}]+}\\)?" ; optional type - "\\s-*\\([a-zA-Z0-9_$]+\\)?" ; name - "\\>") - "Matches jsdoc tags with optional type and optional param name.") - -(defconst js2-jsdoc-typed-tag-regexp - (concat "^\\s-*\\*+\\s-*\\(@\\(?:" - (regexp-opt - '("requires" "return" "returns" "throw" "throws")) - "\\)\\)\\s-*\\({[^}]+}\\)?") - "Matches jsdoc tags with optional type.") - -(defconst js2-jsdoc-arg-tag-regexp - (concat "^\\s-*\\*+\\s-*\\(@\\(?:" - (regexp-opt - '("base" "extends" "member" "type" "version")) - "\\)\\)\\s-+\\([^ \t]+\\)") - "Matches jsdoc tags with a single argument.") - -(defconst js2-jsdoc-empty-tag-regexp - (concat "^\\s-*\\*+\\s-*\\(@\\(?:" - (regexp-opt - '("addon" "author" "class" "constructor" "deprecated" "exec" - "exception" "fileoverview" "final" "ignore" "private")) - "\\)\\)\\s-*") - "Matches empty jsdoc tags.") - -(defconst js2-jsdoc-link-tag-regexp - "{\\(@link\\)\\s-+\\([^#}\n]+\\)\\(#.+\\)?}" - "Matches a jsdoc link tag.") - -(defconst js2-jsdoc-see-tag-regexp - "^\\s-*\\*+\\s-*\\(@see\\)\\s-+\\([^#}\n]+\\)\\(#.+\\)?" - "Matches a jsdoc @see tag.") - -(defconst js2-jsdoc-html-tag-regexp - "\\(</?\\)\\([a-zA-Z]+\\)\\s-*\\(/?>\\)" - "Matches a simple (no attributes) html start- or end-tag.") - -(defsubst js2-jsdoc-highlight-helper () - (js2-set-face (match-beginning 1) - (match-end 1) - 'js2-jsdoc-tag-face) - (if (match-beginning 2) - (if (save-excursion - (goto-char (match-beginning 2)) - (= (char-after) ?{)) - (js2-set-face (1+ (match-beginning 2)) - (1- (match-end 2)) - 'js2-jsdoc-type-face) - (js2-set-face (match-beginning 2) - (match-end 2) - 'js2-jsdoc-value-face))) - (if (match-beginning 3) - (js2-set-face (match-beginning 3) - (match-end 3) - 'js2-jsdoc-value-face))) - -(defun js2-highlight-jsdoc (ast) - "Highlight doc comment tags." - (let ((comments (js2-ast-root-comments ast)) - beg end) - (save-excursion - (dolist (node comments) - (when (eq (js2-comment-node-format node) 'jsdoc) - (setq beg (js2-node-abs-pos node) - end (+ beg (js2-node-len node))) - (save-restriction - (narrow-to-region beg end) - (dolist (re (list js2-jsdoc-param-tag-regexp - js2-jsdoc-typed-tag-regexp - js2-jsdoc-arg-tag-regexp - js2-jsdoc-link-tag-regexp - js2-jsdoc-see-tag-regexp - js2-jsdoc-empty-tag-regexp)) - (goto-char beg) - (while (re-search-forward re nil t) - (js2-jsdoc-highlight-helper))) - ;; simple highlighting for html tags - (goto-char beg) - (while (re-search-forward js2-jsdoc-html-tag-regexp nil t) - (js2-set-face (match-beginning 1) - (match-end 1) - 'js2-jsdoc-html-tag-delimiter-face) - (js2-set-face (match-beginning 2) - (match-end 2) - 'js2-jsdoc-html-tag-name-face) - (js2-set-face (match-beginning 3) - (match-end 3) - 'js2-jsdoc-html-tag-delimiter-face)))))))) - -(defun js2-highlight-assign-targets (node left right) - "Highlight function properties and external variables." - (let (leftpos end name) - ;; highlight vars and props assigned function values - (when (js2-function-node-p right) - (cond - ;; var foo = function() {...} - ((js2-name-node-p left) - (setq name left)) - - ;; foo.bar.baz = function() {...} - ((and (js2-prop-get-node-p left) - (js2-name-node-p (js2-prop-get-node-right left))) - (setq name (js2-prop-get-node-right left)))) - - (when name - (js2-set-face (setq leftpos (js2-node-abs-pos name)) - (+ leftpos (js2-node-len name)) - 'font-lock-function-name-face - 'record))) - - ;; save variable assignments so we can check for undeclared later - ;; (can't do it here since var decls can come at end of script) - (when (and js2-highlight-external-variables - (setq name (js2-member-expr-leftmost-name left))) - (push (list name js2-current-scope - (setq leftpos (js2-node-abs-pos name)) - (setq end (+ leftpos (js2-node-len name)))) - js2-recorded-assignments)))) - -(defun js2-highlight-undeclared-vars () - "After entire parse is finished, look for undeclared variable assignments. -Have to wait until entire buffer is parsed, since JavaScript permits var -decls to occur after they're used. - -We currently use a simple heuristic to rule out complaining about built-ins: -if the name is capitalized we don't highlight it. This could be improved a -bit by declaring all the Ecma global object, constructor and function names -in a hashtable, but we'd still wind up complaining about all the DHTML -builtins, the Mozilla builtins, etc." - (let (name first-char) - (dolist (entry js2-recorded-assignments) - (destructuring-bind (name-node scope pos end) entry - (setq name (js2-name-node-name name-node) - first-char (aref name 0)) - (unless (or (and (>= first-char ?A) (<= first-char ?Z)) - (js2-get-defining-scope scope name)) - (js2-set-face pos end 'js2-external-variable-face 'record) - (js2-record-text-property pos end 'help-echo "Undeclared variable") - (js2-record-text-property pos end 'point-entered #'js2-echo-help)))) - (setq js2-recorded-assignments nil))) - -(provide 'js2-highlight) - -;;; js2-highlight.el ends here -;;; js2-browse.el --- browsing/hierarchy support for js2-mode - -;; Author: Steve Yegge (steve.yegge@gmail.com) -;; Keywords: javascript languages - -;; Commentary: -;; -;; We currently only support imenu, but eventually should support speedbar and -;; possibly other browsing mechanisms. -;; -;; The basic strategy is to identify function assignment targets of the form -;; `foo.bar.baz', convert them to (list foo bar baz <position>), and push the -;; list into `js2-imenu-recorder'. The lists are merged into a trie-like tree -;; for imenu after parsing is finished. -;; -;; A `foo.bar.baz' assignment target may be expressed in many ways in -;; JavaScript, and the general problem is undecidable. However, several forms -;; are readily recognizable at parse-time; the forms we attempt to recognize -;; include: -;; -;; function foo() -- function declaration -;; foo = function() -- function expression assigned to variable -;; foo.bar.baz = function() -- function expr assigned to nested property-get -;; foo = {bar: function()} -- fun prop in object literal assigned to var -;; foo = {bar: {baz: function()}} -- inside nested object literal -;; foo.bar = {baz: function()}} -- obj lit assigned to nested prop get -;; a.b = {c: {d: function()}} -- nested obj lit assigned to nested prop get -;; foo = {get bar() {...}} -- getter/setter in obj literal -;; function foo() {function bar() {...}} -- nested function -;; foo['a'] = function() -- fun expr assigned to deterministic element-get -;; -;; This list boils down to a few forms that can be combined recursively. -;; Top-level named function declarations include both the left-hand (name) -;; and the right-hand (function value) expressions needed to produce an imenu -;; entry. The other "right-hand" forms we need to look for are: -;; - functions declared as props/getters/setters in object literals -;; - nested named function declarations -;; The "left-hand" expressions that functions can be assigned to include: -;; - local/global variables -;; - nested property-get expressions like a.b.c.d -;; - element gets like foo[10] or foo['bar'] where the index -;; expression can be trivially converted to a property name. They -;; effectively then become property gets. -;; -;; All the different definition types are canonicalized into the form -;; foo.bar.baz = position-of-function-keyword -;; -;; We need to build a trie-like structure for imenu. As an example, -;; consider the following JavaScript code: -;; -;; a = function() {...} // function at position 5 -;; b = function() {...} // function at position 25 -;; foo = function() {...} // function at position 100 -;; foo.bar = function() {...} // function at position 200 -;; foo.bar.baz = function() {...} // function at position 300 -;; foo.bar.zab = function() {...} // function at position 400 -;; -;; During parsing we accumulate an entry for each definition in -;; the variable `js2-imenu-recorder', like so: -;; -;; '((a 5) -;; (b 25) -;; (foo 100) -;; (foo bar 200) -;; (foo bar baz 300) -;; (foo bar zab 400)) -;; -;; After parsing these entries are merged into this alist-trie: -;; -;; '((a . 1) -;; (b . 2) -;; (foo (<definition> . 3) -;; (bar (<definition> . 6) -;; (baz . 100) -;; (zab . 200)))) -;; -;; Note the wacky need for a <definition> name. The token can be anything -;; that isn't a valid JavaScript identifier, because you might make foo -;; a function and then start setting properties on it that are also functions. - -;;; Code: - - -(defsubst js2-prop-node-name (node) - "Return the name of a node that may be a property-get/property-name. -If NODE is not a valid name-node, string-node or integral number-node, -returns nil. Otherwise returns the string name/value of the node." - (cond - ((js2-name-node-p node) - (js2-name-node-name node)) - ((js2-string-node-p node) - (js2-string-node-value node)) - ((and (js2-number-node-p node) - (string-match "^[0-9]+$" (js2-number-node-value node))) - (js2-number-node-value node)) - ((js2-this-node-p node) - "this"))) - -(defsubst js2-node-qname-component (node) - "Test function: return the name of this node, if it contributes to a qname. -Returns nil if the node doesn't contribute." - (copy-sequence - (or (js2-prop-node-name node) - (if (and (js2-function-node-p node) - (js2-function-node-name node)) - (js2-name-node-name (js2-function-node-name node)))))) - -(defsubst js2-record-function-qname (fn-node qname) - "Associate FN-NODE with its QNAME for later lookup. -This is used in postprocessing the chain list. When we find a chain -whose first element is a js2-THIS keyword node, we look up the parent -function and see (using this map) whether it is the tail of a chain. -If so, we replace the this-node with a copy of the parent's qname." - (unless js2-imenu-function-map - (setq js2-imenu-function-map (make-hash-table :test 'eq))) - (puthash fn-node qname js2-imenu-function-map)) - -(defun js2-record-imenu-functions (node &optional var) - "Record function definitions for imenu. -NODE is a function node or an object literal. -VAR, if non-nil, is the expression that NODE is being assigned to." - (when js2-parse-ide-mode - (let ((fun-p (js2-function-node-p node)) - qname left fname-node pos) - (cond - ;; non-anonymous function declaration? - ((and fun-p - (not var) - (setq fname-node (js2-function-node-name node))) - (push (setq qname (list fname-node (js2-node-pos node))) - js2-imenu-recorder) - (js2-record-function-qname node qname)) - - ;; for remaining forms, compute left-side tree branch first - ((and var (setq qname (js2-compute-nested-prop-get var))) - (cond - ;; foo.bar.baz = function - (fun-p - (push (nconc qname (list (js2-node-pos node))) - js2-imenu-recorder) - (js2-record-function-qname node qname)) - ;; foo.bar.baz = object-literal - ;; look for nested functions: {a: {b: function() {...} }} - ((js2-object-node-p node) - (js2-record-object-literal node qname)))))))) - -(defun js2-compute-nested-prop-get (node) - "If NODE is of form foo.bar.baz, return component nodes as a list. -Otherwise returns nil. Element-gets can be treated as property-gets -if the index expression is a name, a string, or a positive integer." - (let (left right head) - (cond - ((or (js2-name-node-p node) - (js2-this-node-p node)) - (list node)) - ;; foo.bar.baz is parenthesized as (foo.bar).baz => right operand is a leaf - ((js2-prop-get-node-p node) ; includes elem-get nodes - (setq left (js2-prop-get-node-left node) - right (js2-prop-get-node-right node)) - (if (and (or (js2-prop-get-node-p left) ; left == foo.bar - (js2-name-node-p left) - (js2-this-node-p left)) ; or left == foo - (or (js2-name-node-p right) ; .bar - (js2-string-node-p right) ; ['bar'] - (and (js2-number-node-p right) ; [10] - (string-match "^[0-9]+$" - (js2-number-node-value right))))) - (if (setq head (js2-compute-nested-prop-get left)) - (nconc head (list right)))))))) - -(defun js2-record-object-literal (node qname) - "Recursively process an object literal looking for functions. -NODE is an object literal that is the right-hand child of an assignment -expression. QNAME is a list of nodes representing the assignment target, -e.g. for foo.bar.baz = {...}, QNAME is (foo-node bar-node baz-node). -We do a depth-first traversal of NODE. Any functions we find are prefixed -with QNAME plus the property name of the function and appended to the -variable `js2-imenu-recorder'." - ;; Elements are relative to parent position, which is still absolute, - ;; since the parser passes the assignment target and value expressions - ;; to us before they are added as children of the assignment node. - (let ((pos (js2-node-pos node)) - left right) - (dolist (e (js2-object-node-elems node)) ; e is a `js2-object-prop-node' - (setq left (js2-infix-node-left e)) - (cond - ;; foo: function() {...} - ((js2-function-node-p (setq right (js2-infix-node-right e))) - (when (js2-prop-node-name left) - ;; As a policy decision, we record the position of the property, - ;; not the position of the `function' keyword, since the property - ;; is effectively the name of the function. - (push (append qname (list left) (list (+ pos (js2-node-pos e)))) - js2-imenu-recorder) - (js2-record-function-qname right qname))) - ;; foo: {object-literal} -- add foo to qname and recurse - ((js2-object-node-p right) - (js2-record-object-literal right - (append qname (list (js2-infix-node-left e))))))))) - -(defsubst js2-node-top-level-decl-p (node) - "Return t if NODE's name is defined in the top-level scope. -Also returns t if NODE's name is not defined in any scope, since it implies -that it's an external variable, which must also be in the top-level scope." - (let* ((name (js2-prop-node-name node)) - (this-scope (js2-node-get-enclosing-scope node)) - defining-scope) - (cond - ((js2-this-node-p node) - nil) - ((null this-scope) - t) - ((setq defining-scope (js2-get-defining-scope this-scope name)) - (js2-ast-root-p defining-scope)) - (t t)))) - -(defun js2-browse-postprocess-chains (chains) - "Modify function-declaration name chains after parsing finishes. -Some of the information is only available after the parse tree is complete. -For instance, following a 'this' reference requires a parent function node." - (let (result head fn parent-chain p elem) - (dolist (chain chains) - ;; examine the head of each node to get its defining scope - (setq head (car chain)) - (cond - ;; if top-level/external, keep as-is - ((js2-node-top-level-decl-p head) - (push chain result)) - ;; check for a this-reference - ((eq (js2-node-type head) js2-THIS) - (setq fn (js2-node-parent-script-or-fn head)) - ;; if there is no parent function, or if the parent function - ;; is nested, discard the head node and keep the rest of the chain. - (if (or (null fn) (js2-nested-function-p fn)) - (push (cdr chain) result) - ;; else look up parent in function-map. If not found, discard chain. - (when (setq parent-chain (and js2-imenu-function-map - (gethash fn js2-imenu-function-map))) - ;; else discard head node and prefix parent fn qname, which is - ;; the parent-chain sans tail, to this chain. - (push (append (butlast parent-chain) (cdr chain)) result)))))) - ;; finally replace each node in each chain with its name. - (dolist (chain result) - (setq p chain) - (while p - (if (js2-node-p (setq elem (car p))) - (setcar p (js2-node-qname-component elem))) - (setq p (cdr p)))) - result)) - -;; Merge name chains into a trie-like tree structure of nested lists. -;; To simplify construction of the trie, we first build it out using the rule -;; that the trie consists of lists of pairs. Each pair is a 2-element array: -;; [key, num-or-list]. The second element can be a number; if so, this key -;; is a leaf-node with only one value. (I.e. there is only one declaration -;; associated with the key at this level.) Otherwise the second element is -;; a list of pairs, with the rule applied recursively. This symmetry permits -;; a simple recursive formulation. -;; -;; js2-mode is building the data structure for imenu. The imenu documentation -;; claims that it's the structure above, but in practice it wants the children -;; at the same list level as the key for that level, which is how I've drawn -;; the "Expected final result" above. We'll postprocess the trie to remove the -;; list wrapper around the children at each level. -;; -;; A completed nested imenu-alist entry looks like this: -;; '(("foo" -;; ("<definition>" . 7) -;; ("bar" -;; ("a" . 40) -;; ("b" . 60)))) -;; -;; In particular, the documentation for `imenu--index-alist' says that -;; a nested sub-alist element looks like (INDEX-NAME SUB-ALIST). -;; The sub-alist entries immediately follow INDEX-NAME, the head of the list. - -(defsubst js2-treeify (lst) - "Convert (a b c d) to (a ((b ((c d)))))" - (if (null (cddr lst)) ; list length <= 2 - lst - (list (car lst) (list (js2-treeify (cdr lst)))))) - -(defun js2-build-alist-trie (chains trie) - "Merge declaration name chains into a trie-like alist structure for imenu. -CHAINS is the qname chain list produced during parsing. TRIE is a -list of elements built up so far." - (let (head tail pos branch kids) - (dolist (chain chains) - (setq head (car chain) - tail (cdr chain) - pos (if (numberp (car tail)) (car tail)) - branch (js2-find-if (lambda (n) - (string= (car n) head)) - trie) - kids (second branch)) - (cond - ;; case 1: this key isn't in the trie yet - ((null branch) - (if trie - (setcdr (last trie) (list (js2-treeify chain))) - (setq trie (list (js2-treeify chain))))) - - ;; case 2: key is present with a single number entry: replace w/ list - ;; ("a1" 10) + ("a1" 20) => ("a1" (("<definition>" 10) - ;; ("<definition>" 20))) - ((numberp kids) - (setcar (cdr branch) - (list (list "<definition-1>" kids) - (if pos - (list "<definition-2>" pos) - (js2-treeify tail))))) - - ;; case 3: key is there (with kids), and we're a number entry - (pos - (setcdr (last kids) - (list - (list (format "<definition-%d>" - (1+ (loop for kid in kids - count (eq ?< (aref (car kid) 0))))) - pos)))) - - ;; case 4: key is there with kids, need to merge in our chain - (t - (js2-build-alist-trie (list tail) kids)))) - trie)) - -(defun js2-flatten-trie (trie) - "Convert TRIE to imenu-format. -Recurses through nodes, and for each one whose second element is a list, -appends the list's flattened elements to the current element. Also -changes the tails into conses. For instance, this pre-flattened trie - -'(a ((b 20) - (c ((d 30) - (e 40))))) - -becomes - -'(a (b . 20) - (c (d . 30) - (e . 40))) - -Note that the root of the trie has no key, just a list of chains. -This is also true for the value of any key with multiple children, -e.g. key 'c' in the example above." - (cond - ((listp (car trie)) - (mapcar #'js2-flatten-trie trie)) - (t - (if (numberp (second trie)) - (cons (car trie) (second trie)) - ;; else pop list and append its kids - (apply #'append (list (car trie)) (js2-flatten-trie (cdr trie))))))) - -(defun js2-build-imenu-index () - "Turn `js2-imenu-recorder' into an imenu data structure." - (unless (eq js2-imenu-recorder 'empty) - (let* ((chains (js2-browse-postprocess-chains js2-imenu-recorder)) - (result (js2-build-alist-trie chains nil))) - (js2-flatten-trie result)))) - -(defun js2-test-print-chains (chains) - "Print a list of qname chains. -Each element of CHAINS is a list of the form (NODE [NODE *] pos); -i.e. one or more nodes, and an integer position as the list tail." - (mapconcat (lambda (chain) - (concat "(" - (mapconcat (lambda (elem) - (if (js2-node-p elem) - (or (js2-node-qname-component elem) - "nil") - (number-to-string elem))) - chain - " ") - ")")) - chains - "\n")) - - -(provide 'js2-browse) - -;;; js2-browse.el ends here -;;; js2-parse.el --- JavaScript parser - -;; Author: Steve Yegge (steve.yegge@gmail.com) -;; Keywords: javascript languages - -;; Commentary: - -;; This is based on Rhino's parser and tries to follow its code -;; structure as closely as practical, so that changes to the Rhino -;; parser can easily be propagated into this code. However, Rhino -;; does not currently generate a usable AST representation, at least -;; from an IDE perspective, so we build our own more suitable AST. - -;; The AST node structures are defined in `js2-ast.el'. -;; Every parser function that creates and returns an AST node has -;; the following responsibilities: - -;; 1) set the node start to the absolute buffer start position -;; 2) set the node length to include any closing chars (RC, SEMI) -;; 3) fix up any child-node starts to be relative to this node -;; 4) set any field positions (e.g. keywords) relative to this node -;; 5) report any child nodes with `js2-node-add-children' -;; (note that this call fixes up start positions by default) - -;; The resulting AST has all node start positions relative to the -;; parent nodes; only the root has an absolute start position. - -;; Note: fontification is done inline while parsing. It used to be -;; done in a second pass over the AST, but doing it inline is about -;; twice as fast. Most of the fontification happens when tokens are -;; scanned, and the parser has a few spots that perform extra -;; fontification. In addition to speed, a second benefit of inline -;; parsing is that if a long parse is interrupted, everything parsed -;; so far is still fontified. - -;; The editing mode that uses this parser, `js2-mode', directs the -;; parser to check periodically for user input. If user input -;; arrives, the parse is abandoned, except for the highlighting that -;; has occurred so far, and a re-parse is rescheduled for when Emacs -;; becomes idle again. This works pretty well, but could be better. -;; In particular, when the user input has not resulted in changes to -;; the buffer (for instance, navigation input), the parse tree built -;; so far should not be discarded, and the parse should continue where -;; it left off. It will be some work to create what amounts to a -;; continuation, but it should not be unreasonably difficult. - -;; TODO: -;; - make non-editing input restart parse at previous continuation -;; - in Eclipse, sibling nodes never overlap start/end ranges -;; - for getters, prop name and function nodes overlap -;; - should write a debug tree visitor to look for overlaps -;; - mark array and object literals as "destructuring" (node prop?) -;; so we can syntax-highlight them properly. -;; - figure out a way not to store value in string/name nodes -;; - needs a solution for synthetic nodes - -;;; Code - -(eval-and-compile - (require 'cl)) ; for delete-if - - -(defconst js2-version "1.7.0" - "Version of JavaScript supported, plus minor js2 version.") - -(defmacro js2-record-face (face) - "Record a style run of FACE for the current token." - `(js2-set-face js2-token-beg js2-token-end ,face 'record)) - -(defsubst js2-node-end (n) - "Computes the absolute end of node N. -Use with caution! Assumes `js2-node-pos' is -absolute-, which -is only true until the node is added to its parent; i.e., while parsing." - (+ (js2-node-pos n) - (js2-node-len n))) - -(defsubst js2-record-comment () - (push (make-js2-comment-node :len (- js2-token-end js2-token-beg) - :format js2-ts-comment-type) - js2-scanned-comments) - (when js2-parse-ide-mode - (js2-record-face 'font-lock-comment-face) - (when (memq js2-ts-comment-type '(html preprocessor)) - ;; Tell cc-engine the bounds of the comment. - (put-text-property js2-token-beg (1- js2-token-end) 'c-in-sws t)))) - -;; This function is called depressingly often, so it should be fast. -;; Most of the time it's looking at the same token it peeked before. -(defsubst js2-peek-token () - "Returns the next token without consuming it. -If previous token was consumed, calls scanner to get new token. -If previous token was -not- consumed, returns it (idempotent). - -This function will not return a newline (js2-EOL) - instead, it -gobbles newlines until it finds a non-newline token, and flags -that token as appearing just after a newline. - -This function will also not return a js2-COMMENT. Instead, it -records comments found in `js2-scanned-comments'. If the token -returned by this function immediately follows a jsdoc comment, -the token is flagged as such. - -Note that this function always returned the un-flagged token! -The flags, if any, are saved in `js2-current-flagged-token'." - (if (/= js2-current-flagged-token js2-EOF) ; last token not consumed - js2-current-token ; most common case - return already-peeked token - (let ((tt (js2-get-token)) ; call scanner - saw-eol - face) - ;; process comments and whitespace - (while (or (= tt js2-EOL) - (= tt js2-COMMENT)) - (if (= tt js2-EOL) - (setq saw-eol t) - (setq saw-eol nil) - (if js2-record-comments - (js2-record-comment))) - (setq tt (js2-get-token))) ; call scanner - - (setq js2-current-token tt - js2-current-flagged-token (if saw-eol - (logior tt js2-ti-after-eol) - tt)) - ;; perform lexical fontification as soon as token is scanned - (when js2-parse-ide-mode - (cond - ((minusp tt) - (js2-record-face 'js2-error-face)) - ((setq face (aref js2-kwd-tokens tt)) - (js2-record-face face)) - ((and (= tt js2-NAME) - (equal js2-ts-string "undefined")) - (js2-record-face 'font-lock-constant-face)))) - tt))) ; return unflagged token - -(defsubst js2-peek-flagged-token () - "Returns the current token along with any flags set for it." - (js2-peek-token) - js2-current-flagged-token) - -(defsubst js2-consume-token () - (setq js2-current-flagged-token js2-EOF)) - -(defsubst js2-next-token () - (prog1 - (js2-peek-token) - (js2-consume-token))) - -(defsubst js2-next-flagged-token () - (js2-peek-token) - (prog1 js2-current-flagged-token - (js2-consume-token))) - -(defsubst js2-match-token (match) - "Consume and return t if next token matches MATCH, a bytecode. -Returns nil and consumes nothing if MATCH is not the next token." - (if (/= (js2-peek-token) match) - nil - (js2-consume-token) - t)) - -(defsubst js2-valid-prop-name-token (tt) - (or (= tt js2-NAME) - (and js2-allow-keywords-as-property-names - (plusp tt) - (aref js2-kwd-tokens tt)))) - -(defsubst js2-match-prop-name () - "Consume token and return t if next token is a valid property name. -It's valid if it's a js2-NAME, or `js2-allow-keywords-as-property-names' -is non-nil and it's a keyword token." - (if (js2-valid-prop-name-token (js2-peek-token)) - (progn - (js2-consume-token) - t) - nil)) - -(defsubst js2-must-match-prop-name (msg-id &optional pos len) - (if (js2-match-prop-name) - t - (js2-report-error msg-id nil pos len) - nil)) - -(defsubst js2-peek-token-or-eol () - "Return js2-EOL if the current token immediately follows a newline. -Else returns the current token. Used in situations where we don't -consider certain token types valid if they are preceded by a newline. -One example is the postfix ++ or -- operator, which has to be on the -same line as its operand." - (let ((tt (js2-peek-token))) - ;; Check for last peeked token flags - (if (js2-flag-set-p js2-current-flagged-token js2-ti-after-eol) - js2-EOL - tt))) - -(defsubst js2-set-check-for-label () - (assert (= (logand js2-current-flagged-token js2-clear-ti-mask) js2-NAME)) - (js2-set-flag js2-current-flagged-token js2-ti-check-label)) - -(defsubst js2-must-match (token msg-id &optional pos len) - "Match next token to token code TOKEN, or record a syntax error. -MSG-ID is the error message to report if the match fails. -Returns t on match, nil if no match." - (if (js2-match-token token) - t - (js2-report-error msg-id nil pos len) - nil)) - -(defsubst js2-inside-function () - (plusp js2-nesting-of-function)) - -(defsubst js2-set-requires-activation () - (if (js2-function-node-p js2-current-script-or-fn) - (setf (js2-function-node-needs-activation js2-current-script-or-fn) t))) - -(defsubst js2-check-activation-name (name token) - (when (js2-inside-function) - ;; skip language-version 1.2 check from Rhino - (if (or (string= "arguments" name) - (and js2-compiler-activation-names ; only used in codegen - (gethash name js2-compiler-activation-names))) - (js2-set-requires-activation)))) - -(defsubst js2-set-is-generator () - (if (js2-function-node-p js2-current-script-or-fn) - (setf (js2-function-node-is-generator js2-current-script-or-fn) t))) - -(defsubst js2-must-have-xml () - (unless js2-compiler-xml-available - (js2-report-error "msg.XML.not.available"))) - -(defsubst js2-push-scope (scope) - "Push SCOPE, a `js2-scope', onto the lexical scope chain." - (assert (js2-scope-p scope)) - (assert (null (js2-scope-parent-scope scope))) - (assert (neq js2-current-scope scope)) - (setf (js2-scope-parent-scope scope) js2-current-scope - js2-current-scope scope)) - -(defsubst js2-pop-scope () - (setq js2-current-scope - (js2-scope-parent-scope js2-current-scope))) - -(defsubst js2-enter-loop (loop-node) - (push loop-node js2-loop-set) - (push loop-node js2-loop-and-switch-set) - (js2-push-scope loop-node) - ;; Tell the current labeled statement (if any) its statement, - ;; and set the jump target of the first label to the loop. - ;; These are used in `js2-parse-continue' to verify that the - ;; continue target is an actual labeled loop. (And for codegen.) - (when js2-labeled-stmt - (setf (js2-labeled-stmt-node-stmt js2-labeled-stmt) loop-node - (js2-label-node-loop (car (js2-labeled-stmt-node-labels - js2-labeled-stmt))) loop-node))) - -(defsubst js2-exit-loop () - (pop js2-loop-set) - (pop js2-loop-and-switch-set) - (js2-pop-scope)) - -(defsubst js2-enter-switch (switch-node) - (push switch-node js2-loop-and-switch-set)) - -(defsubst js2-exit-switch () - (pop js2-loop-and-switch-set)) - -(defun js2-parse (&optional buf cb) - "Tells the js2 parser to parse a region of JavaScript. - -BUF is a buffer or buffer name containing the code to parse. -Call `narrow-to-region' first to parse only part of the buffer. - -The returned AST root node is given some additional properties: - `node-count' - total number of nodes in the AST - `buffer' - BUF. The buffer it refers to may change or be killed, - so the value is not necessarily reliable. - -An optional callback CB can be specified to report parsing -progress. If `(functionp CB)' returns t, it will be called with -the current line number once before parsing begins, then again -each time the lexer reaches a new line number. - -CB can also be a list of the form `(symbol cb ...)' to specify -multiple callbacks with different criteria. Each symbol is a -criterion keyword, and the following element is the callback to -call - - :line - called whenever the line number changes - :token - called for each new token consumed - -The list of criteria could be extended to include entering or -leaving a statement, an expression, or a function definition." - (if (and cb (not (functionp cb))) - (error "criteria callbacks not yet implemented")) - (let ((inhibit-point-motion-hooks t) - (js2-compiler-xml-available (>= js2-language-version 160)) - ;; This is a recursive-descent parser, so give it a big stack. - (max-lisp-eval-depth (max max-lisp-eval-depth 3000)) - (max-specpdl-size (max max-specpdl-size 3000)) - (case-fold-search nil) - ast) - (or buf (setq buf (current-buffer))) - (save-excursion - (set-buffer buf) - (setq js2-scanned-comments nil - js2-parsed-errors nil - js2-parsed-warnings nil - js2-imenu-recorder nil - js2-imenu-function-map nil - js2-label-set nil) - (js2-init-scanner) - (setq ast (js2-with-unmodifying-text-property-changes - (js2-do-parse))) - (unless js2-ts-hit-eof - (js2-report-error "msg.got.syntax.errors" (length js2-parsed-errors))) - (setf (js2-ast-root-errors ast) js2-parsed-errors - (js2-ast-root-warnings ast) js2-parsed-warnings) - ;; if we didn't find any declarations, put a dummy in this list so we - ;; don't end up re-parsing the buffer in `js2-mode-create-imenu-index' - (unless js2-imenu-recorder - (setq js2-imenu-recorder 'empty)) - (run-hooks 'js2-parse-finished-hook) - ast))) - -;; Corresponds to Rhino's Parser.parse() method. -(defun js2-do-parse () - "Parse current buffer starting from current point. -Scanner should be initialized." - (let ((pos js2-ts-cursor) - (end js2-ts-cursor) ; in case file is empty - root n tt) - ;; initialize buffer-local parsing vars - (setf root (make-js2-ast-root :buffer (buffer-name) :pos pos) - js2-current-script-or-fn root - js2-current-scope root - js2-current-flagged-token js2-EOF - js2-nesting-of-function 0 - js2-labeled-stmt nil - js2-recorded-assignments nil) ; for js2-highlight - - (while (/= (setq tt (js2-peek-token)) js2-EOF) - (if (= tt js2-FUNCTION) - (progn - (js2-consume-token) - (setq n (js2-parse-function (if js2-called-by-compile-function - 'FUNCTION_EXPRESSION - 'FUNCTION_STATEMENT))) - (js2-record-imenu-functions n)) - ;; not a function - parse a statement - (setq n (js2-parse-statement))) - ;; add function or statement to script - (setq end (js2-node-end n)) - (js2-block-node-push root n)) - - ;; add comments to root in lexical order - (when js2-scanned-comments - ;; if we find a comment beyond end of normal kids, use its end - (setq end (max end (js2-node-end (first js2-scanned-comments)))) - (dolist (comment js2-scanned-comments) - (push comment (js2-ast-root-comments root)) - (js2-node-add-children root comment))) - - (setf (js2-node-len root) (- end pos)) - (js2-highlight-undeclared-vars) - root)) - -(defun js2-function-parser () - (js2-consume-token) - (js2-parse-function 'FUNCTION_EXPRESSION_STATEMENT)) - -(defun js2-parse-function-body (fn-node) - (js2-must-match js2-LC "msg.no.brace.body") - (let ((pos js2-token-beg) ; LC position - (pn (make-js2-block-node)) ; starts at LC position - tt - end) - (incf js2-nesting-of-function) - (unwind-protect - (while (not (or (= (setq tt (js2-peek-token)) js2-ERROR) - (= tt js2-EOF) - (= tt js2-RC))) - (js2-block-node-push pn (if (/= tt js2-FUNCTION) - (js2-parse-statement) - (js2-consume-token) - (js2-parse-function 'FUNCTION_STATEMENT)))) - (decf js2-nesting-of-function)) - (setq end js2-token-end) ; assume no curly and leave at current token - (if (js2-must-match js2-RC "msg.no.brace.after.body" pos) - (setq end js2-token-end)) - (setf (js2-node-pos pn) pos - (js2-node-len pn) (- end pos)) - (setf (js2-function-node-body fn-node) pn) - (js2-node-add-children fn-node pn) - pn)) - -(defun js2-parse-function-params (fn-node pos) - (if (js2-match-token js2-RP) - (setf (js2-function-node-rp fn-node) (- js2-token-beg pos)) - (let (params len param) - (loop for tt = (js2-peek-token) - do - (cond - ;; destructuring param - ((or (= tt js2-LB) (= tt js2-LC)) - (push (js2-parse-primary-expr) params)) - ;; simple name - (t - (js2-must-match js2-NAME "msg.no.parm") - (js2-record-face 'js2-function-param-face) - (setq param (js2-create-name-node)) - (js2-define-symbol js2-LP js2-ts-string param) - (push param params))) - while - (js2-match-token js2-COMMA)) - (if (js2-must-match js2-RP "msg.no.paren.after.parms") - (setf (js2-function-node-rp fn-node) (- js2-token-beg pos))) - (dolist (p params) - (js2-node-add-children fn-node p) - (push p (js2-function-node-params fn-node)))))) - -(defsubst js2-check-inconsistent-return-warning (fn-node name) - "Possibly show inconsistent-return warning. -Last token scanned is the close-curly for the function body." - (when (and js2-mode-show-strict-warnings - js2-strict-inconsistent-return-warning - (not (js2-has-consistent-return-usage - (js2-function-node-body fn-node)))) - ;; Have it extend from close-curly to bol or beginning of block. - (let ((pos (save-excursion - (goto-char js2-token-end) - (max (js2-node-abs-pos (js2-function-node-body fn-node)) - (point-at-bol)))) - (end js2-token-end)) - (if (plusp (js2-name-node-length name)) - (js2-add-strict-warning "msg.no.return.value" - (js2-name-node-name name) pos end) - (js2-add-strict-warning "msg.anon.no.return.value" nil pos end))))) - -(defun js2-parse-function (function-type) - "Function parser. FUNCTION-TYPE is a symbol." - (let ((pos js2-token-beg) ; start of 'function' keyword - name - name-beg - name-end - fn-node - lp - (synthetic-type function-type) - member-expr-node) - - ;; parse function name, expression, or non-name (anonymous) - (cond - ;; function foo(...) - ((js2-match-token js2-NAME) - (setq name (js2-create-name-node t) - name-beg js2-token-beg - name-end js2-token-end) - (unless (js2-match-token js2-LP) - (when js2-allow-member-expr-as-function-name - ;; function foo.bar(...) - (setq member-expr-node name - name nil - member-expr-node (js2-parse-member-expr-tail - nil member-expr-node))) - (js2-must-match js2-LP "msg.no.paren.parms"))) - - ((js2-match-token js2-LP) - nil) ; anonymous function: leave name as null - - (t - ;; function random-member-expr(...) - (when js2-allow-member-expr-as-function-name - ;; Note that memberExpr can not start with '(' like - ;; in function (1+2).toString(), because 'function (' already - ;; processed as anonymous function - (setq member-expr-node (js2-parse-member-expr))) - (js2-must-match js2-LP "msg.no.paren.parms"))) - - (if (= js2-current-token js2-LP) ; eventually matched LP? - (setq lp js2-token-beg)) - - (if member-expr-node - (progn - (setq synthetic-type 'FUNCTION_EXPRESSION) - (js2-parse-highlight-member-expr-fn-name member-expr-node)) - (if name - (js2-set-face name-beg name-end - 'font-lock-function-name-face 'record))) - - (if (and (neq synthetic-type 'FUNCTION_EXPRESSION) - (plusp (js2-name-node-length name))) - ;; Function statements define a symbol in the enclosing scope - (js2-define-symbol js2-FUNCTION (js2-name-node-name name) fn-node)) - - (setf fn-node (make-js2-function-node :pos pos - :name name - :form function-type - :lp (if lp (- lp pos)))) - - (if (or (js2-inside-function) (plusp js2-nesting-of-with)) - ;; 1. Nested functions are not affected by the dynamic scope flag - ;; as dynamic scope is already a parent of their scope. - ;; 2. Functions defined under the with statement also immune to - ;; this setup, in which case dynamic scope is ignored in favor - ;; of the with object. - (setf (js2-function-node-ignore-dynamic fn-node) t)) - - ;; dynamically bind all the per-function variables - (let ((js2-current-script-or-fn fn-node) - (js2-current-scope fn-node) - (js2-nesting-of-with 0) - (js2-end-flags 0) - js2-label-set - js2-loop-set - js2-loop-and-switch-set) - - ;; parse params and function body - (js2-parse-function-params fn-node pos) - (js2-parse-function-body fn-node) - (if name - (js2-node-add-children fn-node name)) - - (js2-check-inconsistent-return-warning fn-node name) - - ;; Function expressions define a name only in the body of the - ;; function, and only if not hidden by a parameter name - (if (and name - (eq synthetic-type 'FUNCTION_EXPRESSION) - (null (js2-scope-get-symbol js2-current-scope - (js2-name-node-name name)))) - (js2-define-symbol js2-FUNCTION - (js2-name-node-name name) - fn-node)) - (if (and name - (eq function-type 'FUNCTION_EXPRESSION_STATEMENT)) - (js2-record-imenu-functions fn-node))) - - (setf (js2-node-len fn-node) (- js2-ts-cursor pos) - (js2-function-node-member-expr fn-node) member-expr-node) ; may be nil - - ;; Rhino doesn't do this, but we need it for finding undeclared vars. - ;; We wait until after parsing the function to set its parent scope, - ;; since `js2-define-symbol' needs the defining-scope check to stop - ;; at the function boundary when checking for redeclarations. - (setf (js2-scope-parent-scope fn-node) js2-current-scope) - - fn-node)) - -(defun js2-parse-statements (&optional parent) - "Parse a statement list. Last token consumed must be js2-LC. - -PARENT can be a `js2-block-node', in which case the statements are -appended to PARENT. Otherwise a new `js2-block-node' is created -and returned. - -This function does not match the closing js2-RC: the caller -matches the RC so it can provide a suitable error message if not -matched. This means it's up to the caller to set the length of -the node to include the closing RC. The node start pos is set to -the absolute buffer start position, and the caller should fix it -up to be relative to the parent node. All children of this block -node are given relative start positions and correct lengths." - (let ((pn (or parent (make-js2-block-node))) - tt) - (setf (js2-node-pos pn) js2-token-beg) - (while (and (> (setq tt (js2-peek-token)) js2-EOF) - (/= tt js2-RC)) - (js2-block-node-push pn (js2-parse-statement))) - pn)) - -(defun js2-parse-statement () - (let (tt pn beg end) - - ;; coarse-grained user-interrupt check - needs work - (and js2-parse-interruptable-p - (zerop (% (incf js2-parse-stmt-count) - js2-statements-per-pause)) - (input-pending-p) - (throw 'interrupted t)) - - (setq pn (js2-statement-helper)) - - ;; no-side-effects warning check - (unless (js2-node-has-side-effects pn) - (setq end (js2-node-end pn)) - (save-excursion - (goto-char end) - (setq beg (max (js2-node-pos pn) (point-at-bol)))) - (js2-add-strict-warning "msg.no.side.effects" nil beg end)) - - pn)) - -;; These correspond to the switch cases in Parser.statementHelper -(defconst js2-parsers - (let ((parsers (make-vector js2-num-tokens - #'js2-parse-expr-stmt))) - (aset parsers js2-BREAK #'js2-parse-break) - (aset parsers js2-CONST #'js2-parse-const-var) - (aset parsers js2-CONTINUE #'js2-parse-continue) - (aset parsers js2-DEBUGGER #'js2-parse-debugger) - (aset parsers js2-DEFAULT #'js2-parse-default-xml-namespace) - (aset parsers js2-DO #'js2-parse-do) - (aset parsers js2-FOR #'js2-parse-for) - (aset parsers js2-FUNCTION #'js2-function-parser) - (aset parsers js2-IF #'js2-parse-if) - (aset parsers js2-LC #'js2-parse-block) - (aset parsers js2-LET #'js2-parse-let-stmt) - (aset parsers js2-NAME #'js2-parse-name-or-label) - (aset parsers js2-RETURN #'js2-parse-ret-yield) - (aset parsers js2-SEMI #'js2-parse-semi) - (aset parsers js2-SWITCH #'js2-parse-switch) - (aset parsers js2-THROW #'js2-parse-throw) - (aset parsers js2-TRY #'js2-parse-try) - (aset parsers js2-VAR #'js2-parse-const-var) - (aset parsers js2-WHILE #'js2-parse-while) - (aset parsers js2-WITH #'js2-parse-with) - (aset parsers js2-YIELD #'js2-parse-ret-yield) - parsers) - "A vector mapping token types to parser functions.") - -(defsubst js2-parse-warn-missing-semi (beg end) - (and js2-mode-show-strict-warnings - js2-strict-missing-semi-warning - (js2-add-strict-warning - "msg.missing.semi" nil - ;; back up to beginning of statement or line - (max beg (save-excursion - (goto-char end) - (point-at-bol))) - end))) - -(defconst js2-no-semi-insertion - (list js2-IF - js2-SWITCH - js2-WHILE - js2-DO - js2-FOR - js2-TRY - js2-WITH - js2-LC - js2-ERROR - js2-SEMI - js2-FUNCTION) - "List of tokens that don't do automatic semicolon insertion.") - -(defconst js2-autoinsert-semi-and-warn - (list js2-ERROR js2-EOF js2-RC)) - -(defun js2-statement-helper () - (let* ((tt (js2-peek-token)) - (first-tt tt) - (beg js2-token-beg) - (parser (if (= tt js2-ERROR) - #'js2-parse-semi - (aref js2-parsers tt))) - pn - tt-flagged) - ;; If the statement is set, then it's been told its label by now. - (and js2-labeled-stmt - (js2-labeled-stmt-node-stmt js2-labeled-stmt) - (setq js2-labeled-stmt nil)) - - (setq pn (funcall parser) - tt-flagged (js2-peek-flagged-token) - tt (logand tt-flagged js2-clear-ti-mask)) - - ;; Don't do auto semi insertion for certain statement types. - (unless (or (memq first-tt js2-no-semi-insertion) - (js2-labeled-stmt-node-p pn)) - (cond - ((= tt js2-SEMI) - ;; Consume ';' as a part of expression - (js2-consume-token) - ;; extend the node bounds to include the semicolon. - (setf (js2-node-len pn) (- js2-token-end beg))) - ((memq tt js2-autoinsert-semi-and-warn) - ;; Autoinsert ; - (js2-parse-warn-missing-semi beg (js2-node-end pn))) - (t - (if (js2-flag-not-set-p tt-flagged js2-ti-after-eol) - ;; Report error if no EOL or autoinsert ';' otherwise - (js2-report-error "msg.no.semi.stmt") - (js2-parse-warn-missing-semi beg (js2-node-end pn)))))) - pn)) - -(defun js2-parse-condition () - "Parse a parenthesized boolean expression, e.g. in an if- or while-stmt. -The parens are discarded and the expression node is returned. -The `pos' field of the return value is set to an absolute position -that must be fixed up by the caller. -Return value is a list (EXPR LP RP), with absolute paren positions." - (let (pn lp rp) - (if (js2-must-match js2-LP "msg.no.paren.cond") - (setq lp js2-token-beg)) - (setq pn (js2-parse-expr)) - (if (js2-must-match js2-RP "msg.no.paren.after.cond") - (setq rp js2-token-beg)) - ;; Report strict warning on code like "if (a = 7) ..." - (if (and js2-strict-cond-assign-warning - (js2-assign-node-p pn)) - (js2-add-strict-warning "msg.equal.as.assign" nil - (js2-node-pos pn) - (+ (js2-node-pos pn) - (js2-node-len pn)))) - (list pn lp rp))) - -(defun js2-parse-if () - "Parser for if-statement. Last matched token must be js2-IF." - (let ((pos js2-token-beg) - cond - if-true - if-false - else-pos - end - pn) - (js2-consume-token) - (setq cond (js2-parse-condition) - if-true (js2-parse-statement) - if-false (if (js2-match-token js2-ELSE) - (progn - (setq else-pos (- js2-token-beg pos)) - (js2-parse-statement))) - end (js2-node-end (or if-false if-true)) - pn (make-js2-if-node :pos pos - :len (- end pos) - :condition (car cond) - :then-part if-true - :else-part if-false - :else-pos else-pos - :lp (js2-relpos (second cond) pos) - :rp (js2-relpos (third cond) pos))) - (js2-node-add-children pn (car cond) if-true if-false) - pn)) - -(defun js2-parse-switch () - "Parser for if-statement. Last matched token must be js2-SWITCH." - (let ((pos js2-token-beg) - tt - pn - discriminant - has-default - case-expr - case-node - case-pos - cases - stmt - lp - rp) - (js2-consume-token) - (if (js2-must-match js2-LP "msg.no.paren.switch") - (setq lp js2-token-beg)) - (setq discriminant (js2-parse-expr) - pn (make-js2-switch-node :discriminant discriminant - :pos pos - :lp (js2-relpos lp pos))) - (js2-node-add-children pn discriminant) - (js2-enter-switch pn) - (unwind-protect - (progn - (if (js2-must-match js2-RP "msg.no.paren.after.switch") - (setf (js2-switch-node-rp pn) (- js2-token-beg pos))) - (js2-must-match js2-LC "msg.no.brace.switch") - (catch 'break - (while t - (setq tt (js2-next-token) - case-pos js2-token-beg) - (cond - ((= tt js2-RC) - (setf (js2-node-len pn) (- js2-token-end pos)) - (throw 'break nil)) ; done - - ((= tt js2-CASE) - (setq case-expr (js2-parse-expr)) - (js2-must-match js2-COLON "msg.no.colon.case")) - - ((= tt js2-DEFAULT) - (if has-default - (js2-report-error "msg.double.switch.default")) - (setq has-default t - case-expr nil) - (js2-must-match js2-COLON "msg.no.colon.case")) - - (t - (js2-report-error "msg.bad.switch") - (throw 'break nil))) - - (setq case-node (make-js2-case-node :pos case-pos - :len (- js2-token-end case-pos) - :expr case-expr)) - (js2-node-add-children case-node case-expr) - (while (and (/= (setq tt (js2-peek-token)) js2-RC) - (/= tt js2-CASE) - (/= tt js2-DEFAULT) - (/= tt js2-EOF)) - (setf stmt (js2-parse-statement) - (js2-node-len case-node) (- (js2-node-end stmt) case-pos)) - (js2-block-node-push case-node stmt)) - (push case-node cases))) - ;; add cases last, as pushing reverses the order to be correct - (dolist (kid cases) - (js2-node-add-children pn kid) - (push kid (js2-switch-node-cases pn))) - pn) ; return value - (js2-exit-switch)))) - -(defun js2-parse-while () - "Parser for while-statement. Last matched token must be js2-WHILE." - (let ((pos js2-token-beg) - (pn (make-js2-while-node)) - cond - body) - (js2-consume-token) - (js2-enter-loop pn) - (unwind-protect - (progn - (setf cond (js2-parse-condition) - (js2-while-node-condition pn) (car cond) - body (js2-parse-statement) - (js2-while-node-body pn) body - (js2-node-len pn) (- (js2-node-end body) pos) - (js2-while-node-lp pn) (js2-relpos (second cond) pos) - (js2-while-node-rp pn) (js2-relpos (third cond) pos)) - (js2-node-add-children pn body (car cond))) - (js2-exit-loop)) - pn)) - -(defun js2-parse-do () - "Parser for do-statement. Last matched token must be js2-DO." - (let ((pos js2-token-beg) - (pn (make-js2-do-node)) - cond - body - end) - (js2-consume-token) - (js2-enter-loop pn) - (unwind-protect - (progn - (setq body (js2-parse-statement)) - (js2-must-match js2-WHILE "msg.no.while.do") - (setf (js2-do-node-while-pos pn) (- js2-token-beg pos) - cond (js2-parse-condition) - (js2-do-node-condition pn) (car cond) - (js2-do-node-body pn) body - end js2-ts-cursor - (js2-do-node-lp pn) (js2-relpos (second cond) pos) - (js2-do-node-rp pn) (js2-relpos (third cond) pos)) - (js2-node-add-children pn (car cond) body)) - (js2-exit-loop)) - ;; Always auto-insert semicolon to follow SpiderMonkey: - ;; It is required by ECMAScript but is ignored by the rest of - ;; world; see bug 238945 - (if (js2-match-token js2-SEMI) - (setq end js2-ts-cursor)) - (setf (js2-node-len pn) (- end pos)) - pn)) - -(defun js2-parse-for () - "Parser for for-statement. Last matched token must be js2-FOR. -Parses for, for-in, and for each-in statements." - (let ((for-pos js2-token-beg) - pn - is-for-each - is-for-in - in-pos - each-pos - tmp-pos - init ; Node init is also foo in 'foo in object' - cond ; Node cond is also object in 'foo in object' - incr ; 3rd section of for-loop initializer - body - tt - lp - rp) - (js2-consume-token) - ;; See if this is a for each () instead of just a for () - (when (js2-match-token js2-NAME) - (if (string= "each" js2-ts-string) - (progn - (setq is-for-each t - each-pos (- js2-token-beg for-pos)) ; relative - (js2-record-face 'font-lock-keyword-face)) - (js2-report-error "msg.no.paren.for"))) - - (if (js2-must-match js2-LP "msg.no.paren.for") - (setq lp (- js2-token-beg for-pos))) - (setq tt (js2-peek-token)) - - ;; parse init clause - (let ((js2-in-for-init t)) ; set as dynamic variable - (cond - ((= tt js2-SEMI) - (setq init (make-js2-empty-expr-node))) - ((or (= tt js2-VAR) (= tt js2-LET)) - (js2-consume-token) - (setq init (js2-parse-variables tt js2-token-beg))) - (t - (setq init (js2-parse-expr))))) - - (if (js2-match-token js2-IN) - (setq is-for-in t - in-pos (- js2-token-beg for-pos) - cond (js2-parse-expr)) ; object over which we're iterating - ;; else ordinary for loop - parse cond and incr - (js2-must-match js2-SEMI "msg.no.semi.for") - (setq cond (if (= (js2-peek-token) js2-SEMI) - (make-js2-empty-expr-node) ; no loop condition - (js2-parse-expr))) - (js2-must-match js2-SEMI "msg.no.semi.for.cond") - (setq tmp-pos js2-token-end - incr (if (= (js2-peek-token) js2-RP) - (make-js2-empty-expr-node :pos tmp-pos) - (js2-parse-expr)))) - - (if (js2-must-match js2-RP "msg.no.paren.for.ctrl") - (setq rp (- js2-token-beg for-pos))) - (if (not is-for-in) - (setq pn (make-js2-for-node :init init - :condition cond - :update incr - :lp lp - :rp rp)) - ;; cond could be null if 'in obj' got eaten by the init node. - (if (js2-infix-node-p init) - ;; it was (foo in bar) instead of (var foo in bar) - (setq cond (js2-infix-node-right init) - init (js2-infix-node-left init)) - (if (and (js2-var-decl-node-p init) - (> (length (js2-var-decl-node-kids init)) 1)) - (js2-report-error "msg.mult.index"))) - - (setq pn (make-js2-for-in-node :iterator init - :object cond - :in-pos in-pos - :foreach-p is-for-each - :each-pos each-pos - :lp lp - :rp rp))) - (unwind-protect - (progn - (js2-enter-loop pn) - ;; We have to parse the body -after- creating the loop node, - ;; so that the loop node appears in the js2-loop-set, allowing - ;; break/continue statements to find the enclosing loop. - (setf body (js2-parse-statement) - (js2-loop-node-body pn) body - (js2-node-pos pn) for-pos - (js2-node-len pn) (- (js2-node-end body) for-pos)) - (js2-node-add-children pn init cond incr body)) - ;; finally - (js2-exit-loop)) - pn)) - -(defun js2-parse-try () - "Parser for try-statement. Last matched token must be js2-TRY." - (let ((try-pos js2-token-beg) - try-end - try-block - catch-blocks - finally-block - saw-default-catch - peek - var-name - catch-cond - catch-node - guard-kwd - catch-pos - finally-pos - pn - block - lp - rp) - (js2-consume-token) - (if (/= (js2-peek-token) js2-LC) - (js2-report-error "msg.no.brace.try")) - (setq try-block (js2-parse-statement) - try-end (js2-node-end try-block) - peek (js2-peek-token)) - (cond - ((= peek js2-CATCH) - (while (js2-match-token js2-CATCH) - (setq catch-pos js2-token-beg - guard-kwd nil - catch-cond nil - lp nil - rp nil) - (if saw-default-catch - (js2-report-error "msg.catch.unreachable")) - (if (js2-must-match js2-LP "msg.no.paren.catch") - (setq lp (- js2-token-beg catch-pos))) - - (js2-must-match js2-NAME "msg.bad.catchcond") - (setq var-name (js2-create-name-node)) - - (if (js2-match-token js2-IF) - (setq guard-kwd (- js2-token-beg catch-pos) - catch-cond (js2-parse-expr)) - (setq saw-default-catch t)) - - (if (js2-must-match js2-RP "msg.bad.catchcond") - (setq rp (- js2-token-beg catch-pos))) - (js2-must-match js2-LC "msg.no.brace.catchblock") - - (setq block (js2-parse-statements) - try-end (js2-node-end block) - catch-node (make-js2-catch-node :pos catch-pos - :var-name var-name - :guard-expr catch-cond - :guard-kwd guard-kwd - :block block - :lp lp - :rp rp)) - (if (js2-must-match js2-RC "msg.no.brace.after.body") - (setq try-end js2-token-beg)) - (setf (js2-node-len block) (- try-end (js2-node-pos block)) - (js2-node-len catch-node) (- try-end catch-pos)) - (js2-node-add-children catch-node var-name catch-cond block) - (push catch-node catch-blocks))) - - ((/= peek js2-FINALLY) - (js2-must-match js2-FINALLY "msg.try.no.catchfinally" - (js2-node-pos try-block) - (- (setq try-end (js2-node-end try-block)) - (js2-node-pos try-block))))) - - (when (js2-match-token js2-FINALLY) - (setq finally-pos js2-token-beg - block (js2-parse-statement) - try-end (js2-node-end block) - finally-block (make-js2-finally-node :pos finally-pos - :len (- try-end finally-pos) - :body block)) - (js2-node-add-children finally-block block)) - - (setq pn (make-js2-try-node :pos try-pos - :len (- try-end try-pos) - :try-block try-block - :finally-block finally-block)) - (js2-node-add-children pn try-block finally-block) - - ;; push them onto the try-node, which reverses and corrects their order - (dolist (cb catch-blocks) - (js2-node-add-children pn cb) - (push cb (js2-try-node-catch-clauses pn))) - pn)) - -(defun js2-parse-throw () - "Parser for throw-statement. Last matched token must be js2-THROW." - (let ((pos js2-token-beg) - expr - pn) - (js2-consume-token) - (if (= (js2-peek-token-or-eol) js2-EOL) - ;; ECMAScript does not allow new lines before throw expression, - ;; see bug 256617 - (js2-report-error "msg.bad.throw.eol")) - (setq expr (js2-parse-expr) - pn (make-js2-throw-node :pos pos - :len (- (js2-node-end expr) pos) - :expr expr)) - (js2-node-add-children pn expr) - pn)) - -(defsubst js2-match-jump-label-name (label-name) - "If break/continue specified a label, return that label's labeled stmt. -Returns the corresponding `js2-labeled-stmt-node', or if LABEL-NAME -does not match an existing label, reports an error and returns nil." - (let ((bundle (cdr (assoc label-name js2-label-set)))) - (if (null bundle) - (js2-report-error "msg.undef.label")) - bundle)) - -(defun js2-parse-break () - "Parser for break-statement. Last matched token must be js2-BREAK." - (let ((pos js2-token-beg) - (end js2-token-end) - break-target ; statement to break from - break-label ; in "break foo", name-node representing the foo - labels ; matching labeled statement to break to - pn) - (js2-consume-token) ; `break' - (when (eq (js2-peek-token-or-eol) js2-NAME) - (js2-consume-token) - (setq break-label (js2-create-name-node) - end (js2-node-end break-label) - ;; matchJumpLabelName only matches if there is one - labels (js2-match-jump-label-name js2-ts-string) - break-target (if labels (car (js2-labeled-stmt-node-labels labels))))) - - (unless (or break-target break-label) - ;; no break target specified - try for innermost enclosing loop/switch - (if (null js2-loop-and-switch-set) - (unless break-label - (js2-report-error "msg.bad.break" nil pos (length "break"))) - (setq break-target (car js2-loop-and-switch-set)))) - - (setq pn (make-js2-break-node :pos pos - :len (- end pos) - :label break-label - :target break-target)) - (js2-node-add-children pn break-label) ; but not break-target - pn)) - -(defun js2-parse-continue () - "Parser for continue-statement. Last matched token must be js2-CONTINUE." - (let ((pos js2-token-beg) - (end js2-token-end) - label ; optional user-specified label, a `js2-name-node' - labels ; current matching labeled stmt, if any - target ; the `js2-loop-node' target of this continue stmt - pn) - (js2-consume-token) ; `continue' - (when (= (js2-peek-token-or-eol) js2-NAME) - (js2-consume-token) - (setq label (js2-create-name-node) - end (js2-node-end label) - ;; matchJumpLabelName only matches if there is one - labels (js2-match-jump-label-name js2-ts-string))) - (cond - ((null labels) ; no current label to go to - (if (null js2-loop-set) ; no loop to continue to - (js2-report-error "msg.continue.outside" nil pos - (length "continue")) - (setq target (car js2-loop-set)))) ; innermost enclosing loop - (t - (if (js2-loop-node-p (js2-labeled-stmt-node-stmt labels)) - (setq target (js2-labeled-stmt-node-stmt labels)) - (js2-report-error "msg.continue.nonloop" nil pos (- end pos))))) - - (setq pn (make-js2-continue-node :pos pos - :len (- end pos) - :label label - :target target)) - (js2-node-add-children pn label) ; but not target - it's not our child - pn)) - -(defun js2-parse-with () - "Parser for with-statement. Last matched token must be js2-WITH." - (js2-consume-token) - (let ((pos js2-token-beg) - obj body pn lp rp) - - (if (js2-must-match js2-LP "msg.no.paren.with") - (setq lp js2-token-beg)) - - (setq obj (js2-parse-expr)) - - (if (js2-must-match js2-RP "msg.no.paren.after.with") - (setq rp js2-token-beg)) - - (let ((js2-nesting-of-with (1+ js2-nesting-of-with))) - (setq body (js2-parse-statement))) - - (setq pn (make-js2-with-node :pos pos - :len (- (js2-node-end body) pos) - :object obj - :body body - :lp (js2-relpos lp pos) - :rp (js2-relpos rp pos))) - (js2-node-add-children pn obj body) - pn)) - -(defun js2-parse-const-var () - "Parser for var- or const-statement. -Last matched token must be js2-CONST or js2-VAR." - (let ((tt (js2-peek-token)) - (pos js2-token-beg) - expr - pn) - (js2-consume-token) - (setq expr (js2-parse-variables tt js2-token-beg) - pn (make-js2-expr-stmt-node :pos pos - :len (- (js2-node-end expr) pos) - :expr expr)) - (js2-node-add-children pn expr) - pn)) - -(defsubst js2-wrap-with-expr-stmt (pos expr &optional add-child) - (let ((pn (make-js2-expr-stmt-node :pos pos - :len (js2-node-len expr) - :type (if (js2-inside-function) - js2-EXPR_VOID - js2-EXPR_RESULT) - :expr expr))) - (if add-child - (js2-node-add-children pn expr)) - pn)) - -(defun js2-parse-let-stmt () - "Parser for let-statement. Last matched token must be js2-LET." - (js2-consume-token) - (let ((pos js2-token-beg) - expr - pn) - (if (= (js2-peek-token) js2-LP) - ;; let expression in statement context - (setq expr (js2-parse-let pos 'statement) - pn (js2-wrap-with-expr-stmt pos expr t)) - ;; else we're looking at a statement like let x=6, y=7; - (setf expr (js2-parse-variables js2-LET pos) - pn (js2-wrap-with-expr-stmt pos expr t) - (js2-node-type pn) js2-EXPR_RESULT)) - pn)) - -(defun js2-parse-ret-yield () - (js2-parse-return-or-yield (js2-peek-token) nil)) - -(defconst js2-parse-return-stmt-enders - (list js2-SEMI js2-RC js2-EOF js2-EOL js2-ERROR js2-RB js2-RP js2-YIELD)) - -(defsubst js2-now-all-set (before after mask) - "Return whether or not the bits in the mask have changed to all set. -BEFORE is bits before change, AFTER is bits after change, and MASK is -the mask for bits. Returns t if all the bits in the mask are set in AFTER -but not BEFORE." - (and (/= (logand before mask) mask) - (= (logand after mask) mask))) - -(defun js2-parse-return-or-yield (tt expr-context) - (let ((pos js2-token-beg) - (end js2-token-end) - (before js2-end-flags) - (inside-function (js2-inside-function)) - e - ret - name) - (unless inside-function - (js2-report-error (if (eq tt js2-RETURN) - "msg.bad.return" - "msg.bad.yield"))) - (js2-consume-token) - ;; This is ugly, but we don't want to require a semicolon. - (unless (memq (js2-peek-token-or-eol) js2-parse-return-stmt-enders) - (setq e (js2-parse-expr) - end (js2-node-end e))) - (cond - ((eq tt js2-RETURN) - (js2-set-flag js2-end-flags (if (null e) - js2-end-returns - js2-end-returns-value)) - (setq ret (make-js2-return-node :pos pos - :len (- end pos) - :retval e)) - (js2-node-add-children ret e) - ;; See if we need a strict mode warning. - ;; TODO: The analysis done by `js2-has-consistent-return-usage' is - ;; more thorough and accurate than this before/after flag check. - ;; E.g. if there's a finally-block that always returns, we shouldn't - ;; show a warning generated by inconsistent returns in the catch blocks. - ;; Basically `js2-has-consistent-return-usage' needs to keep more state, - ;; so we know which returns/yields to highlight, and we should get rid of - ;; all the checking in `js2-parse-return-or-yield'. - (if (and js2-strict-inconsistent-return-warning - (js2-now-all-set before js2-end-flags - (logior js2-end-returns js2-end-returns-value))) - (js2-add-strict-warning "msg.return.inconsistent" nil pos end))) - (t - (unless (js2-inside-function) - (js2-report-error "msg.bad.yield")) - (js2-set-flag js2-end-flags js2-end-yields) - (setq ret (make-js2-yield-node :pos pos - :len (- end pos) - :value e)) - (js2-node-add-children ret e) - (unless expr-context - (setq e ret - ret (js2-wrap-with-expr-stmt pos e t)) - (js2-set-requires-activation) - (js2-set-is-generator)))) - - ;; see if we are mixing yields and value returns. - (when (and inside-function - (js2-now-all-set before js2-end-flags - (logior js2-end-yields js2-end-returns-value))) - (setq name (js2-function-name js2-current-script-or-fn)) - (if (zerop (length name)) - (js2-report-error "msg.anon.generator.returns" nil pos (- end pos)) - (js2-report-error "msg.generator.returns" name pos (- end pos)))) - - ret)) - -(defun js2-parse-debugger () - (js2-consume-token) - (make-js2-keyword-node :type js2-DEBUGGER)) - -(defun js2-parse-block () - "Parser for a curly-delimited statement block. -Last token matched must be js2-LC." - (let ((pos js2-token-beg) - (pn (make-js2-scope))) - (js2-consume-token) - (js2-push-scope pn) - (unwind-protect - (progn - (js2-parse-statements pn) - (js2-must-match js2-RC "msg.no.brace.block") - (setf (js2-node-len pn) (- js2-token-end pos))) - (js2-pop-scope)) - pn)) - -;; for js2-ERROR too, to have a node for error recovery to work on -(defun js2-parse-semi () - "Parse a statement or handle an error. -Last matched token is js-SEMI or js-ERROR." - (let ((tt (js2-peek-token)) pos len) - (js2-consume-token) - (if (eq tt js2-SEMI) - (make-js2-empty-expr-node :len 1) - (setq pos js2-token-beg - len (- js2-token-beg pos)) - (js2-report-error "msg.syntax" nil pos len) - (make-js2-error-node :pos pos :len len)))) - -(defun js2-parse-default-xml-namespace () - "Parse a `default xml namespace = <expr>' e4x statement." - (let ((pos js2-token-beg) - end len expr unary es) - (js2-consume-token) - (js2-must-have-xml) - (js2-set-requires-activation) - (setq len (- js2-ts-cursor pos)) - (unless (and (js2-match-token js2-NAME) - (string= js2-ts-string "xml")) - (js2-report-error "msg.bad.namespace" nil pos len)) - (unless (and (js2-match-token js2-NAME) - (string= js2-ts-string "namespace")) - (js2-report-error "msg.bad.namespace" nil pos len)) - (unless (js2-match-token js2-ASSIGN) - (js2-report-error "msg.bad.namespace" nil pos len)) - (setq expr (js2-parse-expr) - end (js2-node-end expr) - unary (make-js2-unary-node :type js2-DEFAULTNAMESPACE - :pos pos - :len (- end pos) - :operand expr)) - (js2-node-add-children unary expr) - (make-js2-expr-stmt-node :pos pos - :len (- end pos) - :expr unary))) - -(defun js2-record-label (label bundle) - ;; current token should be colon that `js2-parse-primary-expr' left untouched - (js2-consume-token) - (let ((name (js2-label-node-name label)) - labeled-stmt - dup) - (when (setq labeled-stmt (cdr (assoc name js2-label-set))) - ;; flag both labels if possible when used in editing mode - (if (and js2-parse-ide-mode - (setq dup (js2-get-label-by-name labeled-stmt name))) - (js2-report-error "msg.dup.label" nil - (js2-node-abs-pos dup) (js2-node-len dup))) - (js2-report-error "msg.dup.label" nil - (js2-node-pos label) (js2-node-len label))) - (js2-labeled-stmt-node-add-label bundle label) - (js2-node-add-children bundle label) - ;; Add one reference to the bundle per label in `js2-label-set' - (push (cons name bundle) js2-label-set))) - -(defun js2-parse-name-or-label () - "Parser for identifier or label. Last token matched must be js2-NAME. -Called when we found a name in a statement context. If it's a label, we gather -up any following labels and the next non-label statement into a -`js2-labeled-stmt-node' bundle and return that. Otherwise we parse an -expression and return it wrapped in a `js2-expr-stmt-node'." - (let ((pos js2-token-beg) - (end js2-token-end) - expr - stmt - pn - bundle - (continue t)) - ;; set check for label and call down to `js2-parse-primary-expr' - (js2-set-check-for-label) - (setq expr (js2-parse-expr)) - - (if (/= (js2-node-type expr) js2-LABEL) - ;; Parsed non-label expression - wrap with expression stmt. - (setq pn (js2-wrap-with-expr-stmt pos expr t)) - - ;; else parsed a label - (setq bundle (make-js2-labeled-stmt-node :pos pos)) - (js2-record-label expr bundle) - - ;; look for more labels - (while (and continue (= (js2-peek-token) js2-NAME)) - (js2-set-check-for-label) - (setq expr (js2-parse-expr)) - (if (/= (js2-node-type expr) js2-LABEL) - (setq stmt (js2-wrap-with-expr-stmt pos expr t) - continue nil) - (js2-record-label expr bundle))) - - ;; no more labels; now parse the labeled statement - (unwind-protect - (unless stmt - (let ((js2-labeled-stmt bundle)) ; bind dynamically - (setq stmt (js2-statement-helper)))) - ;; remove the labels for this statement from the global set - (dolist (label (js2-labeled-stmt-node-labels bundle)) - (setq js2-label-set (remove label js2-label-set)))) - - (setf (js2-labeled-stmt-node-stmt bundle) stmt) - (js2-node-add-children bundle stmt) - bundle))) - -(defun js2-parse-expr-stmt () - "Default parser in statement context, if no recognized statement found." - (js2-wrap-with-expr-stmt js2-token-beg (js2-parse-expr) t)) - -(defun js2-parse-variables (decl-type pos) - "Parse a comma-separated list of variable declarations. -Could be a 'var', 'const' or 'let' expression, possibly in a for-loop initializer. - -DECL-TYPE is a token value: either VAR, CONST, or LET depending on context. -For 'var' or 'const', the keyword should be the token last scanned. - -POS is the position where the node should start. It's sometimes the -var/const/let keyword, and other times the beginning of the first token -in the first variable declaration. - -Returns the parsed `js2-var-decl-node' expression node." - (let* ((result (make-js2-var-decl-node :decl-type decl-type - :pos pos)) - destructuring - kid-pos - tt - init - name - end - nbeg nend - vi - (continue t)) - ;; Example: - ;; var foo = {a: 1, b: 2}, bar = [3, 4]; - ;; var {b: s2, a: s1} = foo, x = 6, y, [s3, s4] = bar; - (while continue - (setq destructuring nil - name nil - tt (js2-peek-token) - kid-pos js2-token-beg - end js2-token-end - init nil) - (if (or (= tt js2-LB) (= tt js2-LC)) - ;; Destructuring assignment, e.g., var [a, b] = ... - (setq destructuring (js2-parse-primary-expr) - end (js2-node-end destructuring)) - ;; Simple variable name - (when (js2-must-match js2-NAME "msg.bad.var") - (setq name (js2-create-name-node) - nbeg js2-token-beg - nend js2-token-end - end nend) - (js2-define-symbol decl-type js2-ts-string name js2-in-for-init))) - - (when (js2-match-token js2-ASSIGN) - (setq init (js2-parse-assign-expr) - end (js2-node-end init)) - (if (and js2-parse-ide-mode - (or (js2-object-node-p init) - (js2-function-node-p init))) - (js2-record-imenu-functions init name))) - - (when name - (js2-set-face nbeg nend (if (js2-function-node-p init) - 'font-lock-function-name-face - 'font-lock-variable-name-face) - 'record)) - - (setq vi (make-js2-var-init-node :pos kid-pos - :len (- end kid-pos) - :type decl-type)) - (if destructuring - (progn - (if (and (null init) (not js2-in-for-init)) - (js2-report-error "msg.destruct.assign.no.init")) - (setf (js2-var-init-node-target vi) destructuring)) - (setf (js2-var-init-node-target vi) name)) - (setf (js2-var-init-node-initializer vi) init) - (js2-node-add-children vi name destructuring init) - - (js2-block-node-push result vi) - (unless (js2-match-token js2-COMMA) - (setq continue nil))) - - (setf (js2-node-len result) (- end pos)) - result)) - -(defun js2-parse-let (pos &optional stmt-p) - "Parse a let expression or statement. -A let-expression is of the form `let (vars) expr'. -A let-statment is of the form `let (vars) {statements}'. -The third form of let is a variable declaration list, handled -by `js2-parse-variables'." - (let ((pn (make-js2-let-node :pos pos)) - beg vars body) - (if (js2-must-match js2-LP "msg.no.paren.after.let") - (setf (js2-let-node-lp pn) (- js2-token-beg pos))) - (js2-push-scope pn) - (unwind-protect - (progn - (setq vars (js2-parse-variables js2-LET js2-token-beg)) - (if (js2-must-match js2-RP "msg.no.paren.let") - (setf (js2-let-node-rp pn) (- js2-token-beg pos))) - (if (and stmt-p (eq (js2-peek-token) js2-LC)) - ;; let statement - (progn - (js2-consume-token) - (setf beg js2-token-beg ; position stmt at LC - body (js2-parse-statements)) - (js2-must-match js2-RC "msg.no.curly.let") - (setf (js2-node-len body) (- js2-token-end beg) - (js2-node-len pn) (- js2-token-end pos) - (js2-let-node-body pn) body - (js2-node-type pn) js2-LET)) - ;; let expression - (setf body (js2-parse-expr) - (js2-node-len pn) (- (js2-node-end body) pos) - (js2-let-node-body pn) body)) - (js2-node-add-children pn vars body)) - (js2-pop-scope)) - pn)) - -(defsubst js2-define-new-symbol (decl-type name node) - (js2-scope-put-symbol js2-current-scope - name - (make-js2-symbol decl-type name node))) - -(defun js2-define-symbol (decl-type name &optional node ignore-not-in-block) - "Define a symbol in the current scope. -If NODE is non-nil, it is the AST node associated with the symbol." - (let* ((defining-scope (js2-get-defining-scope js2-current-scope name)) - (symbol (if defining-scope - (js2-scope-get-symbol defining-scope name))) - (sdt (if symbol (js2-symbol-decl-type symbol) -1))) - (cond - ((and symbol ; already defined - (or (= sdt js2-CONST) ; old version is const - (= decl-type js2-CONST) ; new version is const - ;; two let-bound vars in this block have same name - (and (= sdt js2-LET) - (eq defining-scope js2-current-scope)))) - (js2-report-error - (cond - ((= sdt js2-CONST) "msg.const.redecl") - ((= sdt js2-LET) "msg.let.redecl") - ((= sdt js2-VAR) "msg.var.redecl") - ((= sdt js2-FUNCTION) "msg.function.redecl") - (t "msg.parm.redecl")) - name)) - - ((= decl-type js2-LET) - (if (and (not ignore-not-in-block) - (or (= (js2-node-type js2-current-scope) js2-IF) - (js2-loop-node-p js2-current-scope))) - (js2-report-error "msg.let.decl.not.in.block") - (js2-define-new-symbol decl-type name node))) - - ((or (= decl-type js2-VAR) - (= decl-type js2-CONST) - (= decl-type js2-FUNCTION)) - (if symbol - (if (and js2-strict-var-redeclaration-warning (= sdt js2-VAR)) - (js2-add-strict-warning "msg.var.redecl" name) - (if (and js2-strict-var-hides-function-arg-warning (= sdt js2-LP)) - (js2-add-strict-warning "msg.var.hides.arg" name))) - (js2-define-new-symbol decl-type name node))) - - ((= decl-type js2-LP) - (if symbol - ;; must be duplicate parameter. Second parameter hides the - ;; first, so go ahead and add the second pararameter - (js2-report-warning "msg.dup.parms" name)) - (js2-define-new-symbol decl-type name node)) - - (t (js2-code-bug))))) - -(defun js2-parse-expr () - (let* ((pn (js2-parse-assign-expr)) - (pos (js2-node-pos pn)) - left - right - op-pos) - (while (js2-match-token js2-COMMA) - (setq op-pos (- js2-token-beg pos)) ; relative - (if (= (js2-peek-token) js2-YIELD) - (js2-report-error "msg.yield.parenthesized")) - (setq right (js2-parse-assign-expr) - left pn - pn (make-js2-infix-node :type js2-COMMA - :pos pos - :len (- js2-ts-cursor pos) - :op-pos op-pos - :left left - :right right)) - (js2-node-add-children pn left right)) - pn)) - -(defun js2-parse-assign-expr () - (let ((tt (js2-peek-token)) - (pos js2-token-beg) - pn - left - right - op-pos) - (if (= tt js2-YIELD) - (js2-parse-return-or-yield tt t) - ;; not yield - parse assignment expression - (setq pn (js2-parse-cond-expr) - tt (js2-peek-token)) - (when (and (<= js2-first-assign tt) - (<= tt js2-last-assign)) - (js2-consume-token) - (setq op-pos (- js2-token-beg pos) ; relative - left pn - right (js2-parse-assign-expr) - pn (make-js2-assign-node :type tt - :pos pos - :len (- (js2-node-end right) pos) - :op-pos op-pos - :left left - :right right)) - (when js2-parse-ide-mode - (js2-highlight-assign-targets pn left right) - (if (or (js2-function-node-p right) - (js2-object-node-p right)) - (js2-record-imenu-functions right left))) - ;; do this last so ide checks above can use absolute positions - (js2-node-add-children pn left right)) - pn))) - -(defun js2-parse-cond-expr () - (let ((pos js2-token-beg) - (pn (js2-parse-or-expr)) - test-expr - if-true - if-false - q-pos - c-pos) - (when (js2-match-token js2-HOOK) - (setq q-pos (- js2-token-beg pos) - if-true (js2-parse-assign-expr)) - (js2-must-match js2-COLON "msg.no.colon.cond") - (setq c-pos (- js2-token-beg pos) - if-false (js2-parse-assign-expr) - test-expr pn - pn (make-js2-cond-node :pos pos - :len (- (js2-node-end if-false) pos) - :test-expr test-expr - :true-expr if-true - :false-expr if-false - :q-pos q-pos - :c-pos c-pos)) - (js2-node-add-children pn test-expr if-true if-false)) - pn)) - -(defun js2-make-binary (type left parser) - "Helper for constructing a binary-operator AST node. -LEFT is the left-side-expression, already parsed, and the -binary operator should have just been matched. -PARSER is a function to call to parse the right operand, -or a `js2-node' struct if it has already been parsed." - (let* ((pos (js2-node-pos left)) - (op-pos (- js2-token-beg pos)) - (right (if (js2-node-p parser) - parser - (funcall parser))) - (pn (make-js2-infix-node :type type - :pos pos - :len (- (js2-node-end right) pos) - :op-pos op-pos - :left left - :right right))) - (js2-node-add-children pn left right) - pn)) - -(defun js2-parse-or-expr () - (let ((pn (js2-parse-and-expr))) - (when (js2-match-token js2-OR) - (setq pn (js2-make-binary js2-OR - pn - 'js2-parse-or-expr))) - pn)) - -(defun js2-parse-and-expr () - (let ((pn (js2-parse-bit-or-expr))) - (when (js2-match-token js2-AND) - (setq pn (js2-make-binary js2-AND - pn - 'js2-parse-and-expr))) - pn)) - -(defun js2-parse-bit-or-expr () - (let ((pn (js2-parse-bit-xor-expr))) - (while (js2-match-token js2-BITOR) - (setq pn (js2-make-binary js2-BITOR - pn - 'js2-parse-bit-xor-expr))) - pn)) - -(defun js2-parse-bit-xor-expr () - (let ((pn (js2-parse-bit-and-expr))) - (while (js2-match-token js2-BITXOR) - (setq pn (js2-make-binary js2-BITXOR - pn - 'js2-parse-bit-and-expr))) - pn)) - -(defun js2-parse-bit-and-expr () - (let ((pn (js2-parse-eq-expr))) - (while (js2-match-token js2-BITAND) - (setq pn (js2-make-binary js2-BITAND - pn - 'js2-parse-eq-expr))) - pn)) - -(defconst js2-parse-eq-ops - (list js2-EQ js2-NE js2-SHEQ js2-SHNE)) - -(defun js2-parse-eq-expr () - (let ((pn (js2-parse-rel-expr)) - tt) - (while (memq (setq tt (js2-peek-token)) js2-parse-eq-ops) - (js2-consume-token) - (setq pn (js2-make-binary tt - pn - 'js2-parse-rel-expr))) - pn)) - -(defconst js2-parse-rel-ops - (list js2-IN js2-INSTANCEOF js2-LE js2-LT js2-GE js2-GT)) - -(defun js2-parse-rel-expr () - (let ((pn (js2-parse-shift-expr)) - (continue t) - tt) - (while continue - (setq tt (js2-peek-token)) - (cond - ((and js2-in-for-init (= tt js2-IN)) - (setq continue nil)) - ((memq tt js2-parse-rel-ops) - (js2-consume-token) - (setq pn (js2-make-binary tt pn 'js2-parse-shift-expr))) - (t - (setq continue nil)))) - pn)) - -(defconst js2-parse-shift-ops - (list js2-LSH js2-URSH js2-RSH)) - -(defun js2-parse-shift-expr () - (let ((pn (js2-parse-add-expr)) - tt - (continue t)) - (while continue - (setq tt (js2-peek-token)) - (if (memq tt js2-parse-shift-ops) - (progn - (js2-consume-token) - (setq pn (js2-make-binary tt pn 'js2-parse-add-expr))) - (setq continue nil))) - pn)) - -(defun js2-parse-add-expr () - (let ((pn (js2-parse-mul-expr)) - tt - (continue t)) - (while continue - (setq tt (js2-peek-token)) - (if (or (= tt js2-ADD) (= tt js2-SUB)) - (progn - (js2-consume-token) - (setq pn (js2-make-binary tt pn 'js2-parse-mul-expr))) - (setq continue nil))) - pn)) - -(defconst js2-parse-mul-ops - (list js2-MUL js2-DIV js2-MOD)) - -(defun js2-parse-mul-expr () - (let ((pn (js2-parse-unary-expr)) - tt - (continue t)) - (while continue - (setq tt (js2-peek-token)) - (if (memq tt js2-parse-mul-ops) - (progn - (js2-consume-token) - (setq pn (js2-make-binary tt pn 'js2-parse-unary-expr))) - (setq continue nil))) - pn)) - -(defsubst js2-make-unary (type parser &rest args) - "Make a unary node of type TYPE. -PARSER is either a node (for postfix operators) or a function to call -to parse the operand (for prefix operators)." - (let* ((pos js2-token-beg) - (postfix (js2-node-p parser)) - (expr (if postfix - parser - (apply parser args))) - end - pn) - (if postfix ; e.g. i++ - (setq pos (js2-node-pos expr) - end js2-token-end) - (setq end (js2-node-end expr))) - (setq pn (make-js2-unary-node :type type - :pos pos - :len (- end pos) - :operand expr)) - (js2-node-add-children pn expr) - pn)) - -(defconst js2-incrementable-node-types - (list js2-NAME js2-GETPROP js2-GETELEM js2-GET_REF js2-CALL) - "Node types that can be the operand of a ++ or -- operator.") - -(defsubst js2-check-bad-inc-dec (tt beg end unary) - (unless (memq (js2-node-type (js2-unary-node-operand unary)) - js2-incrementable-node-types) - (js2-report-error (if (= tt js2-INC) - "msg.bad.incr" - "msg.bad.decr") - nil beg (- end beg)))) - -(defun js2-parse-unary-expr () - (let ((tt (js2-peek-token)) - pn expr beg end) - (cond - ((or (= tt js2-VOID) - (= tt js2-NOT) - (= tt js2-BITNOT) - (= tt js2-TYPEOF)) - (js2-consume-token) - (js2-make-unary tt 'js2-parse-unary-expr)) - - ((= tt js2-ADD) - (js2-consume-token) - ;; Convert to special POS token in decompiler and parse tree - (js2-make-unary js2-POS 'js2-parse-unary-expr)) - - ((= tt js2-SUB) - (js2-consume-token) - ;; Convert to special NEG token in decompiler and parse tree - (js2-make-unary js2-NEG 'js2-parse-unary-expr)) - - ((or (= tt js2-INC) - (= tt js2-DEC)) - (js2-consume-token) - (prog1 - (setq beg js2-token-beg - end js2-token-end - expr (js2-make-unary tt 'js2-parse-member-expr t)) - (js2-check-bad-inc-dec tt beg end expr))) - - ((= tt js2-DELPROP) - (js2-consume-token) - (js2-make-unary js2-DELPROP 'js2-parse-unary-expr)) - - ((= tt js2-ERROR) - (js2-consume-token) - (make-js2-error-node)) ; try to continue - - ((and (= tt js2-LT) - js2-compiler-xml-available) - ;; XML stream encountered in expression. - (js2-consume-token) - (js2-parse-member-expr-tail t (js2-parse-xml-initializer))) - (t - (setq pn (js2-parse-member-expr t) - ;; Don't look across a newline boundary for a postfix incop. - tt (js2-peek-token-or-eol)) - (when (or (= tt js2-INC) (= tt js2-DEC)) - (js2-consume-token) - (setf expr pn - pn (js2-make-unary tt expr)) - (js2-node-set-prop pn 'postfix t) - (js2-check-bad-inc-dec tt js2-token-beg js2-token-end pn)) - pn)))) - -(defun js2-parse-xml-initializer () - "Parse an E4X XML initializer. -I'm parsing it the way Rhino parses it, but without the tree-rewriting. -Then I'll postprocess the result, depending on whether we're in IDE -mode or codegen mode, and generate the appropriate rewritten AST. -IDE mode uses a rich AST that models the XML structure. Codegen mode -just concatenates everything and makes a new XML or XMLList out of it." - (let ((tt (js2-get-first-xml-token)) - pn-xml - pn - expr - kids - expr-pos - (continue t) - (first-token t)) - (when (not (or (= tt js2-XML) (= tt js2-XMLEND))) - (js2-report-error "msg.syntax")) - (setq pn-xml (make-js2-xml-node)) - (while continue - (if first-token - (setq first-token nil) - (setq tt (js2-get-next-xml-token))) - (cond - ;; js2-XML means we found a {expr} in the XML stream. - ;; The js2-ts-string is the XML up to the left-curly. - ((= tt js2-XML) - (push (make-js2-string-node :pos js2-token-beg - :len (- js2-ts-cursor js2-token-beg)) - kids) - (js2-must-match js2-LC "msg.syntax") - (setq expr-pos js2-ts-cursor - expr (if (eq (js2-peek-token) js2-RC) - (make-js2-empty-expr-node :pos expr-pos) - (js2-parse-expr))) - (js2-must-match js2-RC "msg.syntax") - (setq pn (make-js2-xml-js-expr-node :pos (js2-node-pos expr) - :len (js2-node-len expr) - :expr expr)) - (js2-node-add-children pn expr) - (push pn kids)) - - ;; a js2-XMLEND token means we hit the final close-tag. - ((= tt js2-XMLEND) - (push (make-js2-string-node :pos js2-token-beg - :len (- js2-ts-cursor js2-token-beg)) - kids) - (dolist (kid (nreverse kids)) - (js2-block-node-push pn-xml kid)) - (setf (js2-node-len pn-xml) (- js2-ts-cursor - (js2-node-pos pn-xml)) - continue nil)) - (t - (js2-report-error "msg.syntax") - (setq continue nil)))) - pn-xml)) - - -(defun js2-parse-argument-list () - "Parse an argument list and return it as a lisp list of nodes. -Returns the list in reverse order. Consumes the right-paren token." - (let (result) - (unless (js2-match-token js2-RP) - (loop do - (if (= (js2-peek-token) js2-YIELD) - (js2-report-error "msg.yield.parenthesized")) - (push (js2-parse-assign-expr) result) - while - (js2-match-token js2-COMMA)) - (js2-must-match js2-RP "msg.no.paren.arg") - result))) - -(defun js2-parse-member-expr (&optional allow-call-syntax) - (let ((tt (js2-peek-token)) - pn - pos - target - args - beg - end - init - tail) - (if (/= tt js2-NEW) - (setq pn (js2-parse-primary-expr)) - ;; parse a 'new' expression - (js2-consume-token) - (setq pos js2-token-beg - beg pos - target (js2-parse-member-expr) - end (js2-node-end target) - pn (make-js2-new-node :pos pos - :target target - :len (- end pos))) - (js2-node-add-children pn target) - (when (js2-match-token js2-LP) - ;; Add the arguments to pn, if any are supplied. - (setf beg pos ; start of "new" keyword - pos js2-token-beg - args (nreverse (js2-parse-argument-list)) - (js2-new-node-args pn) args - end js2-token-end - (js2-new-node-lp pn) (- pos beg) - (js2-new-node-rp pn) (- end 1 beg)) - (apply #'js2-node-add-children pn args)) - - (when (and js2-allow-rhino-new-expr-initializer - (js2-match-token js2-LC)) - (setf init (js2-parse-object-literal) - end (js2-node-end init) - (js2-new-node-initializer pn) init) - (js2-node-add-children pn init)) - - (setf (js2-node-len pn) (- beg pos))) ; end outer if - - (js2-parse-member-expr-tail allow-call-syntax pn))) - -(defun js2-parse-member-expr-tail (allow-call-syntax pn) - "Parse a chain of property/array accesses or function calls. -Includes parsing for E4X operators like `..' and `.@'. -If ALLOW-CALL-SYNTAX is nil, stops when we encounter a left-paren. -Returns an expression tree that includes PN, the parent node." - (let ((beg (js2-node-pos pn)) - tt - (continue t)) - (while continue - (setq tt (js2-peek-token)) - (cond - ((or (= tt js2-DOT) (= tt js2-DOTDOT)) - (setq pn (js2-parse-property-access tt pn))) - - ((= tt js2-DOTQUERY) - (setq pn (js2-parse-dot-query pn))) - - ((= tt js2-LB) - (setq pn (js2-parse-element-get pn))) - - ((= tt js2-LP) - (if allow-call-syntax - (setq pn (js2-parse-function-call pn)) - (setq continue nil))) - (t - (setq continue nil)))) - (if (>= js2-highlight-level 2) - (js2-parse-highlight-member-expr-node pn)) - pn)) - -(defun js2-parse-dot-query (pn) - "Parse a dot-query expression, e.g. foo.bar.(@name == 2) -Last token parsed must be `js2-DOTQUERY'." - (let ((pos (js2-node-pos pn)) - op-pos - expr - end) - (js2-consume-token) - (js2-must-have-xml) - (js2-set-requires-activation) - (setq op-pos js2-token-beg - expr (js2-parse-expr) - end (js2-node-end expr) - pn (make-js2-xml-dot-query-node :left pn - :pos pos - :op-pos op-pos - :right expr)) - (js2-node-add-children pn - (js2-xml-dot-query-node-left pn) - (js2-xml-dot-query-node-right pn)) - (if (js2-must-match js2-RP "msg.no.paren") - (setf (js2-xml-dot-query-node-rp pn) js2-token-beg - end js2-token-end)) - (setf (js2-node-len pn) (- end pos)) - pn)) - -(defun js2-parse-element-get (pn) - "Parse an element-get expression, e.g. foo[bar]. -Last token parsed must be `js2-RB'." - (let ((lb js2-token-beg) - (pos (js2-node-pos pn)) - rb - expr) - (js2-consume-token) - (setq expr (js2-parse-expr)) - (if (js2-must-match js2-RB "msg.no.bracket.index") - (setq rb js2-token-beg)) - (setq pn (make-js2-elem-get-node :target pn - :pos pos - :element expr - :lb (js2-relpos lb pos) - :rb (js2-relpos rb pos) - :len (- js2-token-end pos))) - (js2-node-add-children pn - (js2-elem-get-node-target pn) - (js2-elem-get-node-element pn)) - pn)) - -(defun js2-parse-function-call (pn) - (let (args - (pos (js2-node-pos pn))) - (js2-consume-token) - (setq pn (make-js2-call-node :pos pos - :target pn - :lp (- js2-token-beg pos))) - (js2-node-add-children pn (js2-call-node-target pn)) - - ;; Add the arguments to pn, if any are supplied. - (setf args (nreverse (js2-parse-argument-list)) - (js2-call-node-rp pn) (- js2-token-beg pos) - (js2-call-node-args pn) args) - (apply #'js2-node-add-children pn args) - - (setf (js2-node-len pn) (- js2-ts-cursor pos)) - pn)) - -(defun js2-parse-property-access (tt pn) - "Parse a property access, XML descendants access, or XML attr access." - (let ((member-type-flags 0) - (dot-pos js2-token-beg) - (dot-len (if (= tt js2-DOTDOT) 2 1)) - name - ref ; right side of . or .. operator - result) - (js2-consume-token) - (when (= tt js2-DOTDOT) - (js2-must-have-xml) - (setq member-type-flags js2-descendants-flag)) - (if (not js2-compiler-xml-available) - (progn - (js2-must-match-prop-name "msg.no.name.after.dot") - (setq name (js2-create-name-node t js2-GETPROP) - result (make-js2-prop-get-node :left pn - :pos js2-token-beg - :right name - :len (- js2-token-end - js2-token-beg))) - (js2-node-add-children result pn name) - result) - ;; otherwise look for XML operators - (setf result (if (= tt js2-DOT) - (make-js2-prop-get-node) - (make-js2-infix-node :type js2-DOTDOT)) - (js2-node-pos result) (js2-node-pos pn) - (js2-infix-node-op-pos result) dot-pos - (js2-infix-node-left result) pn ; do this after setting position - tt (js2-next-token)) - (cond - ;; needed for generator.throw() - ((= tt js2-THROW) - (js2-save-name-token-data js2-token-beg "throw") - (setq ref (js2-parse-property-name nil js2-ts-string member-type-flags))) - - ;; handles: name, ns::name, ns::*, ns::[expr] - ((js2-valid-prop-name-token tt) - (setq ref (js2-parse-property-name -1 js2-ts-string member-type-flags))) - - ;; handles: *, *::name, *::*, *::[expr] - ((= tt js2-MUL) - (js2-save-name-token-data js2-token-beg "*") - (setq ref (js2-parse-property-name nil "*" member-type-flags))) - - ;; handles: '@attr', '@ns::attr', '@ns::*', '@ns::[expr]', etc. - ((= tt js2-XMLATTR) - (setq result (js2-parse-attribute-access))) - - (t - (js2-report-error "msg.no.name.after.dot" nil dot-pos dot-len))) - - (if ref - (setf (js2-node-len result) (- (js2-node-end ref) - (js2-node-pos result)) - (js2-infix-node-right result) ref)) - (if (js2-infix-node-p result) - (js2-node-add-children result - (js2-infix-node-left result) - (js2-infix-node-right result))) - result))) - -(defun js2-parse-attribute-access () - "Parse an E4X XML attribute expression. -This includes expressions of the forms: - - @attr @ns::attr @ns::* - @* @*::attr @*::* - @[expr] @*::[expr] @ns::[expr] - -Called if we peeked an '@' token." - (let ((tt (js2-next-token)) - (at-pos js2-token-beg)) - (cond - ;; handles: @name, @ns::name, @ns::*, @ns::[expr] - ((js2-valid-prop-name-token tt) - (js2-parse-property-name at-pos js2-ts-string 0)) - - ;; handles: @*, @*::name, @*::*, @*::[expr] - ((= tt js2-MUL) - (js2-save-name-token-data js2-token-beg "*") - (js2-parse-property-name js2-token-beg "*" 0)) - - ;; handles @[expr] - ((= tt js2-LB) - (js2-parse-xml-elem-ref at-pos)) - - (t - (js2-report-error "msg.no.name.after.xmlAttr") - ;; Avoid cascaded errors that happen if we make an error node here. - (js2-save-name-token-data js2-token-beg "") - (js2-parse-property-name js2-token-beg "" 0))))) - -(defun js2-parse-property-name (at-pos s member-type-flags) - "Check if :: follows name in which case it becomes qualified name. - -AT-POS is a natural number if we just read an '@' token, else nil. -S is the name or string that was matched: an identifier, 'throw' or '*'. -MEMBER-TYPE-FLAGS is a bit set tracking whether we're a '.' or '..' child. - -Returns a `js2-xml-ref-node' if it's an attribute access, a child of a '..' -operator, or the name is followed by ::. For a plain name, returns a -`js2-name-node'. Returns a `js2-error-node' for malformed XML expressions." - (let ((pos (or at-pos js2-token-beg)) - colon-pos - (name (js2-create-name-node t js2-current-token)) - ns - tt - ref - pn) - (catch 'return - (when (js2-match-token js2-COLONCOLON) - (setq ns name - colon-pos js2-token-beg - tt (js2-next-token)) - (cond - ;; handles name::name - ((js2-valid-prop-name-token tt) - (setq name (js2-create-name-node))) - - ;; handles name::* - ((= tt js2-MUL) - (js2-save-name-token-data js2-token-beg "*") - (setq name (js2-create-name-node))) - - ;; handles name::[expr] - ((= tt js2-LB) - (throw 'return (js2-parse-xml-elem-ref at-pos ns colon-pos))) - - (t - (js2-report-error "msg.no.name.after.coloncolon")))) - - (if (and (null ns) (zerop member-type-flags)) - name - (prog1 - (setq pn - (make-js2-xml-prop-ref-node :pos pos - :len (- (js2-node-end name) pos) - :at-pos at-pos - :colon-pos colon-pos - :propname name)) - (js2-node-add-children pn name)))))) - -(defun js2-parse-xml-elem-ref (at-pos &optional namespace colon-pos) - "Parse the [expr] portion of an xml element reference. -For instance, @[expr], @*::[expr], or ns::[expr]." - (let* ((lb js2-token-beg) - (pos (or at-pos lb)) - rb - (expr (js2-parse-expr)) - (end (js2-node-end expr)) - pn) - (if (js2-must-match js2-RB "msg.no.bracket.index") - (setq rb js2-token-beg - end js2-token-end)) - (prog1 - (setq pn - (make-js2-xml-elem-ref-node :pos pos - :len (- end pos) - :namespace namespace - :colon-pos colon-pos - :at-pos at-pos - :expr expr - :lb (js2-relpos lb pos) - :rb (js2-relpos rb pos))) - (js2-node-add-children pn namespace expr)))) - -(defun js2-parse-primary-expr () - "Parses a literal (leaf) expression of some sort. -Includes complex literals such as functions, object-literals, -array-literals, array comprehensions and regular expressions." - (let ((tt-flagged (js2-next-flagged-token)) - pn ; parent node (usually return value) - tt - px-pos ; paren-expr pos - len - flags ; regexp flags - expr) - (setq tt js2-current-token) - (cond - ((= tt js2-FUNCTION) - (js2-parse-function 'FUNCTION_EXPRESSION)) - - ((= tt js2-LB) - (js2-parse-array-literal)) - - ((= tt js2-LC) - (js2-parse-object-literal)) - - ((= tt js2-LET) - (js2-parse-let js2-token-beg)) - - ((= tt js2-LP) - (setq px-pos js2-token-beg - expr (js2-parse-expr)) - (js2-must-match js2-RP "msg.no.paren") - (setq pn (make-js2-paren-node :pos px-pos - :expr expr - :len (- js2-token-end px-pos))) - (js2-node-add-children pn (js2-paren-node-expr pn)) - pn) - - ((= tt js2-XMLATTR) - (js2-must-have-xml) - (js2-parse-attribute-access)) - - ((= tt js2-NAME) - (js2-parse-name tt-flagged tt)) - - ((= tt js2-NUMBER) - (make-js2-number-node)) - - ((= tt js2-STRING) - (prog1 - (make-js2-string-node) - (js2-record-face 'font-lock-string-face))) - - ((or (= tt js2-DIV) (= tt js2-ASSIGN_DIV)) - ;; Got / or /= which in this context means a regexp literal - (setq px-pos js2-token-beg) - (js2-read-regexp tt) - (setq flags js2-ts-regexp-flags - js2-ts-regexp-flags nil) - (prog1 - (make-js2-regexp-node :pos px-pos - :len (- js2-ts-cursor px-pos) - :value js2-ts-string - :flags flags) - (js2-set-face px-pos js2-ts-cursor 'font-lock-string-face 'record))) - - ((or (= tt js2-NULL) - (= tt js2-THIS) - (= tt js2-FALSE) - (= tt js2-TRUE)) - (make-js2-keyword-node :type tt)) - - ((= tt js2-RESERVED) - (js2-report-error "msg.reserved.id") - (make-js2-name-node)) - - ((= tt js2-ERROR) - ;; the scanner or one of its subroutines reported the error. - (make-js2-error-node)) - - ((= tt js2-EOF) - (setq px-pos (point-at-bol) - len (- js2-ts-cursor px-pos)) - (js2-report-error "msg.unexpected.eof" nil px-pos len) - (make-js2-error-node :pos px-pos :len len)) - - (t - (js2-report-error "msg.syntax") - (make-js2-error-node))))) - -(defun js2-parse-name (tt-flagged tt) - (let ((name js2-ts-string) - (name-pos js2-token-beg)) - (if (and (js2-flag-set-p tt-flagged js2-ti-check-label) - (= (js2-peek-token) js2-COLON)) - (prog1 - ;; Do not consume colon, it is used as unwind indicator - ;; to return to statementHelper. - (make-js2-label-node :pos name-pos - :len (- js2-token-end name-pos) - :name name) - (js2-set-face name-pos - js2-token-end - 'font-lock-variable-name-face 'record)) - ;; Otherwise not a label, just a name. Unfortunately peeking - ;; the next token to check for a colon has biffed js2-token-beg - ;; and js2-token-end. We store the name's bounds in buffer vars - ;; and `js2-create-name-node' uses them. - (js2-save-name-token-data name-pos name) - (if js2-compiler-xml-available - (js2-parse-property-name nil name 0) - (js2-create-name-node 'check-activation))))) - -(defsubst js2-parse-warn-trailing-comma (msg pos elems comma-pos) - (js2-add-strict-warning - msg nil - ;; back up from comma to beginning of line or array/objlit - (max (if elems - (js2-node-pos (car elems)) - pos) - (save-excursion - (goto-char comma-pos) - (back-to-indentation) - (point))) - comma-pos)) - -(defun js2-parse-array-literal () - (let ((pos js2-token-beg) - (end js2-token-end) - (after-lb-or-comma t) - after-comma - tt - elems - pn - (continue t)) - (while continue - (setq tt (js2-peek-token)) - (cond - ;; comma - ((= tt js2-COMMA) - (js2-consume-token) - (setq after-comma js2-token-end) - (if (not after-lb-or-comma) - (setq after-lb-or-comma t) - (push nil elems))) - - ;; end of array - ((or (= tt js2-RB) - (= tt js2-EOF)) ; prevent infinite loop - (if (= tt js2-EOF) - (js2-report-error "msg.no.bracket.arg" nil pos) - (js2-consume-token)) - (setq continue nil - end js2-token-end - pn (make-js2-array-node :pos pos - :len (- js2-ts-cursor pos) - :elems (nreverse elems))) - (apply #'js2-node-add-children pn (js2-array-node-elems pn)) - (when after-comma - (js2-parse-warn-trailing-comma "msg.array.trailing.comma" - pos elems after-comma))) - - ;; array comp - ((and (>= js2-language-version 170) - (= tt js2-FOR) ; check for array comprehension - (not after-lb-or-comma) ; "for" can't follow a comma - elems ; must have at least 1 element - (not (cdr elems))) ; but no 2nd element - (setf continue nil - pn (js2-parse-array-comprehension (car elems) pos))) - - ;; another element - (t - (unless after-lb-or-comma - (js2-report-error "msg.no.bracket.arg")) - (push (js2-parse-assign-expr) elems) - (setq after-lb-or-comma nil - after-comma nil)))) - pn)) - -(defun js2-parse-array-comprehension (expr pos) - "Parse a JavaScript 1.7 Array Comprehension. -EXPR is the first expression after the opening left-bracket. -POS is the beginning of the LB token preceding EXPR. -We should have just parsed the 'for' keyword before calling this function." - (let (loops - filter - if-pos - result) - (while (= (js2-peek-token) js2-FOR) - (push (js2-parse-array-comp-loop) loops)) - (when (= (js2-peek-token) js2-IF) - (js2-consume-token) - (setq if-pos (- js2-token-beg pos) ; relative - filter (js2-parse-condition))) - (js2-must-match js2-RB "msg.no.bracket.arg" pos) - (setq result (make-js2-array-comp-node :pos pos - :len (- js2-ts-cursor pos) - :result expr - :loops (nreverse loops) - :filter (car filter) - :lp (js2-relpos (second filter) pos) - :rp (js2-relpos (third filter) pos) - :if-pos if-pos)) - (apply #'js2-node-add-children result expr (car filter) - (js2-array-comp-node-loops result)) - result)) - -(defun js2-parse-array-comp-loop () - "Parse a 'for [each] (foo in bar)' expression in an Array comprehension. -Last token peeked should be the initial FOR." - (let ((pos js2-token-beg) - (pn (make-js2-array-comp-loop-node)) - tt - iter - obj - foreach-p - in-pos - each-pos - lp - rp) - (assert (= (js2-next-token) js2-FOR)) ; consumes token - (js2-push-scope pn) - (unwind-protect - (progn - (when (js2-match-token js2-NAME) - (if (string= js2-ts-string "each") - (progn - (setq foreach-p t - each-pos (- js2-token-beg pos)) ; relative - (js2-record-face 'font-lock-keyword-face)) - (js2-report-error "msg.no.paren.for"))) - - (if (js2-must-match js2-LP "msg.no.paren.for") - (setq lp (- js2-token-beg pos))) - - (setq tt (js2-peek-token)) - (cond - ((or (= tt js2-LB) - (= tt js2-LC)) - ;; handle destructuring assignment - (setq iter (js2-parse-primary-expr))) - - ((js2-valid-prop-name-token tt) - (js2-consume-token) - (setq iter (js2-create-name-node))) - - (t - (js2-report-error "msg.bad.var"))) - - ;; Define as a let since we want the scope of the variable to - ;; be restricted to the array comprehension - (if (js2-name-node-p iter) - (js2-define-symbol js2-LET (js2-name-node-name iter) pn t)) - - (if (js2-must-match js2-IN "msg.in.after.for.name") - (setq in-pos (- js2-token-beg pos))) - - (setq obj (js2-parse-expr)) - (if (js2-must-match js2-RP "msg.no.paren.for.ctrl") - (setq rp (- js2-token-beg pos))) - - (setf (js2-node-pos pn) pos - (js2-node-len pn) (- js2-ts-cursor pos) - (js2-array-comp-loop-node-iterator pn) iter - (js2-array-comp-loop-node-object pn) obj - (js2-array-comp-loop-node-in-pos pn) in-pos - (js2-array-comp-loop-node-each-pos pn) each-pos - (js2-array-comp-loop-node-foreach-p pn) foreach-p - (js2-array-comp-loop-node-lp pn) lp - (js2-array-comp-loop-node-rp pn) rp) - (js2-node-add-children pn iter obj)) - (js2-pop-scope)) - pn)) - -(defun js2-parse-object-literal () - (let ((pos js2-token-beg) - tt - elems - result - after-comma - (continue t)) - (while continue - (setq tt (js2-peek-token)) - (cond - ;; {foo: ...}, {'foo': ...}, {get foo() {...}}, or {set foo(x) {...}} - ((or (js2-valid-prop-name-token tt) - (= tt js2-STRING)) - (setq after-comma nil - result (js2-parse-named-prop tt)) - (if (and (null result) - (not js2-recover-from-parse-errors)) - (setq continue nil) - (push result elems))) - - ;; {12: x} or {10.7: x} - ((= tt js2-NUMBER) - (js2-consume-token) - (setq after-comma nil) - (push (js2-parse-plain-property (make-js2-number-node)) elems)) - - ;; trailing comma - ((= tt js2-RC) - (setq continue nil) - (if after-comma - (js2-parse-warn-trailing-comma "msg.extra.trailing.comma" - pos elems after-comma))) - (t - (js2-report-error "msg.bad.prop") - (unless js2-recover-from-parse-errors - (setq continue nil)))) ; end switch - - (if (js2-match-token js2-COMMA) - (setq after-comma js2-token-end) - (setq continue nil))) ; end loop - - (js2-must-match js2-RC "msg.no.brace.prop") - (setq result (make-js2-object-node :pos pos - :len (- js2-ts-cursor pos) - :elems (nreverse elems))) - (apply #'js2-node-add-children result (js2-object-node-elems result)) - result)) - -(defun js2-parse-named-prop (tt) - "Parse a name, string, or getter/setter object property." - (js2-consume-token) - (let ((string-prop (and (= tt js2-STRING) - (make-js2-string-node))) - expr - (ppos js2-token-beg) - (pend js2-token-end) - (name (js2-create-name-node)) - (prop js2-ts-string)) - - (if (and (= tt js2-NAME) - (= (js2-peek-token) js2-NAME) - (or (string= prop "get") - (string= prop "set"))) - (progn - ;; getter/setter prop - (js2-consume-token) - (js2-set-face ppos pend 'font-lock-keyword-face 'record) ; get/set - (js2-record-face 'font-lock-function-name-face) ; for peeked name - (setq name (js2-create-name-node)) ; discard get/set & use peeked name - (js2-parse-getter-setter-prop ppos name (string= prop "get"))) - - ;; regular prop - (prog1 - (setq expr (js2-parse-plain-property (or string-prop name))) - (js2-set-face ppos pend - (if (js2-function-node-p - (js2-object-prop-node-right expr)) - 'font-lock-function-name-face - 'font-lock-variable-name-face) - 'record))))) - -(defun js2-parse-plain-property (prop) - "Parse a non-getter/setter property in an object literal. -PROP is the node representing the property: a number, name or string." - (js2-must-match js2-COLON "msg.no.colon.prop") - (let* ((pos (js2-node-pos prop)) - (colon (- js2-token-beg pos)) - (expr (js2-parse-assign-expr)) - (result (make-js2-object-prop-node - :pos pos - ;; don't include last consumed token in length - :len (- (+ (js2-node-pos expr) - (js2-node-len expr)) - pos) - :left prop - :right expr - :op-pos colon))) - (js2-node-add-children result prop expr) - result)) - -(defun js2-parse-getter-setter-prop (pos prop get-p) - "Parse getter or setter property in an object literal. -JavaScript syntax is: - - { get foo() {...}, set foo(x) {...} } - -POS is the start position of the `get' or `set' keyword. -PROP is the `js2-name-node' representing the property name. -GET-P is non-nil if the keyword was `get'." - (let ((type (if get-p js2-GET js2-SET)) - result - end - (fn (js2-parse-function 'FUNCTION_EXPRESSION))) - - ;; it has to be an anonymous function, as we already parsed the name - (if (/= (js2-node-type fn) js2-FUNCTION) - (js2-report-error "msg.bad.prop") - (if (plusp (length (js2-function-name fn))) - (js2-report-error "msg.bad.prop"))) - - (js2-node-set-prop fn 'GETTER_SETTER type) ; for codegen - (setq end (js2-node-end fn) - result (make-js2-getter-setter-node :type type - :pos pos - :len (- end pos) - :left prop - :right fn)) - (js2-node-add-children result prop fn) - result)) - -(defun js2-create-name-node (&optional check-activation-p token) - "Create a name node using the token info from last scanned name. -In some cases we need to either synthesize a name node, or we lost -the name token information by peeking. If the TOKEN parameter is -not `js2-NAME', then we use the token info saved in instance vars." - (let ((beg js2-token-beg) - (s js2-ts-string) - name) - (when (/= js2-current-token js2-NAME) - (setq beg (or js2-prev-name-token-start js2-ts-cursor) - s js2-prev-name-token-string - js2-prev-name-token-start nil - js2-prev-name-token-string nil)) - (setq name (make-js2-name-node :pos beg - :name s - :len (length s))) - (if check-activation-p - (js2-check-activation-name s (or token js2-NAME))) - name)) - -(provide 'js2-parse) - -;;; js2-parse.el ends here -;;; js2-indent.el --- indentation for js2-mode -;; -;; Copyright (C) 2008 Steve Yegge -;; Author: Steve Yegge (steve.yegge@gmail.com) -;; Maintainer: Steve Yegge (steve.yegge@gmail.com) - -;; Commentary: -;; -;; This indenter is based on Karl Landström's "javascript.el" indenter. -;; Karl cleverly deduces that the desired indentation level is often a -;; function of paren/bracket/brace nesting depth, which can be determined -;; quickly via the built-in `parse-partial-sexp' function. His indenter -;; then does some equally clever checks to see if we're in the context of a -;; substatement of a possibly braceless statement keyword such as if, while, -;; or finally. This approach yields pretty good results. -;; -;; The indenter is often "wrong", however, and needs to be overridden. -;; The right long-term solution is probably to emulate (or modify) -;; cc-engine, but it's thousands upon thousands of lines of code. Even -;; if you were to assume the accurate parse tree from `js2-parse' is -;; present, indentation is still thousands of lines of code (I've been -;; down that path) to handle every possible syntactic edge case, and in -;; any case, relying on the parse tree is undesirable because parsing is -;; slow. So you might as well go the cc-engine approach, but it's a -;; huge pile of work that I'm just not up for any time soon. -;; -;; In the meantime, the compromise solution is that we offer a -;; "bounce indenter", configured with `js2-bounce-indent-flag', which -;; cycles the current line indent among various likely guess points. -;; This approach is far from perfect, but should at least make it -;; slightly easier to move the line towards its desired indentation -;; when manually overriding Karl's heuristic nesting guesser. -;; -;; I've made miscellaneous tweaks to Karl's code to handle some Ecma -;; extensions such as `let' and Array comprehensions, and will likely -;; make further tweaks to it, but major kudos to Karl for coming up with -;; the initial approach, which packs a lot of punch for so little code. - -;;; Code: - -(defconst js-possibly-braceless-keyword-re - (regexp-opt - '("catch" "do" "else" "finally" "for" "if" "try" "while" "with" "let") - 'words) - "Regular expression matching keywords that are optionally -followed by an opening brace.") - -(defconst js-indent-operator-re - (concat "[-+*/%<>=&^|?:.]\\([^-+*/]\\|$\\)\\|" - (regexp-opt '("in" "instanceof") 'words)) - "Regular expression matching operators that affect indentation -of continued expressions.") - -;; This function has horrible results if you're typing an array -;; such as [[1, 2], [3, 4], [5, 6]]. Bounce indenting -really- sucks -;; in conjunction with electric-indent, so just disabling it. -(defsubst js2-code-at-bol-p () - "Return t if the first character on line is non-whitespace." - nil) -;; (not (memq (char-after (point-at-bol)) -;; '(? ?\t))))) - -(defun js2-insert-and-indent (key) - "Run command bound to key and indent current line. Runs the command -bound to KEY in the global keymap and indents the current line." - (interactive (list (this-command-keys))) - (let ((cmd (lookup-key (current-global-map) key))) - (if (commandp cmd) - (call-interactively cmd))) - ;; don't do the electric keys inside comments or strings, - ;; and don't do bounce-indent with them. - (let ((parse-state (parse-partial-sexp (point-min) (point))) - (js2-bounce-indent-flag (js2-code-at-bol-p))) - (unless (or (nth 3 parse-state) - (nth 4 parse-state)) - (indent-according-to-mode)))) - -(defun js-re-search-forward-inner (regexp &optional bound count) - "Auxiliary function for `js-re-search-forward'." - (let ((parse) - (saved-point (point-min))) - (while (> count 0) - (re-search-forward regexp bound) - (setq parse (parse-partial-sexp saved-point (point))) - (cond ((nth 3 parse) - (re-search-forward - (concat "\\([^\\]\\|^\\)" (string (nth 3 parse))) - (save-excursion (end-of-line) (point)) t)) - ((nth 7 parse) - (forward-line)) - ((or (nth 4 parse) - (and (eq (char-before) ?\/) (eq (char-after) ?\*))) - (re-search-forward "\\*/")) - (t - (setq count (1- count)))) - (setq saved-point (point)))) - (point)) - -(defun js-re-search-forward (regexp &optional bound noerror count) - "Search forward but ignore strings and comments. Invokes -`re-search-forward' but treats the buffer as if strings and -comments have been removed." - (let ((saved-point (point)) - (search-expr - (cond ((null count) - '(js-re-search-forward-inner regexp bound 1)) - ((< count 0) - '(js-re-search-backward-inner regexp bound (- count))) - ((> count 0) - '(js-re-search-forward-inner regexp bound count))))) - (condition-case err - (eval search-expr) - (search-failed - (goto-char saved-point) - (unless noerror - (error (error-message-string err))))))) - -(defun js-re-search-backward-inner (regexp &optional bound count) - "Auxiliary function for `js-re-search-backward'." - (let ((parse) - (saved-point (point-min))) - (while (> count 0) - (re-search-backward regexp bound) - (setq parse (parse-partial-sexp saved-point (point))) - (cond ((nth 3 parse) - (re-search-backward - (concat "\\([^\\]\\|^\\)" (string (nth 3 parse))) - (save-excursion (beginning-of-line) (point)) t)) - ((nth 7 parse) - (goto-char (nth 8 parse))) - ((or (nth 4 parse) - (and (eq (char-before) ?/) (eq (char-after) ?*))) - (re-search-backward "/\\*")) - (t - (setq count (1- count)))))) - (point)) - -(defun js-re-search-backward (regexp &optional bound noerror count) - "Search backward but ignore strings and comments. Invokes -`re-search-backward' but treats the buffer as if strings and -comments have been removed." - (let ((saved-point (point)) - (search-expr - (cond ((null count) - '(js-re-search-backward-inner regexp bound 1)) - ((< count 0) - '(js-re-search-forward-inner regexp bound (- count))) - ((> count 0) - '(js-re-search-backward-inner regexp bound count))))) - (condition-case err - (eval search-expr) - (search-failed - (goto-char saved-point) - (unless noerror - (error (error-message-string err))))))) - -(defun js-looking-at-operator-p () - "Return non-nil if text after point is an operator (that is not -a comma)." - (save-match-data - (and (looking-at js-indent-operator-re) - (or (not (looking-at ":")) - (save-excursion - (and (js-re-search-backward "[?:{]\\|\\<case\\>" nil t) - (looking-at "?"))))))) - -(defun js-continued-expression-p () - "Returns non-nil if the current line continues an expression." - (save-excursion - (back-to-indentation) - (or (js-looking-at-operator-p) - (and (js-re-search-backward "\n" nil t) - (progn - (skip-chars-backward " \t") - (backward-char) - (and (js-looking-at-operator-p) - (and (progn (backward-char) - (not (looking-at "\\*\\|++\\|--\\|/[/*]")))))))))) - -(defun js-end-of-do-while-loop-p () - "Returns non-nil if word after point is `while' of a do-while -statement, else returns nil. A braceless do-while statement -spanning several lines requires that the start of the loop is -indented to the same column as the current line." - (interactive) - (save-excursion - (save-match-data - (when (looking-at "\\s-*\\<while\\>") - (if (save-excursion - (skip-chars-backward "[ \t\n]*}") - (looking-at "[ \t\n]*}")) - (save-excursion - (backward-list) (backward-word 1) (looking-at "\\<do\\>")) - (js-re-search-backward "\\<do\\>" (point-at-bol) t) - (or (looking-at "\\<do\\>") - (let ((saved-indent (current-indentation))) - (while (and (js-re-search-backward "^[ \t]*\\<" nil t) - (/= (current-indentation) saved-indent))) - (and (looking-at "[ \t]*\\<do\\>") - (not (js-re-search-forward - "\\<while\\>" (point-at-eol) t)) - (= (current-indentation) saved-indent))))))))) - -(defun js-ctrl-statement-indentation () - "Returns the proper indentation of the current line if it -starts the body of a control statement without braces, else -returns nil." - (let (forward-sexp-function) ; temporarily unbind it - (save-excursion - (back-to-indentation) - (when (save-excursion - (and (not (js2-same-line (point-min))) - (not (looking-at "{")) - (js-re-search-backward "[[:graph:]]" nil t) - (not (looking-at "[{([]")) - (progn - (forward-char) - ;; scan-sexps sometimes throws an error - (ignore-errors (backward-sexp)) - (when (looking-at "(") (backward-word 1)) - (and (save-excursion - (skip-chars-backward " \t}" (point-at-bol)) - (bolp)) - (looking-at js-possibly-braceless-keyword-re) - (not (js-end-of-do-while-loop-p)))))) - (save-excursion - (goto-char (match-beginning 0)) - (+ (current-indentation) js2-basic-offset)))))) - -(defun js2-indent-in-array-comp (parse-status) - "Return non-nil if we think we're in an array comprehension. -In particular, return the buffer position of the first `for' kwd." - (let ((end (point))) - (when (nth 1 parse-status) - (save-excursion - (goto-char (nth 1 parse-status)) - (when (looking-at "\\[") - (forward-char 1) - (js2-forward-sws) - (if (looking-at "[[{]") - (let (forward-sexp-function) ; use lisp version - (forward-sexp) ; skip destructuring form - (js2-forward-sws) - (if (and (/= (char-after) ?,) ; regular array - (looking-at "for")) - (match-beginning 0))) - ;; to skip arbitrary expressions we need the parser, - ;; so we'll just guess at it. - (if (re-search-forward "[^,]* \\(for\\) " end t) - (match-beginning 1)))))))) - -(defun js2-array-comp-indentation (parse-status for-kwd) - (if (js2-same-line for-kwd) - ;; first continuation line - (save-excursion - (goto-char (nth 1 parse-status)) - (forward-char 1) - (skip-chars-forward " \t") - (current-column)) - (save-excursion - (goto-char for-kwd) - (current-column)))) - -(defun js-proper-indentation (parse-status) - "Return the proper indentation for the current line." - (save-excursion - (back-to-indentation) - (let ((ctrl-stmt-indent (js-ctrl-statement-indentation)) - (same-indent-p (looking-at "[]})]\\|\\<case\\>\\|\\<default\\>")) - (continued-expr-p (js-continued-expression-p)) - (bracket (nth 1 parse-status)) - beg) - (cond - ;; indent array comprehension continuation lines specially - ((and bracket - (not (js2-same-line bracket)) - (setq beg (js2-indent-in-array-comp parse-status)) - (>= (point) (save-excursion - (goto-char beg) - (point-at-bol)))) ; at or after first loop? - (js2-array-comp-indentation parse-status beg)) - - (ctrl-stmt-indent) - - (bracket - (goto-char bracket) - (cond - ((looking-at "[({[][ \t]*\\(/[/*]\\|$\\)") - (let ((p (parse-partial-sexp (point-at-bol) (point)))) - (when (save-excursion (skip-chars-backward " \t)") - (looking-at ")")) - (backward-list)) - (if (nth 1 p) - (progn (goto-char (1+ (nth 1 p))) - (skip-chars-forward " \t")) - (back-to-indentation)) - (cond (same-indent-p - (current-column)) - (continued-expr-p - (+ (current-column) (* 2 js2-basic-offset))) - (t - (+ (current-column) js2-basic-offset))))) - (t - (unless same-indent-p - (forward-char) - (skip-chars-forward " \t")) - (current-column)))) - - (continued-expr-p js2-basic-offset) - (t 0))))) - -(defun js2-lineup-comment (parse-status) - "Indent a multi-line block comment continuation line." - (let* ((beg (nth 8 parse-status)) - (first-line (js2-same-line beg)) - (offset (save-excursion - (goto-char beg) - (if (looking-at "/\\*") - (+ 1 (current-column)) - 0)))) - (unless first-line - (indent-line-to offset)))) - -(defun js2-backward-sws () - "Move backward through whitespace and comments." - (interactive) - (while (forward-comment -1))) - -(defun js2-forward-sws () - "Move forward through whitespace and comments." - (interactive) - (while (forward-comment 1))) - -(defsubst js2-current-indent (&optional pos) - "Return column of indentation on current line. -If POS is non-nil, go to that point and return indentation for that line." - (save-excursion - (if pos - (goto-char pos)) - (back-to-indentation) - (current-column))) - -(defsubst js2-arglist-close () - "Return non-nil if we're on a line beginning with a close-paren/brace." - (save-match-data - (save-excursion - (goto-char (point-at-bol)) - (js2-forward-sws) - (looking-at "[])}]")))) - -(defsubst js2-indent-looks-like-label-p () - (goto-char (point-at-bol)) - (js2-forward-sws) - (looking-at (concat js2-mode-identifier-re ":"))) - -(defun js2-indent-in-objlit-p (parse-status) - "Return non-nil if this looks like an object-literal entry." - (let ((start (nth 1 parse-status))) - (and - start - (save-excursion - (and (zerop (forward-line -1)) - (not (< (point) start)) ; crossed a {} boundary - (js2-indent-looks-like-label-p))) - (save-excursion - (js2-indent-looks-like-label-p))))) - -;; if prev line looks like foobar({ then we're passing an object -;; literal to a function call, and people pretty much always want to -;; de-dent back to the previous line, so move the 'basic-offset' -;; position to the front. -(defsubst js2-indent-objlit-arg-p (parse-status) - (save-excursion - (back-to-indentation) - (js2-backward-sws) - (and (eq (1- (point)) (nth 1 parse-status)) - (eq (char-before) ?{) - (progn - (forward-char -1) - (skip-chars-backward " \t") - (eq (char-before) ?\())))) - -(defsubst js2-indent-case-block-p () - (save-excursion - (back-to-indentation) - (js2-backward-sws) - (goto-char (point-at-bol)) - (skip-chars-forward " \t") - (save-match-data - (looking-at "case\\s-.+:")))) - -(defsubst js2-syntax-bol () - "Return the point at the first non-whitespace char on the line. -Returns `point-at-bol' if the line is empty." - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (point))) - -(defun js2-bounce-indent (normal-col parse-status) - "Cycle among alternate computed indentation positions. -PARSE-STATUS is the result of `parse-partial-sexp' from the beginning -of the buffer to the current point. NORMAL-COL is the indentation -column computed by the heuristic guesser based on current paren, -bracket, brace and statement nesting." - (let ((cur-indent (js2-current-indent)) - (old-buffer-undo-list buffer-undo-list) - ;; Emacs 21 only has `count-lines', not `line-number-at-pos' - (current-line (save-excursion - (forward-line 0) ; move to bol - (1+ (count-lines (point-min) (point))))) - positions - pos - anchor - arglist-cont - same-indent - prev-line-col - basic-offset - computed-pos) - ;; temporarily don't record undo info, if user requested this - (if js2-mode-indent-inhibit-undo - (setq buffer-undo-list t)) - (unwind-protect - (progn - ;; first likely point: indent from beginning of previous code line - (push (setq basic-offset - (+ (save-excursion - (back-to-indentation) - (js2-backward-sws) - (back-to-indentation) - (setq prev-line-col (current-column))) - js2-basic-offset)) - positions) - - ;; second likely point: indent from assign-expr RHS. This - ;; is just a crude guess based on finding " = " on the previous - ;; line containing actual code. - (setq pos (save-excursion - (save-match-data - (forward-line -1) - (goto-char (point-at-bol)) - (when (re-search-forward "\\s-+\\(=\\)\\s-+" - (point-at-eol) t) - (goto-char (match-end 1)) - (skip-chars-forward " \t\r\n") - (current-column))))) - (when pos - (incf pos js2-basic-offset) - (unless (member pos positions) - (push pos positions))) - - ;; third likely point: same indent as previous line of code. - ;; Make it the first likely point if we're not on an - ;; arglist-close line and previous line ends in a comma, or - ;; both this line and prev line look like object-literal - ;; elements. - (setq pos (save-excursion - (goto-char (point-at-bol)) - (js2-backward-sws) - (back-to-indentation) - (prog1 - (current-column) - ;; while we're here, look for trailing comma - (if (save-excursion - (goto-char (point-at-eol)) - (js2-backward-sws) - (eq (char-before) ?,)) - (setq arglist-cont (1- (point))))))) - (when pos - (if (and (or arglist-cont - (js2-indent-in-objlit-p parse-status)) - (not (js2-arglist-close))) - (setq same-indent pos)) - (unless (member pos positions) - (push pos positions))) - - ;; fourth likely position: first preceding code with less indentation - ;; than the immediately preceding code line. - (setq pos (save-excursion - (js2-backward-sws) - (back-to-indentation) - (setq anchor (current-column)) - (while (and (zerop (forward-line -1)) - (>= (progn - (back-to-indentation) - (current-column)) - anchor))) - (setq pos (current-column)))) - (unless (member pos positions) - (push pos positions)) - - ;; put nesting-heuristic position first in list, sort rest - (setq positions (nreverse (sort positions '<))) - (setq positions (cons normal-col (delete normal-col positions))) - - ;; comma-list continuation lines: prev line indent takes precedence - (if same-indent - (setq positions - (cons same-indent - (sort (delete same-indent positions) '<)))) - - ;; common special cases where we want to indent in from previous line - (if (or (js2-indent-case-block-p) - (js2-indent-objlit-arg-p parse-status)) - (setq positions - (cons basic-offset - (delete basic-offset positions)))) - - ;; record whether we're already sitting on one of the alternatives - (setq pos (member cur-indent positions)) - (cond - ;; case 0: we're one one of the alternatives and this is the - ;; first time they've pressed TAB on this line (best-guess). - ((and js2-mode-indent-ignore-first-tab - pos - ;; first time pressing TAB on this line? - (not (eq js2-mode-last-indented-line current-line))) - ;; do nothing - (setq computed-pos nil)) - ;; case 1: only one computed position => use it - ((null (cdr positions)) - (setq computed-pos 0)) - ;; case 2: not on any of the computed spots => use main spot - ((not pos) - (setq computed-pos 0)) - ;; case 3: on last position: cycle to first position - ((null (cdr pos)) - (setq computed-pos 0)) - ;; case 4: on intermediate position: cycle to next position - (t - (setq computed-pos (js2-position (second pos) positions)))) - - ;; see if any hooks want to indent; otherwise we do it - (loop with result = nil - for hook in js2-indent-hook - while (null result) - do - (setq result (funcall hook positions computed-pos)) - finally do - (unless (or result (null computed-pos)) - (indent-line-to (nth computed-pos positions))))) - - ;; finally - (if js2-mode-indent-inhibit-undo - (setq buffer-undo-list old-buffer-undo-list)) - ;; see commentary for `js2-mode-last-indented-line' - (setq js2-mode-last-indented-line current-line)))) - -(defsubst js2-1-line-comment-continuation-p () - "Return t if we're in a 1-line comment continuation. -If so, we don't ever want to use bounce-indent." - (save-excursion - (save-match-data - (and (progn - (forward-line 0) - (looking-at "\\s-*//")) - (progn - (forward-line -1) - (forward-line 0) - (when (looking-at "\\s-*$") - (js2-backward-sws) - (forward-line 0)) - (looking-at "\\s-*//")))))) - -(defun js2-indent-line () - "Indent the current line as JavaScript source text." - (interactive) - (let (parse-status - current-indent - offset - indent-col - moved - ;; don't whine about errors/warnings when we're indenting. - ;; This has to be set before calling parse-partial-sexp below. - (inhibit-point-motion-hooks t)) - (setq parse-status (save-excursion - (parse-partial-sexp (point-min) - (point-at-bol))) - offset (- (point) (save-excursion - (back-to-indentation) - (setq current-indent (current-column)) - (point)))) - (js2-with-underscore-as-word-syntax - (if (nth 4 parse-status) - (js2-lineup-comment parse-status) - (setq indent-col (js-proper-indentation parse-status)) - ;; see comments below about js2-mode-last-indented-line - (when - (cond - ;; bounce-indenting is disabled during electric-key indent. - ;; It doesn't work well on first line of buffer. - ((and js2-bounce-indent-flag - (not (js2-same-line (point-min))) - (not (js2-1-line-comment-continuation-p))) - (js2-bounce-indent indent-col parse-status) - (setq moved t)) - ;; just indent to the guesser's likely spot - ((/= current-indent indent-col) - (indent-line-to indent-col) - (setq moved t))) - (when (and moved (plusp offset)) - (forward-char offset))))))) - -(defun js2-indent-region (start end) - "Indent the region, but don't use bounce indenting." - (let ((js2-bounce-indent-flag nil) - (indent-region-function nil)) - (indent-region start end nil))) ; nil for byte-compiler - -(provide 'js2-indent) - -;;; js2-indent.el ends here - -(eval-when-compile - (require 'cl)) - -(require 'imenu) -(require 'cc-cmds) ; for `c-fill-paragraph' - - -;;;###autoload (add-to-list 'auto-mode-alist '("\\.js$" . js2-mode)) - -;;;###autoload -(defun js2-mode () - "Major mode for editing JavaScript code." - (interactive) - (js2-mode-check-compat) - (kill-all-local-variables) - (set-syntax-table js2-mode-syntax-table) - (use-local-map js2-mode-map) - (setq major-mode 'js2-mode - mode-name "JavaScript-IDE" - comment-start "//" ; used by comment-region; don't change it - comment-end "") - (setq local-abbrev-table js2-mode-abbrev-table) - (set (make-local-variable 'max-lisp-eval-depth) - (max max-lisp-eval-depth 3000)) - (set (make-local-variable 'indent-line-function) #'js2-indent-line) - (set (make-local-variable 'indent-region-function) #'js2-indent-region) - (set (make-local-variable 'fill-paragraph-function) #'js2-fill-paragraph) - (set (make-local-variable 'before-save-hook) #'js2-before-save) - (set (make-local-variable 'next-error-function) #'js2-next-error) - (set (make-local-variable 'beginning-of-defun-function) #'js2-beginning-of-defun) - (set (make-local-variable 'end-of-defun-function) #'js2-end-of-defun) - ;; We un-confuse `parse-partial-sexp' by setting syntax-table properties - ;; for characters inside regexp literals. - (set (make-local-variable 'parse-sexp-lookup-properties) t) - ;; this is necessary to make `show-paren-function' work properly - (set (make-local-variable 'parse-sexp-ignore-comments) t) - ;; needed for M-x rgrep, among other things - (put 'js2-mode 'find-tag-default-function #'js2-mode-find-tag) - - ;; some variables needed by cc-engine for paragraph-fill, etc. - (setq c-buffer-is-cc-mode t - c-comment-prefix-regexp js2-comment-prefix-regexp - c-paragraph-start js2-paragraph-start - c-paragraph-separate "$" - comment-start-skip js2-comment-start-skip - c-syntactic-ws-start js2-syntactic-ws-start - c-syntactic-ws-end js2-syntactic-ws-end - c-syntactic-eol js2-syntactic-eol) - (if js2-emacs22 - (c-setup-paragraph-variables)) - - ;; We do our own syntax highlighting based on the parse tree. - ;; However, we want minor modes that add keywords to highlight properly - ;; (examples: doxymacs, column-marker). We do this by not letting - ;; font-lock unfontify anything, and telling it to fontify after we - ;; re-parse and re-highlight the buffer. (We currently don't do any - ;; work with regions other than the whole buffer.) - (dolist (var '(font-lock-unfontify-buffer-function - font-lock-unfontify-region-function)) - (set (make-local-variable var) (lambda (&rest args) t))) - - ;; Don't let font-lock do syntactic (string/comment) fontification. - (set (make-local-variable #'font-lock-syntactic-face-function) - (lambda (state) nil)) - - ;; Experiment: make reparse-delay longer for longer files. - (if (plusp js2-dynamic-idle-timer-adjust) - (setq js2-idle-timer-delay - (* js2-idle-timer-delay - (/ (point-max) js2-dynamic-idle-timer-adjust)))) - - (add-hook 'change-major-mode-hook #'js2-mode-exit nil t) - (add-hook 'after-change-functions #'js2-mode-edit nil t) - (setq imenu-create-index-function #'js2-mode-create-imenu-index) - (imenu-add-to-menubar (concat "IM-" mode-name)) - (when js2-mirror-mode - (js2-enter-mirror-mode)) - (add-to-invisibility-spec '(js2-outline . t)) - (set (make-local-variable 'line-move-ignore-invisible) t) - (set (make-local-variable 'forward-sexp-function) #'js2-mode-forward-sexp) - (setq js2-mode-functions-hidden nil - js2-mode-comments-hidden nil - js2-mode-buffer-dirty-p t - js2-mode-parsing nil) - (js2-reparse) - (run-hooks 'js2-mode-hook)) - -(defun js2-mode-check-compat () - "Signal an error if we can't run with this version of Emacs." - (if (and js2-mode-must-byte-compile - (not (byte-code-function-p (symbol-function 'js2-mode)))) - (error "You must byte-compile js2-mode before using it.")) - (if (and (boundp 'running-xemacs) - running-xemacs) - (error "js2-mode is not compatible with XEmacs")) - (unless (>= emacs-major-version 21) - (error "js2-mode requires GNU Emacs version 21 or higher"))) - -(defun js2-mode-exit () - (interactive) - (when js2-mode-node-overlay - (delete-overlay js2-mode-node-overlay) - (setq js2-mode-node-overlay nil)) - (js2-remove-overlays) - (setq js2-mode-ast nil) - (remove-hook 'change-major-mode-hook #'js2-mode-exit t) - (remove-from-invisibility-spec '(js2-outline . t)) - (js2-mode-show-all) - (js2-with-unmodifying-text-property-changes - (js2-clear-face (point-min) (point-max)))) - -(defun js2-before-save () - "Clean up whitespace before saving file. -You can disable this by customizing `js2-cleanup-whitespace'." - (when js2-cleanup-whitespace - (let ((col (current-column))) - (delete-trailing-whitespace) - ;; don't change trailing whitespace on current line - (unless (eq (current-column) col) - (indent-to col))))) - -(defsubst js2-mode-reset-timer () - (if js2-mode-parse-timer - (cancel-timer js2-mode-parse-timer)) - (setq js2-mode-parsing nil) - (setq js2-mode-parse-timer - (run-with-idle-timer js2-idle-timer-delay nil #'js2-reparse))) - -(defun js2-mode-edit (beg end len) - "Schedule a new parse after buffer is edited." - (setq js2-mode-buffer-dirty-p t) - (js2-mode-hide-overlay) - (js2-mode-reset-timer)) - -(defun js2-mode-run-font-lock () - "Run `font-lock-fontify-buffer' after parsing/highlighting. -This is intended to allow modes that install their own font-lock keywords -to work with js2-mode. In practice it never seems to work for long. -Hopefully the Emacs maintainers can help figure out a way to make it work." - (when (and (boundp 'font-lock-keywords) - font-lock-keywords - (boundp 'font-lock-mode) - font-lock-mode) - ;; TODO: font-lock and jit-lock really really REALLY don't want to - ;; play nicely with js2-mode. They go out of their way to fail to - ;; provide any option for saying "look, fontify the goddamn buffer - ;; with just the keywords already". Argh. - (setq font-lock-defaults (list font-lock-keywords 'keywords-only)) - (let (font-lock-verbose) - (font-lock-default-fontify-buffer)))) - -(defun js2-reparse (&optional force) - "Re-parse current buffer after user finishes some data entry. -If we get any user input while parsing, including cursor motion, -we discard the parse and reschedule it. If FORCE is nil, then the -buffer will only rebuild its `js2-mode-ast' if the buffer is dirty." - (let (time - interrupted-p - (js2-compiler-strict-mode js2-mode-show-strict-warnings)) - (unless js2-mode-parsing - (setq js2-mode-parsing t) - (unwind-protect - (when (or js2-mode-buffer-dirty-p force) - (js2-remove-overlays) - (js2-with-unmodifying-text-property-changes - (setq js2-mode-buffer-dirty-p nil - js2-mode-fontifications nil - js2-mode-deferred-properties nil) - (if js2-mode-verbose-parse-p - (message "parsing...")) - (setq time - (js2-time - (setq interrupted-p - (catch 'interrupted - (setq js2-mode-ast (js2-parse)) - (js2-mode-fontify-regions) - (js2-mode-remove-suppressed-warnings) - (js2-mode-show-warnings) - (js2-mode-show-errors) - (js2-mode-run-font-lock) ; note: doesn't work - (if (>= js2-highlight-level 1) - (js2-highlight-jsdoc js2-mode-ast)) - nil)))) - (if interrupted-p - (progn - ;; unfinished parse => try again - (setq js2-mode-buffer-dirty-p t) - (js2-mode-reset-timer)) - (if js2-mode-verbose-parse-p - (message "Parse time: %s" time))))) - ;; finally - (setq js2-mode-parsing nil) - (unless interrupted-p - (setq js2-mode-parse-timer nil)))))) - -(defun js2-mode-show-node () - "Debugging aid: highlight selected AST node on mouse click." - (interactive) - (let ((node (js2-node-at-point)) - beg - end) - (when js2-mode-show-overlay - (if (null node) - (message "No node found at location %s" (point)) - (setq beg (js2-node-abs-pos node) - end (+ beg (js2-node-len node))) - (if js2-mode-node-overlay - (move-overlay js2-mode-node-overlay beg end) - (setq js2-mode-node-overlay (make-overlay beg end)) - (overlay-put js2-mode-node-overlay 'face 'highlight)) - (js2-with-unmodifying-text-property-changes - (put-text-property beg end 'point-left #'js2-mode-hide-overlay)) - (message "%s, parent: %s" - (js2-node-short-name node) - (if (js2-node-parent node) - (js2-node-short-name (js2-node-parent node)) - "nil")))))) - -(defun js2-mode-hide-overlay (&optional p1 p2) - "Remove the debugging overlay when the point moves." - (when js2-mode-node-overlay - (let ((beg (overlay-start js2-mode-node-overlay)) - (end (overlay-end js2-mode-node-overlay))) - ;; Sometimes we're called spuriously. - (unless (and p2 - (>= p2 beg) - (<= p2 end)) - (js2-with-unmodifying-text-property-changes - (remove-text-properties beg end '(point-left nil))) - (delete-overlay js2-mode-node-overlay) - (setq js2-mode-node-overlay nil))))) - -(defun js2-mode-reset () - "Debugging helper; resets everything." - (interactive) - (js2-mode-exit) - (js2-mode)) - -(defsubst js2-mode-show-warn-or-err (e face) - "Highlight a warning or error E with FACE. -E is a list of ((MSG-KEY MSG-ARG) BEG END)." - (let* ((key (first e)) - (beg (second e)) - (end (+ beg (third e))) - ;; Don't inadvertently go out of bounds. - (beg (max (point-min) (min beg (point-max)))) - (end (max (point-min) (min end (point-max)))) - (js2-highlight-level 3) ; so js2-set-face is sure to fire - (ovl (make-overlay beg end))) - (overlay-put ovl 'face face) - (overlay-put ovl 'js2 t) - (put-text-property beg end 'help-echo (js2-get-msg key)) - (put-text-property beg end 'point-entered #'js2-echo-error))) - -(defun js2-remove-overlays () - "Remove overlays from buffer that have a `js2' property." - (let ((beg (point-min)) - (end (point-max))) - (save-excursion - (dolist (o (overlays-in beg end)) - (when (overlay-get o 'js2) - (delete-overlay o)))))) - -(defun js2-mode-fontify-regions () - "Apply fontifications recorded during parsing." - ;; We defer clearing faces as long as possible to eliminate flashing. - (js2-clear-face (point-min) (point-max)) - ;; have to reverse the recorded fontifications so that errors and - ;; warnings overwrite the normal fontifications - (dolist (f (nreverse js2-mode-fontifications)) - (put-text-property (first f) (second f) 'face (third f))) - (setq js2-mode-fontifications nil) - (dolist (p js2-mode-deferred-properties) - (apply #'put-text-property p)) - (setq js2-mode-deferred-properties nil)) - -(defun js2-mode-show-errors () - "Highlight syntax errors." - (when js2-mode-show-parse-errors - (dolist (e (js2-ast-root-errors js2-mode-ast)) - (js2-mode-show-warn-or-err e 'js2-error-face)))) - -(defun js2-mode-remove-suppressed-warnings () - "Take suppressed warnings out of the AST warnings list. -This ensures that the counts and `next-error' are correct." - (setf (js2-ast-root-warnings js2-mode-ast) - (js2-delete-if - (lambda (e) - (let ((key (caar e))) - (or - (and (not js2-strict-trailing-comma-warning) - (string-match "trailing\\.comma" key)) - (and (not js2-strict-cond-assign-warning) - (string= key "msg.equal.as.assign")) - (and js2-missing-semi-one-line-override - (string= key "msg.missing.semi") - (let* ((beg (second e)) - (node (js2-node-at-point beg)) - (fn (js2-mode-find-parent-fn node)) - (body (and fn (js2-function-node-body fn))) - (lc (and body (js2-node-abs-pos body))) - (rc (and lc (+ lc (js2-node-len body))))) - (and fn - (or (null body) - (save-excursion - (goto-char beg) - (and (js2-same-line lc) - (js2-same-line rc)))))))))) - (js2-ast-root-warnings js2-mode-ast)))) - -(defun js2-mode-show-warnings () - "Highlight strict-mode warnings." - (when js2-mode-show-strict-warnings - (dolist (e (js2-ast-root-warnings js2-mode-ast)) - (js2-mode-show-warn-or-err e 'js2-warning-face)))) - -(defun js2-echo-error (old-point new-point) - "Called by point-motion hooks." - (let ((msg (get-text-property new-point 'help-echo))) - (if msg - (message msg)))) - -(defalias #'js2-echo-help #'js2-echo-error) - -(defun js2-enter-key () - "Handle user pressing the Enter key." - (interactive) - (let ((parse-status (save-excursion - (parse-partial-sexp (point-min) (point))))) - (cond - ;; check if we're inside a string - ((nth 3 parse-status) - (js2-mode-split-string parse-status)) - ;; check if inside a block comment - ((nth 4 parse-status) - (js2-mode-extend-comment)) - (t - ;; should probably figure out what the mode-map says we should do - (if js2-indent-on-enter-key - (let ((js2-bounce-indent-flag nil)) - (js2-indent-line))) - (insert "\n") - (if js2-enter-indents-newline - (let ((js2-bounce-indent-flag nil)) - (js2-indent-line))))))) - -(defun js2-mode-split-string (parse-status) - "Turn a newline in mid-string into a string concatenation." - (let* ((col (current-column)) - (quote-char (nth 3 parse-status)) - (quote-string (string quote-char)) - (string-beg (nth 8 parse-status)) - (indent (save-match-data - (or - (save-excursion - (back-to-indentation) - (if (looking-at "\\+") - (current-column))) - (save-excursion - (goto-char string-beg) - (if (looking-back "\\+\\s-+") - (goto-char (match-beginning 0))) - (current-column)))))) - (insert quote-char "\n") - (indent-to indent) - (insert "+ " quote-string) - (when (eolp) - (insert quote-string) - (backward-char 1)))) - -(defun js2-mode-extend-comment () - "When inside a comment block, add comment prefix." - (let (star single col first-line needs-close) - (save-excursion - (back-to-indentation) - (cond - ((looking-at "\\*[^/]") - (setq star t - col (current-column))) - ((looking-at "/\\*") - (setq star t - first-line t - col (1+ (current-column)))) - ((looking-at "//") - (setq single t - col (current-column))))) - ;; Heuristic for whether we need to close the comment: - ;; if we've got a parse error here, assume it's an unterminated - ;; comment. - (setq needs-close - (or - (eq (get-text-property (1- (point)) 'point-entered) - 'js2-echo-error) - ;; The heuristic above doesn't work well when we're - ;; creating a comment and there's another one downstream, - ;; as our parser thinks this one ends at the end of the - ;; next one. (You can have a /* inside a js block comment.) - ;; So just close it if the next non-ws char isn't a *. - (and first-line - (eolp) - (save-excursion - (skip-syntax-forward " ") - (not (eq (char-after) ?*)))))) - (insert "\n") - (cond - (star - (indent-to col) - (insert "* ") - (if (and first-line needs-close) - (save-excursion - (insert "\n") - (indent-to col) - (insert "*/")))) - (single - (when (save-excursion - (and (zerop (forward-line 1)) - (looking-at "\\s-*//"))) - (indent-to col) - (insert "// ")))))) - -(defun js2-fill-string (beg quote) - "Line-wrap a single-line string into a multi-line string. -BEG is the string beginning, QUOTE is the quote char." - (let* ((squote (string quote)) - (end (if (re-search-forward (concat "[^\\]" squote) - (point-at-eol) t) - (1+ (match-beginning 0)) - (point-at-eol))) - (tag (make-marker)) - (fill-column (- fill-column 4))) ; make room - (unwind-protect - (progn - (move-marker tag end) - (fill-paragraph nil) - (goto-char beg) - (while (not (js2-same-line tag)) - (goto-char (point-at-eol)) - (insert squote) - (when (zerop (forward-line 1)) - (back-to-indentation) - (if (looking-at (concat squote "\\s-*$")) - (progn - (setq end (point-at-eol)) - (forward-line -1) - (delete-region (point-at-eol) end)) - (insert "+ " squote))))) - (move-marker tag nil)))) - -(defun js2-fill-paragraph (arg) - "Fill paragraph after point. Prefix ARG means justify as well. -Has special handling for filling in comments and strings." - (let* ((parse-status (save-excursion - (parse-partial-sexp (point-min) (point)))) - (quote-char (or (nth 3 parse-status) - (save-match-data - (if (looking-at "[\"\']") - (char-after)))))) - (cond - (quote-char - (js2-fill-string (or (nth 8 parse-status) - (point)) - quote-char) - t) ; or fill-paragraph does evil things afterwards - ((nth 4 parse-status) ; in block comment? - (js2-fill-comment parse-status arg)) - (t - (fill-paragraph arg))))) - -(defun js2-fill-comment (parse-status arg) - "Fill-paragraph in a block comment." - (let* ((beg (nth 8 parse-status)) - (end (save-excursion - (goto-char beg) - (re-search-forward "[^\\]\\*/" nil t))) - indent - end-marker) - (when end - (setq end-marker (make-marker)) - (move-marker end-marker end)) - (when (and end js2-mode-squeeze-spaces) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (while (re-search-forward "[ \t][ \t]+" nil t) - (replace-match " "))))) - ;; `c-fill-paragraph' doesn't indent the continuation stars properly - ;; if the comment isn't left-justified. They align to the first star - ;; on the first continuation line after the comment-open, so we make - ;; sure the first continuation line has the proper indentation. - (save-excursion - (goto-char beg) - (setq indent (1+ (current-column))) - (goto-char (point-at-eol)) - (skip-chars-forward " \t\r\n") - (indent-line-to indent) - - ;; Invoke `c-fill-paragraph' from the first continuation line, - ;; since it provides better results. Otherwise if you're on the - ;; last line, it doesn't prefix with stars the way you'd expect. - ;; TODO: write our own fill function that works in Emacs 21 - (c-fill-paragraph arg)) - - ;; last line is typically indented wrong, so fix it - (when end-marker - (save-excursion - (goto-char end-marker) - (js2-indent-line))))) - -(defun js2-beginning-of-line () - "Toggles point between bol and first non-whitespace char in line. -Also moves past comment delimiters when inside comments." - (interactive) - (let (node beg) - (cond - ((bolp) - (back-to-indentation)) - ((looking-at "//") - (skip-chars-forward "/ \t")) - ((and (eq (char-after) ?*) - (setq node (js2-comment-at-point)) - (memq (js2-comment-node-format node) '(jsdoc block)) - (save-excursion - (skip-chars-backward " \t") - (bolp))) - (skip-chars-forward "\* \t")) - (t - (goto-char (point-at-bol)))))) - -(defun js2-end-of-line () - "Toggles point between eol and last non-whitespace char in line." - (interactive) - (if (eolp) - (skip-chars-backward " \t") - (goto-char (point-at-eol)))) - -(defun js2-enter-mirror-mode() - "Turns on mirror mode, where quotes, brackets etc are mirrored automatically - on insertion." - (interactive) - (define-key js2-mode-map (read-kbd-macro "{") 'js2-mode-match-curly) - (define-key js2-mode-map (read-kbd-macro "}") 'js2-mode-magic-close-paren) - (define-key js2-mode-map (read-kbd-macro "\"") 'js2-mode-match-double-quote) - (define-key js2-mode-map (read-kbd-macro "'") 'js2-mode-match-single-quote) - (define-key js2-mode-map (read-kbd-macro "(") 'js2-mode-match-paren) - (define-key js2-mode-map (read-kbd-macro ")") 'js2-mode-magic-close-paren) - (define-key js2-mode-map (read-kbd-macro "[") 'js2-mode-match-bracket) - (define-key js2-mode-map (read-kbd-macro "]") 'js2-mode-magic-close-paren)) - -(defun js2-leave-mirror-mode() - "Turns off mirror mode." - (interactive) - (dolist (key '("{" "\"" "'" "(" ")" "[" "]")) - (define-key js2-mode-map (read-kbd-macro key) 'self-insert-command))) - -(defsubst js2-mode-inside-string () - "Return non-nil if inside a string. -Actually returns the quote character that begins the string." - (let ((parse-state (save-excursion - (parse-partial-sexp (point-min) (point))))) - (nth 3 parse-state))) - -(defsubst js2-mode-inside-comment-or-string () - "Return non-nil if inside a comment or string." - (or - (let ((comment-start - (save-excursion - (goto-char (point-at-bol)) - (if (re-search-forward "//" (point-at-eol) t) - (match-beginning 0))))) - (and comment-start - (<= comment-start (point)))) - (let ((parse-state (save-excursion - (parse-partial-sexp (point-min) (point))))) - (or (nth 3 parse-state) - (nth 4 parse-state))))) - -(defun js2-mode-match-curly (arg) - "Insert matching curly-brace." - (interactive "p") - (insert "{") - (if current-prefix-arg - (save-excursion - (insert "}")) - (unless (or (not (looking-at "\\s-*$")) - (js2-mode-inside-comment-or-string)) - (undo-boundary) - - ;; absolutely mystifying bug: when inserting the next "\n", - ;; the buffer-undo-list is given two new entries: the inserted range, - ;; and the incorrect position of the point. It's recorded incorrectly - ;; as being before the opening "{", not after it. But it's recorded - ;; as the correct value if you're debugging `js2-mode-match-curly' - ;; in edebug. I have no idea why it's doing this, but incrementing - ;; the inserted position fixes the problem, so that the undo takes us - ;; back to just after the user-inserted "{". - (insert "\n") - (ignore-errors - (incf (cadr buffer-undo-list))) - - (js2-indent-line) - (save-excursion - (insert "\n}") - (let ((js2-bounce-indent-flag (js2-code-at-bol-p))) - (js2-indent-line)))))) - -(defun js2-mode-match-bracket () - "Insert matching bracket." - (interactive) - (insert "[") - (unless (or (not (looking-at "\\s-*$")) - (js2-mode-inside-comment-or-string)) - (save-excursion - (insert "]")) - (when js2-auto-indent-flag - (let ((js2-bounce-indent-flag (js2-code-at-bol-p))) - (js2-indent-line))))) - -(defun js2-mode-match-paren () - "Insert matching paren unless already inserted." - (interactive) - (insert "(") - (unless (or (not (looking-at "\\s-*$")) - (js2-mode-inside-comment-or-string)) - (save-excursion - (insert ")")) - (when js2-auto-indent-flag - (let ((js2-bounce-indent-flag (js2-code-at-bol-p))) - (js2-indent-line))))) - -(defsubst js2-match-quote (quote-string) - (let ((start-quote (js2-mode-inside-string))) - (cond - ;; inside a comment - don't do quote-matching, since we can't - ;; reliably figure out if we're in a string inside the comment - ((js2-comment-at-point) - (insert quote-string)) - ((not start-quote) - ;; not in string => insert matched quotes - (insert quote-string) - ;; exception: if we're just before a word, don't double it. - (unless (looking-at "[^ \t\r\n]") - (save-excursion - (insert quote-string)))) - ((looking-at quote-string) - (if (looking-back "[^\\]\\\\") - (insert quote-string) - (forward-char 1))) - ((and js2-mode-escape-quotes - (save-excursion - (save-match-data - (re-search-forward quote-string (point-at-eol) t)))) - ;; inside terminated string, escape quote (unless already escaped) - (insert (if (looking-back "[^\\]\\\\") - quote-string - (concat "\\" quote-string)))) - (t - (insert quote-string))))) ; else terminate the string - -(defun js2-mode-match-single-quote () - "Insert matching single-quote." - (interactive) - (let ((parse-status (parse-partial-sexp (point-min) (point)))) - ;; don't match inside comments, since apostrophe is more common - (if (nth 4 parse-status) - (insert "'") - (js2-match-quote "'")))) - -(defun js2-mode-match-double-quote () - "Insert matching double-quote." - (interactive) - (js2-match-quote "\"")) - -(defun js2-mode-magic-close-paren () - "Skip over close-paren rather than inserting, where appropriate. -Uses some heuristics to try to figure out the right thing to do." - (interactive) - (let* ((parse-status (parse-partial-sexp (point-min) (point))) - (open-pos (nth 1 parse-status)) - (close last-input-char) - (open (cond - ((eq close 41) ; close-paren - 40) ; open-paren - ((eq close 93) ; close-bracket - 91) ; open-bracket - ((eq close ?}) - ?{) - (t nil)))) - (if (and (looking-at (string close)) - (eq open (char-after open-pos)) - (js2-same-line open-pos)) - (forward-char 1) - (insert (string close))) - (blink-matching-open))) - -(defun js2-mode-wait-for-parse (callback) - "Invoke CALLBACK when parsing is finished. -If parsing is already finished, calls CALLBACK immediately." - (if (not js2-mode-buffer-dirty-p) - (funcall callback) - (push callback js2-mode-pending-parse-callbacks) - (add-hook 'js2-parse-finished-hook #'js2-mode-parse-finished))) - -(defun js2-mode-parse-finished () - "Invoke callbacks in `js2-mode-pending-parse-callbacks'." - ;; We can't let errors propagate up, since it prevents the - ;; `js2-parse' method from completing normally and returning - ;; the ast, which makes things mysteriously not work right. - (unwind-protect - (dolist (cb js2-mode-pending-parse-callbacks) - (condition-case err - (funcall cb) - (error (message "%s" err)))) - (setq js2-mode-pending-parse-callbacks nil))) - -(defun js2-mode-flag-region (from to flag) - "Hide or show text from FROM to TO, according to FLAG. -If FLAG is nil then text is shown, while if FLAG is t the text is hidden. -Returns the created overlay if FLAG is non-nil." - (remove-overlays from to 'invisible 'js2-outline) - (when flag - (let ((o (make-overlay from to))) - (overlay-put o 'invisible 'js2-outline) - (overlay-put o 'isearch-open-invisible - 'js2-isearch-open-invisible) - o))) - -;; Function to be set as an outline-isearch-open-invisible' property -;; to the overlay that makes the outline invisible (see -;; `js2-mode-flag-region'). -(defun js2-isearch-open-invisible (overlay) - ;; We rely on the fact that isearch places point on the matched text. - (js2-mode-show-element)) - -(defun js2-mode-invisible-overlay-bounds (&optional pos) - "Return cons cell of bounds of folding overlay at POS. -Returns nil if not found." - (let ((overlays (overlays-at (or pos (point)))) - o) - (while (and overlays - (not o)) - (if (overlay-get (car overlays) 'invisible) - (setq o (car overlays)) - (setq overlays (cdr overlays)))) - (if o - (cons (overlay-start o) (overlay-end o))))) - -(defun js2-mode-function-at-point (&optional pos) - "Return the innermost function node enclosing current point. -Returns nil if point is not in a function." - (let ((node (js2-node-at-point pos))) - (while (and node (not (js2-function-node-p node))) - (setq node (js2-node-parent node))) - (if (js2-function-node-p node) - node))) - -(defun js2-mode-toggle-element () - "Hide or show the foldable element at the point." - (interactive) - (let (comment fn pos) - (save-excursion - (save-match-data - (cond - ;; /* ... */ comment? - ((js2-block-comment-p (setq comment (js2-comment-at-point))) - (if (js2-mode-invisible-overlay-bounds - (setq pos (+ 3 (js2-node-abs-pos comment)))) - (progn - (goto-char pos) - (js2-mode-show-element)) - (js2-mode-hide-element))) - - ;; //-comment? - ((save-excursion - (back-to-indentation) - (looking-at js2-mode-//-comment-re)) - (js2-mode-toggle-//-comment)) - - ;; function? - ((setq fn (js2-mode-function-at-point)) - (setq pos (and (js2-function-node-body fn) - (js2-node-abs-pos (js2-function-node-body fn)))) - (goto-char (1+ pos)) - (if (js2-mode-invisible-overlay-bounds) - (js2-mode-show-element) - (js2-mode-hide-element))) - (t - (message "Nothing at point to hide or show"))))))) - -(defun js2-mode-hide-element () - "Fold/hide contents of a block, showing ellipses. -Show the hidden text with \\[js2-mode-show-element]." - (interactive) - (if js2-mode-buffer-dirty-p - (js2-mode-wait-for-parse #'js2-mode-hide-element)) - (let (node body beg end) - (cond - ((js2-mode-invisible-overlay-bounds) - (message "already hidden")) - (t - (setq node (js2-node-at-point)) - (cond - ((js2-block-comment-p node) - (js2-mode-hide-comment node)) - (t - (while (and node (not (js2-function-node-p node))) - (setq node (js2-node-parent node))) - (if (and node - (setq body (js2-function-node-body node))) - (progn - (setq beg (js2-node-abs-pos body) - end (+ beg (js2-node-len body))) - (js2-mode-flag-region (1+ beg) (1- end) 'hide)) - (message "No collapsable element found at point")))))))) - -(defun js2-mode-show-element () - "Show the hidden element at current point." - (interactive) - (let ((bounds (js2-mode-invisible-overlay-bounds))) - (if bounds - (js2-mode-flag-region (car bounds) (cdr bounds) nil) - (message "Nothing to un-hide")))) - -(defun js2-mode-show-all () - "Show all of the text in the buffer." - (interactive) - (js2-mode-flag-region (point-min) (point-max) nil)) - -(defun js2-mode-toggle-hide-functions () - (interactive) - (if js2-mode-functions-hidden - (js2-mode-show-functions) - (js2-mode-hide-functions))) - -(defun js2-mode-hide-functions () - "Hides all non-nested function bodies in the buffer. -Use \\[js2-mode-show-all] to reveal them, or \\[js2-mode-show-element] -to open an individual entry." - (interactive) - (if js2-mode-buffer-dirty-p - (js2-mode-wait-for-parse #'js2-mode-hide-functions)) - (if (null js2-mode-ast) - (message "Oops - parsing failed") - (setq js2-mode-functions-hidden t) - (js2-visit-ast js2-mode-ast #'js2-mode-function-hider))) - -(defun js2-mode-function-hider (n endp) - (when (not endp) - (let ((tt (js2-node-type n)) - body beg end) - (cond - ((and (= tt js2-FUNCTION) - (setq body (js2-function-node-body n))) - (setq beg (js2-node-abs-pos body) - end (+ beg (js2-node-len body))) - (js2-mode-flag-region (1+ beg) (1- end) 'hide) - nil) ; don't process children of function - (t - t))))) ; keep processing other AST nodes - -(defun js2-mode-show-functions () - "Un-hide any folded function bodies in the buffer." - (interactive) - (setq js2-mode-functions-hidden nil) - (save-excursion - (goto-char (point-min)) - (while (/= (goto-char (next-overlay-change (point))) - (point-max)) - (dolist (o (overlays-at (point))) - (when (and (overlay-get o 'invisible) - (not (overlay-get o 'comment))) - (js2-mode-flag-region (overlay-start o) (overlay-end o) nil)))))) - -(defun js2-mode-hide-comment (n) - (let* ((head (if (eq (js2-comment-node-format n) 'jsdoc) - 3 ; /** - 2)) ; /* - (beg (+ (js2-node-abs-pos n) head)) - (end (- (+ beg (js2-node-len n)) head 2)) - (o (js2-mode-flag-region beg end 'hide))) - (overlay-put o 'comment t))) - -(defun js2-mode-toggle-hide-comments () - "Folds all block comments in the buffer. -Use \\[js2-mode-show-all] to reveal them, or \\[js2-mode-show-element] -to open an individual entry." - (interactive) - (if js2-mode-comments-hidden - (js2-mode-show-comments) - (js2-mode-hide-comments))) - -(defun js2-mode-hide-comments () - (interactive) - (if js2-mode-buffer-dirty-p - (js2-mode-wait-for-parse #'js2-mode-hide-comments)) - (if (null js2-mode-ast) - (message "Oops - parsing failed") - (setq js2-mode-comments-hidden t) - (dolist (n (js2-ast-root-comments js2-mode-ast)) - (let ((format (js2-comment-node-format n))) - (when (js2-block-comment-p n) - (js2-mode-hide-comment n)))) - (js2-mode-hide-//-comments))) - -(defsubst js2-mode-extend-//-comment (direction) - "Find start or end of a block of similar //-comment lines. -DIRECTION is -1 to look back, 1 to look forward. -INDENT is the indentation level to match. -Returns the end-of-line position of the furthest adjacent -//-comment line with the same indentation as the current line. -If there is no such matching line, returns current end of line." - (let ((pos (point-at-eol)) - (indent (current-indentation))) - (save-excursion - (save-match-data - (while (and (zerop (forward-line direction)) - (looking-at js2-mode-//-comment-re) - (eq indent (length (match-string 1)))) - (setq pos (point-at-eol))) - pos)))) - -(defun js2-mode-hide-//-comments () - "Fold adjacent 1-line comments, showing only snippet of first one." - (let (beg end) - (save-excursion - (save-match-data - (goto-char (point-min)) - (while (re-search-forward js2-mode-//-comment-re nil t) - (setq beg (point) - end (js2-mode-extend-//-comment 1)) - (unless (eq beg end) - (overlay-put (js2-mode-flag-region beg end 'hide) - 'comment t)) - (goto-char end) - (forward-char 1)))))) - -(defun js2-mode-toggle-//-comment () - "Fold or un-fold any multi-line //-comment at point. -Caller should have determined that this line starts with a //-comment." - (let* ((beg (point-at-eol)) - (end beg)) - (save-excursion - (goto-char end) - (if (js2-mode-invisible-overlay-bounds) - (js2-mode-show-element) - ;; else hide the comment - (setq beg (js2-mode-extend-//-comment -1) - end (js2-mode-extend-//-comment 1)) - (unless (eq beg end) - (overlay-put (js2-mode-flag-region beg end 'hide) - 'comment t)))))) - -(defun js2-mode-show-comments () - "Un-hide any hidden comments, leaving other hidden elements alone." - (interactive) - (setq js2-mode-comments-hidden nil) - (save-excursion - (goto-char (point-min)) - (while (/= (goto-char (next-overlay-change (point))) - (point-max)) - (dolist (o (overlays-at (point))) - (when (overlay-get o 'comment) - (js2-mode-flag-region (overlay-start o) (overlay-end o) nil)))))) - -(defun js2-mode-display-warnings-and-errors () - "Turn on display of warnings and errors." - (interactive) - (setq js2-mode-show-parse-errors t - js2-mode-show-strict-warnings t) - (js2-reparse 'force)) - -(defun js2-mode-hide-warnings-and-errors () - "Turn off display of warnings and errors." - (interactive) - (setq js2-mode-show-parse-errors nil - js2-mode-show-strict-warnings nil) - (js2-reparse 'force)) - -(defun js2-mode-toggle-warnings-and-errors () - "Toggle the display of warnings and errors. -Some users don't like having warnings/errors reported while they type." - (interactive) - (setq js2-mode-show-parse-errors (not js2-mode-show-parse-errors) - js2-mode-show-strict-warnings (not js2-mode-show-strict-warnings)) - (if (interactive-p) - (message "warnings and errors %s" - (if js2-mode-show-parse-errors - "enabled" - "disabled"))) - (js2-reparse 'force)) - -(defun js2-mode-customize () - (interactive) - (customize-group 'js2-mode)) - -(defun js2-mode-forward-sexp (&optional arg) - "Move forward across one statement or balanced expression. -With ARG, do it that many times. Negative arg -N means -move backward across N balanced expressions." - (interactive "p") - (setq arg (or arg 1)) - (if js2-mode-buffer-dirty-p - (js2-mode-wait-for-parse #'js2-mode-forward-sexp)) - (let (node end (start (point))) - (cond - ;; backward-sexp - ;; could probably make this "better" for some cases: - ;; - if in statement block (e.g. function body), go to parent - ;; - infix exprs like (foo in bar) - maybe go to beginning - ;; of infix expr if in the right-side expression? - ((and arg (minusp arg)) - (dotimes (i (- arg)) - (js2-backward-sws) - (forward-char -1) ; enter the node we backed up to - (setq node (js2-node-at-point (point) t)) - (goto-char (if node - (js2-node-abs-pos node) - (point-min))))) - (t - ;; forward-sexp - (js2-forward-sws) - (dotimes (i arg) - (js2-forward-sws) - (setq node (js2-node-at-point (point) t) - end (if node (+ (js2-node-abs-pos node) - (js2-node-len node)))) - (goto-char (or end (point-max)))))))) - -(defun js2-next-error (&optional arg reset) - "Move to next parse error. -Typically invoked via \\[next-error]. -ARG is the number of errors, forward or backward, to move. -RESET means start over from the beginning." - (interactive "p") - (if (or (null js2-mode-ast) - (and (null (js2-ast-root-errors js2-mode-ast)) - (null (js2-ast-root-warnings js2-mode-ast)))) - (message "No errors") - (when reset - (goto-char (point-min))) - (let* ((errs (copy-sequence - (append (js2-ast-root-errors js2-mode-ast) - (js2-ast-root-warnings js2-mode-ast)))) - (continue t) - (start (point)) - (count (or arg 1)) - (backward (minusp count)) - (sorter (if backward '> '<)) - (stopper (if backward '< '>)) - (count (abs count)) - all-errs - err) - ;; sort by start position - (setq errs (sort errs (lambda (e1 e2) - (funcall sorter (second e1) (second e2)))) - all-errs errs) - ;; find nth error with pos > start - (while (and errs continue) - (when (funcall stopper (cadar errs) start) - (setq err (car errs)) - (if (zerop (decf count)) - (setq continue nil))) - (setq errs (cdr errs))) - (if err - (goto-char (second err)) - ;; wrap around to first error - (goto-char (second (car all-errs))) - ;; if we were already on it, echo msg again - (if (= (point) start) - (js2-echo-error (point) (point))))))) - -(defun js2-mouse-3 () - "Make right-click move the point to the click location. -This makes right-click context menu operations a bit more intuitive. -The point will not move if the region is active, however, to avoid -destroying the region selection." - (interactive) - (when (and js2-move-point-on-right-click - (not mark-active)) - (let ((e last-input-event)) - (ignore-errors - (goto-char (cadadr e)))))) - -(defun js2-mode-create-imenu-index () - "Return an alist for `imenu--index-alist'." - ;; This is built up in `js2-parse-record-imenu' during parsing. - (when js2-mode-ast - ;; if we have an ast but no recorder, they're requesting a rescan - (unless js2-imenu-recorder - (js2-reparse 'force)) - (prog1 - (js2-build-imenu-index) - (setq js2-imenu-recorder nil - js2-imenu-function-map nil)))) - -(defun js2-mode-find-tag () - "Replacement for `find-tag-default'. -`find-tag-default' returns a ridiculous answer inside comments." - (let (beg end) - (js2-with-underscore-as-word-syntax - (save-excursion - (if (and (not (looking-at "[A-Za-z0-9_$]")) - (looking-back "[A-Za-z0-9_$]")) - (setq beg (progn (forward-word -1) (point)) - end (progn (forward-word 1) (point))) - (setq beg (progn (forward-word 1) (point)) - end (progn (forward-word -1) (point)))) - (replace-regexp-in-string - "[\"']" "" - (buffer-substring-no-properties beg end)))))) - -(defun js2-mode-forward-sibling () - "Move to the end of the sibling following point in parent. -Returns non-nil if successful, or nil if there was no following sibling." - (let* ((node (js2-node-at-point)) - (parent (js2-mode-find-enclosing-fn node)) - sib) - (when (setq sib (js2-node-find-child-after (point) parent)) - (goto-char (+ (js2-node-abs-pos sib) - (js2-node-len sib)))))) - -(defun js2-mode-backward-sibling () - "Move to the beginning of the sibling node preceding point in parent. -Parent is defined as the enclosing script or function." - (let* ((node (js2-node-at-point)) - (parent (js2-mode-find-enclosing-fn node)) - sib) - (when (setq sib (js2-node-find-child-before (point) parent)) - (goto-char (js2-node-abs-pos sib))))) - -(defun js2-beginning-of-defun () - "Go to line on which current function starts, and return non-nil. -If we're not in a function, go to beginning of previous script-level element." - (interactive) - (let ((parent (js2-node-parent-script-or-fn (js2-node-at-point))) - pos sib) - (cond - ((and (js2-function-node-p parent) - (not (eq (point) (setq pos (js2-node-abs-pos parent))))) - (goto-char pos)) - (t - (js2-mode-backward-sibling))))) - -(defun js2-end-of-defun () - "Go to the char after the last position of the current function. -If we're not in a function, skips over the next script-level element." - (interactive) - (let ((parent (js2-node-parent-script-or-fn (js2-node-at-point)))) - (if (not (js2-function-node-p parent)) - ;; punt: skip over next script-level element beyond point - (js2-mode-forward-sibling) - (goto-char (+ 1 (+ (js2-node-abs-pos parent) - (js2-node-len parent))))))) - -(defun js2-mark-defun (&optional allow-extend) - "Put mark at end of this function, point at beginning. -The function marked is the one that contains point. - -Interactively, if this command is repeated, -or (in Transient Mark mode) if the mark is active, -it marks the next defun after the ones already marked." - (interactive "p") - (let (extended) - (when (and allow-extend - (or (and (eq last-command this-command) (mark t)) - (and transient-mark-mode mark-active))) - (let ((sib (save-excursion - (goto-char (mark)) - (if (js2-mode-forward-sibling) - (point)))) - node) - (if sib - (progn - (set-mark sib) - (setq extended t)) - ;; no more siblings - try extending to enclosing node - (goto-char (mark t))))) - (when (not extended) - (let ((node (js2-node-at-point (point) t)) ; skip comments - ast fn stmt parent beg end) - (when (js2-ast-root-p node) - (setq ast node - node (or (js2-node-find-child-after (point) node) - (js2-node-find-child-before (point) node)))) - ;; only mark whole buffer if we can't find any children - (if (null node) - (setq node ast)) - (if (js2-function-node-p node) - (setq parent node) - (setq fn (js2-mode-find-enclosing-fn node) - stmt (if (or (null fn) - (js2-ast-root-p fn)) - (js2-mode-find-first-stmt node)) - parent (or stmt fn))) - (setq beg (js2-node-abs-pos parent) - end (+ beg (js2-node-len parent))) - (push-mark beg) - (goto-char end) - (exchange-point-and-mark))))) - -(defun js2-narrow-to-defun () - "Narrow to the function enclosing point." - (interactive) - (let* ((node (js2-node-at-point (point) t)) ; skip comments - (fn (if (js2-script-node-p node) - node - (js2-mode-find-enclosing-fn node))) - (beg (js2-node-abs-pos fn))) - (unless (js2-ast-root-p fn) - (narrow-to-region beg (+ beg (js2-node-len fn)))))) - -(defalias 'js2r 'js2-mode-reset) - -(provide 'js2-mode) - -;;; js2-mode.el ends here - - -;;; js2.el ends here
deleted file mode 100644 index 80fbe1d8a673c75d3144a03b542080231298bf31..0000000000000000000000000000000000000000 GIT binary patch literal 0 Hc$@<O00001
deleted file mode 100644 --- a/.elisp/nose.el +++ /dev/null @@ -1,177 +0,0 @@ -;; nose.el --- Easy Python test running in Emacs - -;; Copyright (C) 2009 Jason Pellerin, Augie Fackler - -;; Licensed under the same terms as Emacs. - -;; Version: 0.1.0 -;; Keywords: nose python testing -;; Created: 04 Apr 2009 - -;; This file is NOT part of GNU Emacs. - -;; Licensed under the same terms as Emacs. - -;;; Commentary: -;; This gives a bunch of functions that handle running nosetests on a -;; particular buffer or part of a buffer. - -;;; Installation - -;; In your emacs config: -;; -;; (require 'nose) -;; ; next line only for people with non-eco non-global test runners -;; ; (add-to-list 'nose-project-names "my/crazy/runner") - -;; Note that if your global nose isn't called "nosetests", then you'll want to -;; redefine nose-global-name to be the command that should be used. - -;; By default, the root of a project is found by looking for any of the files -;; 'setup.py', '.hg' and '.git'. You can add files to check for to the file -;; list: -;; -;; ; (add-to-list 'nose-project-root-files "something") - -;; or you can change the project root test to detect in some other way -;; whether a directory is the project root: -;; -;; ; (setq nose-project-root-test (lambda (dirname) (equal dirname "foo"))) - -;; If you want dots as output, rather than the verbose output: -;; (defvar nose-use-verbose nil) ; default is t - -;; Probably also want some keybindings: -;; (add-hook 'python-mode-hook -;; (lambda () -;; (local-set-key "\C-ca" 'nosetests-all) -;; (local-set-key "\C-cm" 'nosetests-module) -;; (local-set-key "\C-c." 'nosetests-one) -;; (local-set-key "\C-cpa" 'nosetests-pdb-all) -;; (local-set-key "\C-cpm" 'nosetests-pdb-module) -;; (local-set-key "\C-cp." 'nosetests-pdb-one))) - -(defvar nose-project-names '("eco/bin/test")) -(defvar nose-project-root-files '("setup.py" ".hg" ".git")) -(defvar nose-project-root-test 'nose-project-root) -(defvar nose-global-name "nosetests") -(defvar nose-use-verbose t) - -(defun run-nose (&optional tests debug failed) - "run nosetests" - (let* ((nose (nose-find-test-runner)) - (where (nose-find-project-root)) - (args (concat (if debug "--pdb" "") - " " - (if failed "--failed" ""))) - (tnames (if tests tests ""))) - (funcall (if debug - 'pdb - '(lambda (command) - (compilation-start command - nil - (lambda (mode) (concat "*nosetests*"))))) - (format - (concat "%s " - (if nose-use-verbose "-v " "") - "%s -w %s -c %ssetup.cfg %s") - (nose-find-test-runner) args where where tnames))) - ) - -(defun nosetests-all (&optional debug failed) - "run all tests" - (interactive) - (run-nose nil debug failed)) - -(defun nosetests-failed (&optional debug) - (interactive) - (nosetests-all debug t)) - -(defun nosetests-pdb-all () - (interactive) - (nosetests-all t)) - -(defun nosetests-module (&optional debug) - "run nosetests (via eggs/bin/test) on current buffer" - (interactive) - (run-nose buffer-file-name debug)) - -(defun nosetests-pdb-module () - (interactive) - (nosetests-module t)) - -(defun nosetests-one (&optional debug) - "run nosetests (via eggs/bin/test) on testable thing - at point in current buffer" - (interactive) - (run-nose (format "%s:%s" buffer-file-name (nose-py-testable)) debug)) - -(defun nosetests-pdb-one () - (interactive) - (nosetests-one t)) - -(defun nose-find-test-runner () - (message - (let ((result - (reduce '(lambda (x y) (or x y)) - (mapcar 'nose-find-test-runner-names nose-project-names)))) - (if result - result - nose-global-name)))) - -(defun nose-find-test-runner-names (runner) - "find eggs/bin/test in a parent dir of current buffer's file" - (nose-find-test-runner-in-dir-named - (file-name-directory buffer-file-name) runner)) - -(defun nose-find-test-runner-in-dir-named (dn runner) - (let ((fn (expand-file-name runner dn))) - (cond ((file-regular-p fn) fn) - ((equal dn "/") nil) - (t (nose-find-test-runner-in-dir-named - (file-name-directory (directory-file-name dn)) - runner))))) - -(defun nose-py-testable () - (let* ((inner-obj (inner-testable)) - (outer (outer-testable)) - ;; elisp can't return multiple values - (outer-def (car outer)) - (outer-obj (cdr outer))) - (cond ((equal outer-def "def") outer-obj) - ((equal inner-obj outer-obj) outer-obj) - (t (format "%s.%s" outer-obj inner-obj))))) - -(defun inner-testable () - (save-excursion - (re-search-backward - "^ \\{0,4\\}\\(class\\|def\\)[ \t]+\\([a-zA-Z0-9_]+\\)" nil t) - (buffer-substring-no-properties (match-beginning 2) (match-end 2)))) - -(defun outer-testable () - (save-excursion - (re-search-backward - "^\\(class\\|def\\)[ \t]+\\([a-zA-Z0-9_]+\\)" nil t) - (let ((result - (buffer-substring-no-properties (match-beginning 2) (match-end 2)))) - - (cons - (buffer-substring-no-properties (match-beginning 1) (match-end 1)) - result)))) - -(defun nose-find-project-root (&optional dirname) - (let ((dn - (if dirname - dirname - (file-name-directory buffer-file-name)))) - (cond ((funcall nose-project-root-test dn) (expand-file-name dn)) - ((equal (expand-file-name dn) "/") nil) - (t (nose-find-project-root - (file-name-directory (directory-file-name dn))))))) - -(defun nose-project-root (dirname) - (reduce '(lambda (x y) (or x y)) - (mapcar (lambda (d) (member d (directory-files dirname))) - nose-project-root-files))) - -(provide 'nose)
new file mode 100644 --- /dev/null +++ b/.elisp/package.el @@ -0,0 +1,1446 @@ +;;; package.el --- Simple package system for Emacs + +;; Copyright (C) 2007, 2008, 2009 Tom Tromey <tromey@redhat.com> + +;; Author: Tom Tromey <tromey@redhat.com> +;; Created: 10 Mar 2007 +;; Version: 0.9.4 +;; Keywords: tools + +;; This file is not (yet) part of GNU Emacs. +;; However, it is distributed under the same license. + +;; 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, 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; To use this, put package.el somewhere on your load-path. Then add +;; this to your .emacs: +;; +;; (load "package") +;; (package-initialize) +;; +;; This will automatically make available the packages you have +;; installed using package.el. If your .emacs will refer to these +;; packages, you may want to initialize the package manager near the +;; top. +;; +;; Note that if you want to be able to automatically download and +;; install packages from ELPA (the Emacs Lisp Package Archive), then +;; you will need the 'url' package. This comes with Emacs 22; Emacs +;; 21 users will have to find it elsewhere. +;; +;; If you installed package.el via the auto-installer: +;; +;; http://tromey.com/elpa/ +;; +;; then you do not need to edit your .emacs, as the installer will +;; have done this for you. The installer will also install the url +;; package if you need it. + +;; Other external functions you may want to use: +;; +;; M-x package-list-packages +;; Enters a mode similar to buffer-menu which lets you manage +;; packages. You can choose packages for install (mark with "i", +;; then "x" to execute) or deletion (not implemented yet), and you +;; can see what packages are available. This will automatically +;; fetch the latest list of packages from ELPA. +;; +;; M-x package-list-packages-no-fetch +;; Like package-list-packages, but does not automatically fetch the +;; new list of packages. +;; +;; M-x package-install-from-buffer +;; Install a package consisting of a single .el file that appears +;; in the current buffer. This only works for packages which +;; define a Version header properly; package.el also supports the +;; extension headers Package-Version (in case Version is an RCS id +;; or similar), and Package-Requires (if the package requires other +;; packages). +;; +;; M-x package-install-file +;; Install a package from the indicated file. The package can be +;; either a tar file or a .el file. A tar file must contain an +;; appropriately-named "-pkg.el" file; a .el file must be properly +;; formatted as with package-install-from-buffer. + +;; The idea behind package.el is to be able to download packages and +;; install them. Packages are versioned and have versioned +;; dependencies. Furthermore, this supports built-in packages which +;; may or may not be newer than user-specified packages. This makes +;; it possible to upgrade Emacs and automatically disable packages +;; which have moved from external to core. (Note though that we don't +;; currently register any of these, so this feature does not actually +;; work.) + +;; This code supports a single package repository, ELPA. All packages +;; must be registered there. + +;; A package is described by its name and version. The distribution +;; format is either a tar file or a single .el file. + +;; A tar file should be named "NAME-VERSION.tar". The tar file must +;; unpack into a directory named after the package and version: +;; "NAME-VERSION". It must contain a file named "PACKAGE-pkg.el" +;; which consists of a call to define-package. It may also contain a +;; "dir" file and the info files it references. + +;; A .el file will be named "NAME-VERSION.el" in ELPA, but will be +;; installed as simply "NAME.el" in a directory named "NAME-VERSION". + +;; The downloader will download all dependent packages. It will also +;; byte-compile the package's Lisp at install time. + +;; At activation time we will set up the load-path and the info path, +;; and we will load the package's autoloads. If a package's +;; dependencies are not available, we will not activate that package. + +;; Conceptually a package has multiple state transitions: +;; +;; * Download. Fetching the package from ELPA. +;; * Install. Untar the package, or write the .el file, into +;; ~/.emacs.d/elpa/ directory. +;; * Byte compile. Currently this phase is done during install, +;; but we may change this. +;; * Activate. Evaluate the autoloads for the package to make it +;; available to the user. +;; * Load. Actually load the package and run some code from it. + +;;; Thanks: +;;; (sorted by sort-lines): + +;; Jim Blandy <jimb@red-bean.com> +;; Karl Fogel <kfogel@red-bean.com> +;; Kevin Ryde <user42@zip.com.au> +;; Lawrence Mitchell +;; Michael Olson <mwolson@member.fsf.org> +;; Sebastian Tennant <sebyte@smolny.plus.com> +;; Stefan Monnier <monnier@iro.umontreal.ca> +;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Phil Hagelberg <phil@hagelb.org> +;; Samuel Bronson <naesten@gmail.com> + +;;; History: +;; +;; Originally written by Tom Tromey, multiple archive support added by Phil +;; Hagelberg. + +;;; Code: + +(defcustom package-archives '(("elpa" . "http://tromey.com/elpa/")) + "An alist of archives (names and URLs) from which to fetch. +The default points to ELPA, the Emacs Lisp Package Archive. +Note that some code in package.el assumes that this is an http: URL." + :type '(alist :key-type (string :tag "Archive name") + :value-type (string :tag "Archive URL")) + :group 'package + :package-version '("package.el" . "0.9.3")) + +(defconst package-archive-version 1 + "Version number of the package archive understood by this file. +Lower version numbers than this will probably be understood as well.") + +(defconst package-el-version "0.9.4" + "Version of package.el.") + +;; We don't prime the cache since it tends to get out of date. +(defvar package-archive-contents + nil + "A representation of the contents of the ELPA archive. +This is an alist mapping package names (symbols) to package +descriptor vectors. These are like the vectors for `package-alist' +but have extra entries: one which is 'tar for tar packages and +'single for single-file packages, and one which is the name of +the archive from which it came.") + +(defvar package-user-dir + (expand-file-name (convert-standard-filename "~/.emacs.d/elpa")) + "Name of the directory where the user's packages are stored.") + +(defvar package-directory-list + (list (file-name-as-directory package-user-dir) + "/usr/share/emacs/site-lisp/elpa/") + "List of directories to search for packages.") + +(defun package-version-split (string) + "Split a package STRING into a version list." + (mapcar 'string-to-int (split-string string "[.]"))) + +(defconst package--builtins-base + ;; We use package-version split here to make sure to pick up the + ;; minor version. + `((emacs . [,(package-version-split emacs-version) nil + "GNU Emacs"]) + (package . [,(package-version-split package-el-version) + nil "Simple package system for GNU Emacs"])) + "Packages which are always built-in.") + +(defvar package--builtins + (delq nil + (append + package--builtins-base + (if (>= emacs-major-version 22) + ;; FIXME: emacs 22 includes tramp, rcirc, maybe + ;; other things... + '((erc . [(5 2) nil "An Emacs Internet Relay Chat client"]) + ;; The external URL is version 1.15, so make sure the + ;; built-in one looks newer. + (url . [(1 16) nil "URL handling libary"]))) + (if (>= emacs-major-version 23) + '(;; Strangely, nxml-version is missing in Emacs 23. + ;; We pick the merge date as the version. + (nxml . [(20071123) nil "Major mode for editing XML documents."]) + (bubbles . [(0 5) nil "Puzzle game for Emacs."]))))) + "Alist of all built-in packages. +Maps the package name to a vector [VERSION REQS DOCSTRING].") + +(defvar package-alist package--builtins + "Alist of all packages available for activation. +Maps the package name to a vector [VERSION REQS DOCSTRING].") + +(defvar package-activated-list + (mapcar #'car package-alist) + "List of the names of all activated packages.") + +(defvar package-obsolete-alist nil + "Representation of obsolete packages. +Like `package-alist', but maps package name to a second alist. +The inner alist is keyed by version.") + +(defun package-version-join (l) + "Turn a list L of version numbers into a version string." + (mapconcat 'int-to-string l ".")) + +(defun package--version-first-nonzero (l) + "Find the first non-zero number in the list L. + +Returns the value of the first non-zero integer in L, or 0 if +none is found." + (while (and l (= (car l) 0)) + (setq l (cdr l))) + (if l (car l) 0)) + +(defun package-version-compare (v1 v2 fun) + "Compare two version V1 and V2 lists according to FUN. + +FUN can be <, <=, =, >, >=, or /=." + (while (and v1 v2 (= (car v1) (car v2))) + (setq v1 (cdr v1) + v2 (cdr v2))) + (if v1 + (if v2 + ;; Both not null; we know the cars are not =. + (funcall fun (car v1) (car v2)) + ;; V1 not null, V2 null. + (funcall fun (package--version-first-nonzero v1) 0)) + (if v2 + ;; V1 null, V2 not null. + (funcall fun 0 (package--version-first-nonzero v2)) + ;; Both null. + (funcall fun 0 0)))) + +(defun package--test-version-compare () + "Test suite for `package-version-compare'." + (unless (and (package-version-compare '(0) '(0) '=) + (not (package-version-compare '(1) '(0) '=)) + (package-version-compare '(1 0 1) '(1) '>=) + (package-version-compare '(1 0 1) '(1) '>) + (not (package-version-compare '(0 9 1) '(1 0 2) '>=))) + (error "Failed")) + t) + +(defun package-strip-version (dirname) + "Strip the version from a combined package name and version. +E.g., if DIRNAME is \"quux-23.0\", will return \"quux\"" + (if (string-match "^\\(.*\\)-[0-9]+\\([.][0-9]+\\)*$" dirname) + (match-string 1 dirname))) + +(defun package-load-descriptor (dir package) + "Load the description file in directory DIR for a PACKAGE. +Return nil if the package could not be found." + (let* ((pkg-dir (expand-file-name package dir)) + (pkg-file (expand-file-name + (concat (package-strip-version package) "-pkg") pkg-dir))) + (when (and (file-directory-p pkg-dir) + (file-exists-p (concat pkg-file ".el"))) + (load pkg-file nil t)))) + +(defun package-load-all-descriptors () + "Load descriptors of all packages. +Uses `package-directory-list' to find packages." + (mapc (lambda (dir) + (if (file-directory-p dir) + (mapc (lambda (name) + (package-load-descriptor dir name)) + (directory-files dir nil "^[^.]")))) + package-directory-list)) + +(defsubst package-desc-vers (desc) + "Extract version from a package description vector DESC." + (aref desc 0)) + +(defsubst package-desc-reqs (desc) + "Extract requirements from a package description vector DESC." + (aref desc 1)) + +(defsubst package-desc-doc (desc) + "Extract doc string from a package description vector DESC." + (aref desc 2)) + +(defsubst package-desc-kind (desc) + "Extract the kind of download from an archive package description vector DESC." + (aref desc 3)) + +(defun package-do-activate (package pkg-vec) + "Set up a single PACKAGE. + +Modifies `load-path' to include the package directory and loads +the `autoload' file for the package. PKG-VEC is the package info +as retrieved from the package mirror." + (let* ((pkg-name (symbol-name package)) + (pkg-ver-str (package-version-join (package-desc-vers pkg-vec))) + (dir-list package-directory-list) + (pkg-dir)) + (while dir-list + (let ((subdir (concat (car dir-list) pkg-name "-" pkg-ver-str "/"))) + (if (file-directory-p subdir) + (progn + (setq pkg-dir subdir) + (setq dir-list nil)) + (setq dir-list (cdr dir-list))))) + (unless pkg-dir + (error "Internal error: could not find directory for %s-%s" + pkg-name pkg-ver-str)) + (if (file-exists-p (concat pkg-dir "dir")) + (progn + ;; FIXME: not the friendliest, but simple. + (require 'info) + (info-initialize) + (setq Info-directory-list (cons pkg-dir Info-directory-list)))) + (setq load-path (cons pkg-dir load-path)) + ;; Load the autoloads and activate the package. + (load (concat pkg-dir (symbol-name package) "-autoloads") + nil t) + (setq package-activated-list (cons package package-activated-list)) + ;; Don't return nil. + t)) + +(defun package--built-in (package version) + "Return true if PACKAGE at VERSION is built-in to Emacs." + (let ((elt (assq package package--builtins))) + (and elt + (package-version-compare (package-desc-vers (cdr elt)) version '=)))) + +;; FIXME: return a reason instead? +(defun package-activate (package version) + "Try to activate PACKAGE at version VERSION. +Return nil if the package could not be activated. +Recursively activates all dependencies of the named package." + ;; Assume the user knows what he is doing -- go ahead and activate a + ;; newer version of a package if an older one has already been + ;; activated. This is not ideal; we'd at least need to check to see + ;; if the package has actually been loaded, and not merely + ;; activated. However, don't try to activate 'emacs', as that makes + ;; no sense. + (unless (eq package 'emacs) + (let* ((pkg-desc (assq package package-alist)) + (this-version (package-desc-vers (cdr pkg-desc))) + (req-list (package-desc-reqs (cdr pkg-desc))) + ;; If the package was never activated, we want to do it + ;; now. + (keep-going (or (not (memq package package-activated-list)) + (package-version-compare this-version version '>)))) + (while (and req-list keep-going) + (or (package-activate (car (car req-list)) + (car (cdr (car req-list)))) + (setq keep-going nil)) + (setq req-list (cdr req-list))) + (if keep-going + (package-do-activate package (cdr pkg-desc)) + ;; We get here if a dependency failed to activate -- but we + ;; can also get here if the requested package was already + ;; activated. Return non-nil in the latter case. + (and (memq package package-activated-list) + (package-version-compare this-version version '>=)))))) + +(defun package-mark-obsolete (package pkg-vec) + "Put PACKAGE on the obsolete list, if not already there. + +PKG-VEC describes the version of PACKAGE to mark obsolete." + (let ((elt (assq package package-obsolete-alist))) + (if elt + ;; If this obsolete version does not exist in the list, update + ;; it the list. + (unless (assoc (package-desc-vers pkg-vec) (cdr elt)) + (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec) + (cdr elt)))) + ;; Make a new association. + (setq package-obsolete-alist + (cons (cons package (list (cons (package-desc-vers pkg-vec) + pkg-vec))) + package-obsolete-alist))))) + +;; (define-package "emacs" "21.4.1" "GNU Emacs core package.") +;; (define-package "erc" "5.1" "ERC - irc client" '((emacs "21.0"))) +(defun define-package (name-str version-string + &optional docstring requirements) + "Define a new package. +NAME-STR is the name of the package, a string. +VERSION-STRING is the version of the package, a dotted sequence +of integers. +DOCSTRING is the optional description. +REQUIREMENTS is a list of requirements on other packages. +Each requirement is of the form (OTHER-PACKAGE \"VERSION\")." + (let* ((name (intern name-str)) + (pkg-desc (assq name package-alist)) + (new-version (package-version-split version-string)) + (new-pkg-desc + (cons name + (vector new-version + (mapcar + (lambda (elt) + (list (car elt) + (package-version-split (car (cdr elt))))) + requirements) + docstring)))) + ;; Only redefine a package if the redefinition is newer. + (if (or (not pkg-desc) + (package-version-compare new-version + (package-desc-vers (cdr pkg-desc)) + '>)) + (progn + (when pkg-desc + ;; Remove old package and declare it obsolete. + (setq package-alist (delq pkg-desc package-alist)) + (package-mark-obsolete (car pkg-desc) (cdr pkg-desc))) + ;; Add package to the alist. + (setq package-alist (cons new-pkg-desc package-alist))) + ;; You can have two packages with the same version, for instance + ;; one in the system package directory and one in your private + ;; directory. We just let the first one win. + (unless (package-version-compare new-version + (package-desc-vers (cdr pkg-desc)) + '=) + ;; The package is born obsolete. + (package-mark-obsolete (car new-pkg-desc) (cdr new-pkg-desc)))))) + +;; From Emacs 22. +(defun package-autoload-ensure-default-file (file) + "Make sure that the autoload file FILE exists and if not create it." + (unless (file-exists-p file) + (write-region + (concat ";;; " (file-name-nondirectory file) + " --- automatically extracted autoloads\n" + ";;\n" + ";;; Code:\n\n" + " \n;; Local Variables:\n" + ";; version-control: never\n" + ";; no-byte-compile: t\n" + ";; no-update-autoloads: t\n" + ";; End:\n" + ";;; " (file-name-nondirectory file) + " ends here\n") + nil file)) + file) + +(defun package-generate-autoloads (name pkg-dir) + "Generate autoload definitions for package NAME in PKG-DIR." + (let* ((auto-name (concat name "-autoloads.el")) + (ignore-name (concat name "-pkg.el")) + (generated-autoload-file (concat pkg-dir auto-name)) + (version-control 'never)) + ;; In Emacs 22 `update-directory-autoloads' does not seem + ;; to be autoloaded... + (require 'autoload) + (unless (fboundp 'autoload-ensure-default-file) + (package-autoload-ensure-default-file generated-autoload-file)) + (update-directory-autoloads pkg-dir))) + +(defun package-untar-buffer () + "Untar the current buffer. +This uses `tar-untar-buffer' if it is available. +Otherwise it uses an external `tar' program. +`default-directory' should be set by the caller." + (require 'tar-mode) + (if (fboundp 'tar-untar-buffer) + (progn + ;; tar-mode messes with narrowing, so we just let it have the + ;; whole buffer to play with. + (delete-region (point-min) (point)) + (tar-mode) + (tar-untar-buffer)) + ;; FIXME: check the result. + (call-process-region (point) (point-max) "tar" nil '(nil nil) nil + "xf" "-"))) + +(defun package-unpack (name version) + "Unpack a package tar from the current buffer. + +Unpack the package, using NAME and VERSION to determine the +target. The current buffer is expected to contain a tarred +package archive." + (let ((pkg-dir (concat (file-name-as-directory package-user-dir) + (symbol-name name) "-" version "/"))) + ;; Be careful!! + (make-directory package-user-dir t) + (if (file-directory-p pkg-dir) + (mapc (lambda (file) nil) ; 'delete-file -- FIXME: when we're + ; more confident + (directory-files pkg-dir t "^[^.]"))) + (let* ((default-directory (file-name-as-directory package-user-dir))) + (package-untar-buffer) + (package-generate-autoloads (symbol-name name) pkg-dir) + (let ((load-path (cons pkg-dir load-path))) + (byte-recompile-directory pkg-dir 0 t))))) + +(defun package-unpack-single (file-name version desc requires) + "Install the contents of the current buffer as a package. + +FILE-NAME is the name of the current file being unpacked. +package.el itself is handled specially, so this information is +important. + +VERSION is the version (as a string) of the file being unpacked. + +DESC is a brief description of the package. + +REQUIRES is a list of symbols which this package needs to run." + (let* ((dir (file-name-as-directory package-user-dir))) + ;; Special case "package". + (if (string= file-name "package") + (write-region (point-min) (point-max) (concat dir file-name ".el") + nil nil nil nil) + (let ((pkg-dir (file-name-as-directory + (concat dir file-name "-" version)))) + (make-directory pkg-dir t) + (write-region (point-min) (point-max) + (concat pkg-dir file-name ".el") + nil nil nil 'excl) + (let ((print-level nil) + (print-length nil)) + (write-region + (concat + (prin1-to-string + (list 'define-package + file-name + version + desc + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (car (cdr elt))))) + requires)))) + "\n") + nil + (concat pkg-dir file-name "-pkg.el") + nil nil nil 'excl)) + (package-generate-autoloads file-name pkg-dir) + (let ((load-path (cons pkg-dir load-path))) + (byte-recompile-directory pkg-dir 0 t)))))) + +(defun package-handle-response () + "Handle the response from the server. +Parse the HTTP response and throw if an error occurred. +The url package seems to require extra processing for this. +This should be called in a `save-excursion', in the download buffer. +It will move point to somewhere in the headers." + (let ((type (url-type url-current-object))) + (cond + ((equal type "http") + (let ((response (url-http-parse-response))) + (when (or (< response 200) (>= response 300)) + (display-buffer (current-buffer)) + (error "Error during download request:%s" + (buffer-substring-no-properties (point) (progn + (end-of-line) + (point))))))) + ((equal type "file") + nil)))) + +(defun package-download-single (name version desc requires) + "Download and install a single-file package. + +NAME, VERSION, DESC, and REQUIRES are used to build the package +info." + (let ((buffer (url-retrieve-synchronously + (concat (package-archive-for name) + (symbol-name name) "-" version ".el")))) + (save-excursion + (set-buffer buffer) + (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (delete-region (point-min) (point)) + (package-unpack-single (symbol-name name) version desc requires) + (kill-buffer buffer)))) + +(defun package-download-tar (name version) + "Download and install a tar package NAME at VERSION." + (let ((tar-buffer (url-retrieve-synchronously + (concat (package-archive-for name) + (symbol-name name) "-" version ".tar")))) + (save-excursion + (set-buffer tar-buffer) + (package-handle-response) + + ;; Skip past url-retrieve headers, which would otherwise confuse poor + ;; tar-mode. + (goto-char (point-min)) + (re-search-forward "^$" nil 'move) + (forward-char) + + (package-unpack name version) + (kill-buffer tar-buffer)))) + +(defun package-installed? (package &optional min-version) + "Check whether PACKAGE is installed and at least MIN-VERSION." + (let ((pkg-desc (assq package package-alist))) + (and pkg-desc + (package-version-compare min-version + (package-desc-vers (cdr pkg-desc)) + '<=)))) + +(defun package-compute-transaction (result requirements) + "Recursively prepare a transaction, resolving dependencies. + +RESULT is a flattened list of packages to install. +`package-compute-transaction' recursively builds this argument +before passing it up to the caller. + +REQUIREMENTS is a list of required packages, to be recursively +processed to resolve all dependencies (if possible)." + (while requirements + (let* ((elt (car requirements)) + (next-pkg (car elt)) + (next-version (car (cdr elt)))) + (unless (package-installed? next-pkg next-version) + (let ((pkg-desc (assq next-pkg package-archive-contents))) + (unless pkg-desc + (error "Package '%s' not available for installation" + (symbol-name next-pkg))) + (unless (package-version-compare (package-desc-vers (cdr pkg-desc)) + next-version + '>=) + (error + "Need package '%s' with version %s, but only %s is available" + (symbol-name next-pkg) (package-version-join next-version) + (package-version-join (package-desc-vers (cdr pkg-desc))))) + ;; Only add to the transaction if we don't already have it. + (unless (memq next-pkg result) + (setq result (cons next-pkg result))) + (setq result + (package-compute-transaction result + (package-desc-reqs + (cdr pkg-desc))))))) + (setq requirements (cdr requirements))) + result) + +(defun package-read-from-string (str) + "Read a Lisp expression from STR. +Signal an error if the entire string was not used." + (let* ((read-data (read-from-string str)) + (more-left + (condition-case nil + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string + (substring str (cdr read-data)))) + t) + (end-of-file nil)))) + (if more-left + (error "Can't read whole string") + (car read-data)))) + +(defun package--read-archive-file (file) + "Re-read archive file FILE, if it exists. +Will return the data from the file, or nil if the file does not exist. +Will throw an error if the archive version is too new." + (let ((filename (concat (file-name-as-directory package-user-dir) + file))) + (if (file-exists-p filename) + (with-temp-buffer + (insert-file-contents-literally filename) + (let ((contents (package-read-from-string + (buffer-substring-no-properties (point-min) + (point-max))))) + (if (> (car contents) package-archive-version) + (error "Package archive version %d is greater than %d - upgrade package.el" + (car contents) package-archive-version)) + (cdr contents)))))) + +(defun package-read-all-archive-contents () + "Read the archive description of each of the archives in `package-archives'." + (dolist (archive package-archives) + (package-read-archive-contents (car archive))) + (let ((builtins (package--read-archive-file + (concat "archives/" (caar package-archives) + "/builtin-packages")))) + (if builtins + ;; Version 1 of 'builtin-packages' is a list where the car is + ;; a split emacs version and the cdr is an alist suitable for + ;; package--builtins. + (let ((our-version (package-version-split emacs-version)) + (result package--builtins-base)) + (setq package--builtins + (dolist (elt builtins result) + (if (package-version-compare our-version (car elt) '>=) + (setq result (append (cdr elt) result))))))))) + +(defun package-read-archive-contents (archive) + "Re-read `archive-contents' and `builtin-packages', for ARCHIVE if they exist. + +Will set `package-archive-contents' and `package--builtins' if +successful. Will throw an error if the archive version is too +new." + (let ((archive-contents (package--read-archive-file + (concat "archives/" archive + "/archive-contents")))) + (if archive-contents + ;; Version 1 of 'archive-contents' is identical to our + ;; internal representation. + ;; TODO: merge archive lists + (dolist (package archive-contents) + (package--add-to-archive-contents package archive))))) + +(defun package--add-to-archive-contents (package archive) + "Add the PACKAGE from the given ARCHIVE if needed. + +Adds the archive from which it came to the end of the package vector." + (let* ((package-name (car package)) + (package-version (aref (cdr package) 0)) + (package-with-archive (cons (car package) + (vconcat (cdr package) (vector archive)))) + (existing-package (cdr (assq package-name package-archive-contents)))) + (when (or (not existing-package) + (package-version-compare package-version + (aref existing-package 0) '>)) + (add-to-list 'package-archive-contents package-with-archive)))) + +(defun package-download-transaction (transaction) + "Download and install all the packages in the given TRANSACTION." + (mapc (lambda (elt) + (let* ((desc (cdr (assq elt package-archive-contents))) + (v-string (package-version-join (package-desc-vers desc))) + (kind (package-desc-kind desc))) + (cond + ((eq kind 'tar) + (package-download-tar elt v-string)) + ((eq kind 'single) + (package-download-single elt v-string + (package-desc-doc desc) + (package-desc-reqs desc))) + (t + (error "Unknown package kind: " (symbol-name kind)))))) + transaction)) + +(defun package-install (name) + "Install the package named NAME. +Interactively, prompts for the package name." + (interactive + (list (progn + (intern (completing-read "Install package: " + (mapcar (lambda (elt) + (cons (symbol-name (car elt)) + nil)) + package-archive-contents) + nil t))))) + (let ((pkg-desc (assq name package-archive-contents))) + (unless pkg-desc + (error "Package '%s' not available for installation" + (symbol-name name))) + (let ((transaction + (package-compute-transaction (list name) + (package-desc-reqs (cdr pkg-desc))))) + (package-download-transaction transaction))) + ;; Try to activate it. + (package-initialize)) + +(defun package-strip-rcs-id (v-str) + "Strip RCS version ID from the version string V-STR. + +If the result looks like a dotted numeric version, return it. +Otherwise return nil." + (if v-str + (if (string-match "[ \t]*\\$\\(?:Revision\\|Id\\):[ \t]\\(?:[^ \t]+,v[ \t]+\\)?\\([0-9.]+\\).*\\$$" v-str) + (match-string 1 v-str) + (if (string-match "^[0-9.]*$" v-str) + v-str)))) + +(defun package-buffer-info () + "Return a vector of information about the package in the current buffer. +The vector looks like [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] +FILENAME is the file name, a string. It does not have the \".el\" extension. +REQUIRES is a requires list, or nil. +DESCRIPTION is the package description (a string). +VERSION is the version, a string. +COMMENTARY is the commentary section, a string, or nil if none. +Throws an exception if the buffer does not contain a conforming package. +If there is a package, narrows the buffer to the file's boundaries. +May narrow buffer or move point even on failure." + (goto-char (point-min)) + (if (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t) + (let ((file-name (match-string 1)) + (desc (match-string 2)) + (start (progn (beginning-of-line) (point)))) + (if (search-forward (concat ";;; " file-name ".el ends here")) + (progn + ;; Try to include a trailing newline. + (forward-line) + (narrow-to-region start (point)) + (require 'lisp-mnt) + ;; Use some headers we've invented to drive the process. + (let* ((requires-str (lm-header "package-requires")) + (requires (if requires-str + (package-read-from-string requires-str))) + ;; Prefer Package-Version, because if it is + ;; defined the package author probably wants us + ;; to use it. Otherwise try Version. + (pkg-version + (or (package-strip-rcs-id (lm-header "package-version")) + (package-strip-rcs-id (lm-header "version")))) + (commentary (lm-commentary))) + (unless pkg-version + (error + "Package does not define a usable \"Version\" or \"Package-Version\" header")) + ;; Turn string version numbers into list form. + (setq requires + (mapcar + (lambda (elt) + (list (car elt) + (package-version-split (car (cdr elt))))) + requires)) + (set-text-properties 0 (length file-name) nil file-name) + (set-text-properties 0 (length pkg-version) nil pkg-version) + (set-text-properties 0 (length desc) nil desc) + (vector file-name requires desc pkg-version commentary))) + (error "Package missing a terminating comment"))) + (error "No starting comment for package"))) + +(defun package-tar-file-info (file) + "Find package information for a tar file. +FILE is the name of the tar file to examine. +The return result is a vector like `package-buffer-info'." + (setq file (expand-file-name file)) + (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file) + (error "`%s' doesn't have a package-ish name" file)) + (let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file))) + (pkg-version (match-string-no-properties 2 file)) + ;; Extract the package descriptor. + (pkg-def-contents (shell-command-to-string + ;; Requires GNU tar. + (concat "tar -xOf " file " " + pkg-name "-" pkg-version "/" + pkg-name "-pkg.el"))) + (pkg-def-parsed (package-read-from-string pkg-def-contents))) + (unless (eq (car pkg-def-parsed) 'define-package) + (error "%s-pkg.el doesn't contain `define-package' sexp" pkg-name)) + (let ((name-str (nth 1 pkg-def-parsed)) + (version-string (nth 2 pkg-def-parsed)) + (docstring (nth 3 pkg-def-parsed)) + (requires (nth 4 pkg-def-parsed)) + + (readme (shell-command-to-string + ;; Requires GNU tar. + (concat "tar -xOf " file " " + pkg-name "-" pkg-version "/README")))) + (unless (equal pkg-version version-string) + (error "Inconsistent versions!")) + (unless (equal pkg-name name-str) + (error "Inconsistent names!")) + ;; Kind of a hack. + (if (string-match ": Not found in archive" readme) + (setq readme nil)) + ;; Turn string version numbers into list form. + (if (eq (car requires) 'quote) + (setq requires (car (cdr requires)))) + (setq requires + (mapcar + (lambda (elt) + (list (car elt) + (package-version-split (car (cdr elt))))) + requires)) + (vector pkg-name requires docstring version-string readme)))) + +(defun package-install-buffer-internal (pkg-info type) + "Download and install a single package. + +PKG-INFO describes the package to be installed. + +TYPE is either `single' or `tar'." + (save-excursion + (save-restriction + (let* ((file-name (aref pkg-info 0)) + (requires (aref pkg-info 1)) + (desc (if (string= (aref pkg-info 2) "") + "No description available." + (aref pkg-info 2))) + (pkg-version (aref pkg-info 3))) + ;; Download and install the dependencies. + (let ((transaction (package-compute-transaction nil requires))) + (package-download-transaction transaction)) + ;; Install the package itself. + (cond + ((eq type 'single) + (package-unpack-single file-name pkg-version desc requires)) + ((eq type 'tar) + (package-unpack (intern file-name) pkg-version)) + (t + (error "Unknown type: %s" (symbol-name type)))) + ;; Try to activate it. + (package-initialize))))) + +(defun package-install-from-buffer () + "Install a package from the current buffer. +The package is assumed to be a single .el file which +follows the elisp comment guidelines; see +info node `(elisp)Library Headers'." + (interactive) + (package-install-buffer-internal (package-buffer-info) 'single)) + +(defun package-install-file (file) + "Install a package from a FILE. +The file can either be a tar file or an Emacs Lisp file." + (interactive "fPackage file name: ") + (with-temp-buffer + (insert-file-contents-literally file) + (cond + ((string-match "\\.el$" file) (package-install-from-buffer)) + ((string-match "\\.tar$" file) + (package-install-buffer-internal (package-tar-file-info file) 'tar)) + (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) + +(defun package-delete (name version) + "Delete package NAME at VERSION." + (require 'dired) ; for dired-delete-file + (dired-delete-file (concat (file-name-as-directory package-user-dir) + name "-" version) + ;; FIXME: query user? + 'always)) + +(defun package--encode (string) + "Encode a STRING by replacing some characters with XML entities." + ;; We need a special case for translating "&" to "&". + (let ((index)) + (while (setq index (string-match "[&]" string index)) + (setq string (replace-match "&" t nil string)) + (setq index (1+ index)))) + (while (string-match "[<]" string) + (setq string (replace-match "<" t nil string))) + (while (string-match "[>]" string) + (setq string (replace-match ">" t nil string))) + (while (string-match "[']" string) + (setq string (replace-match "'" t nil string))) + (while (string-match "[\"]" string) + (setq string (replace-match """ t nil string))) + string) + +(defun package--update-file (file location text) + "Update FILE by finding LOCATION and inserting TEXT." + (save-excursion + (let ((old-buffer (find-buffer-visiting file))) + (with-current-buffer (let ((find-file-visit-truename t)) + (or old-buffer (find-file-noselect file))) + (goto-char (point-min)) + (search-forward location) + (forward-line) + (insert text) + (let ((file-precious-flag t)) + (save-buffer)) + (unless old-buffer + (kill-buffer (current-buffer))))))) + +(defun package-archive-for (name) + "Return the archive containing the package NAME." + (let ((desc (cdr (assq (intern-soft name) package-archive-contents)))) + (cdr (assoc (aref desc (- (length desc) 1)) package-archives)))) + +(defun package--download-one-archive (archive file) + "Download a single archive file and cache it locally. + +Downloads the archive index from ARCHIVE and stores it in FILE." + (let* ((archive-name (car archive)) + (archive-url (cdr archive)) + (buffer (url-retrieve-synchronously (concat archive-url file)))) + (save-excursion + (set-buffer buffer) + (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (delete-region (point-min) (point)) + (make-directory (concat (file-name-as-directory package-user-dir) + "archives/" archive-name) t) + (setq buffer-file-name (concat (file-name-as-directory package-user-dir) + "archives/" archive-name "/" file)) + (let ((version-control 'never)) + (save-buffer)) + (kill-buffer buffer)))) + +(defun package-refresh-contents () + "Download the ELPA archive description if needed. +Invoking this will ensure that Emacs knows about the latest versions +of all packages. This will let Emacs make them available for +download." + (interactive) + (dolist (archive package-archives) + (package--download-one-archive archive "archive-contents")) + (package-read-all-archive-contents)) + +(defun package-initialize () + "Load all packages and activate as many as possible." + (setq package-obsolete-alist nil) + (package-load-all-descriptors) + (package-read-all-archive-contents) + ;; Try to activate all our packages. + (mapc (lambda (elt) + (package-activate (car elt) (package-desc-vers (cdr elt)))) + package-alist)) + + + +;;;; Package menu mode. + +(defvar package-menu-mode-map + (let ((map (make-keymap)) + (menu-map (make-sparse-keymap "Package"))) + (suppress-keymap map) + (define-key map "q" 'quit-window) + (define-key map "n" 'next-line) + (define-key map "p" 'previous-line) + (define-key map "u" 'package-menu-mark-unmark) + (define-key map "\177" 'package-menu-backup-unmark) + (define-key map "d" 'package-menu-mark-delete) + (define-key map "i" 'package-menu-mark-install) + (define-key map "g" 'package-menu-revert) + (define-key map "r" 'package-menu-refresh) + (define-key map "~" 'package-menu-mark-obsolete-for-deletion) + (define-key map "x" 'package-menu-execute) + (define-key map "h" 'package-menu-quick-help) + (define-key map "?" 'package-menu-view-commentary) + (define-key map [menu-bar package-menu] (cons "Package" menu-map)) + (define-key menu-map [mq] + '(menu-item "Quit" quit-window + :help "Quit package selection")) + (define-key menu-map [s1] '("--")) + (define-key menu-map [mn] + '(menu-item "Next" next-line + :help "Next Line")) + (define-key menu-map [mp] + '(menu-item "Previous" previous-line + :help "Previous Line")) + (define-key menu-map [s2] '("--")) + (define-key menu-map [mu] + '(menu-item "Unmark" package-menu-mark-unmark + :help "Clear any marks on a package and move to the next line")) + (define-key menu-map [munm] + '(menu-item "Unmark backwards" package-menu-backup-unmark + :help "Back up one line and clear any marks on that package")) + (define-key menu-map [md] + '(menu-item "Mark for deletion" package-menu-mark-delete + :help "Mark a package for deletion and move to the next line")) + (define-key menu-map [mi] + '(menu-item "Mark for install" package-menu-mark-install + :help "Mark a package for installation and move to the next line")) + (define-key menu-map [s3] '("--")) + (define-key menu-map [mg] + '(menu-item "Update package list" package-menu-revert + :help "Update the list of packages")) + (define-key menu-map [mr] + '(menu-item "Refresh package list" package-menu-refresh + :help "Download the ELPA archive")) + (define-key menu-map [s4] '("--")) + (define-key menu-map [mt] + '(menu-item "Mark obsolete packages" package-menu-mark-obsolete-for-deletion + :help "Mark all obsolete packages for deletion")) + (define-key menu-map [mx] + '(menu-item "Execute actions" package-menu-execute + :help "Perform all the marked actions")) + (define-key menu-map [s5] '("--")) + (define-key menu-map [mh] + '(menu-item "Help" package-menu-quick-help + :help "Show short key binding help for package-menu-mode")) + (define-key menu-map [mc] + '(menu-item "View Commentary" package-menu-view-commentary + :help "Display information about this package")) + map) + "Local keymap for `package-menu-mode' buffers.") + +(defvar package-menu-sort-button-map + (let ((map (make-sparse-keymap))) + (define-key map [header-line mouse-1] 'package-menu-sort-by-column) + (define-key map [follow-link] 'mouse-face) + map) + "Local keymap for package menu sort buttons.") + +(put 'package-menu-mode 'mode-class 'special) + +(defun package-menu-mode () + "Major mode for browsing a list of packages. +Letters do not insert themselves; instead, they are commands. +\\<package-menu-mode-map> +\\{package-menu-mode-map}" + (kill-all-local-variables) + (use-local-map package-menu-mode-map) + (setq major-mode 'package-menu-mode) + (setq mode-name "Package Menu") + (setq truncate-lines t) + (setq buffer-read-only t) + ;; Support Emacs 21. + (if (fboundp 'run-mode-hooks) + (run-mode-hooks 'package-menu-mode-hook) + (run-hooks 'package-menu-mode-hook))) + +(defun package-menu-refresh () + "Download the ELPA archive. +This fetches the file describing the current contents of +the Emacs Lisp Package Archive, and then refreshes the +package menu. This lets you see what new packages are +available for download." + (interactive) + (package-refresh-contents) + (package-list-packages-internal)) + +(defun package-menu-revert () + "Update the list of packages." + (interactive) + (package-list-packages-internal)) + +(defun package-menu-mark-internal (what) + "Internal function to mark a package. + +WHAT is the character used to mark the line." + (unless (eobp) + (let ((buffer-read-only nil)) + (beginning-of-line) + (delete-char 1) + (insert what) + (forward-line)))) + +(defun package-menu-mark-delete (&optional arg) + "Mark a package for deletion and move to the next line. + +ARG is a (currently unused) numeric argument." + (interactive "p") + (package-menu-mark-internal "D")) + +(defun package-menu-mark-install (&optional arg) + "Mark a package for installation and move to the next line. + +ARG is a (currently unused) numeric argument." + (interactive "p") + (package-menu-mark-internal "I")) + +(defun package-menu-mark-unmark (&optional arg) + "Clear any marks on a package and move to the next line. + +ARG is a (currently unused) numeric argument." + (interactive "p") + (package-menu-mark-internal " ")) + +(defun package-menu-backup-unmark () + "Back up one line and clear any marks on that package." + (interactive) + (forward-line -1) + (package-menu-mark-internal " ") + (forward-line -1)) + +(defun package-menu-mark-obsolete-for-deletion () + "Mark all obsolete packages for deletion." + (interactive) + (save-excursion + (goto-char (point-min)) + (forward-line 2) + (while (not (eobp)) + (if (looking-at ".*\\s obsolete\\s ") + (package-menu-mark-internal "D") + (forward-line 1))))) + +(defun package-menu-quick-help () + "Show short key binding help for `package-menu-mode'." + (interactive) + (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp ?-view commentary")) + +(defun package-menu-view-commentary () + "Display information about this package. +For single-file packages, shows the commentary section from the header. +For larger packages, shows the README file." + (interactive) + (let* (start-point ok + (pkg-name (package-menu-get-package)) + (buffer (url-retrieve-synchronously + (concat (package-archive-for pkg-name) + pkg-name "-readme.txt")))) + (with-current-buffer buffer + ;; FIXME: it would be nice to work with any URL type. + (setq start-point url-http-end-of-headers) + (setq ok (eq (url-http-parse-response) 200))) + (let ((new-buffer (get-buffer-create "*Package Info*"))) + (with-current-buffer new-buffer + (let ((buffer-read-only nil)) + (erase-buffer) + (insert "Package information for " pkg-name "\n\n") + (if ok + (insert-buffer-substring buffer start-point) + (insert "This package does not have a README file or commentary comment.\n")) + (goto-char (point-min)) + (view-mode))) + (display-buffer new-buffer t)))) + +(defun package-menu-get-package () + "Return the name of the package on the current line." + (save-excursion + (beginning-of-line) + (if (looking-at ". \\([^ \t]*\\)") + (match-string-no-properties 1)))) + +(defun package-menu-get-version () + "Return the version of the package on the current line." + (save-excursion + (beginning-of-line) + (if (looking-at ". [^ \t]*[ \t]*\\([0-9.]*\\)") + (match-string 1)))) + +(defun package-menu-get-status () + "Get the status of the current line." + (save-excursion + (if (looking-at ". [^ \t]*[ \t]*[^ \t]*[ \t]*\\([^ \t]*\\)") + (match-string 1) + ""))) + +(defun package-menu-execute () + "Perform all the marked actions. +Packages marked for installation will be downloaded and +installed. Packages marked for deletion will be removed. +Note that after installing packages you will want to restart +Emacs." + (interactive) + (goto-char (point-min)) + (forward-line 2) + (while (not (eobp)) + (let ((cmd (char-after)) + (pkg-name (package-menu-get-package)) + (pkg-vers (package-menu-get-version)) + (pkg-status (package-menu-get-status))) + (cond + ((eq cmd ?D) + (when (and (string= pkg-status "installed") + (string= pkg-name "package")) + ;; FIXME: actually, we could be tricky and remove all info. + ;; But that is drastic and the user can do that instead. + (error "Can't delete most recent version of `package'")) + ;; Ask for confirmation here? Maybe if package status is ""? + ;; Or if any lisp from package is actually loaded? + (message "Deleting %s-%s..." pkg-name pkg-vers) + (package-delete pkg-name pkg-vers) + (message "Deleting %s-%s... done" pkg-name pkg-vers)) + ((eq cmd ?I) + (package-install (intern pkg-name))))) + (forward-line)) + (package-menu-revert)) + +(defun package-print-package (package version key desc) + "Print out a single PACKAGE line for the menu buffer. + +PACKAGE is the package name as a symbol. + +VERSION is the version as an integer vector. + +KEY is the installation status of the package; either +\"available\" or \"installed\". + +DESC is the short description of the package." + (let ((face + (cond ((eq package 'emacs) 'font-lock-builtin-face) + ((string= key "available") 'default) + ((string= key "installed") 'font-lock-comment-face) + (t ; obsolete, but also the default. + ; is warning ok? + 'font-lock-warning-face)))) + (insert (propertize " " 'font-lock-face face)) + (insert (propertize (symbol-name package) 'font-lock-face face)) + (indent-to 20 1) + (insert (propertize (package-version-join version) 'font-lock-face face)) + (indent-to 30 1) + (insert (propertize key 'font-lock-face face)) + ;; FIXME: this 'when' is bogus... + (when desc + (indent-to 41 1) + (insert (propertize desc 'font-lock-face face))) + (insert "\n"))) + +(defun package-list-maybe-add (package version status description result) + "Add PACKAGE to the list if it is not already there. + +PACKAGE is the package name as a symbol. + +VERSION is the package version, as an integer vector. + +STATUS is the installation status of the package, either +\"available\" or \"installed\". + +DESCRIPTION is the short description of the package. + +RESULT is the list to which to add the package." + (let ((elt (assoc (cons package version) result))) + (unless elt + (setq result (cons (list (cons package version) status description) + result)))) + result) + +;; This decides how we should sort; nil means by package name. +(defvar package-menu-sort-key nil) + +(defun package-list-packages-internal () + "List the available and installed packages." + (package-initialize) ; FIXME: do this here? + (with-current-buffer (get-buffer-create "*Packages*") + (setq buffer-read-only nil) + (erase-buffer) + (let ((info-list)) + (mapc (lambda (elt) + (setq info-list + (package-list-maybe-add (car elt) + (package-desc-vers (cdr elt)) + ;; FIXME: it turns out to + ;; be tricky to see if + ;; this package is + ;; presently activated. + ;; That is lame! + "installed" + (package-desc-doc (cdr elt)) + info-list))) + package-alist) + (mapc (lambda (elt) + (setq info-list + (package-list-maybe-add (car elt) + (package-desc-vers (cdr elt)) + "available" + (package-desc-doc (cdr elt)) + info-list))) + package-archive-contents) + (mapc (lambda (elt) + (mapc (lambda (inner-elt) + (setq info-list + (package-list-maybe-add (car elt) + (package-desc-vers + (cdr inner-elt)) + "obsolete" + (package-desc-doc + (cdr inner-elt)) + info-list))) + (cdr elt))) + package-obsolete-alist) + (let ((selector (cond + ((string= package-menu-sort-key "Version") + ;; FIXME this doesn't work. + #'(lambda (e) (cdr (car e)))) + ((string= package-menu-sort-key "Status") + #'(lambda (e) (car (cdr e)))) + ((string= package-menu-sort-key "Description") + #'(lambda (e) (car (cdr (cdr e))))) + (t ; "Package" is default. + #'(lambda (e) (symbol-name (car (car e)))))))) + (setq info-list + (sort info-list + (lambda (left right) + (let ((vleft (funcall selector left)) + (vright (funcall selector right))) + (string< vleft vright)))))) + (mapc (lambda (elt) + (package-print-package (car (car elt)) + (cdr (car elt)) + (car (cdr elt)) + (car (cdr (cdr elt))))) + info-list)) + (goto-char (point-min)) + (current-buffer))) + +(defun package-menu-sort-by-column (&optional e) + "Sort the package menu by the last column clicked, E." + (interactive (list last-input-event)) + (if e (mouse-select-window e)) + (let* ((pos (event-start e)) + (obj (posn-object pos)) + (col (if obj + (get-text-property (cdr obj) 'column-name (car obj)) + (get-text-property (posn-point pos) 'column-name)))) + (setq package-menu-sort-key col)) + (package-list-packages-internal)) + +(defun package--list-packages () + "Display a list of packages. +Helper function that does all the work for the user-facing functions." + (with-current-buffer (package-list-packages-internal) + (package-menu-mode) + ;; Set up the header line. + (setq header-line-format + (mapconcat + (lambda (pair) + (let ((column (car pair)) + (name (cdr pair))) + (concat + ;; Insert a space that aligns the button properly. + (propertize " " 'display (list 'space :align-to column) + 'face 'fixed-pitch) + ;; Set up the column button. + (if (string= name "Version") + name + (propertize name + 'column-name name + 'help-echo "mouse-1: sort by column" + 'mouse-face 'highlight + 'keymap package-menu-sort-button-map))))) + ;; We take a trick from buff-menu and have a dummy leading + ;; space to align the header line with the beginning of the + ;; text. This doesn't really work properly on Emacs 21, + ;; but it is close enough. + '((0 . "") + (2 . "Package") + (20 . "Version") + (30 . "Status") + (41 . "Description")) + "")) + + ;; It's okay to use pop-to-buffer here. The package menu buffer + ;; has keybindings, and the user just typed 'M-x + ;; package-list-packages', suggesting that they might want to use + ;; them. + (pop-to-buffer (current-buffer)))) + +(defun package-list-packages () + "Display a list of packages. +Fetches the updated list of packages before displaying. +The list is displayed in a buffer named `*Packages*'." + (interactive) + (package-refresh-contents) + (package--list-packages)) + +(defun package-list-packages-no-fetch () + "Display a list of packages. +Does not fetch the updated list of packages before displaying. +The list is displayed in a buffer named `*Packages*'." + (interactive) + (package--list-packages)) + +;; Make it appear on the menu. +(define-key-after menu-bar-options-menu [package] + '(menu-item "Manage Packages" package-list-packages + :help "Install or uninstall additional Emacs packages")) + +(provide 'package) + +;;; package.el ends here
deleted file mode 100644 --- a/.elisp/paredit.el +++ /dev/null @@ -1,1828 +0,0 @@ -;;; -*- Mode: Emacs-Lisp; outline-regexp: " \n;;;;+" -*- - -;;;;;; Paredit: Parenthesis-Editing Minor Mode -;;;;;; Version 20 - -;;; This code is written by Taylor R. Campbell (except where explicitly -;;; noted) and placed in the Public Domain. All warranties are -;;; disclaimed. - -;;; Add this to your .emacs after adding paredit.el to /path/to/elisp/: -;;; -;;; (add-to-list 'load-path "/path/to/elisp/") -;;; (autoload 'paredit-mode "paredit" -;;; "Minor mode for pseudo-structurally editing Lisp code." -;;; t) -;;; (add-hook '...-mode-hook (lambda () (paredit-mode +1))) -;;; -;;; Usually the ... will be lisp or scheme or both. Alternatively, you -;;; can manually toggle this mode with M-x paredit-mode. Customization -;;; of paredit can be accomplished with `eval-after-load': -;;; -;;; (eval-after-load 'paredit -;;; '(progn ...redefine keys, &c....)) -;;; -;;; This should run in GNU Emacs 21 or later and XEmacs 21.5 or later. -;;; It is highly unlikely to work in earlier versions of GNU Emacs, and -;;; it may have obscure problems in earlier versions of XEmacs due to -;;; the way its syntax parser reports conditions, as a result of which -;;; the code that uses the syntax parser must mask *all* error -;;; conditions, not just those generated by the syntax parser. - -;;; This mode changes the keybindings for a number of simple keys, -;;; notably (, ), ", \, and ;. The bracket keys (round or square) are -;;; defined to insert parenthesis pairs and move past the close, -;;; respectively; the double-quote key is multiplexed to do both, and -;;; also insert an escape if within a string; backslashes prompt the -;;; user for the next character to input, because a lone backslash can -;;; break structure inadvertently; and semicolons ensure that they do -;;; not accidentally comment valid structure. (Use M-; to comment an -;;; expression.) These all have their ordinary behaviour when inside -;;; comments, and, outside comments, if truly necessary, you can insert -;;; them literally with C-q. -;;; -;;; These keybindings are set up for my preference. One particular -;;; preference which I've seen vary greatly from person to person is -;;; whether the command to move past a closing delimiter ought to -;;; insert a newline. Since I find this behaviour to be more common -;;; than that which inserts no newline, I have ) bound to it, and the -;;; more involved M-) to perform the less common action. This bothers -;;; some users, though, and they prefer the other way around. This -;;; code, which you can use `eval-after-load' to put in your .emacs, -;;; will exchange the bindings: -;;; -;;; (define-key paredit-mode-map (kbd ")") -;;; 'paredit-close-parenthesis) -;;; (define-key paredit-mode-map (kbd "M-)") -;;; 'paredit-close-parenthesis-and-newline) -;;; -;;; Paredit also changes the bindings of keys for deleting and killing, -;;; so that they will not destroy any S-expression structure by killing -;;; or deleting only one side of a bracket or quote pair. If the point -;;; is on a closing bracket, DEL will move left over it; if it is on an -;;; opening bracket, C-d will move right over it. Only if the point is -;;; between a pair of brackets will C-d or DEL delete them, and in that -;;; case it will delete both simultaneously. M-d and M-DEL kill words, -;;; but skip over any S-expression structure. C-k kills from the start -;;; of the line, either to the line's end, if it contains only balanced -;;; expressions; to the first closing bracket, if the point is within a -;;; form that ends on the line; or up to the end of the last expression -;;; that starts on the line after the point. -;;; -;;; Automatic reindentation is performed as locally as possible, to -;;; ensure that Emacs does not interfere with custom indentation used -;;; elsewhere in some S-expression. It is performed only by the -;;; advanced S-expression frobnication commands, and only on the forms -;;; that were immediately operated upon (& their subforms). -;;; -;;; This code is written for clarity, not efficiency. S-expressions -;;; are frequently walked over redundantly. If you have problems with -;;; some of the commands taking too long to execute, tell me, but first -;;; make sure that what you're doing is reasonable: it is stylistically -;;; bad to have huge, long, hideously nested code anyway. -;;; -;;; Questions, bug reports, comments, feature suggestions, &c., can be -;;; addressed to the author via mail on the host mumble.net to campbell -;;; or via IRC on irc.freenode.net in the #paredit channel under the -;;; nickname Riastradh. - -;;; This assumes Unix-style LF line endings. - -(defconst paredit-version 20) - -(eval-and-compile - - (defun paredit-xemacs-p () - ;; No idea I got this definition from. Edward O'Connor (hober on - ;; IRC) suggested the current definition. - ;; (and (boundp 'running-xemacs) - ;; running-xemacs) - (featurep 'xemacs)) - - (defun paredit-gnu-emacs-p () - (not (paredit-xemacs-p))) - - (defmacro xcond (&rest clauses) - "Exhaustive COND. -Signal an error if no clause matches." - `(cond ,@clauses - (t (error "XCOND lost.")))) - - (defalias 'paredit-warn (if (fboundp 'warn) 'warn 'message)) - - (defvar paredit-sexp-error-type - (with-temp-buffer - (insert "(") - (condition-case condition - (backward-sexp) - (error (if (eq (car condition) 'error) - (paredit-warn "%s%s%s%s" - "Paredit is unable to discriminate" - " S-expression parse errors from" - " other errors. " - " This may cause obscure problems. " - " Please upgrade Emacs.")) - (car condition))))) - - (defmacro paredit-handle-sexp-errors (body &rest handler) - `(condition-case () - ,body - (,paredit-sexp-error-type ,@handler))) - - (put 'paredit-handle-sexp-errors 'lisp-indent-function 1) - - (defmacro paredit-ignore-sexp-errors (&rest body) - `(paredit-handle-sexp-errors (progn ,@body) - nil)) - - (put 'paredit-ignore-sexp-errors 'lisp-indent-function 0) - - nil) - -;;;; Minor Mode Definition - -(defvar paredit-mode-map (make-sparse-keymap) - "Keymap for the paredit minor mode.") - -(define-minor-mode paredit-mode - "Minor mode for pseudo-structurally editing Lisp code. -\\<paredit-mode-map>" - :lighter " Paredit" - ;; If we're enabling paredit-mode, the prefix to this code that - ;; DEFINE-MINOR-MODE inserts will have already set PAREDIT-MODE to - ;; true. If this is the case, then first check the parentheses, and - ;; if there are any imbalanced ones we must inhibit the activation of - ;; paredit mode. We skip the check, though, if the user supplied a - ;; prefix argument interactively. - (if (and paredit-mode - (not current-prefix-arg)) - (if (not (fboundp 'check-parens)) - (paredit-warn "`check-parens' is not defined; %s" - "be careful of malformed S-expressions.") - (condition-case condition - (check-parens) - (error (setq paredit-mode nil) - (signal (car condition) (cdr condition))))))) - -;;; Old functions from when there was a different mode for emacs -nw. - -(defun enable-paredit-mode () - "Turn on pseudo-structural editing of Lisp code. - -Deprecated: use `paredit-mode' instead." - (interactive) - (paredit-mode +1)) - -(defun disable-paredit-mode () - "Turn off pseudo-structural editing of Lisp code. - -Deprecated: use `paredit-mode' instead." - (interactive) - (paredit-mode -1)) - -(defvar paredit-backward-delete-key - (xcond ((paredit-xemacs-p) "BS") - ((paredit-gnu-emacs-p) "DEL"))) - -(defvar paredit-forward-delete-keys - (xcond ((paredit-xemacs-p) '("DEL")) - ((paredit-gnu-emacs-p) '("<delete>" "<deletechar>")))) - -;;;; Paredit Keys - -;;; Separating the definition and initialization of this variable -;;; simplifies the development of paredit, since re-evaluating DEFVAR -;;; forms doesn't actually do anything. - -(defvar paredit-commands nil - "List of paredit commands with their keys and examples.") - -;;; Each specifier is of the form: -;;; (key[s] function (example-input example-output) ...) -;;; where key[s] is either a single string suitable for passing to KBD -;;; or a list of such strings. Entries in this list may also just be -;;; strings, in which case they are headings for the next entries. - -(progn (setq paredit-commands - `( - "Basic Insertion Commands" - ("(" paredit-open-parenthesis - ("(a b |c d)" - "(a b (|) c d)") - ("(foo \"bar |baz\" quux)" - "(foo \"bar (|baz\" quux)")) - (")" paredit-close-parenthesis-and-newline - ("(defun f (x| ))" - "(defun f (x)\n |)") - ("; (Foo.|" - "; (Foo.)|")) - ("M-)" paredit-close-parenthesis - ("(a b |c )" "(a b c)|") - ("; Hello,| world!" - "; Hello,)| world!")) - ("[" paredit-open-bracket - ("(a b |c d)" - "(a b [|] c d)") - ("(foo \"bar |baz\" quux)" - "(foo \"bar [baz\" quux)")) - ("]" paredit-close-bracket - ("(define-key keymap [frob| ] 'frobnicate)" - "(define-key keymap [frob]| 'frobnicate)") - ("; [Bar.|" - "; [Bar.]|")) - ("\"" paredit-doublequote - ("(frob grovel |full lexical)" - "(frob grovel \"|\" full lexical)") - ("(foo \"bar |baz\" quux)" - "(foo \"bar \\\"|baz\" quux)")) - ("M-\"" paredit-meta-doublequote - ("(foo \"bar |baz\" quux)" - "(foo \"bar baz\"\n |quux)") - ("(foo |(bar #\\x \"baz \\\\ quux\") zot)" - ,(concat "(foo \"|(bar #\\\\x \\\"baz \\\\" - "\\\\ quux\\\")\" zot)"))) - ("\\" paredit-backslash - ("(string #|)\n ; Escaping character... (x)" - "(string #\\x|)") - ("\"foo|bar\"\n ; Escaping character... (\")" - "\"foo\\\"|bar\"")) - (";" paredit-semicolon - ("|(frob grovel)" - ";|\n(frob grovel)") - ("(frob grovel) |" - "(frob grovel) ;|")) - ("M-;" paredit-comment-dwim - ("(foo |bar) ; baz" - "(foo bar) ; |baz") - ("(frob grovel)|" - "(frob grovel) ;|") - (" (foo bar)\n|\n (baz quux)" - " (foo bar)\n ;; |\n (baz quux)") - (" (foo bar) |(baz quux)" - " (foo bar)\n ;; |\n (baz quux)") - ("|(defun hello-world ...)" - ";;; |\n(defun hello-world ...)")) - - ("C-j" paredit-newline - ("(let ((n (frobbotz))) |(display (+ n 1)\nport))" - ,(concat "(let ((n (frobbotz)))" - "\n |(display (+ n 1)" - "\n port))"))) - - "Deleting & Killing" - (("C-d" ,@paredit-forward-delete-keys) - paredit-forward-delete - ("(quu|x \"zot\")" "(quu| \"zot\")") - ("(quux |\"zot\")" - "(quux \"|zot\")" - "(quux \"|ot\")") - ("(foo (|) bar)" "(foo | bar)") - ("|(foo bar)" "(|foo bar)")) - (,paredit-backward-delete-key - paredit-backward-delete - ("(\"zot\" q|uux)" "(\"zot\" |uux)") - ("(\"zot\"| quux)" - "(\"zot|\" quux)" - "(\"zo|\" quux)") - ("(foo (|) bar)" "(foo | bar)") - ("(foo bar)|" "(foo bar|)")) - ("C-k" paredit-kill - ("(foo bar)| ; Useless comment!" - "(foo bar)|") - ("(|foo bar) ; Useful comment!" - "(|) ; Useful comment!") - ("|(foo bar) ; Useless line!" - "|") - ("(foo \"|bar baz\"\n quux)" - "(foo \"|\"\n quux)")) - ("M-d" paredit-forward-kill-word - ("|(foo bar) ; baz" - "(| bar) ; baz" - "(|) ; baz" - "() ;|") - (";;;| Frobnicate\n(defun frobnicate ...)" - ";;;|\n(defun frobnicate ...)" - ";;;\n(| frobnicate ...)")) - (,(concat "M-" paredit-backward-delete-key) - paredit-backward-kill-word - ("(foo bar) ; baz\n(quux)|" - "(foo bar) ; baz\n(|)" - "(foo bar) ; |\n()" - "(foo |) ; \n()" - "(|) ; \n()")) - - "Movement & Navigation" - ("C-M-f" paredit-forward - ("(foo |(bar baz) quux)" - "(foo (bar baz)| quux)") - ("(foo (bar)|)" - "(foo (bar))|")) - ("C-M-b" paredit-backward - ("(foo (bar baz)| quux)" - "(foo |(bar baz) quux)") - ("(|(foo) bar)" - "|((foo) bar)")) -;;;("C-M-u" backward-up-list) ; These two are built-in. -;;;("C-M-d" down-list) - ("C-M-p" backward-down-list) ; Built-in, these are FORWARD- - ("C-M-n" up-list) ; & BACKWARD-LIST, which have - ; no need given C-M-f & C-M-b. - - "Depth-Changing Commands" - ("M-(" paredit-wrap-sexp - ("(foo |bar baz)" - "(foo (|bar) baz)")) - ("M-[" paredit-bracket-wrap-sexp - ("(foo |bar baz)" - "(foo [|bar] baz)")) - ("M-s" paredit-splice-sexp - ("(foo (bar| baz) quux)" - "(foo bar| baz quux)")) - (("M-<up>" "ESC <up>") - paredit-splice-sexp-killing-backward - ("(foo (let ((x 5)) |(sqrt n)) bar)" - "(foo (sqrt n) bar)")) - (("M-<down>" "ESC <down>") - paredit-splice-sexp-killing-forward - ("(a (b c| d e) f)" - "(a b c f)")) - ("M-r" paredit-raise-sexp - ("(dynamic-wind in (lambda () |body) out)" - "(dynamic-wind in |body out)" - "|body")) - - "Barfage & Slurpage" - (("C-)" "C-<right>") - paredit-forward-slurp-sexp - ("(foo (bar |baz) quux zot)" - "(foo (bar |baz quux) zot)") - ("(a b ((c| d)) e f)" - "(a b ((c| d) e) f)")) - (("C-}" "C-<left>") - paredit-forward-barf-sexp - ("(foo (bar |baz quux) zot)" - "(foo (bar |baz) quux zot)")) - (("C-(" "C-M-<left>" "ESC C-<left>") - paredit-backward-slurp-sexp - ("(foo bar (baz| quux) zot)" - "(foo (bar baz| quux) zot)") - ("(a b ((c| d)) e f)" - "(a (b (c| d)) e f)")) - (("C-{" "C-M-<right>" "ESC C-<right>") - paredit-backward-barf-sexp - ("(foo (bar baz |quux) zot)" - "(foo bar (baz |quux) zot)")) - - "Miscellaneous Commands" - ("M-S" paredit-split-sexp - ("(hello| world)" - "(hello)| (world)") - ("\"Hello, |world!\"" - "\"Hello, \"| \"world!\"")) - ("M-J" paredit-join-sexps - ("(hello)| (world)" - "(hello| world)") - ("\"Hello, \"| \"world!\"" - "\"Hello, |world!\"") - ("hello-\n| world" - "hello-|world")) - ("C-c C-M-l" paredit-recentre-on-sexp) - )) - nil) ; end of PROGN - -;;;;; Command Examples - -(eval-and-compile - (defmacro paredit-do-commands (vars string-case &rest body) - (let ((spec (nth 0 vars)) - (keys (nth 1 vars)) - (fn (nth 2 vars)) - (examples (nth 3 vars))) - `(dolist (,spec paredit-commands) - (if (stringp ,spec) - ,string-case - (let ((,keys (let ((k (car ,spec))) - (cond ((stringp k) (list k)) - ((listp k) k) - (t (error "Invalid paredit command %s." - ,spec))))) - (,fn (cadr ,spec)) - (,examples (cddr ,spec))) - ,@body))))) - - (put 'paredit-do-commands 'lisp-indent-function 2)) - -(defun paredit-define-keys () - (paredit-do-commands (spec keys fn examples) - nil ; string case - (dolist (key keys) - (define-key paredit-mode-map (read-kbd-macro key) fn)))) - -(defun paredit-function-documentation (fn) - (let ((original-doc (get fn 'paredit-original-documentation)) - (doc (documentation fn 'function-documentation))) - (or original-doc - (progn (put fn 'paredit-original-documentation doc) - doc)))) - -(defun paredit-annotate-mode-with-examples () - (let ((contents - (list (paredit-function-documentation 'paredit-mode)))) - (paredit-do-commands (spec keys fn examples) - (push (concat "\n \n" spec "\n") - contents) - (let ((name (symbol-name fn))) - (if (string-match (symbol-name 'paredit-) name) - (push (concat "\n\n\\[" name "]\t" name - (if examples - (mapconcat (lambda (example) - (concat - "\n" - (mapconcat 'identity - example - "\n --->\n") - "\n")) - examples - "") - "\n (no examples)\n")) - contents)))) - (put 'paredit-mode 'function-documentation - (apply 'concat (reverse contents)))) - ;; PUT returns the huge string we just constructed, which we don't - ;; want it to return. - nil) - -(defun paredit-annotate-functions-with-examples () - (paredit-do-commands (spec keys fn examples) - nil ; string case - (put fn 'function-documentation - (concat (paredit-function-documentation fn) - "\n\n\\<paredit-mode-map>\\[" (symbol-name fn) "]\n" - (mapconcat (lambda (example) - (concat "\n" - (mapconcat 'identity - example - "\n ->\n") - "\n")) - examples - ""))))) - -;;;;; HTML Examples - -(defun paredit-insert-html-examples () - "Insert HTML for a paredit quick reference table." - (interactive) - (let ((insert-lines (lambda (&rest lines) - (mapc (lambda (line) (insert line) (newline)) - lines))) - (html-keys (lambda (keys) - (mapconcat 'paredit-html-quote keys ", "))) - (html-example - (lambda (example) - (concat "<table><tr><td><pre>" - (mapconcat 'paredit-html-quote - example - (concat "</pre></td></tr><tr><td>" - " --->" - "</td></tr><tr><td><pre>")) - "</pre></td></tr></table>"))) - (firstp t)) - (paredit-do-commands (spec keys fn examples) - (progn (if (not firstp) - (insert "</table>\n") - (setq firstp nil)) - (funcall insert-lines - (concat "<h3>" spec "</h3>") - "<table border=\"1\" cellpadding=\"1\">" - " <tr>" - " <th>Command</th>" - " <th>Keys</th>" - " <th>Examples</th>" - " </tr>")) - (let ((name (symbol-name fn))) - (if (string-match (symbol-name 'paredit-) name) - (funcall insert-lines - " <tr>" - (concat " <td><tt>" name "</tt></td>") - (concat " <td align=\"center\">" - (funcall html-keys keys) - "</td>") - (concat " <td>" - (if examples - (mapconcat html-example examples - "<hr>") - "(no examples)") - "</td>") - " </tr>"))))) - (insert "</table>\n")) - -(defun paredit-html-quote (string) - (with-temp-buffer - (dotimes (i (length string)) - (insert (let ((c (elt string i))) - (cond ((eq c ?\<) "<") - ((eq c ?\>) ">") - ((eq c ?\&) "&") - ((eq c ?\') "'") - ((eq c ?\") """) - (t c))))) - (buffer-string))) - -;;;; Delimiter Insertion - -(eval-and-compile - (defun paredit-conc-name (&rest strings) - (intern (apply 'concat strings))) - - (defmacro define-paredit-pair (open close name) - `(progn - (defun ,(paredit-conc-name "paredit-open-" name) (&optional n) - ,(concat "Insert a balanced " name " pair. -With a prefix argument N, put the closing " name " after N - S-expressions forward. -If the region is active, `transient-mark-mode' is enabled, and the - region's start and end fall in the same parenthesis depth, insert a - " name " pair around the region. -If in a string or a comment, insert a single " name ". -If in a character literal, do nothing. This prevents changing what was - in the character literal to a meaningful delimiter unintentionally.") - (interactive "P") - (cond ((or (paredit-in-string-p) - (paredit-in-comment-p)) - (insert ,open)) - ((not (paredit-in-char-p)) - (paredit-insert-pair n ,open ,close 'goto-char)))) - (defun ,(paredit-conc-name "paredit-close-" name) () - ,(concat "Move past one closing delimiter and reindent. -\(Agnostic to the specific closing delimiter.) -If in a string or comment, insert a single closing " name ". -If in a character literal, do nothing. This prevents changing what was - in the character literal to a meaningful delimiter unintentionally.") - (interactive) - (paredit-move-past-close ,close)) - (defun ,(paredit-conc-name "paredit-close-" name "-and-newline") () - ,(concat "Move past one closing delimiter, add a newline," - " and reindent. -If there was a margin comment after the closing delimiter, preserve it - on the same line.") - (interactive) - (paredit-move-past-close-and-newline ,close)) - (defun ,(paredit-conc-name "paredit-" name "-wrap-sexp") (&optional n) - ,(concat "Wrap a pair of " name " around a sexp") - (interactive "P") - (paredit-wrap-sexp n ,open ,close))))) - -(define-paredit-pair ?\( ?\) "parenthesis") -(define-paredit-pair ?\[ ?\] "bracket") -(define-paredit-pair ?\{ ?\} "brace") -(define-paredit-pair ?\< ?\> "brocket") - -(defun paredit-move-past-close (close) - (cond ((or (paredit-in-string-p) - (paredit-in-comment-p)) - (insert close)) - ((not (paredit-in-char-p)) - (paredit-move-past-close-and-reindent) - (paredit-blink-paren-match nil)))) - -(defun paredit-move-past-close-and-newline (close) - (cond ((or (paredit-in-string-p) - (paredit-in-comment-p)) - (insert close)) - (t (if (paredit-in-char-p) (forward-char)) - (paredit-move-past-close-and-reindent) - (let ((comment.point (paredit-find-comment-on-line))) - (newline) - (if comment.point - (save-excursion - (forward-line -1) - (end-of-line) - (indent-to (cdr comment.point)) - (insert (car comment.point))))) - (lisp-indent-line) - (paredit-ignore-sexp-errors (indent-sexp)) - (paredit-blink-paren-match t)))) - -(defun paredit-find-comment-on-line () - "Find a margin comment on the current line. -If such a comment exists, delete the comment (including all leading - whitespace) and return a cons whose car is the comment as a string - and whose cdr is the point of the comment's initial semicolon, - relative to the start of the line." - (save-excursion - (catch 'return - (while t - (if (search-forward ";" (point-at-eol) t) - (if (not (or (paredit-in-string-p) - (paredit-in-char-p))) - (let* ((start (progn (backward-char) ;before semicolon - (point))) - (comment (buffer-substring start - (point-at-eol)))) - (paredit-skip-whitespace nil (point-at-bol)) - (delete-region (point) (point-at-eol)) - (throw 'return - (cons comment (- start (point-at-bol)))))) - (throw 'return nil)))))) - -(defun paredit-insert-pair (n open close forward) - (let* ((regionp (and (paredit-region-active-p) - (paredit-region-safe-for-insert-p))) - (end (and regionp - (not n) - (prog1 (region-end) - (goto-char (region-beginning)))))) - (let ((spacep (paredit-space-for-delimiter-p nil open))) - (if spacep (insert " ")) - (insert open) - (save-excursion - ;; Move past the desired region. - (cond (n (funcall forward - (save-excursion - (forward-sexp (prefix-numeric-value n)) - (point)))) - (regionp (funcall forward (+ end (if spacep 2 1))))) - (insert close) - (if (paredit-space-for-delimiter-p t close) - (insert " ")))))) - -(defun paredit-region-safe-for-insert-p () - (save-excursion - (let ((beginning (region-beginning)) - (end (region-end))) - (goto-char beginning) - (let* ((beginning-state (paredit-current-parse-state)) - (end-state (parse-partial-sexp beginning end - nil nil beginning-state))) - (and (= (nth 0 beginning-state) ; 0. depth in parens - (nth 0 end-state)) - (eq (nth 3 beginning-state) ; 3. non-nil if inside a - (nth 3 end-state)) ; string - (eq (nth 4 beginning-state) ; 4. comment status, yada - (nth 4 end-state)) - (eq (nth 5 beginning-state) ; 5. t if following char - (nth 5 end-state))))))) ; quote - -(defun paredit-space-for-delimiter-p (endp delimiter) - ;; If at the buffer limit, don't insert a space. If there is a word, - ;; symbol, other quote, or non-matching parenthesis delimiter (i.e. a - ;; close when want an open the string or an open when we want to - ;; close the string), do insert a space. - (and (not (if endp (eobp) (bobp))) - (memq (char-syntax (if endp - (char-after) - (char-before))) - (list ?w ?_ ?\" - (let ((matching (matching-paren delimiter))) - (and matching (char-syntax matching))))))) - -(defun paredit-move-past-close-and-reindent () - (let ((orig (point))) - (up-list) - (if (catch 'return ; This CATCH returns T if it - (while t ; should delete leading spaces - (save-excursion ; and NIL if not. - (let ((before-paren (1- (point)))) - (back-to-indentation) - (cond ((not (eq (point) before-paren)) - ;; Can't call PAREDIT-DELETE-LEADING-WHITESPACE - ;; here -- we must return from SAVE-EXCURSION - ;; first. - (throw 'return t)) - ((save-excursion (forward-line -1) - (end-of-line) - (paredit-in-comment-p)) - ;; Moving the closing parenthesis any further - ;; would put it into a comment, so we just - ;; indent the closing parenthesis where it is - ;; and abort the loop, telling its continuation - ;; that no leading whitespace should be deleted. - (lisp-indent-line) - (throw 'return nil)) - (t (delete-indentation))))))) - (paredit-delete-leading-whitespace)))) - -(defun paredit-delete-leading-whitespace () - ;; This assumes that we're on the closing parenthesis already. - (save-excursion - (backward-char) - (while (let ((syn (char-syntax (char-before)))) - (and (or (eq syn ?\ ) (eq syn ?-)) ; whitespace syntax - ;; The above line is a perfect example of why the - ;; following test is necessary. - (not (paredit-in-char-p (1- (point)))))) - (backward-delete-char 1)))) - -(defun paredit-blink-paren-match (another-line-p) - (if (and blink-matching-paren - (or (not show-paren-mode) another-line-p)) - (paredit-ignore-sexp-errors - (save-excursion - (backward-sexp) - (forward-sexp) - ;; SHOW-PAREN-MODE inhibits any blinking, so we disable it - ;; locally here. - (let ((show-paren-mode nil)) - (blink-matching-open)))))) - -(defun paredit-doublequote (&optional n) - "Insert a pair of double-quotes. -With a prefix argument N, wrap the following N S-expressions in - double-quotes, escaping intermediate characters if necessary. -If the region is active, `transient-mark-mode' is enabled, and the - region's start and end fall in the same parenthesis depth, insert a - pair of double-quotes around the region, again escaping intermediate - characters if necessary. -Inside a comment, insert a literal double-quote. -At the end of a string, move past the closing double-quote. -In the middle of a string, insert a backslash-escaped double-quote. -If in a character literal, do nothing. This prevents accidentally - changing a what was in the character literal to become a meaningful - delimiter unintentionally." - (interactive "P") - (cond ((paredit-in-string-p) - (if (eq (cdr (paredit-string-start+end-points)) - (point)) - (forward-char) ; We're on the closing quote. - (insert ?\\ ?\" ))) - ((paredit-in-comment-p) - (insert ?\" )) - ((not (paredit-in-char-p)) - (paredit-insert-pair n ?\" ?\" 'paredit-forward-for-quote)))) - -(defun paredit-meta-doublequote (&optional n) - "Move to the end of the string, insert a newline, and indent. -If not in a string, act as `paredit-doublequote'; if no prefix argument - is specified and the region is not active or `transient-mark-mode' is - disabled, the default is to wrap one S-expression, however, not - zero." - (interactive "P") - (if (not (paredit-in-string-p)) - (paredit-doublequote (or n - (and (not (paredit-region-active-p)) - 1))) - (let ((start+end (paredit-string-start+end-points))) - (goto-char (1+ (cdr start+end))) - (newline) - (lisp-indent-line) - (paredit-ignore-sexp-errors (indent-sexp))))) - -(defun paredit-forward-for-quote (end) - (let ((state (paredit-current-parse-state))) - (while (< (point) end) - (let ((new-state (parse-partial-sexp (point) (1+ (point)) - nil nil state))) - (if (paredit-in-string-p new-state) - (if (not (paredit-in-string-escape-p)) - (setq state new-state) - ;; Escape character: turn it into an escaped escape - ;; character by appending another backslash. - (insert ?\\ ) - ;; Now the point is after both escapes, and we want to - ;; rescan from before the first one to after the second - ;; one. - (setq state - (parse-partial-sexp (- (point) 2) (point) - nil nil state)) - ;; Advance the end point, since we just inserted a new - ;; character. - (setq end (1+ end))) - ;; String: escape by inserting a backslash before the quote. - (backward-char) - (insert ?\\ ) - ;; The point is now between the escape and the quote, and we - ;; want to rescan from before the escape to after the quote. - (setq state - (parse-partial-sexp (1- (point)) (1+ (point)) - nil nil state)) - ;; Advance the end point for the same reason as above. - (setq end (1+ end))))))) - -;;;; Escape Insertion - -(defun paredit-backslash () - "Insert a backslash followed by a character to escape." - (interactive) - (insert ?\\ ) - ;; This funny conditional is necessary because PAREDIT-IN-COMMENT-P - ;; assumes that PAREDIT-IN-STRING-P already returned false; otherwise - ;; it may give erroneous answers. - (if (or (paredit-in-string-p) - (not (paredit-in-comment-p))) - (let ((delp t)) - (unwind-protect (setq delp - (call-interactively 'paredit-escape)) - ;; We need this in an UNWIND-PROTECT so that the backlash is - ;; left in there *only* if PAREDIT-ESCAPE return NIL normally - ;; -- in any other case, such as the user hitting C-g or an - ;; error occurring, we must delete the backslash to avoid - ;; leaving a dangling escape. (This control structure is a - ;; crock.) - (if delp (backward-delete-char 1)))))) - -;;; This auxiliary interactive function returns true if the backslash -;;; should be deleted and false if not. - -(defun paredit-escape (char) - ;; I'm too lazy to figure out how to do this without a separate - ;; interactive function. - (interactive "cEscaping character...") - (if (eq char 127) ; The backslash was a typo, so - t ; the luser wants to delete it. - (insert char) ; (Is there a better way to - nil)) ; express the rubout char? - ; ?\^? works, but ugh...) - -;;; The placement of this function in this file is totally random. - -(defun paredit-newline () - "Insert a newline and indent it. -This is like `newline-and-indent', but it not only indents the line - that the point is on but also the S-expression following the point, - if there is one. -Move forward one character first if on an escaped character. -If in a string, just insert a literal newline." - (interactive) - (if (paredit-in-string-p) - (newline) - (if (and (not (paredit-in-comment-p)) (paredit-in-char-p)) - (forward-char)) - (newline-and-indent) - ;; Indent the following S-expression, but don't signal an error if - ;; there's only a closing parenthesis after the point. - (paredit-ignore-sexp-errors (indent-sexp)))) - -;;;; Comment Insertion - -(defun paredit-semicolon (&optional n) - "Insert a semicolon, moving any code after the point to a new line. -If in a string, comment, or character literal, insert just a literal - semicolon, and do not move anything to the next line. -With a prefix argument N, insert N semicolons." - (interactive "P") - (if (not (or (paredit-in-string-p) - (paredit-in-comment-p) - (paredit-in-char-p) - ;; No more code on the line after the point. - (save-excursion - (paredit-skip-whitespace t (point-at-eol)) - (or (eolp) - ;; Let the user prefix semicolons to existing - ;; comments. - (eq (char-after) ?\;))))) - ;; Don't use NEWLINE-AND-INDENT, because that will delete all of - ;; the horizontal whitespace first, but we just want to move the - ;; code following the point onto the next line while preserving - ;; the point on this line. - ;++ Why indent only the line? - (save-excursion (newline) (lisp-indent-line))) - (insert (make-string (if n (prefix-numeric-value n) 1) - ?\; ))) - -(defun paredit-comment-dwim (&optional arg) - "Call the Lisp comment command you want (Do What I Mean). -This is like `comment-dwim', but it is specialized for Lisp editing. -If transient mark mode is enabled and the mark is active, comment or - uncomment the selected region, depending on whether it was entirely - commented not not already. -If there is already a comment on the current line, with no prefix - argument, indent to that comment; with a prefix argument, kill that - comment. -Otherwise, insert a comment appropriate for the context and ensure that - any code following the comment is moved to the next line. -At the top level, where indentation is calculated to be at column 0, - insert a triple-semicolon comment; within code, where the indentation - is calculated to be non-zero, and on the line there is either no code - at all or code after the point, insert a double-semicolon comment; - and if the point is after all code on the line, insert a single- - semicolon margin comment at `comment-column'." - (interactive "*P") - (require 'newcomment) - (comment-normalize-vars) - (cond ((paredit-region-active-p) - (comment-or-uncomment-region (region-beginning) - (region-end) - arg)) - ((paredit-comment-on-line-p) - (if arg - (comment-kill (if (integerp arg) arg nil)) - (comment-indent))) - (t (paredit-insert-comment)))) - -(defun paredit-comment-on-line-p () - (save-excursion - (beginning-of-line) - (let ((comment-p nil)) - ;; Search forward for a comment beginning. If there is one, set - ;; COMMENT-P to true; if not, it will be nil. - (while (progn (setq comment-p - (search-forward ";" (point-at-eol) - ;; t -> no error - t)) - (and comment-p - (or (paredit-in-string-p) - (paredit-in-char-p (1- (point)))))) - (forward-char)) - comment-p))) - -(defun paredit-insert-comment () - (let ((code-after-p - (save-excursion (paredit-skip-whitespace t (point-at-eol)) - (not (eolp)))) - (code-before-p - (save-excursion (paredit-skip-whitespace nil (point-at-bol)) - (not (bolp))))) - (if (and (bolp) - ;; We have to use EQ 0 here and not ZEROP because ZEROP - ;; signals an error if its argument is non-numeric, but - ;; CALCULATE-LISP-INDENT may return nil. - (eq (let ((indent (calculate-lisp-indent))) - (if (consp indent) - (car indent) - indent)) - 0)) - ;; Top-level comment - (progn (if code-after-p (save-excursion (newline))) - (insert ";;; ")) - (if code-after-p - ;; Code comment - (progn (if code-before-p - ;++ Why NEWLINE-AND-INDENT here and not just - ;++ NEWLINE, or PAREDIT-NEWLINE? - (newline-and-indent)) - (lisp-indent-line) - (insert ";; ") - ;; Move the following code. (NEWLINE-AND-INDENT will - ;; delete whitespace after the comment, though, so use - ;; NEWLINE & LISP-INDENT-LINE manually here.) - (save-excursion (newline) - (lisp-indent-line))) - ;; Margin comment - (progn (indent-to comment-column - 1) ; 1 -> force one leading space - (insert ?\; )))))) - -;;;; Character Deletion - -(defun paredit-forward-delete (&optional arg) - "Delete a character forward or move forward over a delimiter. -If on an opening S-expression delimiter, move forward into the - S-expression. -If on a closing S-expression delimiter, refuse to delete unless the - S-expression is empty, in which case delete the whole S-expression. -With a prefix argument, simply delete a character forward, without - regard for delimiter balancing." - (interactive "P") - (cond ((or arg (eobp)) - (delete-char 1)) - ((paredit-in-string-p) - (paredit-forward-delete-in-string)) - ((paredit-in-comment-p) - ;++ What to do here? This could move a partial S-expression - ;++ into a comment and thereby invalidate the file's form, - ;++ or move random text out of a comment. - (delete-char 1)) - ((paredit-in-char-p) ; Escape -- delete both chars. - (backward-delete-char 1) - (delete-char 1)) - ((eq (char-after) ?\\ ) ; ditto - (delete-char 2)) - ((let ((syn (char-syntax (char-after)))) - (or (eq syn ?\( ) - (eq syn ?\" ))) - (forward-char)) - ((and (not (paredit-in-char-p (1- (point)))) - (eq (char-syntax (char-after)) ?\) ) - (eq (char-before) (matching-paren (char-after)))) - (backward-delete-char 1) ; Empty list -- delete both - (delete-char 1)) ; delimiters. - ;; Just delete a single character, if it's not a closing - ;; parenthesis. (The character literal case is already - ;; handled by now.) - ((not (eq (char-syntax (char-after)) ?\) )) - (delete-char 1)))) - -(defun paredit-forward-delete-in-string () - (let ((start+end (paredit-string-start+end-points))) - (cond ((not (eq (point) (cdr start+end))) - ;; If it's not the close-quote, it's safe to delete. But - ;; first handle the case that we're in a string escape. - (cond ((paredit-in-string-escape-p) - ;; We're right after the backslash, so backward - ;; delete it before deleting the escaped character. - (backward-delete-char 1)) - ((eq (char-after) ?\\ ) - ;; If we're not in a string escape, but we are on a - ;; backslash, it must start the escape for the next - ;; character, so delete the backslash before deleting - ;; the next character. - (delete-char 1))) - (delete-char 1)) - ((eq (1- (point)) (car start+end)) - ;; If it is the close-quote, delete only if we're also right - ;; past the open-quote (i.e. it's empty), and then delete - ;; both quotes. Otherwise we refuse to delete it. - (backward-delete-char 1) - (delete-char 1))))) - -(defun paredit-backward-delete (&optional arg) - "Delete a character backward or move backward over a delimiter. -If on a closing S-expression delimiter, move backward into the - S-expression. -If on an opening S-expression delimiter, refuse to delete unless the - S-expression is empty, in which case delete the whole S-expression. -With a prefix argument, simply delete a character backward, without - regard for delimiter balancing." - (interactive "P") - (cond ((or arg (bobp)) - (backward-delete-char 1)) ;++ should this untabify? - ((paredit-in-string-p) - (paredit-backward-delete-in-string)) - ((paredit-in-comment-p) - (backward-delete-char 1)) - ((paredit-in-char-p) ; Escape -- delete both chars. - (backward-delete-char 1) - (delete-char 1)) - ((paredit-in-char-p (1- (point))) - (backward-delete-char 2)) ; ditto - ((let ((syn (char-syntax (char-before)))) - (or (eq syn ?\) ) - (eq syn ?\" ))) - (backward-char)) - ((and (eq (char-syntax (char-before)) ?\( ) - (eq (char-after) (matching-paren (char-before)))) - (backward-delete-char 1) ; Empty list -- delete both - (delete-char 1)) ; delimiters. - ;; Delete it, unless it's an opening parenthesis. The case - ;; of character literals is already handled by now. - ((not (eq (char-syntax (char-before)) ?\( )) - (backward-delete-char-untabify 1)))) - -(defun paredit-backward-delete-in-string () - (let ((start+end (paredit-string-start+end-points))) - (cond ((not (eq (1- (point)) (car start+end))) - ;; If it's not the open-quote, it's safe to delete. - (if (paredit-in-string-escape-p) - ;; If we're on a string escape, since we're about to - ;; delete the backslash, we must first delete the - ;; escaped char. - (delete-char 1)) - (backward-delete-char 1) - (if (paredit-in-string-escape-p) - ;; If, after deleting a character, we find ourselves in - ;; a string escape, we must have deleted the escaped - ;; character, and the backslash is behind the point, so - ;; backward delete it. - (backward-delete-char 1))) - ((eq (point) (cdr start+end)) - ;; If it is the open-quote, delete only if we're also right - ;; past the close-quote (i.e. it's empty), and then delete - ;; both quotes. Otherwise we refuse to delete it. - (backward-delete-char 1) - (delete-char 1))))) - -;;;; Killing - -(defun paredit-kill (&optional arg) - "Kill a line as if with `kill-line', but respecting delimiters. -In a string, act exactly as `kill-line' but do not kill past the - closing string delimiter. -On a line with no S-expressions on it starting after the point or - within a comment, act exactly as `kill-line'. -Otherwise, kill all S-expressions that start after the point." - (interactive "P") - (cond (arg (kill-line)) - ((paredit-in-string-p) - (paredit-kill-line-in-string)) - ((or (paredit-in-comment-p) - (save-excursion - (paredit-skip-whitespace t (point-at-eol)) - (or (eq (char-after) ?\; ) - (eolp)))) - ;** Be careful about trailing backslashes. - (kill-line)) - (t (paredit-kill-sexps-on-line)))) - -(defun paredit-kill-line-in-string () - (if (save-excursion (paredit-skip-whitespace t (point-at-eol)) - (eolp)) - (kill-line) - (save-excursion - ;; Be careful not to split an escape sequence. - (if (paredit-in-string-escape-p) - (backward-char)) - (let ((beginning (point))) - (while (not (or (eolp) - (eq (char-after) ?\" ))) - (forward-char) - ;; Skip past escaped characters. - (if (eq (char-before) ?\\ ) - (forward-char))) - (kill-region beginning (point)))))) - -(defun paredit-kill-sexps-on-line () - (if (paredit-in-char-p) ; Move past the \ and prefix. - (backward-char 2)) ; (# in Scheme/CL, ? in elisp) - (let ((beginning (point)) - (eol (point-at-eol))) - (let ((end-of-list-p (paredit-forward-sexps-to-kill beginning eol))) - ;; If we got to the end of the list and it's on the same line, - ;; move backward past the closing delimiter before killing. (This - ;; allows something like killing the whitespace in ( ).) - (if end-of-list-p (progn (up-list) (backward-char))) - (if kill-whole-line - (paredit-kill-sexps-on-whole-line beginning) - (kill-region beginning - ;; If all of the S-expressions were on one line, - ;; i.e. we're still on that line after moving past - ;; the last one, kill the whole line, including - ;; any comments; otherwise just kill to the end of - ;; the last S-expression we found. Be sure, - ;; though, not to kill any closing parentheses. - (if (and (not end-of-list-p) - (eq (point-at-eol) eol)) - eol - (point))))))) - -;;; Please do not try to understand this code unless you have a VERY -;;; good reason to do so. I gave up trying to figure it out well -;;; enough to explain it, long ago. - -(defun paredit-forward-sexps-to-kill (beginning eol) - (let ((end-of-list-p nil) - (firstp t)) - ;; Move to the end of the last S-expression that started on this - ;; line, or to the closing delimiter if the last S-expression in - ;; this list is on the line. - (catch 'return - (while t - ;; This and the `kill-whole-line' business below fix a bug that - ;; inhibited any S-expression at the very end of the buffer - ;; (with no trailing newline) from being deleted. It's a - ;; bizarre fix that I ought to document at some point, but I am - ;; too busy at the moment to do so. - (if (and kill-whole-line (eobp)) (throw 'return nil)) - (save-excursion - (paredit-handle-sexp-errors (forward-sexp) - (up-list) - (setq end-of-list-p (eq (point-at-eol) eol)) - (throw 'return nil)) - (if (or (and (not firstp) - (not kill-whole-line) - (eobp)) - (paredit-handle-sexp-errors - (progn (backward-sexp) nil) - t) - (not (eq (point-at-eol) eol))) - (throw 'return nil))) - (forward-sexp) - (if (and firstp - (not kill-whole-line) - (eobp)) - (throw 'return nil)) - (setq firstp nil))) - end-of-list-p)) - -(defun paredit-kill-sexps-on-whole-line (beginning) - (kill-region beginning - (or (save-excursion ; Delete trailing indentation... - (paredit-skip-whitespace t) - (and (not (eq (char-after) ?\; )) - (point))) - ;; ...or just use the point past the newline, if - ;; we encounter a comment. - (point-at-eol))) - (cond ((save-excursion (paredit-skip-whitespace nil (point-at-bol)) - (bolp)) - ;; Nothing but indentation before the point, so indent it. - (lisp-indent-line)) - ((eobp) nil) ; Protect the CHAR-SYNTAX below against NIL. - ;; Insert a space to avoid invalid joining if necessary. - ((let ((syn-before (char-syntax (char-before))) - (syn-after (char-syntax (char-after)))) - (or (and (eq syn-before ?\) ) ; Separate opposing - (eq syn-after ?\( )) ; parentheses, - (and (eq syn-before ?\" ) ; string delimiter - (eq syn-after ?\" )) ; pairs, - (and (memq syn-before '(?_ ?w)) ; or word or symbol - (memq syn-after '(?_ ?w))))) ; constituents. - (insert " ")))) - -;;;;; Killing Words - -;;; This is tricky and asymmetrical because backward parsing is -;;; extraordinarily difficult or impossible, so we have to implement -;;; killing in both directions by parsing forward. - -(defun paredit-forward-kill-word () - "Kill a word forward, skipping over intervening delimiters." - (interactive) - (let ((beginning (point))) - (skip-syntax-forward " -") - (let* ((parse-state (paredit-current-parse-state)) - (state (paredit-kill-word-state parse-state 'char-after))) - (while (not (or (eobp) - (eq ?w (char-syntax (char-after))))) - (setq parse-state - (progn (forward-char 1) (paredit-current-parse-state)) -;; (parse-partial-sexp (point) (1+ (point)) -;; nil nil parse-state) - ) - (let* ((old-state state) - (new-state - (paredit-kill-word-state parse-state 'char-after))) - (cond ((not (eq old-state new-state)) - (setq parse-state - (paredit-kill-word-hack old-state - new-state - parse-state)) - (setq state - (paredit-kill-word-state parse-state - 'char-after)) - (setq beginning (point))))))) - (goto-char beginning) - (kill-word 1))) - -(defun paredit-backward-kill-word () - "Kill a word backward, skipping over any intervening delimiters." - (interactive) - (if (not (or (bobp) - (eq (char-syntax (char-before)) ?w))) - (let ((end (point))) - (backward-word 1) - (forward-word 1) - (goto-char (min end (point))) - (let* ((parse-state (paredit-current-parse-state)) - (state - (paredit-kill-word-state parse-state 'char-before))) - (while (and (< (point) end) - (progn - (setq parse-state - (parse-partial-sexp (point) (1+ (point)) - nil nil parse-state)) - (or (eq state - (paredit-kill-word-state parse-state - 'char-before)) - (progn (backward-char 1) nil))))) - (if (and (eq state 'comment) - (eq ?\# (char-after (point))) - (eq ?\| (char-before (point)))) - (backward-char 1))))) - (backward-kill-word 1)) - -;;; Word-Killing Auxiliaries - -(defun paredit-kill-word-state (parse-state adjacent-char-fn) - (cond ((paredit-in-comment-p parse-state) 'comment) - ((paredit-in-string-p parse-state) 'string) - ((memq (char-syntax (funcall adjacent-char-fn)) - '(?\( ?\) )) - 'delimiter) - (t 'other))) - -;;; This optionally advances the point past any comment delimiters that -;;; should probably not be touched, based on the last state change and -;;; the characters around the point. It returns a new parse state, -;;; starting from the PARSE-STATE parameter. - -(defun paredit-kill-word-hack (old-state new-state parse-state) - (cond ((and (not (eq old-state 'comment)) - (not (eq new-state 'comment)) - (not (paredit-in-string-escape-p)) - (eq ?\# (char-before)) - (eq ?\| (char-after))) - (forward-char 1) - (paredit-current-parse-state) -;; (parse-partial-sexp (point) (1+ (point)) -;; nil nil parse-state) - ) - ((and (not (eq old-state 'comment)) - (eq new-state 'comment) - (eq ?\; (char-before))) - (skip-chars-forward ";") - (paredit-current-parse-state) -;; (parse-partial-sexp (point) (save-excursion -;; (skip-chars-forward ";")) -;; nil nil parse-state) - ) - (t parse-state))) - -;;;; Cursor and Screen Movement - -(eval-and-compile - (defmacro defun-saving-mark (name bvl doc &rest body) - `(defun ,name ,bvl - ,doc - ,(xcond ((paredit-xemacs-p) - '(interactive "_")) - ((paredit-gnu-emacs-p) - '(interactive))) - ,@body))) - -(defun-saving-mark paredit-forward () - "Move forward an S-expression, or up an S-expression forward. -If there are no more S-expressions in this one before the closing - delimiter, move past that closing delimiter; otherwise, move forward - past the S-expression following the point." - (paredit-handle-sexp-errors - (forward-sexp) - ;++ Is it necessary to use UP-LIST and not just FORWARD-CHAR? - (if (paredit-in-string-p) (forward-char) (up-list)))) - -(defun-saving-mark paredit-backward () - "Move backward an S-expression, or up an S-expression backward. -If there are no more S-expressions in this one before the opening - delimiter, move past that opening delimiter backward; otherwise, move - move backward past the S-expression preceding the point." - (paredit-handle-sexp-errors - (backward-sexp) - (if (paredit-in-string-p) (backward-char) (backward-up-list)))) - -;;; Why is this not in lisp.el? - -(defun backward-down-list (&optional arg) - "Move backward and descend into one level of parentheses. -With ARG, do this that many times. -A negative argument means move forward but still descend a level." - (interactive "p") - (down-list (- (or arg 1)))) - -;;; Thanks to Marco Baringer for suggesting & writing this function. - -(defun paredit-recentre-on-sexp (&optional n) - "Recentre the screen on the S-expression following the point. -With a prefix argument N, encompass all N S-expressions forward." - (interactive "P") - (save-excursion - (forward-sexp n) - (let ((end-point (point))) - (backward-sexp n) - (let* ((start-point (point)) - (start-line (count-lines (point-min) (point))) - (lines-on-sexps (count-lines start-point end-point))) - (goto-line (+ start-line (/ lines-on-sexps 2))) - (recenter))))) - -;;;; Depth-Changing Commands: Wrapping, Splicing, & Raising - -(defun paredit-wrap-sexp (&optional n open close) - "Wrap the following S-expression in a list. -If a prefix argument N is given, wrap N S-expressions. -Automatically indent the newly wrapped S-expression. -As a special case, if the point is at the end of a list, simply insert - a pair of parentheses, rather than insert a lone opening parenthesis - and then signal an error, in the interest of preserving structure." - (interactive "P") - (let ((open (or open ?\()) - (close (or close ?\)))) - (paredit-handle-sexp-errors - (paredit-insert-pair (or n - (and (not (paredit-region-active-p)) - 1)) - open close - 'goto-char) - (insert close) - (backward-char)) - (save-excursion (backward-up-list) (indent-sexp)))) - -;;; Thanks to Marco Baringer for the suggestion of a prefix argument -;;; for PAREDIT-SPLICE-SEXP. (I, Taylor R. Campbell, however, still -;;; implemented it, in case any of you lawyer-folk get confused by the -;;; remark in the top of the file about explicitly noting code written -;;; by other people.) - -(defun paredit-splice-sexp (&optional arg) - "Splice the list that the point is on by removing its delimiters. -With a prefix argument as in `C-u', kill all S-expressions backward in - the current list before splicing all S-expressions forward into the - enclosing list. -With two prefix arguments as in `C-u C-u', kill all S-expressions - forward in the current list before splicing all S-expressions - backward into the enclosing list. -With a numerical prefix argument N, kill N S-expressions backward in - the current list before splicing the remaining S-expressions into the - enclosing list. If N is negative, kill forward. -This always creates a new entry on the kill ring." - (interactive "P") - (save-excursion - (paredit-kill-surrounding-sexps-for-splice arg) - (backward-up-list) ; Go up to the beginning... - (save-excursion - (forward-sexp) ; Go forward an expression, to - (backward-delete-char 1)) ; delete the end delimiter. - (delete-char 1) ; ...to delete the open char. - (paredit-ignore-sexp-errors - (backward-up-list) ; Reindent, now that the - (indent-sexp)))) ; structure has changed. - -(defun paredit-kill-surrounding-sexps-for-splice (arg) - (cond ((paredit-in-string-p) (error "Splicing illegal in strings.")) - ((or (not arg) (eq arg 0)) nil) - ((or (numberp arg) (eq arg '-)) - ;; Kill ARG S-expressions before/after the point by saving - ;; the point, moving across them, and killing the region. - (let* ((arg (if (eq arg '-) -1 arg)) - (saved (paredit-point-at-sexp-boundary (- arg)))) - (paredit-ignore-sexp-errors (backward-sexp arg)) - (kill-region-new saved (point)))) - ((consp arg) - (let ((v (car arg))) - (if (= v 4) ; one prefix argument - ;; Move backward until we hit the open paren; then - ;; kill that selected region. - (let ((end (paredit-point-at-sexp-start))) - (paredit-ignore-sexp-errors - (while (not (bobp)) - (backward-sexp))) - (kill-region-new (point) end)) - ;; Move forward until we hit the close paren; then - ;; kill that selected region. - (let ((beginning (paredit-point-at-sexp-end))) - (paredit-ignore-sexp-errors - (while (not (eobp)) - (forward-sexp))) - (kill-region-new beginning (point)))))) - (t (error "Bizarre prefix argument: %s" arg)))) - -(defun paredit-splice-sexp-killing-backward (&optional n) - "Splice the list the point is on by removing its delimiters, and - also kill all S-expressions before the point in the current list. -With a prefix argument N, kill only the preceding N S-expressions." - (interactive "P") - (paredit-splice-sexp (if n - (prefix-numeric-value n) - '(4)))) - -(defun paredit-splice-sexp-killing-forward (&optional n) - "Splice the list the point is on by removing its delimiters, and - also kill all S-expressions after the point in the current list. -With a prefix argument N, kill only the following N S-expressions." - (interactive "P") - (paredit-splice-sexp (if n - (- (prefix-numeric-value n)) - '(16)))) - -(defun paredit-raise-sexp (&optional n) - "Raise the following S-expression in a tree, deleting its siblings. -With a prefix argument N, raise the following N S-expressions. If N - is negative, raise the preceding N S-expressions." - (interactive "p") - ;; Select the S-expressions we want to raise in a buffer substring. - (let* ((bound (save-excursion (forward-sexp n) (point))) - (sexps (save-excursion ;++ Is this necessary? - (if (and n (< n 0)) - (buffer-substring bound - (paredit-point-at-sexp-end)) - (buffer-substring (paredit-point-at-sexp-start) - bound))))) - ;; Move up to the list we're raising those S-expressions out of and - ;; delete it. - (backward-up-list) - (delete-region (point) (save-excursion (forward-sexp) (point))) - (save-excursion (insert sexps)) ; Insert & reindent the sexps. - (save-excursion (let ((n (abs (or n 1)))) - (while (> n 0) - (paredit-forward-and-indent) - (setq n (1- n))))))) - -;;;; Slurpage & Barfage - -(defun paredit-forward-slurp-sexp () - "Add the S-expression following the current list into that list - by moving the closing delimiter. -Automatically reindent the newly slurped S-expression with respect to - its new enclosing form. -If in a string, move the opening double-quote forward by one - S-expression and escape any intervening characters as necessary, - without altering any indentation or formatting." - (interactive) - (save-excursion - (cond ((or (paredit-in-comment-p) - (paredit-in-char-p)) - (error "Invalid context for slurpage")) - ((paredit-in-string-p) - (paredit-forward-slurp-into-string)) - (t - (paredit-forward-slurp-into-list))))) - -(defun paredit-forward-slurp-into-list () - (up-list) ; Up to the end of the list to - (let ((close (char-before))) ; save and delete the closing - (backward-delete-char 1) ; delimiter. - (catch 'return ; Go to the end of the desired - (while t ; S-expression, going up a - (paredit-handle-sexp-errors ; list if it's not in this, - (progn (paredit-forward-and-indent) - (throw 'return nil)) - (insert close) - (up-list) - (setq close (char-before)) - (backward-delete-char 1)))) - (insert close))) ; to insert that delimiter. - -(defun paredit-forward-slurp-into-string () - (goto-char (1+ (cdr (paredit-string-start+end-points)))) - ;; Signal any errors that we might get first, before mucking with the - ;; buffer's contents. - (save-excursion (forward-sexp)) - (let ((close (char-before))) - (backward-delete-char 1) - (paredit-forward-for-quote (save-excursion (forward-sexp) (point))) - (insert close))) - -(defun paredit-forward-barf-sexp () - "Remove the last S-expression in the current list from that list - by moving the closing delimiter. -Automatically reindent the newly barfed S-expression with respect to - its new enclosing form." - (interactive) - (save-excursion - (up-list) ; Up to the end of the list to - (let ((close (char-before))) ; save and delete the closing - (backward-delete-char 1) ; delimiter. - (paredit-ignore-sexp-errors ; Go back to where we want to - (backward-sexp)) ; insert the delimiter. - (paredit-skip-whitespace nil) ; Skip leading whitespace. - (cond ((bobp) - (error "Barfing all subexpressions with no open-paren?")) - ((paredit-in-comment-p) ; Don't put the close-paren in - (newline-and-indent))) ; a comment. - (insert close)) - ;; Reindent all of the newly barfed S-expressions. - (paredit-forward-and-indent))) - -(defun paredit-backward-slurp-sexp () - "Add the S-expression preceding the current list into that list - by moving the closing delimiter. -Automatically reindent the whole form into which new S-expression was - slurped. -If in a string, move the opening double-quote backward by one - S-expression and escape any intervening characters as necessary, - without altering any indentation or formatting." - (interactive) - (save-excursion - (cond ((or (paredit-in-comment-p) - (paredit-in-char-p)) - (error "Invalid context for slurpage")) - ((paredit-in-string-p) - (paredit-backward-slurp-into-string)) - (t - (paredit-backward-slurp-into-list))))) - -(defun paredit-backward-slurp-into-list () - (backward-up-list) - (let ((open (char-after))) - (delete-char 1) - (catch 'return - (while t - (paredit-handle-sexp-errors - (progn (backward-sexp) - (throw 'return nil)) - (insert open) - (backward-char 1) - (backward-up-list) - (setq open (char-after)) - (delete-char 1)))) - (insert open)) - ;; Reindent the line at the beginning of wherever we inserted the - ;; opening parenthesis, and then indent the whole S-expression. - (backward-up-list) - (lisp-indent-line) - (indent-sexp)) - -(defun paredit-backward-slurp-into-string () - (goto-char (car (paredit-string-start+end-points))) - ;; Signal any errors that we might get first, before mucking with the - ;; buffer's contents. - (save-excursion (backward-sexp)) - (let ((open (char-after)) - (target (point))) - (message "open = %S" open) - (delete-char 1) - (backward-sexp) - (insert open) - (paredit-forward-for-quote target))) - -(defun paredit-backward-barf-sexp () - "Remove the first S-expression in the current list from that list - by moving the closing delimiter. -Automatically reindent the barfed S-expression and the form from which - it was barfed." - (interactive) - (save-excursion - (backward-up-list) - (let ((open (char-after))) - (delete-char 1) - (paredit-ignore-sexp-errors - (paredit-forward-and-indent)) - (while (progn (paredit-skip-whitespace t) - (eq (char-after) ?\; )) - (forward-line 1)) - (if (eobp) - (error - "Barfing all subexpressions with no close-paren?")) - ;** Don't use `insert' here. Consider, e.g., barfing from - ;** (foo|) - ;** and how `save-excursion' works. - (insert-before-markers open)) - (backward-up-list) - (lisp-indent-line) - (indent-sexp))) - -;;;; Splitting & Joining - -(defun paredit-split-sexp () - "Split the list or string the point is on into two." - (interactive) - (cond ((paredit-in-string-p) - (insert "\"") - (save-excursion (insert " \""))) - ((or (paredit-in-comment-p) - (paredit-in-char-p)) - (error "Invalid context for `paredit-split-sexp'")) - (t (let ((open (save-excursion (backward-up-list) - (char-after))) - (close (save-excursion (up-list) - (char-before)))) - (delete-horizontal-space) - (insert close) - (save-excursion (insert ?\ ) - (insert open) - (backward-char) - (indent-sexp)))))) - -(defun paredit-join-sexps () - "Join the S-expressions adjacent on either side of the point. -Both must be lists, strings, or atoms; error if there is a mismatch." - (interactive) - ;++ How ought this to handle comments intervening symbols or strings? - (save-excursion - (if (or (paredit-in-comment-p) - (paredit-in-string-p) - (paredit-in-char-p)) - (error "Invalid context in which to join S-expressions.") - (let ((left-point (save-excursion (paredit-point-at-sexp-end))) - (right-point (save-excursion - (paredit-point-at-sexp-start)))) - (let ((left-char (char-before left-point)) - (right-char (char-after right-point))) - (let ((left-syntax (char-syntax left-char)) - (right-syntax (char-syntax right-char))) - (cond ((>= left-point right-point) - (error "Can't join a datum with itself.")) - ((and (eq left-syntax ?\) ) - (eq right-syntax ?\( ) - (eq left-char (matching-paren right-char)) - (eq right-char (matching-paren left-char))) - ;; Leave intermediate formatting alone. - (goto-char right-point) - (delete-char 1) - (goto-char left-point) - (backward-delete-char 1) - (backward-up-list) - (indent-sexp)) - ((and (eq left-syntax ?\" ) - (eq right-syntax ?\" )) - ;; Delete any intermediate formatting. - (delete-region (1- left-point) - (1+ right-point))) - ((and (memq left-syntax '(?w ?_)) ; Word or symbol - (memq right-syntax '(?w ?_))) - (delete-region left-point right-point)) - (t - (error "Mismatched S-expressions to join."))))))))) - -;;;; Utilities - -(defun paredit-in-string-escape-p () - "True if the point is on a character escape of a string. -This is true only if the character is preceded by an odd number of - backslashes. -This assumes that `paredit-in-string-p' has already returned true." - (let ((oddp nil)) - (save-excursion - (while (eq (char-before) ?\\ ) - (setq oddp (not oddp)) - (backward-char))) - oddp)) - -(defun paredit-in-char-p (&optional arg) - "True if the point is immediately after a character literal. -A preceding escape character, not preceded by another escape character, - is considered a character literal prefix. (This works for elisp, - Common Lisp, and Scheme.) -Assumes that `paredit-in-string-p' is false, so that it need not handle - long sequences of preceding backslashes in string escapes. (This - assumes some other leading character token -- ? in elisp, # in Scheme - and Common Lisp.)" - (let ((arg (or arg (point)))) - (and (eq (char-before arg) ?\\ ) - (not (eq (char-before (1- arg)) ?\\ ))))) - -(defun paredit-forward-and-indent () - "Move forward an S-expression, indenting it fully. -Indent with `lisp-indent-line' and then `indent-sexp'." - (forward-sexp) ; Go forward, and then find the - (save-excursion ; beginning of this next - (backward-sexp) ; S-expression. - (lisp-indent-line) ; Indent its opening line, and - (indent-sexp))) ; the rest of it. - -(defun paredit-skip-whitespace (trailing-p &optional limit) - "Skip past any whitespace, or until the point LIMIT is reached. -If TRAILING-P is nil, skip leading whitespace; otherwise, skip trailing - whitespace." - (funcall (if trailing-p 'skip-chars-forward 'skip-chars-backward) - " \t\n " ; This should skip using the syntax table, but LF - limit)) ; is a comment end, not newline, in Lisp mode. - -(defalias 'paredit-region-active-p - (xcond ((paredit-xemacs-p) 'region-active-p) - ((paredit-gnu-emacs-p) - (lambda () - (and mark-active transient-mark-mode))))) - -(defun kill-region-new (start end) - "Kill the region between START and END. -Do not append to any current kill, and - do not let the next kill append to this one." - (interactive "r") ;Eh, why not? - ;; KILL-REGION sets THIS-COMMAND to tell the next kill that the last - ;; command was a kill. It also checks LAST-COMMAND to see whether it - ;; should append. If we bind these locally, any modifications to - ;; THIS-COMMAND will be masked, and it will not see LAST-COMMAND to - ;; indicate that it should append. - (let ((this-command nil) - (last-command nil)) - (kill-region start end))) - -;;;;; S-expression Parsing Utilities - -;++ These routines redundantly traverse S-expressions a great deal. -;++ If performance issues arise, this whole section will probably have -;++ to be refactored to preserve the state longer, like paredit.scm -;++ does, rather than to traverse the definition N times for every key -;++ stroke as it presently does. - -(defun paredit-current-parse-state () - "Return parse state of point from beginning of defun." - (let ((point (point))) - (beginning-of-defun) - ;; Calling PARSE-PARTIAL-SEXP will advance the point to its second - ;; argument (unless parsing stops due to an error, but we assume it - ;; won't in paredit-mode). - (parse-partial-sexp (point) point))) - -(defun paredit-in-string-p (&optional state) - "True if the parse state is within a double-quote-delimited string. -If no parse state is supplied, compute one from the beginning of the - defun to the point." - ;; 3. non-nil if inside a string (the terminator character, really) - (and (nth 3 (or state (paredit-current-parse-state))) - t)) - -(defun paredit-string-start+end-points (&optional state) - "Return a cons of the points of open and close quotes of the string. -The string is determined from the parse state STATE, or the parse state - from the beginning of the defun to the point. -This assumes that `paredit-in-string-p' has already returned true, i.e. - that the point is already within a string." - (save-excursion - ;; 8. character address of start of comment or string; nil if not - ;; in one - (let ((start (nth 8 (or state (paredit-current-parse-state))))) - (goto-char start) - (forward-sexp 1) - (cons start (1- (point)))))) - -(defun paredit-in-comment-p (&optional state) - "True if parse state STATE is within a comment. -If no parse state is supplied, compute one from the beginning of the - defun to the point." - ;; 4. nil if outside a comment, t if inside a non-nestable comment, - ;; else an integer (the current comment nesting) - (and (nth 4 (or state (paredit-current-parse-state))) - t)) - -(defun paredit-point-at-sexp-boundary (n) - (cond ((< n 0) (paredit-point-at-sexp-start)) - ((= n 0) (point)) - ((> n 0) (paredit-point-at-sexp-end)))) - -(defun paredit-point-at-sexp-start () - (forward-sexp) - (backward-sexp) - (point)) - -(defun paredit-point-at-sexp-end () - (backward-sexp) - (forward-sexp) - (point)) - -;;;; Initialization - -(paredit-define-keys) -(paredit-annotate-mode-with-examples) -(paredit-annotate-functions-with-examples) - -(provide 'paredit)
deleted file mode 100644 --- a/.elisp/pycomplete.el +++ /dev/null @@ -1,50 +0,0 @@ -;;; Complete symbols at point using Pymacs. - -;; Copyright (C) 2007 Skip Montanaro - -;; Author: Skip Montanaro -;; Maintainer: skip@pobox.com -;; Created: Oct 2004 -;; Keywords: python pymacs emacs - -;; This software is provided as-is, without express or implied warranty. -;; Permission to use, copy, modify, distribute or sell this software, -;; without fee, for any purpose and by any individual or organization, is -;; hereby granted, provided that the above copyright notice and this -;; paragraph appear in all copies. - -;; Along with pycomplete.py this file allows programmers to complete Python -;; symbols within the current buffer. See pycomplete.py for the Python side -;; of things and a short description of what to expect. - -(require 'pymacs) -(require 'python-mode) - -(pymacs-load "pycomplete") - -(defun py-complete () - (interactive) - (let ((pymacs-forget-mutability t)) - (insert (pycomplete-pycomplete (py-symbol-near-point) - (py-find-global-imports))))) - -(defun py-find-global-imports () - (save-excursion - (let (first-class-or-def imports) - (goto-char (point-min)) - (setq first-class-or-def - (re-search-forward "^ *\\(def\\|class\\) " nil t)) - (goto-char (point-min)) - (setq imports nil) - (while (re-search-forward - "^\\(import \\|from \\([A-Za-z_][A-Za-z_0-9]*\\) import \\).*" - nil t) - (setq imports (append imports - (list (buffer-substring - (match-beginning 0) - (match-end 0)))))) - imports))) - -(define-key py-mode-map "\M-\C-i" 'py-complete) - -(provide 'pycomplete)
deleted file mode 100644 --- a/.elisp/pycomplete.py +++ /dev/null @@ -1,110 +0,0 @@ - -""" -Python dot expression completion using Pymacs. - -This almost certainly needs work, but if you add - - (require 'pycomplete) - -to your .xemacs/init.el file (untried w/ GNU Emacs so far) and have Pymacs -installed, when you hit M-TAB it will try to complete the dot expression -before point. For example, given this import at the top of the file: - - import time - -typing "time.cl" then hitting M-TAB should complete "time.clock". - -This is unlikely to be done the way Emacs completion ought to be done, but -it's a start. Perhaps someone with more Emacs mojo can take this stuff and -do it right. - -See pycomplete.el for the Emacs Lisp side of things. -""" - -# Author: Skip Montanaro -# Maintainer: skip@pobox.com -# Created: Oct 2004 -# Keywords: python pymacs emacs - -# This software is provided as-is, without express or implied warranty. -# Permission to use, copy, modify, distribute or sell this software, without -# fee, for any purpose and by any individual or organization, is hereby -# granted, provided that the above copyright notice and this paragraph -# appear in all copies. - -# Along with pycomplete.el this file allows programmers to complete Python -# symbols within the current buffer. - -import sys -import os.path - -try: - x = set -except NameError: - from sets import Set as set -else: - del x - -def get_all_completions(s, imports=None): - """Return contextual completion of s (string of >= zero chars). - - If given, imports is a list of import statements to be executed first. - """ - locald = {} - if imports is not None: - for stmt in imports: - try: - exec stmt in globals(), locald - except TypeError: - raise TypeError, "invalid type: %s" % stmt - - dots = s.split(".") - if not s or len(dots) == 1: - keys = set() - keys.update(locald.keys()) - keys.update(globals().keys()) - import __builtin__ - keys.update(dir(__builtin__)) - keys = list(keys) - keys.sort() - if s: - return [k for k in keys if k.startswith(s)] - else: - return keys - - sym = None - for i in range(1, len(dots)): - s = ".".join(dots[:i]) - try: - sym = eval(s, globals(), locald) - except NameError: - try: - sym = __import__(s, globals(), locald, []) - except ImportError: - return [] - if sym is not None: - s = dots[-1] - return [k for k in dir(sym) if k.startswith(s)] - -def pycomplete(s, imports=None): - completions = get_all_completions(s, imports) - dots = s.split(".") - return os.path.commonprefix([k[len(dots[-1]):] for k in completions]) - -if __name__ == "__main__": - print "<empty> ->", pycomplete("") - print "sys.get ->", pycomplete("sys.get") - print "sy ->", pycomplete("sy") - print "sy (sys in context) ->", pycomplete("sy", imports=["import sys"]) - print "foo. ->", pycomplete("foo.") - print "Enc (email * imported) ->", - print pycomplete("Enc", imports=["from email import *"]) - print "E (email * imported) ->", - print pycomplete("E", imports=["from email import *"]) - - print "Enc ->", pycomplete("Enc") - print "E ->", pycomplete("E") - -# Local Variables : -# pymacs-auto-reload : t -# End :
deleted file mode 100644 --- a/.elisp/pymacs.el +++ /dev/null @@ -1,688 +0,0 @@ -;;; Interface between Emacs Lisp and Python - Lisp part. -*- emacs-lisp -*- -;;; Copyright © 2001, 2002, 2003 Progiciels Bourbeau-Pinard inc. -;;; François Pinard <pinard@iro.umontreal.ca>, 2001. - -;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */ - -;;; Portability stunts. - -(defvar pymacs-use-hash-tables - (and (fboundp 'make-hash-table) (fboundp 'gethash) (fboundp 'puthash)) - "Set to t if hash tables are available.") - -(eval-and-compile - - (if (fboundp 'multibyte-string-p) - (defalias 'pymacs-multibyte-string-p 'multibyte-string-p) - (defun pymacs-multibyte-string-p (string) - "Tell XEmacs if STRING should be handled as multibyte." - (not (equal (find-charset-string string) '(ascii)))))) - -(defalias 'pymacs-report-error (symbol-function 'error)) - -;;; Published variables and functions. - -(defvar pymacs-load-path nil - "List of additional directories to search for Python modules. -The directories listed will be searched first, in the order given.") - -(defvar pymacs-trace-transit '(5000 . 30000) - "Keep the communication buffer growing, for debugging. -When this variable is nil, the `*Pymacs*' communication buffer gets erased -before each communication round-trip. Setting it to `t' guarantees that -the full communication is saved, which is useful for debugging. -It could also be given as (KEEP . LIMIT): whenever the buffer exceeds LIMIT -bytes, it is reduced to approximately KEEP bytes.") - -(defvar pymacs-forget-mutability nil - "Transmit copies to Python instead of Lisp handles, as much as possible. -When this variable is nil, most mutable objects are transmitted as handles. -This variable is meant to be temporarily rebound to force copies.") - -(defvar pymacs-mutable-strings nil - "Prefer transmitting Lisp strings to Python as handles. -When this variable is nil, strings are transmitted as copies, and the -Python side thus has no way for modifying the original Lisp strings. -This variable is ignored whenever `forget-mutability' is set.") - -(defvar pymacs-timeout-at-start 30 - "Maximum reasonable time, in seconds, for starting the Pymacs helper. -A machine should be pretty loaded before one needs to increment this.") - -(defvar pymacs-timeout-at-reply 5 - "Expected maximum time, in seconds, to get the first line of a reply. -The status of the Pymacs helper is checked at every such timeout.") - -(defvar pymacs-timeout-at-line 2 - "Expected maximum time, in seconds, to get another line of a reply. -The status of the Pymacs helper is checked at every such timeout.") - -(defvar pymacs-dreadful-zombies nil - "If zombies should trigger hard errors, whenever they get called. -If `nil', calling a zombie will merely produce a diagnostic message.") - -(defun pymacs-load (module &optional prefix noerror) - "Import the Python module named MODULE into Emacs. -Each function in the Python module is made available as an Emacs function. -The Lisp name of each function is the concatenation of PREFIX with -the Python name, in which underlines are replaced by dashes. If PREFIX is -not given, it defaults to MODULE followed by a dash. -If NOERROR is not nil, do not raise error when the module is not found." - (interactive - (let* ((module (read-string "Python module? ")) - (default (concat (car (last (split-string module "\\."))) "-")) - (prefix (read-string (format "Prefix? [%s] " default) - nil nil default))) - (list module prefix))) - (message "Pymacs loading %s..." module) - (let ((lisp-code (pymacs-call "pymacs_load_helper" module prefix))) - (cond (lisp-code (let ((result (eval lisp-code))) - (message "Pymacs loading %s...done" module) - result)) - (noerror (message "Pymacs loading %s...failed" module) nil) - (t (pymacs-report-error "Pymacs loading %s...failed" module))))) - -(defun pymacs-eval (text) - "Compile TEXT as a Python expression, and return its value." - (interactive "sPython expression? ") - (let ((value (pymacs-serve-until-reply "eval" `(princ ,text)))) - (when (interactive-p) - (message "%S" value)) - value)) - -(defun pymacs-exec (text) - "Compile and execute TEXT as a sequence of Python statements. -This functionality is experimental, and does not appear to be useful." - (interactive "sPython statements? ") - (let ((value (pymacs-serve-until-reply "exec" `(princ ,text)))) - (when (interactive-p) - (message "%S" value)) - value)) - -(defun pymacs-call (function &rest arguments) - "Return the result of calling a Python function FUNCTION over ARGUMENTS. -FUNCTION is a string denoting the Python function, ARGUMENTS are separate -Lisp expressions, one per argument. Immutable Lisp constants are converted -to Python equivalents, other structures are converted into Lisp handles." - (pymacs-serve-until-reply - "eval" `(pymacs-print-for-apply ',function ',arguments))) - -(defun pymacs-apply (function arguments) - "Return the result of calling a Python function FUNCTION over ARGUMENTS. -FUNCTION is a string denoting the Python function, ARGUMENTS is a list of -Lisp expressions. Immutable Lisp constants are converted to Python -equivalents, other structures are converted into Lisp handles." - (pymacs-serve-until-reply - "eval" `(pymacs-print-for-apply ',function ',arguments))) - -;;; Integration details. - -;; Python functions and modules should ideally look like Lisp functions and -;; modules. This page tries to increase the integration seamlessness. - -(defadvice documentation (around pymacs-ad-documentation activate) - ;; Integration of doc-strings. - (let* ((reference (pymacs-python-reference function)) - (python-doc (when reference - (pymacs-eval (format "doc_string(%s)" reference))))) - (if (or reference python-doc) - (setq ad-return-value - (concat - "It interfaces to a Python function.\n\n" - (when python-doc - (if raw python-doc (substitute-command-keys python-doc))))) - ad-do-it))) - -(defun pymacs-python-reference (object) - ;; Return the text reference of a Python object if possible, else nil. - (when (functionp object) - (let* ((definition (indirect-function object)) - (body (and (pymacs-proper-list-p definition) - (> (length definition) 2) - (eq (car definition) 'lambda) - (cddr definition)))) - (when (and body (listp (car body)) (eq (caar body) 'interactive)) - ;; Skip the interactive specification of a function. - (setq body (cdr body))) - (when (and body - ;; Advised functions start with a string. - (not (stringp (car body))) - ;; Python trampolines hold exactly one expression. - (= (length body) 1)) - (let ((expression (car body))) - ;; EXPRESSION might now hold something like: - ;; (pymacs-apply (quote (pymacs-python . N)) ARGUMENT-LIST) - (when (and (pymacs-proper-list-p expression) - (= (length expression) 3) - (eq (car expression) 'pymacs-apply) - (eq (car (cadr expression)) 'quote)) - (setq object (cadr (cadr expression)))))))) - (when (eq (car-safe object) 'pymacs-python) - (format "python[%d]" (cdr object)))) - -;; The following functions are experimental -- they are not satisfactory yet. - -(defun pymacs-file-handler (operation &rest arguments) - ;; Integration of load-file, autoload, etc. - ;; Emacs might want the contents of some `MODULE.el' which does not exist, - ;; while there is a `MODULE.py' or `MODULE.pyc' file in the same directory. - ;; The goal is to generate a virtual contents for this `MODULE.el' file, as - ;; a set of Lisp trampoline functions to the Python module functions. - ;; Python modules can then be loaded or autoloaded as if they were Lisp. - (cond ((and (eq operation 'file-readable-p) - (let ((module (substring (car arguments) 0 -3))) - (or (pymacs-file-force operation arguments) - (file-readable-p (concat module ".py")) - (file-readable-p (concat module ".pyc")))))) - ((and (eq operation 'load) - (not (pymacs-file-force - 'file-readable-p (list (car arguments)))) - (file-readable-p (car arguments))) - (let ((lisp-code (pymacs-call "pymacs_load_helper" - (substring (car arguments) 0 -3) - nil))) - (unless lisp-code - (pymacs-report-error "Python import error")) - (eval lisp-code))) - ((and (eq operation 'insert-file-contents) - (not (pymacs-file-force - 'file-readable-p (list (car arguments)))) - (file-readable-p (car arguments))) - (let ((lisp-code (pymacs-call "pymacs_load_helper" - (substring (car arguments) 0 -3) - nil))) - (unless lisp-code - (pymacs-report-error "Python import error")) - (insert (prin1-to-string lisp-code)))) - (t (pymacs-file-force operation arguments)))) - -(defun pymacs-file-force (operation arguments) - ;; Bypass the file handler. - (let ((inhibit-file-name-handlers - (cons 'pymacs-file-handler - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation arguments))) - -;(add-to-list 'file-name-handler-alist '("\\.el\\'" . pymacs-file-handler)) - -;;; Gargabe collection of Python IDs. - -;; Python objects which have no Lisp representation are allocated on the -;; Python side as `python[INDEX]', and INDEX is transmitted to Emacs, with -;; the value to use on the Lisp side for it. Whenever Lisp does not need a -;; Python object anymore, it should be freed on the Python side. The -;; following variables and functions are meant to fill this duty. - -(defvar pymacs-used-ids nil - "List of received IDs, currently allocated on the Python side.") - -(defvar pymacs-weak-hash nil - "Weak hash table, meant to find out which IDs are still needed.") - -(defvar pymacs-gc-wanted nil - "Flag if it is time to clean up unused IDs on the Python side.") - -(defvar pymacs-gc-running nil - "Flag telling that a Pymacs garbage collection is in progress.") - -(defvar pymacs-gc-timer nil - "Timer to trigger Pymacs garbage collection at regular time intervals. -The timer is used only if `post-gc-hook' is not available.") - -(defun pymacs-schedule-gc (&optional xemacs-list) - (unless pymacs-gc-running - (setq pymacs-gc-wanted t))) - -(defun pymacs-garbage-collect () - ;; Clean up unused IDs on the Python side. - (when pymacs-use-hash-tables - (let ((pymacs-gc-running t) - (pymacs-forget-mutability t) - (ids pymacs-used-ids) - used-ids unused-ids) - (while ids - (let ((id (car ids))) - (setq ids (cdr ids)) - (if (gethash id pymacs-weak-hash) - (setq used-ids (cons id used-ids)) - (setq unused-ids (cons id unused-ids))))) - (setq pymacs-used-ids used-ids - pymacs-gc-wanted nil) - (when unused-ids - (pymacs-apply "free_python" unused-ids))))) - -(defun pymacs-defuns (arguments) - ;; Take one argument, a list holding a number of items divisible by 3. The - ;; first argument is an INDEX, the second is a NAME, the third is the - ;; INTERACTION specification, and so forth. Register Python INDEX with a - ;; function with that NAME and INTERACTION on the Lisp side. The strange - ;; calling convention is to minimise quoting at call time. - (while (>= (length arguments) 3) - (let ((index (nth 0 arguments)) - (name (nth 1 arguments)) - (interaction (nth 2 arguments))) - (fset name (pymacs-defun index interaction)) - (setq arguments (nthcdr 3 arguments))))) - -(defun pymacs-defun (index interaction) - ;; Register INDEX on the Lisp side with a Python object that is a function, - ;; and return a lambda form calling that function. If the INTERACTION - ;; specification is nil, the function is not interactive. Otherwise, the - ;; function is interactive, INTERACTION is then either a string, or the - ;; index of an argument-less Python function returning the argument list. - (let ((object (pymacs-python index))) - (cond ((null interaction) - `(lambda (&rest arguments) - (pymacs-apply ',object arguments))) - ((stringp interaction) - `(lambda (&rest arguments) - (interactive ,interaction) - (pymacs-apply ',object arguments))) - (t `(lambda (&rest arguments) - (interactive (pymacs-call ',(pymacs-python interaction))) - (pymacs-apply ',object arguments)))))) - -(defun pymacs-python (index) - ;; Register on the Lisp side a Python object having INDEX, and return it. - ;; The result is meant to be recognised specially by `print-for-eval', and - ;; in the function position by `print-for-apply'. - (let ((object (cons 'pymacs-python index))) - (when pymacs-use-hash-tables - (puthash index object pymacs-weak-hash) - (setq pymacs-used-ids (cons index pymacs-used-ids))) - object)) - -;;; Generating Python code. - -;; Many Lisp expressions cannot fully be represented in Python, at least -;; because the object is mutable on the Lisp side. Such objects are allocated -;; somewhere into a vector of handles, and the handle index is used for -;; communication instead of the expression itself. - -(defvar pymacs-lisp nil - "Vector of handles to hold transmitted expressions.") - -(defvar pymacs-freed-list nil - "List of unallocated indices in Lisp.") - -;; When the Python GC is done with a Lisp object, a communication occurs so to -;; free the object on the Lisp side as well. - -(defun pymacs-allocate-lisp (expression) - ;; This function allocates some handle for an EXPRESSION, and return its - ;; index. - (unless pymacs-freed-list - (let* ((previous pymacs-lisp) - (old-size (length previous)) - (new-size (if (zerop old-size) 100 (+ old-size (/ old-size 2)))) - (counter new-size)) - (setq pymacs-lisp (make-vector new-size nil)) - (while (> counter 0) - (setq counter (1- counter)) - (if (< counter old-size) - (aset pymacs-lisp counter (aref previous counter)) - (setq pymacs-freed-list (cons counter pymacs-freed-list)))))) - (let ((index (car pymacs-freed-list))) - (setq pymacs-freed-list (cdr pymacs-freed-list)) - (aset pymacs-lisp index expression) - index)) - -(defun pymacs-free-lisp (indices) - ;; This function is triggered from Python side for Lisp handles which lost - ;; their last reference. These references should be cut on the Lisp side as - ;; well, or else, the objects will never be garbage-collected. - (while indices - (let ((index (car indices))) - (aset pymacs-lisp index nil) - (setq pymacs-freed-list (cons index pymacs-freed-list) - indices (cdr indices))))) - -(defun pymacs-print-for-apply (function arguments) - ;; This function prints a Python expression calling FUNCTION, which is a - ;; string naming a Python function, or a Python reference, over all its - ;; ARGUMENTS, which are Lisp expressions. - (let ((separator "") - argument) - (if (eq (car-safe function) 'pymacs-python) - (princ (format "python[%d]" (cdr function))) - (princ function)) - (princ "(") - (while arguments - (setq argument (car arguments) - arguments (cdr arguments)) - (princ separator) - (setq separator ", ") - (pymacs-print-for-eval argument)) - (princ ")"))) - -(defun pymacs-print-for-eval (expression) - ;; This function prints a Python expression out of a Lisp EXPRESSION. - (let (done) - (cond ((not expression) - (princ "None") - (setq done t)) - ((eq expression t) - (princ "True") - (setq done t)) - ((numberp expression) - (princ expression) - (setq done t)) - ((stringp expression) - (when (or pymacs-forget-mutability - (not pymacs-mutable-strings)) - (let* ((multibyte (pymacs-multibyte-string-p expression)) - (text (if multibyte - (encode-coding-string expression 'utf-8) - (copy-sequence expression)))) - (set-text-properties 0 (length text) nil text) - (princ (mapconcat 'identity - (split-string (prin1-to-string text) "\n") - "\\n")) - (when (and multibyte - (not (equal (find-charset-string text) '(ascii)))) - (princ ".decode('UTF-8')"))) - (setq done t))) - ((symbolp expression) - (let ((name (symbol-name expression))) - ;; The symbol can only be transmitted when in the main oblist. - (when (eq expression (intern-soft name)) - (princ "lisp[") - (prin1 name) - (princ "]") - (setq done t)))) - ((vectorp expression) - (when pymacs-forget-mutability - (let ((limit (length expression)) - (counter 0)) - (princ "(") - (while (< counter limit) - (unless (zerop counter) - (princ ", ")) - (pymacs-print-for-eval (aref expression counter)) - (setq counter (1+ counter))) - (when (= limit 1) - (princ ",")) - (princ ")") - (setq done t)))) - ((eq (car-safe expression) 'pymacs-python) - (princ "python[") - (princ (cdr expression)) - (princ "]") - (setq done t)) - ((pymacs-proper-list-p expression) - (when pymacs-forget-mutability - (princ "[") - (pymacs-print-for-eval (car expression)) - (while (setq expression (cdr expression)) - (princ ", ") - (pymacs-print-for-eval (car expression))) - (princ "]") - (setq done t)))) - (unless done - (let ((class (cond ((vectorp expression) "Vector") - ((and pymacs-use-hash-tables - (hash-table-p expression)) - "Table") - ((bufferp expression) "Buffer") - ((pymacs-proper-list-p expression) "List") - (t "Lisp")))) - (princ class) - (princ "(") - (princ (pymacs-allocate-lisp expression)) - (princ ")"))))) - -;;; Communication protocol. - -(defvar pymacs-transit-buffer nil - "Communication buffer between Emacs and Python.") - -;; The principle behind the communication protocol is that it is easier to -;; generate than parse, and that each language already has its own parser. -;; So, the Emacs side generates Python text for the Python side to interpret, -;; while the Python side generates Lisp text for the Lisp side to interpret. -;; About nothing but expressions are transmitted, which are evaluated on -;; arrival. The pseudo `reply' function is meant to signal the final result -;; of a series of exchanges following a request, while the pseudo `error' -;; function is meant to explain why an exchange could not have been completed. - -;; The protocol itself is rather simple, and contains human readable text -;; only. A message starts at the beginning of a line in the communication -;; buffer, either with `>' for the Lisp to Python direction, or `<' for the -;; Python to Lisp direction. This is followed by a decimal number giving the -;; length of the message text, a TAB character, and the message text itself. -;; Message direction alternates systematically between messages, it never -;; occurs that two successive messages are sent in the same direction. The -;; first message is received from the Python side, it is `(version VERSION)'. - -(defun pymacs-start-services () - ;; This function gets called automatically, as needed. - (let ((buffer (get-buffer-create "*Pymacs*"))) - (with-current-buffer buffer - (buffer-disable-undo) - (set-buffer-multibyte nil) - (set-buffer-file-coding-system 'raw-text) - (save-match-data - ;; Launch the Pymacs helper. - (let ((process - (apply 'start-process "pymacs" buffer - (let ((python (getenv "PYMACS_PYTHON"))) - (if (or (null python) (equal python "")) - "python" - python)) - "-c" (concat "import sys;" - " from Pymacs.pymacs import main;" - " main(*sys.argv[1:])") - (mapcar 'expand-file-name pymacs-load-path)))) - (cond ((fboundp 'set-process-query-on-exit-flag) - (set-process-query-on-exit-flag process nil)) - ((fboundp 'process-kill-without-query-process) - (process-kill-without-query process))) - ;; Receive the synchronising reply. - (while (progn - (goto-char (point-min)) - (not (re-search-forward "<\\([0-9]+\\)\t" nil t))) - (unless (accept-process-output process pymacs-timeout-at-start) - (pymacs-report-error - "Pymacs helper did not start within %d seconds" - pymacs-timeout-at-start))) - (let ((marker (process-mark process)) - (limit-position (+ (match-end 0) - (string-to-number (match-string 1))))) - (while (< (marker-position marker) limit-position) - (unless (accept-process-output process pymacs-timeout-at-start) - (pymacs-report-error - "Pymacs helper probably was interrupted at start"))))) - ;; Check that synchronisation occurred. - (goto-char (match-end 0)) - (let ((reply (read (current-buffer)))) - (if (and (pymacs-proper-list-p reply) - (= (length reply) 2) - (eq (car reply) 'version)) - (unless (string-equal (cadr reply) "0.23") - (pymacs-report-error - "Pymacs Lisp version is 0.23, Python is %s" - (cadr reply))) - (pymacs-report-error "Pymacs got an invalid initial reply"))))) - (when pymacs-use-hash-tables - (if pymacs-weak-hash - ;; A previous Pymacs session occurred in *this* Emacs session. Some - ;; IDs may hang around, which do not correspond to anything on the - ;; Python side. Python should not recycle such IDs for new objects. - (when pymacs-used-ids - (let ((pymacs-transit-buffer buffer) - (pymacs-forget-mutability t)) - (pymacs-apply "zombie_python" pymacs-used-ids))) - (setq pymacs-weak-hash (make-hash-table :weakness 'value))) - (if (boundp 'post-gc-hook) - (add-hook 'post-gc-hook 'pymacs-schedule-gc) - (setq pymacs-gc-timer (run-at-time 20 20 'pymacs-schedule-gc)))) - ;; If nothing failed, only then declare that Pymacs has started! - (setq pymacs-transit-buffer buffer))) - -(defun pymacs-terminate-services () - ;; This function is mainly provided for documentation purposes. - (interactive) - (garbage-collect) - (pymacs-garbage-collect) - (when (or (not pymacs-used-ids) - (yes-or-no-p "\ -Killing the Pymacs helper might create zombie objects. Kill? ")) - (cond ((boundp 'post-gc-hook) - (remove-hook 'post-gc-hook 'pymacs-schedule-gc)) - ((timerp pymacs-gc-timer) - (cancel-timer pymacs-gc-timer))) - (when pymacs-transit-buffer - (kill-buffer pymacs-transit-buffer)) - (setq pymacs-gc-running nil - pymacs-gc-timer nil - pymacs-transit-buffer nil - pymacs-lisp nil - pymacs-freed-list nil))) - -(defun pymacs-serve-until-reply (action inserter) - ;; This function builds a Python request by printing ACTION and - ;; evaluating INSERTER, which itself prints an argument. It then - ;; sends the request to the Pymacs helper, and serves all - ;; sub-requests coming from the Python side, until either a reply or - ;; an error is finally received. - (unless (and pymacs-transit-buffer - (buffer-name pymacs-transit-buffer) - (get-buffer-process pymacs-transit-buffer)) - (pymacs-start-services)) - (when pymacs-gc-wanted - (pymacs-garbage-collect)) - (let ((inhibit-quit t) - done value) - (while (not done) - (let ((form (pymacs-round-trip action inserter))) - (setq action (car form)) - (when (eq action 'free) - (pymacs-free-lisp (cadr form)) - (setq form (cddr form) - action (car form))) - (let* ((pair (pymacs-interruptible-eval (cadr form))) - (success (cdr pair))) - (setq value (car pair)) - (cond ((eq action 'eval) - (if success - (setq action "return" - inserter `(pymacs-print-for-eval ',value)) - (setq action "raise" - inserter `(let ((pymacs-forget-mutability t)) - (pymacs-print-for-eval ,value))))) - ((eq action 'expand) - (if success - (setq action "return" - inserter `(let ((pymacs-forget-mutability t)) - (pymacs-print-for-eval ,value))) - (setq action "raise" - inserter `(let ((pymacs-forget-mutability t)) - (pymacs-print-for-eval ,value))))) - ((eq action 'return) - (if success - (setq done t) - (pymacs-report-error "%s" value))) - ((eq action 'raise) - (if success - (pymacs-report-error "Python: %s" value) - (pymacs-report-error "%s" value))) - (t (pymacs-report-error "Protocol error: %s" form)))))) - value)) - -(defun pymacs-round-trip (action inserter) - ;; This function produces a Python request by printing and - ;; evaluating INSERTER, which itself prints an argument. It sends - ;; the request to the Pymacs helper, awaits for any kind of reply, - ;; and returns it. - (with-current-buffer pymacs-transit-buffer - ;; Possibly trim the beginning of the transit buffer. - (cond ((not pymacs-trace-transit) - (erase-buffer)) - ((consp pymacs-trace-transit) - (when (> (buffer-size) (cdr pymacs-trace-transit)) - (let ((cut (- (buffer-size) (car pymacs-trace-transit)))) - (when (> cut 0) - (save-excursion - (goto-char cut) - (unless (memq (preceding-char) '(0 ?\n)) - (forward-line 1)) - (delete-region (point-min) (point)))))))) - ;; Send the request, wait for a reply, and process it. - (let* ((process (get-buffer-process pymacs-transit-buffer)) - (status (process-status process)) - (marker (process-mark process)) - (moving (= (point) marker)) - send-position reply-position reply) - (save-excursion - (save-match-data - ;; Encode request. - (setq send-position (marker-position marker)) - (let ((standard-output marker)) - (princ action) - (princ " ") - (eval inserter)) - (goto-char marker) - (unless (= (preceding-char) ?\n) - (princ "\n" marker)) - ;; Send request text. - (goto-char send-position) - (insert (format ">%d\t" (- marker send-position))) - (setq reply-position (marker-position marker)) - (process-send-region process send-position marker) - ;; Receive reply text. - (while (and (eq status 'run) - (progn - (goto-char reply-position) - (not (re-search-forward "<\\([0-9]+\\)\t" nil t)))) - (unless (accept-process-output process pymacs-timeout-at-reply) - (setq status (process-status process)))) - (when (eq status 'run) - (let ((limit-position (+ (match-end 0) - (string-to-number (match-string 1))))) - (while (and (eq status 'run) - (< (marker-position marker) limit-position)) - (unless (accept-process-output process pymacs-timeout-at-line) - (setq status (process-status process)))))) - ;; Decode reply. - (if (not (eq status 'run)) - (pymacs-report-error "Pymacs helper status is `%S'" status) - (goto-char (match-end 0)) - (setq reply (read (current-buffer)))))) - (when (and moving (not pymacs-trace-transit)) - (goto-char marker)) - reply))) - -(defun pymacs-interruptible-eval (expression) - ;; This function produces a pair (VALUE . SUCCESS) for EXPRESSION. - ;; A cautious evaluation of EXPRESSION is attempted, and any - ;; error while evaluating is caught, including Emacs quit (C-g). - ;; Any Emacs quit also gets forward as a SIGINT to the Pymacs handler. - ;; With SUCCESS being true, VALUE is the expression value. - ;; With SUCCESS being false, VALUE is an interruption diagnostic. - (condition-case info - (cons (let ((inhibit-quit nil)) (eval expression)) t) - (quit (setq quit-flag t) - (interrupt-process pymacs-transit-buffer) - (cons "*Interrupted!*" nil)) - (error (cons (prin1-to-string info) nil)))) - -(defun pymacs-proper-list-p (expression) - ;; Tell if a list is proper, id est, that it is `nil' or ends with `nil'. - (cond ((not expression)) - ((consp expression) (not (cdr (last expression)))))) - -(provide 'pymacs)
--- a/.elisp/settings/10.require.el +++ b/.elisp/settings/10.require.el @@ -4,6 +4,32 @@ (setq ido-enable-flex-matching t) (ido-mode t) +(load "package") +(package-initialize) + +(setq package-archives '(("durin42" . "http://home.durin42.com/elpa/") + ("elpa" . "http://tromey.com/elpa/"))) + +(defun af-bootstrap-packages () + (interactive) + (unless package-archive-contents (package-refresh-contents)) + (dolist (pack '(diff-mode- + doctest-mode + http-twiddle + ipython + nose + ;; disabled until I don't need a modified version + ;; textmate + iedit + ;; from elpa + js2-mode + paredit + yaml-mode)) + (unless (or (member pack package-activated-list) + (functionp pack)) + (message "Installing %s" (symbol-name pack)) + (package-install pack)))) + (require 'python-mode) (require 'ipython) (require 'show-wspace)
deleted file mode 100644 --- a/.elisp/yaml-mode.el +++ /dev/null @@ -1,392 +0,0 @@ -;;; yaml-mode.el --- Major mode for editing YAML files - -;; Copyright (C) 2006 Yoshiki Kurihara - -;; Author: Yoshiki Kurihara <kurihara@cpan.org> -;; Marshall T. Vandegrift <llasram@gmail.com> -;; Keywords: data yaml -;; Version: 0.0.3 - -;; This file is not part of Emacs - -;; This 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 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 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. - -;;; Commentary: - -;; This is a major mode for editing files in the YAML data -;; serialization format. It was initially developed by Yoshiki -;; Kurihara and many features were added by Marshall Vandegrift. As -;; YAML and Python share the fact that indentation determines -;; structure, this mode provides indentation and indentation command -;; behavior very similar to that of python-mode. - -;;; Installation: - -;; To install, just drop this file into a directory in your -;; `load-path' and (optionally) byte-compile it. To automatically -;; handle files ending in '.yml', add something like: -;; -;; (require 'yaml-mode) -;; (add-to-list 'auto-mode-alist '("\\.yml$" . yaml-mode)) -;; -;; to your .emacs file. -;; -;; Unlike python-mode, this mode follows the Emacs convention of not -;; binding the ENTER key to `newline-and-indent'. To get this -;; behavior, add the key definition to `yaml-mode-hook': -;; -;; (add-hook 'yaml-mode-hook -;; '(lambda () -;; (define-key yaml-mode-map "\C-m" 'newline-and-indent))) - -;;; Known Bugs: - -;; YAML is easy to write but complex to parse, and this mode doesn't -;; even really try. Indentation and highlighting will break on -;; abnormally complicated structures. - -;;; Code: - - -;; User definable variables - -(defgroup yaml nil - "Support for the YAML serialization format" - :group 'languages - :prefix "yaml-") - -(defcustom yaml-mode-hook nil - "*Hook run by `yaml-mode'." - :type 'hook - :group 'yaml) - -(defcustom yaml-indent-offset 2 - "*Amount of offset per level of indentation." - :type 'integer - :group 'yaml) - -(defcustom yaml-backspace-function 'backward-delete-char-untabify - "*Function called by `yaml-electric-backspace' when deleting backwards." - :type 'function - :group 'yaml) - -(defcustom yaml-block-literal-search-lines 100 - "*Maximum number of lines to search for start of block literals." - :type 'integer - :group 'yaml) - -(defcustom yaml-block-literal-electric-alist - '((?| . "") (?> . "-")) - "*Characters for which to provide electric behavior. -The association list key should be a key code and the associated value -should be a string containing additional characters to insert when -that key is pressed to begin a block literal." - :type 'alist - :group 'yaml) - -(defface yaml-tab-face - '((((class color)) (:background "red" :foreground "red" :bold t)) - (t (:reverse-video t))) - "Face to use for highlighting tabs in YAML files." - :group 'faces - :group 'yaml) - - -;; Constants - -(defconst yaml-mode-version "0.0.3" "Version of `yaml-mode.'") - -(defconst yaml-blank-line-re "^ *$" - "Regexp matching a line containing only (valid) whitespace.") - -(defconst yaml-comment-re "\\(#*.*\\)" - "Regexp matching a line containing a YAML comment or delimiter.") - -(defconst yaml-directive-re "^\\(?:--- \\)? *%\\(\\w+\\)" - "Regexp matching a line contatining a YAML directive.") - -(defconst yaml-document-delimiter-re "^ *\\(?:---\\|[.][.][.]\\)" - "Rexexp matching a YAML document delimiter line.") - -(defconst yaml-node-anchor-alias-re "[&*]\\w+" - "Regexp matching a YAML node anchor or alias.") - -(defconst yaml-tag-re "!!?[^ \n]+" - "Rexexp matching a YAML tag.") - -(defconst yaml-bare-scalar-re - "\\(?:[^-:,#!\n{\\[ ]\\|[^#!\n{\\[ ]\\S-\\)[^#\n]*?" - "Rexexp matching a YAML bare scalar.") - -(defconst yaml-hash-key-re - (concat "\\(?:^\\(?:--- \\)?\\|{\\|\\(?:[-,] +\\)+\\) *" - "\\(?:" yaml-tag-re " +\\)?" - "\\(" yaml-bare-scalar-re "\\) *:" - "\\(?: +\\|$\\)") - "Regexp matching a single YAML hash key.") - -(defconst yaml-scalar-context-re - (concat "\\(?:^\\(?:--- \\)?\\|{\\|\\(?:[-,] +\\)+\\) *" - "\\(?:" yaml-bare-scalar-re " *: \\)?") - "Regexp indicating the begininng of a scalar context.") - -(defconst yaml-nested-map-re - (concat ".*: *\\(?:&.*\\|{ *\\|" yaml-tag-re " *\\)?$") - "Regexp matching a line beginning a YAML nested structure.") - -(defconst yaml-block-literal-base-re " *[>|][-+0-9]* *\\(?:\n\\|\\'\\)" - "Regexp matching the substring start of a block literal.") - -(defconst yaml-block-literal-re - (concat yaml-scalar-context-re - "\\(?:" yaml-tag-re "\\)?" - yaml-block-literal-base-re) - "Regexp matching a line beginning a YAML block literal") - -(defconst yaml-nested-sequence-re - (concat "^\\(?: *- +\\)+" - "\\(?:" yaml-bare-scalar-re " *:\\(?: +.*\\)?\\)?$") - "Regexp matching a line containing one or more nested YAML sequences") - -(defconst yaml-constant-scalars-re - (concat "\\(?:^\\|\\(?::\\|-\\|,\\|{\\|\\[\\) +\\) *" - (regexp-opt - '("~" "null" "Null" "NULL" - ".nan" ".NaN" ".NAN" - ".inf" ".Inf" ".INF" - "-.inf" "-.Inf" "-.INF" - "y" "Y" "yes" "Yes" "YES" "n" "N" "no" "No" "NO" - "true" "True" "TRUE" "false" "False" "FALSE" - "on" "On" "ON" "off" "Off" "OFF") t) - " *$") - "Regexp matching certain scalar constants in scalar context") - - -;; Mode setup - -(defvar yaml-mode-map () - "Keymap used in `yaml-mode' buffers.") -(if yaml-mode-map - nil - (setq yaml-mode-map (make-sparse-keymap)) - (define-key yaml-mode-map "|" 'yaml-electric-bar-and-angle) - (define-key yaml-mode-map ">" 'yaml-electric-bar-and-angle) - (define-key yaml-mode-map "-" 'yaml-electric-dash-and-dot) - (define-key yaml-mode-map "." 'yaml-electric-dash-and-dot) - (define-key yaml-mode-map [backspace] 'yaml-electric-backspace) - (define-key yaml-mode-map "\C-j" 'newline-and-indent)) - -(defvar yaml-mode-syntax-table nil - "Syntax table in use in yaml-mode buffers.") -(if yaml-mode-syntax-table - nil - (setq yaml-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\' "\"" yaml-mode-syntax-table) - (modify-syntax-entry ?\" "\"" yaml-mode-syntax-table) - (modify-syntax-entry ?# "<" yaml-mode-syntax-table) - (modify-syntax-entry ?\n ">" yaml-mode-syntax-table) - (modify-syntax-entry ?\\ "\\" yaml-mode-syntax-table) - (modify-syntax-entry ?- "." yaml-mode-syntax-table) - (modify-syntax-entry ?_ "_" yaml-mode-syntax-table) - (modify-syntax-entry ?\( "." yaml-mode-syntax-table) - (modify-syntax-entry ?\) "." yaml-mode-syntax-table) - (modify-syntax-entry ?\{ "(}" yaml-mode-syntax-table) - (modify-syntax-entry ?\} "){" yaml-mode-syntax-table) - (modify-syntax-entry ?\[ "(]" yaml-mode-syntax-table) - (modify-syntax-entry ?\] ")[" yaml-mode-syntax-table)) - -(define-derived-mode yaml-mode fundamental-mode "YAML" - "Simple mode to edit YAML. - -\\{yaml-mode-map}" - (set (make-local-variable 'comment-start) "# ") - (set (make-local-variable 'comment-start-skip) "#+ *") - (set (make-local-variable 'indent-line-function) 'yaml-indent-line) - (set (make-local-variable 'font-lock-defaults) - '(yaml-font-lock-keywords - nil nil nil nil - (font-lock-syntactic-keywords . yaml-font-lock-syntactic-keywords)))) - - -;; Font-lock support - -(defvar yaml-font-lock-keywords - (list - (cons yaml-comment-re '(1 font-lock-comment-face)) - (cons yaml-constant-scalars-re '(1 font-lock-constant-face)) - (cons yaml-tag-re '(0 font-lock-type-face)) - (cons yaml-node-anchor-alias-re '(0 font-lock-function-name-face t)) - (cons yaml-hash-key-re '(1 font-lock-variable-name-face t)) - (cons yaml-document-delimiter-re '(0 font-lock-comment-face)) - (cons yaml-directive-re '(1 font-lock-builtin-face)) - '(yaml-font-lock-block-literals 0 font-lock-string-face t) - '("^[\t]+" 0 'yaml-tab-face t)) - "Additional expressions to highlight in YAML mode.") - -(defvar yaml-font-lock-syntactic-keywords - (list '(yaml-syntactic-block-literals 0 "." t)) - "Additional syntax features to highlight in YAML mode.") - - -(defun yaml-font-lock-block-literals (bound) - "Find lines within block literals. -Find the next line of the first (if any) block literal after point and -prior to BOUND. Returns the beginning and end of the block literal -line in the match data, as consumed by `font-lock-keywords' matcher -functions. The function begins by searching backwards to determine -whether or not the current line is within a block literal. This could -be time-consuming in large buffers, so the number of lines searched is -artificially limitted to the value of -`yaml-block-literal-search-lines'." - (if (eolp) (goto-char (1+ (point)))) - (unless (or (eobp) (>= (point) bound)) - (let ((begin (point)) - (end (min (1+ (point-at-eol)) bound))) - (goto-char (point-at-bol)) - (while (and (looking-at yaml-blank-line-re) (not (bobp))) - (forward-line -1)) - (let ((nlines yaml-block-literal-search-lines) - (min-level (current-indentation))) - (forward-line -1) - (while (and (/= nlines 0) - (/= min-level 0) - (not (looking-at yaml-block-literal-re)) - (not (bobp))) - (set 'nlines (1- nlines)) - (unless (looking-at yaml-blank-line-re) - (set 'min-level (min min-level (current-indentation)))) - (forward-line -1)) - (cond - ((and (< (current-indentation) min-level) - (looking-at yaml-block-literal-re)) - (goto-char end) (set-match-data (list begin end)) t) - ((progn - (goto-char begin) - (re-search-forward (concat yaml-block-literal-re - " *\\(.*\\)\n") - bound t)) - (set-match-data (nthcdr 2 (match-data))) t)))))) - -(defun yaml-syntactic-block-literals (bound) - "Find quote characters within block literals. -Finds the first quote character within a block literal (if any) after -point and prior to BOUND. Returns the position of the quote character -in the match data, as consumed by matcher functions in -`font-lock-syntactic-keywords'. This allows the mode to treat ['\"] -characters in block literals as punctuation syntax instead of string -syntax, preventing unmatched quotes in block literals from painting -the entire buffer in `font-lock-string-face'." - (let ((found nil)) - (while (and (not found) - (/= (point) bound) - (yaml-font-lock-block-literals bound)) - (let ((begin (match-beginning 0)) (end (match-end 0))) - (goto-char begin) - (cond - ((re-search-forward "['\"]" end t) (setq found t)) - ((goto-char end))))) - found)) - - -;; Indentation and electric keys - -(defun yaml-compute-indentation () - "Calculate the maximum sensible indentation for the current line." - (save-excursion - (beginning-of-line) - (if (looking-at yaml-document-delimiter-re) 0 - (forward-line -1) - (while (and (looking-at yaml-blank-line-re) - (> (point) (point-min))) - (forward-line -1)) - (+ (current-indentation) - (if (looking-at yaml-nested-map-re) yaml-indent-offset 0) - (if (looking-at yaml-nested-sequence-re) yaml-indent-offset 0) - (if (looking-at yaml-block-literal-re) yaml-indent-offset 0))))) - -(defun yaml-indent-line () - "Indent the current line. -The first time this command is used, the line will be indented to the -maximum sensible indentation. Each immediately subsequent usage will -back-dent the line by `yaml-indent-offset' spaces. On reaching column -0, it will cycle back to the maximum sensible indentation." - (interactive "*") - (let ((ci (current-indentation)) - (cc (current-column)) - (need (yaml-compute-indentation))) - (save-excursion - (beginning-of-line) - (delete-horizontal-space) - (if (and (equal last-command this-command) (/= ci 0)) - (indent-to (* (/ (- ci 1) yaml-indent-offset) yaml-indent-offset)) - (indent-to need))) - (if (< (current-column) (current-indentation)) - (forward-to-indentation 0)))) - -(defun yaml-electric-backspace (arg) - "Delete characters or back-dent the current line. -If invoked following only whitespace on a line, will back-dent to the -immediately previous multiple of `yaml-indent-offset' spaces." - (interactive "*p") - (if (or (/= (current-indentation) (current-column)) (bolp)) - (funcall yaml-backspace-function arg) - (let ((ci (current-column))) - (beginning-of-line) - (delete-horizontal-space) - (indent-to (* (/ (- ci (* arg yaml-indent-offset)) - yaml-indent-offset) - yaml-indent-offset))))) - -(defun yaml-electric-bar-and-angle (arg) - "Insert the bound key and possibly begin a block literal. -Inserts the bound key. If inserting the bound key causes the current -line to match the initial line of a block literal, then inserts the -matching string from `yaml-block-literal-electric-alist', a newline, -and indents appropriately." - (interactive "*P") - (self-insert-command (prefix-numeric-value arg)) - (let ((extra-chars - (assoc last-command-char - yaml-block-literal-electric-alist))) - (cond - ((and extra-chars (not arg) (eolp) - (save-excursion - (beginning-of-line) - (looking-at yaml-block-literal-re))) - (insert (cdr extra-chars)) - (newline-and-indent))))) - -(defun yaml-electric-dash-and-dot (arg) - "Insert the bound key and possibly de-dent line. -Inserts the bound key. If inserting the bound key causes the current -line to match a document delimiter, de-dent the line to the left -margin." - (interactive "*P") - (self-insert-command (prefix-numeric-value arg)) - (save-excursion - (beginning-of-line) - (if (and (not arg) (looking-at yaml-document-delimiter-re)) - (delete-horizontal-space)))) - -(defun yaml-mode-version () - "Diplay version of `yaml-mode'." - (interactive) - (message "yaml-mode %s" yaml-mode-version) - yaml-mode-version) - -(provide 'yaml-mode) - -;;; yaml-mode.el ends here