(opascal-newline-always-indents): Remove custom.
(opascal-tab, opascal-newline): Remove commands.
(opascal-new-comment-line): Insert "\n" instead of calling newline.
(opascal-mode-map): Keep default bindings for RET and TAB and DEL.
(opascal-save-match-data): Remove, use save-match-data instead.
(opascal-save-state): Use with-silent-modifications.
\f
* Changes in Specialized Modes and Packages in Emacs 24.4
+** Delphi mode is now called OPascal mode.
+*** All delphi-* variables and functions have been renamed to opascal-*.
+*** `delphi-newline-always-indents' is not supported any more
+use `electric-indent-mode' instead.
+*** `delphi-tab' is gone, replaced by `indent-for-tab-command'.
+
** jit-lock-debug-mode lets you use the debuggers on code run via jit-lock.
** completing-read-multiple's separator can now be a regexp.
2013-01-31 Stefan Monnier <monnier@iro.umontreal.ca>
+ * progmodes/opascal.el: Rename from delphi.el. Use lexical-binding.
+ (opascal-newline-always-indents): Remove custom.
+ (opascal-tab, opascal-newline): Remove commands.
+ (opascal-new-comment-line): Insert "\n" instead of calling newline.
+ (opascal-mode-map): Keep default bindings for RET and TAB and DEL.
+ (opascal-save-match-data): Remove, use save-match-data instead.
+ (opascal-save-state): Use with-silent-modifications.
+
* progmodes/pascal.el (pascal-mode-syntax-table): Accept //..\n comments
(bug#13585).
+++ /dev/null
-;;; delphi.el --- major mode for editing Delphi source (Object Pascal) in Emacs
-
-;; Copyright (C) 1998-1999, 2001-2013 Free Software Foundation, Inc.
-
-;; Authors: Ray Blaak <blaak@infomatch.com>,
-;; Simon South <ssouth@member.fsf.org>
-;; Maintainer: Simon South <ssouth@member.fsf.org>
-;; Keywords: languages
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; To enter Delphi mode when you find a Delphi source file, one must override
-;; the auto-mode-alist to associate Delphi with .pas (and .dpr and .dpk)
-;; files. Emacs, by default, will otherwise enter Pascal mode. E.g.
-;;
-;; (autoload 'delphi-mode "delphi")
-;; (setq auto-mode-alist
-;; (cons '("\\.\\(pas\\|dpr\\|dpk\\)$" . delphi-mode) auto-mode-alist))
-
-;; To get keyword, comment, and string literal coloring, be sure that font-lock
-;; is running. One can manually do M-x font-lock-mode in a Delphi buffer, or
-;; one can put in .emacs:
-;;
-;; (add-hook 'delphi-mode-hook 'turn-on-font-lock)
-
-;; If font-lock is not loaded by default, you might have to do:
-;;
-;; (autoload 'font-lock-mode "font-lock")
-;; (autoload 'turn-on-font-lock "font-lock")
-;; (setq font-lock-support-mode 'lazy-lock-mode)
-;;
-;; Lazy lock is very necessary for faster screen updates.
-
-;; For good performance, be sure to byte-compile delphi.el, e.g.
-;;
-;; M-x byte-compile-file <give the path to delphi.el when prompted>
-
-;; This will generate delphi.elc, which will be loaded instead of delphi.el
-;; when delphi-mode is autoloaded.
-
-;; When you have entered Delphi mode, you may get more info by pressing
-;; C-h m.
-
-;; This Delphi mode implementation is fairly tolerant of syntax errors, relying
-;; as much as possible on the indentation of the previous statement. This also
-;; makes it faster and simpler, since there is less searching for properly
-;; constructed beginnings.
-
-;;; Code:
-
-(provide 'delphi)
-
-(defgroup delphi nil
- "Major mode for editing Delphi source in Emacs."
- :version "21.1"
- :group 'languages)
-
-(defconst delphi-debug nil
- "True if in debug mode.")
-
-(defcustom delphi-search-path "."
- "Directories to search when finding external units.
-It is a list of directory strings. If only a single directory,
-it can be a single string instead of a list. If a directory
-ends in \"...\" then that directory is recursively searched."
- :type 'string
- :group 'delphi)
-
-(defcustom delphi-indent-level 3
- "Indentation of Delphi statements with respect to containing block.
-E.g.
-
-begin
- // This is an indent of 3.
-end;"
- :type 'integer
- :group 'delphi)
-
-(defcustom delphi-compound-block-indent 0
- "Extra indentation for blocks in compound statements. E.g.
-
-// block indent = 0 vs // block indent = 2
-if b then if b then
-begin begin
-end else begin end
-end; else
- begin
- end;"
- :type 'integer
- :group 'delphi)
-
-(defcustom delphi-case-label-indent delphi-indent-level
- "Extra indentation for case statement labels. E.g.
-
-// case indent = 0 vs // case indent = 3
-case value of case value of
-v1: process_v1; v1: process_v1;
-v2: process_v2; v2: process_v2;
-else else
- process_else; process_else;
-end; end;"
- :type 'integer
- :group 'delphi)
-
-(defcustom delphi-verbose t ; nil
- "If true then Delphi token processing progress is reported to the user."
- :type 'boolean
- :group 'delphi)
-
-(defcustom delphi-tab-always-indents t
- "Non-nil means TAB in Delphi mode should always reindent the current line,
-regardless of where in the line point is when the TAB command is used."
- :type 'boolean
- :group 'delphi)
-
-(defcustom delphi-newline-always-indents t
- "Non-nil means NEWLINE in Delphi mode should always reindent the current
-line, insert a blank line and move to the default indent column of the blank
-line. If nil, then no indentation occurs, and NEWLINE does the usual
-behavior. This is useful when one needs to do customized indentation that
-differs from the default."
- :type 'boolean
- :group 'delphi)
-
-(defcustom delphi-comment-face 'font-lock-comment-face
- "Face used to color Delphi comments."
- :type 'face
- :group 'delphi)
-
-(defcustom delphi-string-face 'font-lock-string-face
- "Face used to color Delphi strings."
- :type 'face
- :group 'delphi)
-
-(defcustom delphi-keyword-face 'font-lock-keyword-face
- "Face used to color Delphi keywords."
- :type 'face
- :group 'delphi)
-
-(defcustom delphi-other-face nil
- "Face used to color everything else."
- :type '(choice (const :tag "None" nil) face)
- :group 'delphi)
-
-(defconst delphi-directives
- '(absolute abstract assembler automated cdecl default dispid dynamic
- export external far forward index inline message name near nodefault
- overload override pascal private protected public published read readonly
- register reintroduce resident resourcestring safecall stdcall stored
- virtual write writeonly)
- "Delphi4 directives.")
-
-(defconst delphi-keywords
- (append
- '(;; Keywords.
- and array as asm at begin case class const constructor contains
- destructor dispinterface div do downto else end except exports
- file finalization finally for function goto if implementation implements
- in inherited initialization interface is label library mod nil not
- of object on or out package packed procedure program property
- raise record repeat requires result self set shl shr then threadvar
- to try type unit uses until var while with xor
-
- ;; These routines should be keywords, if Borland had the balls.
- break exit)
-
- ;; We want directives to look like keywords.
- delphi-directives)
- "Delphi4 keywords.")
-
-(defconst delphi-previous-terminators `(semicolon comma)
- "Expression/statement terminators that denote a previous expression.")
-
-(defconst delphi-comments
- '(comment-single-line comment-multi-line-1 comment-multi-line-2)
- "Tokens that represent comments.")
-
-(defconst delphi-strings
- '(string double-quoted-string)
- "Tokens that represent string literals.")
-
-(defconst delphi-whitespace `(space newline ,@delphi-comments)
- "Tokens that are considered whitespace.")
-
-(defconst delphi-routine-statements
- '(procedure function constructor destructor property)
- "Marks the start of a routine, or routine-ish looking expression.")
-
-(defconst delphi-body-expr-statements '(if while for on)
- "Statements that have either a single statement or a block as a body and also
-are followed by an expression.")
-
-(defconst delphi-expr-statements `(case ,@delphi-body-expr-statements)
- "Expression statements contain expressions after their keyword.")
-
-(defconst delphi-body-statements `(else ,@delphi-body-expr-statements)
- "Statements that have either a single statement or a block as a body.")
-
-(defconst delphi-expr-delimiters '(then do of)
- "Expression delimiter tokens.")
-
-(defconst delphi-binary-ops
- '(plus minus equals not-equals times divides div mod and or xor)
- "Delphi binary operations.")
-
-(defconst delphi-visibilities '(public private protected published automated)
- "Class visibilities.")
-
-(defconst delphi-block-statements
- '(begin try case repeat initialization finalization asm)
- "Statements that contain multiple substatements.")
-
-(defconst delphi-mid-block-statements
- `(except finally ,@delphi-visibilities)
- "Statements that mark mid sections of the enclosing block.")
-
-(defconst delphi-end-block-statements `(end until)
- "Statements that end block sections.")
-
-(defconst delphi-match-block-statements
- `(,@delphi-end-block-statements ,@delphi-mid-block-statements)
- "Statements that match the indentation of the parent block.")
-
-(defconst delphi-decl-sections '(type const var label resourcestring)
- "Denotes the start of a declaration section.")
-
-(defconst delphi-interface-types '(dispinterface interface)
- "Interface types.")
-
-(defconst delphi-class-types '(class object)
- "Class types.")
-
-(defconst delphi-composite-types
- `(,@delphi-class-types ,@delphi-interface-types record)
- "Types that contain declarations within them.")
-
-(defconst delphi-unit-sections
- '(interface implementation program library package)
- "Unit sections within which the indent is 0.")
-
-(defconst delphi-use-clauses `(uses requires exports contains)
- "Statements that refer to foreign symbols.")
-
-(defconst delphi-unit-statements
- `(,@delphi-use-clauses ,@delphi-unit-sections initialization finalization)
- "Statements indented at level 0.")
-
-(defconst delphi-decl-delimiters
- `(,@delphi-decl-sections ,@delphi-unit-statements
- ,@delphi-routine-statements)
- "Statements that a declaration statement should align with.")
-
-(defconst delphi-decl-matchers
- `(begin ,@delphi-decl-sections)
- "Statements that should match to declaration statement indentation.")
-
-(defconst delphi-enclosing-statements
- `(,@delphi-block-statements ,@delphi-mid-block-statements
- ,@delphi-decl-sections ,@delphi-use-clauses ,@delphi-routine-statements)
- "Delimits an enclosing statement.")
-
-(defconst delphi-previous-statements
- `(,@delphi-unit-statements ,@delphi-routine-statements)
- "Delimits a previous statement.")
-
-(defconst delphi-previous-enclosing-statements
- `(,@delphi-block-statements ,@delphi-mid-block-statements
- ,@delphi-decl-sections)
- "Delimits a previous enclosing statement.")
-
-(defconst delphi-begin-enclosing-tokens
- `(,@delphi-block-statements ,@delphi-mid-block-statements)
- "Tokens that a begin token indents from.")
-
-(defconst delphi-begin-previous-tokens
- `(,@delphi-decl-sections ,@delphi-routine-statements)
- "Tokens that a begin token aligns with, but only if not part of a nested
-routine.")
-
-(defconst delphi-space-chars "\000-\011\013- ") ; all except \n
-(defconst delphi-non-space-chars (concat "^" delphi-space-chars))
-(defconst delphi-spaces-re (concat "[" delphi-space-chars "]*"))
-(defconst delphi-leading-spaces-re (concat "^" delphi-spaces-re))
-(defconst delphi-word-chars "a-zA-Z0-9_")
-
-(defmacro delphi-save-match-data (&rest forms)
- ;; Executes the forms such that the current match data is preserved, so as
- ;; not to disturb any existing search results.
- `(let ((data (match-data)))
- (unwind-protect
- (progn ,@forms)
- (set-match-data data))))
-
-(defmacro delphi-save-excursion (&rest forms)
- ;; Executes the forms such that any movements have no effect, including
- ;; searches.
- `(save-excursion
- (delphi-save-match-data
- (let ((inhibit-point-motion-hooks t)
- (deactivate-mark nil))
- (progn ,@forms)))))
-
-(defmacro delphi-save-state (&rest forms)
- ;; Executes the forms such that any buffer modifications do not have any side
- ;; effects beyond the buffer's actual content changes.
- `(let ((delphi-ignore-changes t)
- (old-supersession-threat
- (symbol-function 'ask-user-about-supersession-threat))
- (buffer-read-only nil)
- (inhibit-read-only t)
- (buffer-undo-list t)
- (before-change-functions nil)
- (after-change-functions nil)
- (modified (buffer-modified-p)))
- ;; Disable any queries about editing obsolete files.
- (fset 'ask-user-about-supersession-threat (lambda (_fn)))
- (unwind-protect
- (progn ,@forms)
- (set-buffer-modified-p modified)
- (fset 'ask-user-about-supersession-threat old-supersession-threat))))
-
-(defsubst delphi-is (element in-set)
- ;; If the element is in the set, the element cdr is returned, otherwise nil.
- (memq element in-set))
-
-(defun delphi-string-of (start end)
- ;; Returns the buffer string from start to end.
- (buffer-substring-no-properties start end))
-
-(defun delphi-looking-at-string (p s)
- ;; True if point p marks the start of string s. s is not a regular
- ;; expression.
- (let ((limit (+ p (length s))))
- (and (<= limit (point-max))
- (string= s (delphi-string-of p limit)))))
-
-(defun delphi-token-of (kind start end)
- ;; Constructs a token from a kind symbol and its start/end points.
- `[,kind ,start ,end])
-
-(defsubst delphi-token-kind (token)
- ;; Returns the kind symbol of the token.
- (if token (aref token 0) nil))
-
-(defun delphi-set-token-kind (token to-kind)
- ;; Sets the kind symbol of the token.
- (if token (aset token 0 to-kind)))
-
-(defsubst delphi-token-start (token)
- ;; Returns the start point of the token.
- (if token (aref token 1) (point-min)))
-
-(defsubst delphi-token-end (token)
- ;; Returns the end point of the token.
- (if token (aref token 2) (point-min)))
-
-(defun delphi-set-token-start (token start)
- ;; Sets the start point of the token.
- (if token (aset token 1 start)))
-
-(defun delphi-set-token-end (token end)
- ;; Sets the end point of the token.
- (if token (aset token 2 end)))
-
-(defun delphi-token-string (token)
- ;; Returns the string image of the token.
- (if token
- (delphi-string-of (delphi-token-start token) (delphi-token-end token))
- ""))
-
-(defun delphi-in-token (p token)
- ;; Returns true if the point p is within the token's start/end points.
- (and (<= (delphi-token-start token) p) (< p (delphi-token-end token))))
-
-(defun delphi-column-of (p)
- ;; Returns the column of the point p.
- (save-excursion (goto-char p) (current-column)))
-
-(defun delphi-face-of (token-kind)
- ;; Returns the face property appropriate for the token kind.
- (cond ((delphi-is token-kind delphi-comments) delphi-comment-face)
- ((delphi-is token-kind delphi-strings) delphi-string-face)
- ((delphi-is token-kind delphi-keywords) delphi-keyword-face)
- (delphi-other-face)))
-
-(defvar delphi-progress-last-reported-point nil
- "The last point at which progress was reported.")
-
-(defconst delphi-parsing-progress-step 16384
- "Number of chars to process before the next parsing progress report.")
-(defconst delphi-scanning-progress-step 2048
- "Number of chars to process before the next scanning progress report.")
-(defconst delphi-fontifying-progress-step delphi-scanning-progress-step
- "Number of chars to process before the next fontification progress report.")
-
-(defun delphi-progress-start ()
- ;; Initializes progress reporting.
- (setq delphi-progress-last-reported-point nil))
-
-(defun delphi-progress-done (&rest msgs)
- ;; Finalizes progress reporting.
- (setq delphi-progress-last-reported-point nil)
- (when delphi-verbose
- (if (null msgs)
- (message "")
- (apply #'message msgs))))
-
-(defun delphi-step-progress (p desc step-size)
- ;; If enough distance has elapsed since the last reported point, then report
- ;; the current progress to the user.
- (cond ((null delphi-progress-last-reported-point)
- ;; This is the first progress step.
- (setq delphi-progress-last-reported-point p))
-
- ((and delphi-verbose
- (>= (abs (- p delphi-progress-last-reported-point)) step-size))
- ;; Report the percentage complete.
- (setq delphi-progress-last-reported-point p)
- (message "%s %s ... %d%%"
- desc (buffer-name) (/ (* 100 p) (point-max))))))
-
-(defun delphi-next-line-start (&optional from-point)
- ;; Returns the first point of the next line.
- (let ((curr-point (point))
- (next nil))
- (if from-point (goto-char from-point))
- (end-of-line)
- (setq next (min (1+ (point)) (point-max)))
- (goto-char curr-point)
- next))
-
-(defvar delphi-ignore-changes t
- "Internal flag to control if the Delphi mode responds to buffer changes.
-Defaults to t in case the `delphi-after-change' function is called on a
-non-Delphi buffer. Set to nil in a Delphi buffer. To override, just do:
- (let ((delphi-ignore-changes t)) ...)")
-
-(defun delphi-set-text-properties (from to properties)
- ;; Like `set-text-properties', except we do not consider this to be a buffer
- ;; modification.
- (delphi-save-state
- (set-text-properties from to properties)))
-
-(defun delphi-literal-kind (p)
- ;; Returns the literal kind the point p is in (or nil if not in a literal).
- (if (and (<= (point-min) p) (<= p (point-max)))
- (get-text-property p 'token)))
-
-(defun delphi-literal-start-pattern (literal-kind)
- ;; Returns the start pattern of the literal kind.
- (cdr (assoc literal-kind
- '((comment-single-line . "//")
- (comment-multi-line-1 . "{")
- (comment-multi-line-2 . "(*")
- (string . "'")
- (double-quoted-string . "\"")))))
-
-(defun delphi-literal-end-pattern (literal-kind)
- ;; Returns the end pattern of the literal kind.
- (cdr (assoc literal-kind
- '((comment-single-line . "\n")
- (comment-multi-line-1 . "}")
- (comment-multi-line-2 . "*)")
- (string . "'")
- (double-quoted-string . "\"")))))
-
-(defun delphi-literal-stop-pattern (literal-kind)
- ;; Returns the pattern that delimits end of the search for the literal kind.
- ;; These are regular expressions.
- (cdr (assoc literal-kind
- '((comment-single-line . "\n")
- (comment-multi-line-1 . "}")
- (comment-multi-line-2 . "\\*)")
- ;; Strings cannot span lines.
- (string . "['\n]")
- (double-quoted-string . "[\"\n]")))))
-
-(defun delphi-is-literal-start (p)
- ;; True if the point p is at the start point of a (completed) literal.
- (let* ((kind (delphi-literal-kind p))
- (pattern (delphi-literal-start-pattern kind)))
- (or (null kind) ; Non-literals are considered as start points.
- (delphi-looking-at-string p pattern))))
-
-(defun delphi-is-literal-end (p)
- ;; True if the point p is at the end point of a (completed) literal.
- (let* ((kind (delphi-literal-kind (1- p)))
- (pattern (delphi-literal-end-pattern kind)))
- (or (null kind) ; Non-literals are considered as end points.
-
- (and (delphi-looking-at-string (- p (length pattern)) pattern)
- (or (not (delphi-is kind delphi-strings))
- ;; Special case: string delimiters are start/end ambiguous.
- ;; We have an end only if there is some string content (at
- ;; least a starting delimiter).
- (not (delphi-is-literal-end (1- p)))))
-
- ;; Special case: strings cannot span lines.
- (and (delphi-is kind delphi-strings) (eq ?\n (char-after (1- p)))))))
-
-(defun delphi-is-stable-literal (p)
- ;; True if the point p marks a stable point. That is, a point outside of a
- ;; literal region, inside of a literal region, or adjacent to completed
- ;; literal regions.
- (let ((at-start (delphi-is-literal-start p))
- (at-end (delphi-is-literal-end p)))
- (or (>= p (point-max))
- (and at-start at-end)
- (and (not at-start) (not at-end)
- (eq (delphi-literal-kind (1- p)) (delphi-literal-kind p))))))
-
-(defun delphi-complete-literal (literal-kind limit)
- ;; Continues the search for a literal's true end point and returns the
- ;; point past the end pattern (if found) or the limit (if not found).
- (let ((pattern (delphi-literal-stop-pattern literal-kind)))
- (if (not (stringp pattern))
- (error "Invalid literal kind %S" literal-kind)
- ;; Search up to the limit.
- (re-search-forward pattern limit 'goto-limit-on-fail)
- (point))))
-
-(defun delphi-literal-text-properties (kind)
- ;; Creates a list of text properties for the literal kind.
- (if (and (boundp 'font-lock-mode)
- font-lock-mode)
- (list 'token kind 'face (delphi-face-of kind) 'lazy-lock t)
- (list 'token kind)))
-
-(defun delphi-parse-next-literal (limit)
- ;; Searches for the next literal region (i.e. comment or string) and sets the
- ;; the point to its end (or the limit, if not found). The literal region is
- ;; marked as such with a text property, to speed up tokenizing during face
- ;; coloring and indentation scanning.
- (let ((search-start (point)))
- (cond ((not (delphi-is-literal-end search-start))
- ;; We are completing an incomplete literal.
- (let ((kind (delphi-literal-kind (1- search-start))))
- (delphi-complete-literal kind limit)
- (delphi-set-text-properties
- search-start (point) (delphi-literal-text-properties kind))))
-
- ((re-search-forward
- "\\(//\\)\\|\\({\\)\\|\\((\\*\\)\\|\\('\\)\\|\\(\"\\)"
- limit 'goto-limit-on-fail)
- ;; We found the start of a new literal. Find its end and mark it.
- (let ((kind (cond ((match-beginning 1) 'comment-single-line)
- ((match-beginning 2) 'comment-multi-line-1)
- ((match-beginning 3) 'comment-multi-line-2)
- ((match-beginning 4) 'string)
- ((match-beginning 5) 'double-quoted-string)))
- (start (match-beginning 0)))
- (delphi-set-text-properties search-start start nil)
- (delphi-complete-literal kind limit)
- (delphi-set-text-properties
- start (point) (delphi-literal-text-properties kind))))
-
- ;; Nothing found. Mark it as a non-literal.
- ((delphi-set-text-properties search-start limit nil)))
- (delphi-step-progress (point) "Parsing" delphi-parsing-progress-step)))
-
-(defun delphi-literal-token-at (p)
- ;; Returns the literal token surrounding the point p, or nil if none.
- (let ((kind (delphi-literal-kind p)))
- (when kind
- (let ((start (previous-single-property-change (1+ p) 'token))
- (end (next-single-property-change p 'token)))
- (delphi-token-of kind (or start (point-min)) (or end (point-max)))))))
-
-(defun delphi-point-token-at (p kind)
- ;; Returns the single character token at the point p.
- (delphi-token-of kind p (1+ p)))
-
-(defsubst delphi-char-token-at (p char kind)
- ;; Returns the token at the point p that describes the specified character.
- ;; If not actually over such a character, nil is returned.
- (when (eq char (char-after p))
- (delphi-token-of kind p (1+ p))))
-
-(defun delphi-charset-token-at (p charset kind)
- ;; Returns the token surrounding point p that contains only members of the
- ;; character set.
- (let ((currp (point))
- (end nil)
- (token nil))
- (goto-char p)
- (when (> (skip-chars-forward charset) 0)
- (setq end (point))
- (goto-char (1+ p))
- (skip-chars-backward charset)
- (setq token (delphi-token-of kind (point) end)))
- (goto-char currp)
- token))
-
-(defun delphi-space-token-at (p)
- ;; If point p is surrounded by space characters, then return the token of the
- ;; contiguous spaces.
- (delphi-charset-token-at p delphi-space-chars 'space))
-
-(defun delphi-word-token-at (p)
- ;; If point p is over a word (i.e. identifier characters), then return a word
- ;; token. If the word is actually a keyword, then return the keyword token.
- (let ((word (delphi-charset-token-at p delphi-word-chars 'word)))
- (when word
- (let* ((word-image (downcase (delphi-token-string word)))
- (keyword (intern-soft word-image)))
- (when (and (or keyword (string= "nil" word-image))
- (delphi-is keyword delphi-keywords))
- (delphi-set-token-kind word keyword))
- word))))
-
-(defun delphi-explicit-token-at (p token-string kind)
- ;; If point p is anywhere in the token string then returns the resulting
- ;; token.
- (let ((token (delphi-charset-token-at p token-string kind)))
- (when (and token (string= token-string (delphi-token-string token)))
- token)))
-
-(defun delphi-token-at (p)
- ;; Returns the token from parsing text at point p.
- (when (and (<= (point-min) p) (<= p (point-max)))
- (cond ((delphi-char-token-at p ?\n 'newline))
-
- ((delphi-literal-token-at p))
-
- ((delphi-space-token-at p))
-
- ((delphi-word-token-at p))
-
- ((delphi-char-token-at p ?\( 'open-group))
- ((delphi-char-token-at p ?\) 'close-group))
- ((delphi-char-token-at p ?\[ 'open-group))
- ((delphi-char-token-at p ?\] 'close-group))
- ((delphi-char-token-at p ?\; 'semicolon))
- ((delphi-char-token-at p ?. 'dot))
- ((delphi-char-token-at p ?, 'comma))
- ((delphi-char-token-at p ?= 'equals))
- ((delphi-char-token-at p ?+ 'plus))
- ((delphi-char-token-at p ?- 'minus))
- ((delphi-char-token-at p ?* 'times))
- ((delphi-char-token-at p ?/ 'divides))
- ((delphi-char-token-at p ?: 'colon))
-
- ((delphi-explicit-token-at p "<>" 'not-equals))
-
- ((delphi-point-token-at p 'punctuation)))))
-
-(defun delphi-current-token ()
- ;; Returns the delphi source token under the current point.
- (delphi-token-at (point)))
-
-(defun delphi-next-token (token)
- ;; Returns the token after the specified token.
- (when token
- (let ((next (delphi-token-at (delphi-token-end token))))
- (if next
- (delphi-step-progress (delphi-token-start next) "Scanning"
- delphi-scanning-progress-step))
- next)))
-
-(defun delphi-previous-token (token)
- ;; Returns the token before the specified token.
- (when token
- (let ((previous (delphi-token-at (1- (delphi-token-start token)))))
- (if previous
- (delphi-step-progress (delphi-token-start previous) "Scanning"
- delphi-scanning-progress-step))
- previous)))
-
-(defun delphi-next-visible-token (token)
- ;; Returns the first non-space token after the specified token.
- (let (next-token)
- (while (progn
- (setq next-token (delphi-next-token token))
- (delphi-is (delphi-token-kind next-token) '(space newline))))
- next-token))
-
-(defun delphi-parse-region (from to)
- ;; Parses the literal tokens in the region. The point is set to "to".
- (save-restriction
- (widen)
- (goto-char from)
- (while (< (point) to)
- (delphi-parse-next-literal to))))
-
-(defun delphi-parse-region-until-stable (from to)
- ;; Parses at least the literal tokens in the region. After that, parsing
- ;; continues as long as obsolete literal regions are encountered. The point
- ;; is set to the encountered stable point.
- (save-restriction
- (widen)
- (delphi-parse-region from to)
- (while (not (delphi-is-stable-literal (point)))
- (delphi-parse-next-literal (point-max)))))
-
-(defun delphi-fontify-region (from to &optional verbose)
- ;; Colors the text in the region according to Delphi rules.
- (delphi-save-excursion
- (delphi-save-state
- (let ((p from)
- (delphi-verbose verbose)
- (token nil))
- (delphi-progress-start)
- (while (< p to)
- ;; Color the token and move past it.
- (setq token (delphi-token-at p))
- (add-text-properties
- (delphi-token-start token) (delphi-token-end token)
- (list 'face (delphi-face-of (delphi-token-kind token)) 'lazy-lock t))
- (setq p (delphi-token-end token))
- (delphi-step-progress p "Fontifying" delphi-fontifying-progress-step))
- (delphi-progress-done)))))
-
-(defun delphi-after-change (change-start change-end _old-length)
- ;; Called when the buffer has changed. Reparses the changed region.
- (unless delphi-ignore-changes
- (let ((delphi-ignore-changes t)) ; Prevent recursive calls.
- (delphi-save-excursion
- (delphi-progress-start)
- ;; Reparse at least from the token previous to the change to the end of
- ;; line after the change.
- (delphi-parse-region-until-stable
- (delphi-token-start (delphi-token-at (1- change-start)))
- (progn (goto-char change-end) (end-of-line) (point)))
- (delphi-progress-done)))))
-
-(defun delphi-group-start (from-token)
- ;; Returns the token that denotes the start of the ()/[] group.
- (let ((token (delphi-previous-token from-token))
- (token-kind nil))
- (catch 'done
- (while token
- (setq token-kind (delphi-token-kind token))
- (cond
- ;; Skip over nested groups.
- ((eq 'close-group token-kind) (setq token (delphi-group-start token)))
- ((eq 'open-group token-kind) (throw 'done token)))
- (setq token (delphi-previous-token token)))
- ;; Start not found.
- nil)))
-
-(defun delphi-group-end (from-token)
- ;; Returns the token that denotes the end of the ()/[] group.
- (let ((token (delphi-next-token from-token))
- (token-kind nil))
- (catch 'done
- (while token
- (setq token-kind (delphi-token-kind token))
- (cond
- ;; Skip over nested groups.
- ((eq 'open-group token-kind) (setq token (delphi-group-end token)))
- ((eq 'close-group token-kind) (throw 'done token)))
- (setq token (delphi-next-token token)))
- ;; end not found.
- nil)))
-
-(defun delphi-indent-of (token &optional offset)
- ;; Returns the start column of the token, plus any offset.
- (let ((indent (+ (delphi-column-of (delphi-token-start token))
- (if offset offset 0))))
- (when delphi-debug
- (delphi-debug-log
- (concat "\n Indent of: %S %S"
- "\n column: %d indent: %d offset: %d")
- token (delphi-token-string token)
- (delphi-column-of (delphi-token-start token))
- indent (if offset offset 0)))
- indent))
-
-(defun delphi-line-indent-of (from-token &optional offset &rest terminators)
- ;; Returns the column of first non-space character on the token's line, plus
- ;; any offset. We also stop if one of the terminators or an open ( or [ is
- ;; encountered.
- (let ((token (delphi-previous-token from-token))
- (last-token from-token)
- (kind nil))
- (catch 'done
- (while token
- (setq kind (delphi-token-kind token))
- (cond
- ;; Skip over ()/[] groups.
- ((eq 'close-group kind) (setq token (delphi-group-start token)))
-
- ;; Stop at the beginning of the line or an open group.
- ((delphi-is kind '(newline open-group)) (throw 'done nil))
-
- ;; Stop at one of the specified terminators.
- ((delphi-is kind terminators) (throw 'done nil)))
- (unless (delphi-is kind delphi-whitespace) (setq last-token token))
- (setq token (delphi-previous-token token))))
- (delphi-indent-of last-token offset)))
-
-(defun delphi-stmt-line-indent-of (from-token &optional offset)
- ;; Like `delphi-line-indent-of' except is also stops on a use clause, and
- ;; colons that precede statements (i.e. case labels).
- (let ((token (delphi-previous-token from-token))
- (last-token from-token)
- (kind nil))
- (catch 'done
- (while token
- (setq kind (delphi-token-kind token))
- (cond
- ((and (eq 'colon kind)
- (delphi-is (delphi-token-kind last-token)
- `(,@delphi-block-statements
- ,@delphi-expr-statements)))
- ;; We hit a label followed by a statement. Indent to the statement.
- (throw 'done nil))
-
- ;; Skip over ()/[] groups.
- ((eq 'close-group kind) (setq token (delphi-group-start token)))
-
- ((delphi-is kind `(newline open-group ,@delphi-use-clauses))
- ;; Stop at the beginning of the line, an open group, or a use clause
- (throw 'done nil)))
- (unless (delphi-is kind delphi-whitespace) (setq last-token token))
- (setq token (delphi-previous-token token))))
- (delphi-indent-of last-token offset)))
-
-(defun delphi-open-group-indent (token last-token &optional offset)
- ;; Returns the indent relative to an unmatched ( or [.
- (when (eq 'open-group (delphi-token-kind token))
- (if last-token
- (delphi-indent-of last-token offset)
- ;; There is nothing following the ( or [. Indent from its line.
- (delphi-stmt-line-indent-of token delphi-indent-level))))
-
-(defun delphi-composite-type-start (token last-token)
- ;; Returns true (actually the last-token) if the pair equals (= class), (=
- ;; dispinterface), (= interface), (= object), or (= record), and nil
- ;; otherwise.
- (if (and (eq 'equals (delphi-token-kind token))
- (delphi-is (delphi-token-kind last-token) delphi-composite-types))
- last-token))
-
-(defun delphi-is-simple-class-type (at-token limit-token)
- ;; True if at-token is the start of a simple class type. E.g.
- ;; class of TClass;
- ;; class (TBaseClass);
- ;; class;
- (when (delphi-is (delphi-token-kind at-token) delphi-class-types)
- (catch 'done
- ;; Scan until the semi colon.
- (let ((token (delphi-next-token at-token))
- (token-kind nil)
- (limit (delphi-token-start limit-token)))
- (while (and token (<= (delphi-token-start token) limit))
- (setq token-kind (delphi-token-kind token))
- (cond
- ;; A semicolon delimits the search.
- ((eq 'semicolon token-kind) (throw 'done token))
-
- ;; Skip over the inheritance list.
- ((eq 'open-group token-kind) (setq token (delphi-group-end token)))
-
- ;; Only allow "of" and whitespace, and an identifier
- ((delphi-is token-kind `(of word ,@delphi-whitespace)))
-
- ;; Otherwise we are not in a simple class declaration.
- ((throw 'done nil)))
- (setq token (delphi-next-token token)))))))
-
-(defun delphi-block-start (from-token &optional stop-on-class)
- ;; Returns the token that denotes the start of the block.
- (let ((token (delphi-previous-token from-token))
- (last-token nil)
- (token-kind nil))
- (catch 'done
- (while token
- (setq token-kind (delphi-token-kind token))
- (cond
- ;; Skip over nested blocks.
- ((delphi-is token-kind delphi-end-block-statements)
- (setq token (delphi-block-start token)))
-
- ;; Regular block start found.
- ((delphi-is token-kind delphi-block-statements)
- (throw 'done
- ;; As a special case, when a "case" block appears
- ;; within a record declaration (to denote a variant
- ;; part), the record declaration should be considered
- ;; the enclosing block.
- (if (eq 'case token-kind)
- (let ((enclosing-token
- (delphi-block-start token
- 'stop-on-class)))
- (if
- (eq 'record
- (delphi-token-kind enclosing-token))
- (if stop-on-class
- enclosing-token
- (delphi-previous-token enclosing-token))
- token))
- token)))
-
- ;; A class/record start also begins a block.
- ((delphi-composite-type-start token last-token)
- (throw 'done (if stop-on-class last-token token)))
- )
- (unless (delphi-is token-kind delphi-whitespace)
- (setq last-token token))
- (setq token (delphi-previous-token token)))
- ;; Start not found.
- nil)))
-
-(defun delphi-else-start (from-else)
- ;; Returns the token of the if or case statement.
- (let ((token (delphi-previous-token from-else))
- (token-kind nil)
- (semicolon-count 0))
- (catch 'done
- (while token
- (setq token-kind (delphi-token-kind token))
- (cond
- ;; Skip over nested groups.
- ((eq 'close-group token-kind) (setq token (delphi-group-start token)))
-
- ;; Skip over any nested blocks.
- ((delphi-is token-kind delphi-end-block-statements)
- (setq token (delphi-block-start token)))
-
- ((eq 'semicolon token-kind)
- ;; Semicolon means we are looking for an enclosing if, unless we
- ;; are in a case statement. Keep counts of the semicolons and decide
- ;; later.
- (setq semicolon-count (1+ semicolon-count)))
-
- ((and (eq 'if token-kind) (= semicolon-count 0))
- ;; We only can match an if when there have been no intervening
- ;; semicolons.
- (throw 'done token))
-
- ((eq 'case token-kind)
- ;; We have hit a case statement start.
- (throw 'done token)))
- (setq token (delphi-previous-token token)))
- ;; No if or case statement found.
- nil)))
-
-(defun delphi-comment-content-start (comment)
- ;; Returns the point of the first non-space character in the comment.
- (let ((kind (delphi-token-kind comment)))
- (when (delphi-is kind delphi-comments)
- (delphi-save-excursion
- (goto-char (+ (delphi-token-start comment)
- (length (delphi-literal-start-pattern kind))))
- (skip-chars-forward delphi-space-chars)
- (point)))))
-
-(defun delphi-comment-block-start (comment)
- ;; Returns the starting comment token of a contiguous // comment block. If
- ;; the comment is multiline (i.e. {...} or (*...*)), the original comment is
- ;; returned.
- (if (not (eq 'comment-single-line (delphi-token-kind comment)))
- comment
- ;; Scan until we run out of // comments.
- (let ((prev-comment comment)
- (start-comment comment))
- (while (let ((kind (delphi-token-kind prev-comment)))
- (cond ((eq kind 'space))
- ((eq kind 'comment-single-line)
- (setq start-comment prev-comment))
- (t nil)))
- (setq prev-comment (delphi-previous-token prev-comment)))
- start-comment)))
-
-(defun delphi-comment-block-end (comment)
- ;; Returns the end comment token of a contiguous // comment block. If the
- ;; comment is multiline (i.e. {...} or (*...*)), the original comment is
- ;; returned.
- (if (not (eq 'comment-single-line (delphi-token-kind comment)))
- comment
- ;; Scan until we run out of // comments.
- (let ((next-comment comment)
- (end-comment comment))
- (while (let ((kind (delphi-token-kind next-comment)))
- (cond ((eq kind 'space))
- ((eq kind 'comment-single-line)
- (setq end-comment next-comment))
- (t nil)))
- (setq next-comment (delphi-next-token next-comment)))
- end-comment)))
-
-(defun delphi-on-first-comment-line (comment)
- ;; Returns true if the current point is on the first line of the comment.
- (save-excursion
- (let ((comment-start (delphi-token-start comment))
- (current-point (point)))
- (goto-char comment-start)
- (end-of-line)
- (and (<= comment-start current-point) (<= current-point (point))))))
-
-(defun delphi-comment-indent-of (comment)
- ;; Returns the correct indentation for the comment.
- (let ((start-comment (delphi-comment-block-start comment)))
- (if (and (eq start-comment comment)
- (delphi-on-first-comment-line comment))
- ;; Indent as a statement.
- (delphi-enclosing-indent-of comment)
- (save-excursion
- (let ((kind (delphi-token-kind comment)))
- (beginning-of-line)
- (cond ((eq 'comment-single-line kind)
- ;; Indent to the first comment in the // block.
- (delphi-indent-of start-comment))
-
- ((looking-at (concat delphi-leading-spaces-re
- (delphi-literal-stop-pattern kind)))
- ;; Indent multi-line comment terminators to the comment start.
- (delphi-indent-of comment))
-
- ;; Indent according to the comment's content start.
- ((delphi-column-of (delphi-comment-content-start comment)))))))
- ))
-
-(defun delphi-is-use-clause-end (at-token last-token last-colon from-kind)
- ;; True if we are after the end of a uses type clause.
- (when (and last-token
- (not last-colon)
- (eq 'comma (delphi-token-kind at-token))
- (eq 'semicolon from-kind))
- ;; Scan for the uses statement, just to be sure.
- (let ((token (delphi-previous-token at-token))
- (token-kind nil))
- (catch 'done
- (while token
- (setq token-kind (delphi-token-kind token))
- (cond ((delphi-is token-kind delphi-use-clauses)
- (throw 'done t))
-
- ;; Whitespace, identifiers, strings, "in" keyword, and commas
- ;; are allowed in use clauses.
- ((or (delphi-is token-kind '(word comma in newline))
- (delphi-is token-kind delphi-whitespace)
- (delphi-is token-kind delphi-strings)))
-
- ;; Nothing else is.
- ((throw 'done nil)))
- (setq token (delphi-previous-token token)))
- nil))))
-
-(defun delphi-is-block-after-expr-statement (token)
- ;; Returns true if we have a block token trailing an expression delimiter (of
- ;; presumably an expression statement).
- (when (delphi-is (delphi-token-kind token) delphi-block-statements)
- (let ((previous (delphi-previous-token token))
- (previous-kind nil))
- (while (progn
- (setq previous-kind (delphi-token-kind previous))
- (eq previous-kind 'space))
- (setq previous (delphi-previous-token previous)))
- (or (delphi-is previous-kind delphi-expr-delimiters)
- (eq previous-kind 'else)))))
-
-(defun delphi-previous-indent-of (from-token)
- ;; Returns the indentation of the previous statement of the token.
- (let ((token (delphi-previous-token from-token))
- (token-kind nil)
- (from-kind (delphi-token-kind from-token))
- (last-colon nil)
- (last-of nil)
- (last-token nil))
- (catch 'done
- (while token
- (setq token-kind (delphi-token-kind token))
- (cond
- ;; An open ( or [ always is an indent point.
- ((eq 'open-group token-kind)
- (throw 'done (delphi-open-group-indent token last-token)))
-
- ;; Skip over any ()/[] groups.
- ((eq 'close-group token-kind) (setq token (delphi-group-start token)))
-
- ((delphi-is token-kind delphi-end-block-statements)
- (if (eq 'newline (delphi-token-kind (delphi-previous-token token)))
- ;; We can stop at an end token that is right up against the
- ;; margin.
- (throw 'done 0)
- ;; Otherwise, skip over any nested blocks.
- (setq token (delphi-block-start token))))
-
- ;; Special case: if we encounter a ", word;" then we assume that we
- ;; are in some kind of uses clause, and thus indent to column 0. This
- ;; works because no other constructs are known to have that form.
- ;; This fixes the irritating case of having indents after a uses
- ;; clause look like:
- ;; uses
- ;; someUnit,
- ;; someOtherUnit;
- ;; // this should be at column 0!
- ((delphi-is-use-clause-end token last-token last-colon from-kind)
- (throw 'done 0))
-
- ;; A previous terminator means we can stop. If we are on a directive,
- ;; however, then we are not actually encountering a new statement.
- ((and last-token
- (delphi-is token-kind delphi-previous-terminators)
- (not (delphi-is (delphi-token-kind last-token)
- delphi-directives)))
- (throw 'done (delphi-stmt-line-indent-of last-token 0)))
-
- ;; Ignore whitespace.
- ((delphi-is token-kind delphi-whitespace))
-
- ;; Remember any "of" we encounter, since that affects how we
- ;; indent to a case statement within a record declaration
- ;; (i.e. a variant part).
- ((eq 'of token-kind)
- (setq last-of token))
-
- ;; Remember any ':' we encounter (until we reach an "of"),
- ;; since that affects how we indent to case statements in
- ;; general.
- ((eq 'colon token-kind)
- (unless last-of (setq last-colon token)))
-
- ;; A case statement delimits a previous statement. We indent labels
- ;; specially.
- ((eq 'case token-kind)
- (throw 'done
- (if last-colon (delphi-line-indent-of last-colon)
- (delphi-line-indent-of token delphi-case-label-indent))))
-
- ;; If we are in a use clause then commas mark an enclosing rather than
- ;; a previous statement.
- ((delphi-is token-kind delphi-use-clauses)
- (throw 'done
- (if (eq 'comma from-kind)
- (if last-token
- ;; Indent to first unit in use clause.
- (delphi-indent-of last-token)
- ;; Indent from use clause keyword.
- (delphi-line-indent-of token delphi-indent-level))
- ;; Indent to use clause keyword.
- (delphi-line-indent-of token))))
-
- ;; Assembly sections always indent in from the asm keyword.
- ((eq token-kind 'asm)
- (throw 'done (delphi-stmt-line-indent-of token delphi-indent-level)))
-
- ;; An enclosing statement delimits a previous statement.
- ;; We try to use the existing indent of the previous statement,
- ;; otherwise we calculate from the enclosing statement.
- ((delphi-is token-kind delphi-previous-enclosing-statements)
- (throw 'done (if last-token
- ;; Otherwise indent to the last token
- (delphi-line-indent-of last-token)
- ;; Just indent from the enclosing keyword
- (delphi-line-indent-of token delphi-indent-level))))
-
- ;; A class or record declaration also delimits a previous statement.
- ((delphi-composite-type-start token last-token)
- (throw
- 'done
- (if (delphi-is-simple-class-type last-token from-token)
- ;; c = class; or c = class of T; are previous statements.
- (delphi-line-indent-of token)
- ;; Otherwise c = class ... or r = record ... are enclosing
- ;; statements.
- (delphi-line-indent-of last-token delphi-indent-level))))
-
- ;; We have a definite previous statement delimiter.
- ((delphi-is token-kind delphi-previous-statements)
- (throw 'done (delphi-stmt-line-indent-of token 0)))
- )
- (unless (delphi-is token-kind delphi-whitespace)
- (setq last-token token))
- (setq token (delphi-previous-token token)))
- ;; We ran out of tokens. Indent to column 0.
- 0)))
-
-(defun delphi-section-indent-of (section-token)
- ;; Returns the indentation appropriate for begin/var/const/type/label
- ;; tokens.
- (let* ((token (delphi-previous-token section-token))
- (token-kind nil)
- (last-token nil)
- (nested-block-count 0)
- (expr-delimited nil)
- (last-terminator nil))
- (catch 'done
- (while token
- (setq token-kind (delphi-token-kind token))
- (cond
- ;; Always stop at unmatched ( or [.
- ((eq token-kind 'open-group)
- (throw 'done (delphi-open-group-indent token last-token)))
-
- ;; Skip over any ()/[] groups.
- ((eq 'close-group token-kind) (setq token (delphi-group-start token)))
-
- ((delphi-is token-kind delphi-end-block-statements)
- (if (eq 'newline (delphi-token-kind (delphi-previous-token token)))
- ;; We can stop at an end token that is right up against the
- ;; margin.
- (throw 'done 0)
- ;; Otherwise, skip over any nested blocks.
- (setq token (delphi-block-start token)
- nested-block-count (1+ nested-block-count))))
-
- ;; Remember if we have encountered any forward routine declarations.
- ((eq 'forward token-kind)
- (setq nested-block-count (1+ nested-block-count)))
-
- ;; Mark the completion of a nested routine traversal.
- ((and (delphi-is token-kind delphi-routine-statements)
- (> nested-block-count 0))
- (setq nested-block-count (1- nested-block-count)))
-
- ;; Remember if we have encountered any statement terminators.
- ((eq 'semicolon token-kind) (setq last-terminator token))
-
- ;; Remember if we have encountered any expression delimiters.
- ((delphi-is token-kind delphi-expr-delimiters)
- (setq expr-delimited token))
-
- ;; Enclosing body statements are delimiting. We indent the compound
- ;; bodies specially.
- ((and (not last-terminator)
- (delphi-is token-kind delphi-body-statements))
- (throw 'done
- (delphi-stmt-line-indent-of token delphi-compound-block-indent)))
-
- ;; An enclosing ":" means a label.
- ((and (eq 'colon token-kind)
- (delphi-is (delphi-token-kind section-token)
- delphi-block-statements)
- (not last-terminator)
- (not expr-delimited)
- (not (eq 'equals (delphi-token-kind last-token))))
- (throw 'done
- (delphi-stmt-line-indent-of token delphi-indent-level)))
-
- ;; Block and mid block tokens are always enclosing
- ((delphi-is token-kind delphi-begin-enclosing-tokens)
- (throw 'done
- (delphi-stmt-line-indent-of token delphi-indent-level)))
-
- ;; Declaration sections and routines are delimiters, unless they
- ;; are part of a nested routine.
- ((and (delphi-is token-kind delphi-decl-delimiters)
- (= 0 nested-block-count))
- (throw 'done (delphi-line-indent-of token 0)))
-
- ;; Unit statements mean we indent right to the left.
- ((delphi-is token-kind delphi-unit-statements) (throw 'done 0))
- )
- (unless (delphi-is token-kind delphi-whitespace)
- (setq last-token token))
- (setq token (delphi-previous-token token)))
- ;; We ran out of tokens. Indent to column 0.
- 0)))
-
-(defun delphi-enclosing-indent-of (from-token)
- ;; Returns the indentation offset from the enclosing statement of the token.
- (let ((token (delphi-previous-token from-token))
- (from-kind (delphi-token-kind from-token))
- (token-kind nil)
- (stmt-start nil)
- (last-token nil)
- (equals-encountered nil)
- (before-equals nil)
- (expr-delimited nil))
- (catch 'done
- (while token
- (setq token-kind (delphi-token-kind token))
- (cond
- ;; An open ( or [ always is an indent point.
- ((eq 'open-group token-kind)
- (throw 'done
- (delphi-open-group-indent
- token last-token
- (if (delphi-is from-kind delphi-binary-ops)
- ;; Keep binary operations aligned with the open group.
- 0
- delphi-indent-level))))
-
- ;; Skip over any ()/[] groups.
- ((eq 'close-group token-kind) (setq token (delphi-group-start token)))
-
- ;; Skip over any nested blocks.
- ((delphi-is token-kind delphi-end-block-statements)
- (setq token (delphi-block-start token)))
-
- ;; An expression delimiter affects indentation depending on whether
- ;; the point is before or after it. Remember that we encountered one.
- ;; Also remember the last encountered token, since if it exists it
- ;; should be the actual indent point.
- ((delphi-is token-kind delphi-expr-delimiters)
- (setq expr-delimited token stmt-start last-token))
-
- ;; With a non-delimited expression statement we indent after the
- ;; statement's keyword, unless we are on the delimiter itself.
- ((and (not expr-delimited)
- (delphi-is token-kind delphi-expr-statements))
- (throw 'done
- (cond ((delphi-is from-kind delphi-expr-delimiters)
- ;; We are indenting a delimiter. Indent to the statement.
- (delphi-stmt-line-indent-of token 0))
-
- ((and last-token (delphi-is from-kind delphi-binary-ops))
- ;; Align binary ops with the expression.
- (delphi-indent-of last-token))
-
- (last-token
- ;; Indent in from the expression.
- (delphi-indent-of last-token delphi-indent-level))
-
- ;; Indent in from the statement's keyword.
- ((delphi-indent-of token delphi-indent-level)))))
-
- ;; A delimited case statement indents the label according to
- ;; a special rule.
- ((eq 'case token-kind)
- (throw 'done
- (if stmt-start
- ;; We are not actually indenting to the case statement,
- ;; but are within a label expression.
- (delphi-stmt-line-indent-of
- stmt-start delphi-indent-level)
- ;; Indent from the case keyword.
- (delphi-stmt-line-indent-of
- token delphi-case-label-indent))))
-
- ;; Body expression statements are enclosing. Indent from the
- ;; statement's keyword, unless we have a non-block statement following
- ;; it.
- ((delphi-is token-kind delphi-body-expr-statements)
- (throw 'done
- (delphi-stmt-line-indent-of
- (or stmt-start token) delphi-indent-level)))
-
- ;; An else statement is enclosing, but it doesn't have an expression.
- ;; Thus we take into account last-token instead of stmt-start.
- ((eq 'else token-kind)
- (throw 'done (delphi-stmt-line-indent-of
- (or last-token token) delphi-indent-level)))
-
- ;; We indent relative to an enclosing declaration section.
- ((delphi-is token-kind delphi-decl-sections)
- (throw 'done (delphi-indent-of (if last-token last-token token)
- delphi-indent-level)))
-
- ;; In unit sections we indent right to the left.
- ((delphi-is token-kind delphi-unit-sections)
- (throw 'done
- ;; Handle specially the case of "interface", which can be used
- ;; to start either a unit section or an interface definition.
- (if (delphi-is token-kind delphi-interface-types)
- (progn
- ;; Find the previous non-whitespace token.
- (while (progn
- (setq last-token token
- token (delphi-previous-token token)
- token-kind (delphi-token-kind token))
- (and token
- (delphi-is token-kind
- delphi-whitespace))))
- ;; If this token is an equals sign, "interface" is being
- ;; used to start an interface definition and we should
- ;; treat it as a composite type; otherwise, we should
- ;; consider it the start of a unit section.
- (if (and token (eq token-kind 'equals))
- (delphi-line-indent-of last-token
- delphi-indent-level)
- 0))
- 0)))
-
- ;; A previous terminator means we can stop.
- ((delphi-is token-kind delphi-previous-terminators)
- (throw 'done
- (cond ((and last-token
- (eq 'comma token-kind)
- (delphi-is from-kind delphi-binary-ops))
- ;; Align binary ops with the expression.
- (delphi-indent-of last-token))
-
- (last-token
- ;; Indent in from the expression.
- (delphi-indent-of last-token delphi-indent-level))
-
- ;; No enclosing expression; use the previous statement's
- ;; indent.
- ((delphi-previous-indent-of token)))))
-
- ;; A block statement after an expression delimiter has its start
- ;; column as the expression statement. E.g.
- ;; if (a = b)
- ;; and (a != c) then begin
- ;; //...
- ;; end;
- ;; Remember it for when we encounter the expression statement start.
- ((delphi-is-block-after-expr-statement token)
- (throw 'done
- (cond (last-token (delphi-indent-of last-token delphi-indent-level))
-
- ((+ (delphi-section-indent-of token) delphi-indent-level)))))
-
- ;; Assembly sections always indent in from the asm keyword.
- ((eq token-kind 'asm)
- (throw 'done (delphi-stmt-line-indent-of token delphi-indent-level)))
-
- ;; Stop at an enclosing statement and indent from it.
- ((delphi-is token-kind delphi-enclosing-statements)
- (throw 'done (delphi-stmt-line-indent-of
- (or last-token token) delphi-indent-level)))
-
- ;; A class/record declaration is also enclosing.
- ((delphi-composite-type-start token last-token)
- (throw 'done
- (delphi-line-indent-of last-token delphi-indent-level)))
-
- ;; A ":" we indent relative to its line beginning. If we are in a
- ;; parameter list, then stop also if we hit a ";".
- ((and (eq token-kind 'colon)
- (not expr-delimited)
- (not (delphi-is from-kind delphi-expr-delimiters))
- (not equals-encountered)
- (not (eq from-kind 'equals)))
- (throw 'done
- (if last-token
- (delphi-indent-of last-token delphi-indent-level)
- (delphi-line-indent-of token delphi-indent-level 'semicolon))))
-
- ;; If the ":" was not processed above and we have token after the "=",
- ;; then indent from the "=". Ignore :=, however.
- ((and (eq token-kind 'colon) equals-encountered before-equals)
- (cond
- ;; Ignore binary ops for now. It would do, for example:
- ;; val := 1 + 2
- ;; + 3;
- ;; which is good, but also
- ;; val := Foo
- ;; (foo, args)
- ;; + 2;
- ;; which doesn't look right.
- ;;;; Align binary ops with the before token.
- ;;((delphi-is from-kind delphi-binary-ops)
- ;;(throw 'done (delphi-indent-of before-equals 0)))
-
- ;; Assignments (:=) we skip over to get a normal indent.
- ((eq (delphi-token-kind last-token) 'equals))
-
- ;; Otherwise indent in from the equals.
- ((throw 'done
- (delphi-indent-of before-equals delphi-indent-level)))))
-
- ;; Remember any "=" we encounter if it has not already been processed.
- ((eq token-kind 'equals)
- (setq equals-encountered token
- before-equals last-token))
- )
- (unless (delphi-is token-kind delphi-whitespace)
- (setq last-token token))
- (setq token (delphi-previous-token token)))
- ;; We ran out of tokens. Indent to column 0.
- 0)))
-
-(defun delphi-corrected-indentation ()
- ;; Returns the corrected indentation for the current line.
- (delphi-save-excursion
- (delphi-progress-start)
- ;; Move to the first token on the line.
- (beginning-of-line)
- (skip-chars-forward delphi-space-chars)
- (let* ((token (delphi-current-token))
- (token-kind (delphi-token-kind token))
- (indent
- (cond ((eq 'close-group token-kind)
- ;; Indent to the matching start ( or [.
- (delphi-indent-of (delphi-group-start token)))
-
- ((delphi-is token-kind delphi-unit-statements) 0)
-
- ((delphi-is token-kind delphi-comments)
- ;; In a comment.
- (delphi-comment-indent-of token))
-
- ((delphi-is token-kind delphi-decl-matchers)
- ;; Use a previous section/routine's indent.
- (delphi-section-indent-of token))
-
- ((delphi-is token-kind delphi-match-block-statements)
- ;; Use the block's indentation.
- (let ((block-start
- (delphi-block-start token 'stop-on-class)))
- (cond
- ;; When trailing a body statement, indent to
- ;; the statement's keyword.
- ((delphi-is-block-after-expr-statement block-start)
- (delphi-section-indent-of block-start))
-
- ;; Otherwise just indent to the block start.
- ((delphi-stmt-line-indent-of block-start 0)))))
-
- ((eq 'else token-kind)
- ;; Find the start of the if or case statement.
- (delphi-stmt-line-indent-of (delphi-else-start token) 0))
-
- ;; Otherwise indent in from enclosing statement.
- ((delphi-enclosing-indent-of
- (if token token (delphi-token-at (1- (point)))))))))
- (delphi-progress-done)
- indent)))
-
-(defun delphi-indent-line ()
- "Indent the current line according to the current language construct.
-If before the indent, the point is moved to the indent."
- (interactive)
- (delphi-save-match-data
- (let ((marked-point (point-marker)) ; Maintain our position reliably.
- (line-start nil)
- (old-indent 0)
- (new-indent 0))
- (beginning-of-line)
- (setq line-start (point))
- (skip-chars-forward delphi-space-chars)
- (setq old-indent (current-column))
- (setq new-indent (delphi-corrected-indentation))
- (if (< marked-point (point))
- ;; If before the indent column, then move to it.
- (set-marker marked-point (point)))
- ;; Advance our marked point after inserted spaces.
- (set-marker-insertion-type marked-point t)
- (when (/= old-indent new-indent)
- (delete-region line-start (point))
- (insert (make-string new-indent ?\s)))
- (goto-char marked-point)
- (set-marker marked-point nil))))
-
-(defvar delphi-mode-abbrev-table nil
- "Abbrev table in use in Delphi mode buffers.")
-(define-abbrev-table 'delphi-mode-abbrev-table ())
-
-(defmacro delphi-ensure-buffer (buffer-var buffer-name)
- ;; Ensures there exists a buffer of the specified name in the specified
- ;; variable.
- `(when (not (buffer-live-p ,buffer-var))
- (setq ,buffer-var (get-buffer-create ,buffer-name))))
-
-(defun delphi-log-msg (to-buffer the-msg)
- ;; Writes a message to the end of the specified buffer.
- (with-current-buffer to-buffer
- (save-selected-window
- (switch-to-buffer-other-window to-buffer)
- (goto-char (point-max))
- (set-window-point (get-buffer-window to-buffer) (point))
- (insert the-msg))))
-
-;; Debugging helpers:
-
-(defvar delphi-debug-buffer nil
- "Buffer to write Delphi mode debug messages to. Created on demand.")
-
-(defun delphi-debug-log (format-string &rest args)
- ;; Writes a message to the log buffer.
- (when delphi-debug
- (delphi-ensure-buffer delphi-debug-buffer "*Delphi Debug Log*")
- (delphi-log-msg delphi-debug-buffer
- (concat (format-time-string "%H:%M:%S " (current-time))
- (apply #'format (cons format-string args))
- "\n"))))
-
-(defun delphi-debug-token-string (token)
- (let* ((image (delphi-token-string token))
- (has-newline (string-match "^\\([^\n]*\\)\n\\(.+\\)?$" image)))
- (when has-newline
- (setq image (concat (match-string 1 image)
- (if (match-beginning 2) "..."))))
- image))
-
-(defun delphi-debug-show-current-token ()
- (interactive)
- (let ((token (delphi-current-token)))
- (delphi-debug-log "Token: %S %S" token (delphi-debug-token-string token))))
-
-(defun delphi-debug-goto-point (p)
- (interactive "NGoto char: ")
- (goto-char p))
-
-(defun delphi-debug-goto-next-token ()
- (interactive)
- (goto-char (delphi-token-start (delphi-next-token (delphi-current-token)))))
-
-(defun delphi-debug-goto-previous-token ()
- (interactive)
- (goto-char
- (delphi-token-start (delphi-previous-token (delphi-current-token)))))
-
-(defun delphi-debug-show-current-string (from to)
- (interactive "r")
- (delphi-debug-log "String: %S" (buffer-substring from to)))
-
-(defun delphi-debug-show-is-stable ()
- (interactive)
- (delphi-debug-log "stable: %S prev: %S next: %S"
- (delphi-is-stable-literal (point))
- (delphi-literal-kind (1- (point)))
- (delphi-literal-kind (point))))
-
-(defun delphi-debug-unparse-buffer ()
- (interactive)
- (delphi-set-text-properties (point-min) (point-max) nil))
-
-(defun delphi-debug-parse-region (from to)
- (interactive "r")
- (let ((delphi-verbose t))
- (delphi-save-excursion
- (delphi-progress-start)
- (delphi-parse-region from to)
- (delphi-progress-done "Parsing done"))))
-
-(defun delphi-debug-parse-window ()
- (interactive)
- (delphi-debug-parse-region (window-start) (window-end)))
-
-(defun delphi-debug-parse-buffer ()
- (interactive)
- (delphi-debug-parse-region (point-min) (point-max)))
-
-(defun delphi-debug-fontify-window ()
- (interactive)
- (delphi-fontify-region (window-start) (window-end) t))
-
-(defun delphi-debug-fontify-buffer ()
- (interactive)
- (delphi-fontify-region (point-min) (point-max) t))
-
-(defun delphi-debug-tokenize-region (from to)
- (interactive)
- (delphi-save-excursion
- (delphi-progress-start)
- (goto-char from)
- (while (< (point) to)
- (goto-char (delphi-token-end (delphi-current-token)))
- (delphi-step-progress (point) "Tokenizing" delphi-scanning-progress-step))
- (delphi-progress-done "Tokenizing done")))
-
-(defun delphi-debug-tokenize-buffer ()
- (interactive)
- (delphi-debug-tokenize-region (point-min) (point-max)))
-
-(defun delphi-debug-tokenize-window ()
- (interactive)
- (delphi-debug-tokenize-region (window-start) (window-end)))
-
-(defun delphi-newline ()
- "Terminate the current line with a newline and indent the next, unless
-`delphi-newline-always-indents' is nil, in which case no reindenting occurs."
- (interactive)
- ;; Remove trailing spaces
- (delete-horizontal-space)
- (newline)
- (when delphi-newline-always-indents
- ;; Indent both the (now) previous and current line first.
- (save-excursion
- (forward-line -1)
- (delphi-indent-line))
- (delphi-indent-line)))
-
-
-(defun delphi-tab ()
- "Indent the region, when Transient Mark mode is enabled and the region is
-active. Otherwise, indent the current line or insert a TAB, depending on the
-value of `delphi-tab-always-indents' and the current line position."
- (interactive)
- (cond ((use-region-p)
- ;; If Transient Mark mode is enabled and the region is active, indent
- ;; the entire region.
- (indent-region (region-beginning) (region-end)))
- ((or delphi-tab-always-indents
- (save-excursion (skip-chars-backward delphi-space-chars) (bolp)))
- ;; Otherwise, if we are configured always to indent (regardless of the
- ;; point's position in the line) or we are before the first non-space
- ;; character on the line, indent the line.
- (delphi-indent-line))
- (t
- ;; Otherwise, insert a tab character.
- (insert "\t"))))
-
-
-(defun delphi-is-directory (path)
- ;; True if the specified path is an existing directory.
- (let ((attributes (file-attributes path)))
- (and attributes (car attributes))))
-
-(defun delphi-is-file (path)
- ;; True if the specified file exists as a file.
- (let ((attributes (file-attributes path)))
- (and attributes (null (car attributes)))))
-
-(defun delphi-search-directory (unit dir &optional recurse)
- ;; Searches for the unit in the specified directory. If recurse is true, then
- ;; the directory is recursively searched. File name comparison is done in a
- ;; case insensitive manner.
- (when (delphi-is-directory dir)
- (let ((files (directory-files dir))
- (unit-file (downcase unit)))
- (catch 'done
- ;; Search for the file.
- (mapc #'(lambda (file)
- (let ((path (concat dir "/" file)))
- (if (and (string= unit-file (downcase file))
- (delphi-is-file path))
- (throw 'done path))))
- files)
-
- ;; Not found. Search subdirectories.
- (when recurse
- (mapc #'(lambda (subdir)
- (unless (member subdir '("." ".."))
- (let ((path (delphi-search-directory
- unit (concat dir "/" subdir) recurse)))
- (if path (throw 'done path)))))
- files))
-
- ;; Not found.
- nil))))
-
-
-(defun delphi-find-unit-in-directory (unit dir)
- ;; Searches for the unit in the specified directory. If the directory ends
- ;; in \"...\", then it is recursively searched.
- (let ((dir-name dir)
- (recurse nil))
- ;; Check if we need to recursively search the directory.
- (if (string-match "^\\(.+\\)\\.\\.\\.$" dir-name)
- (setq dir-name (match-string 1 dir-name)
- recurse t))
- ;; Ensure the trailing slash is removed.
- (if (string-match "^\\(.+\\)[\\\\/]$" dir-name)
- (setq dir-name (match-string 1 dir-name)))
- (delphi-search-directory unit dir-name recurse)))
-
-(defun delphi-find-unit-file (unit)
- ;; Finds the specified delphi source file according to `delphi-search-path'.
- ;; If found, the full path is returned, otherwise nil is returned.
- (catch 'done
- (cond ((null delphi-search-path)
- (delphi-find-unit-in-directory unit "."))
-
- ((stringp delphi-search-path)
- (delphi-find-unit-in-directory unit delphi-search-path))
-
- ((mapc
- #'(lambda (dir)
- (let ((file (delphi-find-unit-in-directory unit dir)))
- (if file (throw 'done file))))
- delphi-search-path)))
- nil))
-
-(defun delphi-find-unit (unit)
- "Find the specified Delphi source file according to `delphi-search-path'.
-If no extension is specified, .pas is assumed. Creates a buffer for the unit."
- (interactive "sDelphi unit name: ")
- (let* ((unit-file (if (string-match "^\\(.*\\)\\.[a-z]+$" unit)
- unit
- (concat unit ".pas")))
- (file (delphi-find-unit-file unit-file)))
- (if (null file)
- (error "unit not found: %s" unit-file)
- (find-file file)
- (if (not (derived-mode-p 'delphi-mode))
- (delphi-mode)))
- file))
-
-(defun delphi-find-current-def ()
- "Find the definition of the identifier under the current point."
- (interactive)
- (error "delphi-find-current-def: not implemented yet"))
-
-(defun delphi-find-current-xdef ()
- "Find the definition of the identifier under the current point, searching
-in external units if necessary (as listed in the current unit's use clause).
-The set of directories to search for a unit is specified by the global variable
-`delphi-search-path'."
- (interactive)
- (error "delphi-find-current-xdef: not implemented yet"))
-
-(defun delphi-find-current-body ()
- "Find the body of the identifier under the current point, assuming
-it is a routine."
- (interactive)
- (error "delphi-find-current-body: not implemented yet"))
-
-(defun delphi-fill-comment ()
- "Fill the text of the current comment, according to `fill-column'.
-An error is raised if not in a comment."
- (interactive)
- (save-excursion
- (save-restriction
- (let* ((comment (delphi-current-token))
- (comment-kind (delphi-token-kind comment)))
- (if (not (delphi-is comment-kind delphi-comments))
- (error "Not in a comment")
- (let* ((start-comment (delphi-comment-block-start comment))
- (end-comment (delphi-comment-block-end comment))
- (comment-start (delphi-token-start start-comment))
- (comment-end (delphi-token-end end-comment))
- (content-start (delphi-comment-content-start start-comment))
- (content-indent (delphi-column-of content-start))
- (content-prefix (make-string content-indent ?\s))
- (content-prefix-re delphi-leading-spaces-re)
- (p nil)
- (marked-point (point-marker))) ; Maintain our position reliably.
- (when (eq 'comment-single-line comment-kind)
- ;; // style comments need more work.
- (setq content-prefix
- (let ((comment-indent (delphi-column-of comment-start)))
- (concat (make-string comment-indent ?\s) "//"
- (make-string (- content-indent comment-indent 2)
- ?\s)))
- content-prefix-re (concat delphi-leading-spaces-re
- "//"
- delphi-spaces-re)
- comment-end (if (delphi-is-literal-end comment-end)
- ;; Don't include the trailing newline.
- (1- comment-end)
- comment-end)))
-
- ;; Advance our marked point after inserted spaces.
- (set-marker-insertion-type marked-point t)
-
- ;; Ensure we can modify the buffer
- (goto-char content-start)
- (insert " ")
- (delete-char -1)
-
- (narrow-to-region content-start comment-end)
-
- ;; Strip off the comment prefixes
- (setq p (point-min))
- (while (when (< p (point-max))
- (goto-char p)
- (re-search-forward content-prefix-re nil t))
- (replace-match "" nil nil)
- (setq p (1+ (point))))
-
- ;; add an extra line to prevent the fill from doing it for us.
- (goto-char (point-max))
- (insert "\n")
-
- ;; Fill the comment contents.
- (let ((fill-column (- fill-column content-indent)))
- (fill-region (point-min) (point-max)))
-
- (goto-char (point-max))
- (delete-char -1)
-
- ;; Restore comment prefixes.
- (goto-char (point-min))
- (end-of-line) ; Don't reset the first line.
- (setq p (point))
- (while (when (< p (point-max))
- (goto-char p)
- (re-search-forward "^" nil t))
- (replace-match content-prefix nil nil)
- (setq p (1+ (point))))
-
- (setq comment-end (point-max))
- (widen)
-
- ;; Restore our position
- (goto-char marked-point)
- (set-marker marked-point nil)
-
- ;; React to the entire fill change as a whole.
- (delphi-progress-start)
- (delphi-parse-region comment-start comment-end)
- (delphi-progress-done)))))))
-
-(defun delphi-new-comment-line ()
- "If in a // comment, do a newline, indented such that one is still in the
-comment block. If not in a // comment, just does a normal newline."
- (interactive)
- (let ((comment (delphi-current-token)))
- (if (not (eq 'comment-single-line (delphi-token-kind comment)))
- ;; Not in a // comment. Just do the normal newline.
- (delphi-newline)
- (let* ((start-comment (delphi-comment-block-start comment))
- (comment-start (delphi-token-start start-comment))
- (content-start (delphi-comment-content-start start-comment))
- (prefix
- (concat (make-string (delphi-column-of comment-start) ?\s) "//"
- (make-string (- content-start comment-start 2) ?\s))))
- (delete-horizontal-space)
- (newline)
- (insert prefix)))))
-
-(defun delphi-match-token (token limit)
- ;; Sets the match region used by (match-string 0) and friends to the token's
- ;; region. Sets the current point to the end of the token (or limit).
- (set-match-data nil)
- (if token
- (let ((end (min (delphi-token-end token) limit)))
- (set-match-data (list (delphi-token-start token) end))
- (goto-char end)
- token)))
-
-(defconst delphi-font-lock-defaults
- '(nil ; We have our own fontify routine, so keywords don't apply.
- t ; Syntactic fontification doesn't apply.
- nil ; Don't care about case since we don't use regexps to find tokens.
- nil ; Syntax alists don't apply.
- nil ; Syntax begin movement doesn't apply
- (font-lock-fontify-region-function . delphi-fontify-region)
- (font-lock-verbose . delphi-fontifying-progress-step))
- "Delphi mode font-lock defaults. Syntactic fontification is ignored.")
-
-(defvar delphi-debug-mode-map
- (let ((kmap (make-sparse-keymap)))
- (mapc #'(lambda (binding) (define-key kmap (car binding) (cadr binding)))
- '(("n" delphi-debug-goto-next-token)
- ("p" delphi-debug-goto-previous-token)
- ("t" delphi-debug-show-current-token)
- ("T" delphi-debug-tokenize-buffer)
- ("W" delphi-debug-tokenize-window)
- ("g" delphi-debug-goto-point)
- ("s" delphi-debug-show-current-string)
- ("a" delphi-debug-parse-buffer)
- ("w" delphi-debug-parse-window)
- ("f" delphi-debug-fontify-window)
- ("F" delphi-debug-fontify-buffer)
- ("r" delphi-debug-parse-region)
- ("c" delphi-debug-unparse-buffer)
- ("x" delphi-debug-show-is-stable)
- ))
- kmap)
- "Keystrokes for Delphi mode debug commands.")
-
-(defvar delphi-mode-map
- (let ((kmap (make-sparse-keymap)))
- (mapc #'(lambda (binding) (define-key kmap (car binding) (cadr binding)))
- (list '("\r" delphi-newline)
- '("\t" delphi-tab)
- '("\177" backward-delete-char-untabify)
-;; '("\C-cd" delphi-find-current-def)
-;; '("\C-cx" delphi-find-current-xdef)
-;; '("\C-cb" delphi-find-current-body)
- '("\C-cu" delphi-find-unit)
- '("\M-q" delphi-fill-comment)
- '("\M-j" delphi-new-comment-line)
- ;; Debug bindings:
- (list "\C-c\C-d" delphi-debug-mode-map)))
- kmap)
- "Keymap used in Delphi mode.")
-
-;;;###autoload
-(define-derived-mode delphi-mode prog-mode "Delphi"
- "Major mode for editing Delphi code. \\<delphi-mode-map>
-\\[delphi-tab]\t- Indents the current line (or region, if Transient Mark mode
-\t is enabled and the region is active) of Delphi code.
-\\[delphi-find-unit]\t- Search for a Delphi source file.
-\\[delphi-fill-comment]\t- Fill the current comment.
-\\[delphi-new-comment-line]\t- If in a // comment, do a new comment line.
-
-\\[indent-region] also works for indenting a whole region.
-
-Customization:
-
- `delphi-indent-level' (default 3)
- Indentation of Delphi statements with respect to containing block.
- `delphi-compound-block-indent' (default 0)
- Extra indentation for blocks in compound statements.
- `delphi-case-label-indent' (default 0)
- Extra indentation for case statement labels.
- `delphi-tab-always-indents' (default t)
- Non-nil means TAB in Delphi mode should always reindent the current line,
- regardless of where in the line point is when the TAB command is used.
- `delphi-newline-always-indents' (default t)
- Non-nil means NEWLINE in Delphi mode should always reindent the current
- line, insert a blank line and move to the default indent column of the
- blank line.
- `delphi-search-path' (default .)
- Directories to search when finding external units.
- `delphi-verbose' (default nil)
- If true then Delphi token processing progress is reported to the user.
-
-Coloring:
-
- `delphi-comment-face' (default font-lock-comment-face)
- Face used to color Delphi comments.
- `delphi-string-face' (default font-lock-string-face)
- Face used to color Delphi strings.
- `delphi-keyword-face' (default font-lock-keyword-face)
- Face used to color Delphi keywords.
- `delphi-other-face' (default nil)
- Face used to color everything else.
-
-Turning on Delphi mode calls the value of the variable `delphi-mode-hook'
-with no args, if that value is non-nil."
-
- ;; Buffer locals:
- (mapc #'(lambda (var)
- (let ((var-symb (car var))
- (var-val (cadr var)))
- (set (make-local-variable var-symb) var-val)))
- (list '(indent-line-function delphi-indent-line)
- '(comment-indent-function delphi-indent-line)
- '(case-fold-search t)
- '(delphi-progress-last-reported-point nil)
- '(delphi-ignore-changes nil)
- (list 'font-lock-defaults delphi-font-lock-defaults)))
-
- ;; We need to keep track of changes to the buffer to determine if we need
- ;; to retokenize changed text.
- (add-hook 'after-change-functions 'delphi-after-change nil t)
-
- (widen)
-
- (delphi-save-excursion
- (let ((delphi-verbose t))
- (delphi-progress-start)
- (delphi-parse-region (point-min) (point-max))
- (delphi-progress-done)))
-
- (run-mode-hooks 'delphi-mode-hook))
-
-;;; delphi.el ends here
--- /dev/null
+;;; opascal.el --- major mode for editing Object Pascal source in Emacs -*- lexical-binding: t -*-
+
+;; Copyright (C) 1998-1999, 2001-2013 Free Software Foundation, Inc.
+
+;; Authors: Ray Blaak <blaak@infomatch.com>,
+;; Simon South <ssouth@member.fsf.org>
+;; Maintainer: Simon South <ssouth@member.fsf.org>
+;; Keywords: languages
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; To enter OPascal mode when you find an Object Pascal source file, one must
+;; override the auto-mode-alist to associate OPascal with .pas (and .dpr and
+;; .dpk) files. Emacs, by default, will otherwise enter Pascal mode. E.g.
+;;
+;; (autoload 'opascal-mode "opascal")
+;; (add-to-list 'auto-mode-alist
+;; '("\\.\\(pas\\|dpr\\|dpk\\)\\'" . opascal-mode))
+
+;; When you have entered OPascal mode, you may get more info by pressing
+;; C-h m.
+
+;; This OPascal mode implementation is fairly tolerant of syntax errors,
+;; relying as much as possible on the indentation of the previous statement.
+;; This also makes it faster and simpler, since there is less searching for
+;; properly constructed beginnings.
+
+;;; Code:
+
+(defgroup opascal nil
+ "Major mode for editing OPascal source in Emacs."
+ :version "24.4"
+ :group 'languages)
+
+(defconst opascal-debug nil
+ "True if in debug mode.")
+
+(define-obsolete-variable-alias
+ 'delphi-search-path 'opascal-search-path "24.4")
+(defcustom opascal-search-path "."
+ "Directories to search when finding external units.
+It is a list of directory strings. If only a single directory,
+it can be a single string instead of a list. If a directory
+ends in \"...\" then that directory is recursively searched."
+ :type 'string)
+
+(define-obsolete-variable-alias
+ 'delphi-indent-level 'opascal-indent-level "24.4")
+(defcustom opascal-indent-level 3
+ "Indentation of OPascal statements with respect to containing block.
+E.g.
+
+begin
+ // This is an indent of 3.
+end;"
+ :type 'integer)
+
+(define-obsolete-variable-alias
+ 'delphi-compound-block-indent 'opascal-compound-block-indent "24.4")
+(defcustom opascal-compound-block-indent 0
+ "Extra indentation for blocks in compound statements. E.g.
+
+// block indent = 0 vs // block indent = 2
+if b then if b then
+begin begin
+end else begin end
+end; else
+ begin
+ end;"
+ :type 'integer)
+
+(define-obsolete-variable-alias
+ 'delphi-case-label-indent 'opascal-case-label-indent "24.4")
+(defcustom opascal-case-label-indent opascal-indent-level
+ "Extra indentation for case statement labels. E.g.
+
+// case indent = 0 vs // case indent = 3
+case value of case value of
+v1: process_v1; v1: process_v1;
+v2: process_v2; v2: process_v2;
+else else
+ process_else; process_else;
+end; end;"
+ :type 'integer)
+
+(define-obsolete-variable-alias 'delphi-verbose 'opascal-verbose "24.4")
+(defcustom opascal-verbose t ; nil
+ "If true then OPascal token processing progress is reported to the user."
+ :type 'boolean)
+
+(define-obsolete-variable-alias
+ 'delphi-tab-always-indents 'opascal-tab-always-indents "24.4")
+(defcustom opascal-tab-always-indents tab-always-indent
+ "Non-nil means TAB in OPascal mode should always reindent the current line,
+regardless of where in the line point is when the TAB command is used."
+ :type 'boolean)
+
+(define-obsolete-variable-alias
+ 'delphi-comment-face 'opascal-comment-face "24.4")
+(defcustom opascal-comment-face 'font-lock-comment-face
+ "Face used to color OPascal comments."
+ :type 'face)
+
+(define-obsolete-variable-alias
+ 'delphi-string-face 'opascal-string-face "24.4")
+(defcustom opascal-string-face 'font-lock-string-face
+ "Face used to color OPascal strings."
+ :type 'face)
+
+(define-obsolete-variable-alias
+ 'delphi-keyword-face 'opascal-keyword-face "24.4")
+(defcustom opascal-keyword-face 'font-lock-keyword-face
+ "Face used to color OPascal keywords."
+ :type 'face)
+
+(define-obsolete-variable-alias 'delphi-other-face 'opascal-other-face "24.4")
+(defcustom opascal-other-face nil
+ "Face used to color everything else."
+ :type '(choice (const :tag "None" nil) face))
+
+(defconst opascal-directives
+ '(absolute abstract assembler automated cdecl default dispid dynamic
+ export external far forward index inline message name near nodefault
+ overload override pascal private protected public published read readonly
+ register reintroduce resident resourcestring safecall stdcall stored
+ virtual write writeonly)
+ "OPascal4 directives.")
+
+(defconst opascal-keywords
+ (append
+ '(;; Keywords.
+ and array as asm at begin case class const constructor contains
+ destructor dispinterface div do downto else end except exports
+ file finalization finally for function goto if implementation implements
+ in inherited initialization interface is label library mod nil not
+ of object on or out package packed procedure program property
+ raise record repeat requires result self set shl shr then threadvar
+ to try type unit uses until var while with xor
+
+ ;; These routines should be keywords, if Borland had the balls.
+ break exit)
+
+ ;; We want directives to look like keywords.
+ opascal-directives)
+ "OPascal4 keywords.")
+
+(defconst opascal-previous-terminators `(semicolon comma)
+ "Expression/statement terminators that denote a previous expression.")
+
+(defconst opascal-comments
+ '(comment-single-line comment-multi-line-1 comment-multi-line-2)
+ "Tokens that represent comments.")
+
+(defconst opascal-strings
+ '(string double-quoted-string)
+ "Tokens that represent string literals.")
+
+(defconst opascal-whitespace `(space newline ,@opascal-comments)
+ "Tokens that are considered whitespace.")
+
+(defconst opascal-routine-statements
+ '(procedure function constructor destructor property)
+ "Marks the start of a routine, or routine-ish looking expression.")
+
+(defconst opascal-body-expr-statements '(if while for on)
+ "Statements that have either a single statement or a block as a body and also
+are followed by an expression.")
+
+(defconst opascal-expr-statements `(case ,@opascal-body-expr-statements)
+ "Expression statements contain expressions after their keyword.")
+
+(defconst opascal-body-statements `(else ,@opascal-body-expr-statements)
+ "Statements that have either a single statement or a block as a body.")
+
+(defconst opascal-expr-delimiters '(then do of)
+ "Expression delimiter tokens.")
+
+(defconst opascal-binary-ops
+ '(plus minus equals not-equals times divides div mod and or xor)
+ "OPascal binary operations.")
+
+(defconst opascal-visibilities '(public private protected published automated)
+ "Class visibilities.")
+
+(defconst opascal-block-statements
+ '(begin try case repeat initialization finalization asm)
+ "Statements that contain multiple substatements.")
+
+(defconst opascal-mid-block-statements
+ `(except finally ,@opascal-visibilities)
+ "Statements that mark mid sections of the enclosing block.")
+
+(defconst opascal-end-block-statements `(end until)
+ "Statements that end block sections.")
+
+(defconst opascal-match-block-statements
+ `(,@opascal-end-block-statements ,@opascal-mid-block-statements)
+ "Statements that match the indentation of the parent block.")
+
+(defconst opascal-decl-sections '(type const var label resourcestring)
+ "Denotes the start of a declaration section.")
+
+(defconst opascal-interface-types '(dispinterface interface)
+ "Interface types.")
+
+(defconst opascal-class-types '(class object)
+ "Class types.")
+
+(defconst opascal-composite-types
+ `(,@opascal-class-types ,@opascal-interface-types record)
+ "Types that contain declarations within them.")
+
+(defconst opascal-unit-sections
+ '(interface implementation program library package)
+ "Unit sections within which the indent is 0.")
+
+(defconst opascal-use-clauses `(uses requires exports contains)
+ "Statements that refer to foreign symbols.")
+
+(defconst opascal-unit-statements
+ `(,@opascal-use-clauses ,@opascal-unit-sections initialization finalization)
+ "Statements indented at level 0.")
+
+(defconst opascal-decl-delimiters
+ `(,@opascal-decl-sections ,@opascal-unit-statements
+ ,@opascal-routine-statements)
+ "Statements that a declaration statement should align with.")
+
+(defconst opascal-decl-matchers
+ `(begin ,@opascal-decl-sections)
+ "Statements that should match to declaration statement indentation.")
+
+(defconst opascal-enclosing-statements
+ `(,@opascal-block-statements ,@opascal-mid-block-statements
+ ,@opascal-decl-sections ,@opascal-use-clauses ,@opascal-routine-statements)
+ "Delimits an enclosing statement.")
+
+(defconst opascal-previous-statements
+ `(,@opascal-unit-statements ,@opascal-routine-statements)
+ "Delimits a previous statement.")
+
+(defconst opascal-previous-enclosing-statements
+ `(,@opascal-block-statements ,@opascal-mid-block-statements
+ ,@opascal-decl-sections)
+ "Delimits a previous enclosing statement.")
+
+(defconst opascal-begin-enclosing-tokens
+ `(,@opascal-block-statements ,@opascal-mid-block-statements)
+ "Tokens that a begin token indents from.")
+
+(defconst opascal-begin-previous-tokens
+ `(,@opascal-decl-sections ,@opascal-routine-statements)
+ "Tokens that a begin token aligns with, but only if not part of a nested
+routine.")
+
+(defconst opascal-space-chars "\000-\011\013- ") ; all except \n
+(defconst opascal-non-space-chars (concat "^" opascal-space-chars))
+(defconst opascal-spaces-re (concat "[" opascal-space-chars "]*"))
+(defconst opascal-leading-spaces-re (concat "^" opascal-spaces-re))
+(defconst opascal-word-chars "a-zA-Z0-9_")
+
+(defmacro opascal-save-excursion (&rest forms)
+ ;; Executes the forms such that any movements have no effect, including
+ ;; searches.
+ `(save-excursion
+ (save-match-data
+ (let ((inhibit-point-motion-hooks t)
+ (deactivate-mark nil))
+ (progn ,@forms)))))
+
+(defmacro opascal-save-state (&rest forms)
+ ;; Executes the forms such that any buffer modifications do not have any side
+ ;; effects beyond the buffer's actual content changes.
+ `(let ((opascal--ignore-changes t))
+ (with-silent-modifications
+ ,@forms)))
+
+(defsubst opascal-is (element in-set)
+ ;; If the element is in the set, the element cdr is returned, otherwise nil.
+ (memq element in-set))
+
+(defun opascal-string-of (start end)
+ ;; Returns the buffer string from start to end.
+ (buffer-substring-no-properties start end))
+
+(defun opascal-looking-at-string (p s)
+ ;; True if point p marks the start of string s. s is not a regular
+ ;; expression.
+ (let ((limit (+ p (length s))))
+ (and (<= limit (point-max))
+ (string= s (opascal-string-of p limit)))))
+
+(defun opascal-token-of (kind start end)
+ ;; Constructs a token from a kind symbol and its start/end points.
+ `[,kind ,start ,end])
+
+(defsubst opascal-token-kind (token)
+ ;; Returns the kind symbol of the token.
+ (if token (aref token 0) nil))
+
+(defun opascal-set-token-kind (token to-kind)
+ ;; Sets the kind symbol of the token.
+ (if token (aset token 0 to-kind)))
+
+(defsubst opascal-token-start (token)
+ ;; Returns the start point of the token.
+ (if token (aref token 1) (point-min)))
+
+(defsubst opascal-token-end (token)
+ ;; Returns the end point of the token.
+ (if token (aref token 2) (point-min)))
+
+(defun opascal-set-token-start (token start)
+ ;; Sets the start point of the token.
+ (if token (aset token 1 start)))
+
+(defun opascal-set-token-end (token end)
+ ;; Sets the end point of the token.
+ (if token (aset token 2 end)))
+
+(defun opascal-token-string (token)
+ ;; Returns the string image of the token.
+ (if token
+ (opascal-string-of (opascal-token-start token) (opascal-token-end token))
+ ""))
+
+(defun opascal-in-token (p token)
+ ;; Returns true if the point p is within the token's start/end points.
+ (and (<= (opascal-token-start token) p) (< p (opascal-token-end token))))
+
+(defun opascal-column-of (p)
+ ;; Returns the column of the point p.
+ (save-excursion (goto-char p) (current-column)))
+
+(defun opascal-face-of (token-kind)
+ ;; Returns the face property appropriate for the token kind.
+ (cond ((opascal-is token-kind opascal-comments) opascal-comment-face)
+ ((opascal-is token-kind opascal-strings) opascal-string-face)
+ ((opascal-is token-kind opascal-keywords) opascal-keyword-face)
+ (opascal-other-face)))
+
+(defvar opascal-progress-last-reported-point nil
+ "The last point at which progress was reported.")
+
+(defconst opascal-parsing-progress-step 16384
+ "Number of chars to process before the next parsing progress report.")
+(defconst opascal-scanning-progress-step 2048
+ "Number of chars to process before the next scanning progress report.")
+(defconst opascal-fontifying-progress-step opascal-scanning-progress-step
+ "Number of chars to process before the next fontification progress report.")
+
+(defun opascal-progress-start ()
+ ;; Initializes progress reporting.
+ (setq opascal-progress-last-reported-point nil))
+
+(defun opascal-progress-done (&rest msgs)
+ ;; Finalizes progress reporting.
+ (setq opascal-progress-last-reported-point nil)
+ (when opascal-verbose
+ (if (null msgs)
+ (message "")
+ (apply #'message msgs))))
+
+(defun opascal-step-progress (p desc step-size)
+ ;; If enough distance has elapsed since the last reported point, then report
+ ;; the current progress to the user.
+ (cond ((null opascal-progress-last-reported-point)
+ ;; This is the first progress step.
+ (setq opascal-progress-last-reported-point p))
+
+ ((and opascal-verbose
+ (>= (abs (- p opascal-progress-last-reported-point)) step-size))
+ ;; Report the percentage complete.
+ (setq opascal-progress-last-reported-point p)
+ (message "%s %s ... %d%%"
+ desc (buffer-name) (/ (* 100 p) (point-max))))))
+
+(defun opascal-next-line-start (&optional from-point)
+ ;; Returns the first point of the next line.
+ (let ((curr-point (point))
+ (next nil))
+ (if from-point (goto-char from-point))
+ (end-of-line)
+ (setq next (min (1+ (point)) (point-max)))
+ (goto-char curr-point)
+ next))
+
+(defvar opascal--ignore-changes t
+ "Internal flag to control if the OPascal mode responds to buffer changes.
+Defaults to t in case the `opascal-after-change' function is called on a
+non-OPascal buffer. Set to nil in OPascal buffers. To override, just do:
+ (let ((opascal--ignore-changes t)) ...)")
+
+(defun opascal-set-text-properties (from to properties)
+ ;; Like `set-text-properties', except we do not consider this to be a buffer
+ ;; modification.
+ (opascal-save-state
+ (set-text-properties from to properties)))
+
+(defun opascal-literal-kind (p)
+ ;; Returns the literal kind the point p is in (or nil if not in a literal).
+ (if (and (<= (point-min) p) (<= p (point-max)))
+ (get-text-property p 'token)))
+
+(defun opascal-literal-start-pattern (literal-kind)
+ ;; Returns the start pattern of the literal kind.
+ (cdr (assoc literal-kind
+ '((comment-single-line . "//")
+ (comment-multi-line-1 . "{")
+ (comment-multi-line-2 . "(*")
+ (string . "'")
+ (double-quoted-string . "\"")))))
+
+(defun opascal-literal-end-pattern (literal-kind)
+ ;; Returns the end pattern of the literal kind.
+ (cdr (assoc literal-kind
+ '((comment-single-line . "\n")
+ (comment-multi-line-1 . "}")
+ (comment-multi-line-2 . "*)")
+ (string . "'")
+ (double-quoted-string . "\"")))))
+
+(defun opascal-literal-stop-pattern (literal-kind)
+ ;; Returns the pattern that delimits end of the search for the literal kind.
+ ;; These are regular expressions.
+ (cdr (assoc literal-kind
+ '((comment-single-line . "\n")
+ (comment-multi-line-1 . "}")
+ (comment-multi-line-2 . "\\*)")
+ ;; Strings cannot span lines.
+ (string . "['\n]")
+ (double-quoted-string . "[\"\n]")))))
+
+(defun opascal-is-literal-start (p)
+ ;; True if the point p is at the start point of a (completed) literal.
+ (let* ((kind (opascal-literal-kind p))
+ (pattern (opascal-literal-start-pattern kind)))
+ (or (null kind) ; Non-literals are considered as start points.
+ (opascal-looking-at-string p pattern))))
+
+(defun opascal-is-literal-end (p)
+ ;; True if the point p is at the end point of a (completed) literal.
+ (let* ((kind (opascal-literal-kind (1- p)))
+ (pattern (opascal-literal-end-pattern kind)))
+ (or (null kind) ; Non-literals are considered as end points.
+
+ (and (opascal-looking-at-string (- p (length pattern)) pattern)
+ (or (not (opascal-is kind opascal-strings))
+ ;; Special case: string delimiters are start/end ambiguous.
+ ;; We have an end only if there is some string content (at
+ ;; least a starting delimiter).
+ (not (opascal-is-literal-end (1- p)))))
+
+ ;; Special case: strings cannot span lines.
+ (and (opascal-is kind opascal-strings) (eq ?\n (char-after (1- p)))))))
+
+(defun opascal-is-stable-literal (p)
+ ;; True if the point p marks a stable point. That is, a point outside of a
+ ;; literal region, inside of a literal region, or adjacent to completed
+ ;; literal regions.
+ (let ((at-start (opascal-is-literal-start p))
+ (at-end (opascal-is-literal-end p)))
+ (or (>= p (point-max))
+ (and at-start at-end)
+ (and (not at-start) (not at-end)
+ (eq (opascal-literal-kind (1- p)) (opascal-literal-kind p))))))
+
+(defun opascal-complete-literal (literal-kind limit)
+ ;; Continues the search for a literal's true end point and returns the
+ ;; point past the end pattern (if found) or the limit (if not found).
+ (let ((pattern (opascal-literal-stop-pattern literal-kind)))
+ (if (not (stringp pattern))
+ (error "Invalid literal kind %S" literal-kind)
+ ;; Search up to the limit.
+ (re-search-forward pattern limit 'goto-limit-on-fail)
+ (point))))
+
+(defun opascal-literal-text-properties (kind)
+ ;; Creates a list of text properties for the literal kind.
+ (if (and (boundp 'font-lock-mode)
+ font-lock-mode)
+ (list 'token kind 'face (opascal-face-of kind) 'lazy-lock t)
+ (list 'token kind)))
+
+(defun opascal-parse-next-literal (limit)
+ ;; Searches for the next literal region (i.e. comment or string) and sets the
+ ;; the point to its end (or the limit, if not found). The literal region is
+ ;; marked as such with a text property, to speed up tokenizing during face
+ ;; coloring and indentation scanning.
+ (let ((search-start (point)))
+ (cond ((not (opascal-is-literal-end search-start))
+ ;; We are completing an incomplete literal.
+ (let ((kind (opascal-literal-kind (1- search-start))))
+ (opascal-complete-literal kind limit)
+ (opascal-set-text-properties
+ search-start (point) (opascal-literal-text-properties kind))))
+
+ ((re-search-forward
+ "\\(//\\)\\|\\({\\)\\|\\((\\*\\)\\|\\('\\)\\|\\(\"\\)"
+ limit 'goto-limit-on-fail)
+ ;; We found the start of a new literal. Find its end and mark it.
+ (let ((kind (cond ((match-beginning 1) 'comment-single-line)
+ ((match-beginning 2) 'comment-multi-line-1)
+ ((match-beginning 3) 'comment-multi-line-2)
+ ((match-beginning 4) 'string)
+ ((match-beginning 5) 'double-quoted-string)))
+ (start (match-beginning 0)))
+ (opascal-set-text-properties search-start start nil)
+ (opascal-complete-literal kind limit)
+ (opascal-set-text-properties
+ start (point) (opascal-literal-text-properties kind))))
+
+ ;; Nothing found. Mark it as a non-literal.
+ ((opascal-set-text-properties search-start limit nil)))
+ (opascal-step-progress (point) "Parsing" opascal-parsing-progress-step)))
+
+(defun opascal-literal-token-at (p)
+ ;; Returns the literal token surrounding the point p, or nil if none.
+ (let ((kind (opascal-literal-kind p)))
+ (when kind
+ (let ((start (previous-single-property-change (1+ p) 'token))
+ (end (next-single-property-change p 'token)))
+ (opascal-token-of kind (or start (point-min)) (or end (point-max)))))))
+
+(defun opascal-point-token-at (p kind)
+ ;; Returns the single character token at the point p.
+ (opascal-token-of kind p (1+ p)))
+
+(defsubst opascal-char-token-at (p char kind)
+ ;; Returns the token at the point p that describes the specified character.
+ ;; If not actually over such a character, nil is returned.
+ (when (eq char (char-after p))
+ (opascal-token-of kind p (1+ p))))
+
+(defun opascal-charset-token-at (p charset kind)
+ ;; Returns the token surrounding point p that contains only members of the
+ ;; character set.
+ (let ((currp (point))
+ (end nil)
+ (token nil))
+ (goto-char p)
+ (when (> (skip-chars-forward charset) 0)
+ (setq end (point))
+ (goto-char (1+ p))
+ (skip-chars-backward charset)
+ (setq token (opascal-token-of kind (point) end)))
+ (goto-char currp)
+ token))
+
+(defun opascal-space-token-at (p)
+ ;; If point p is surrounded by space characters, then return the token of the
+ ;; contiguous spaces.
+ (opascal-charset-token-at p opascal-space-chars 'space))
+
+(defun opascal-word-token-at (p)
+ ;; If point p is over a word (i.e. identifier characters), then return a word
+ ;; token. If the word is actually a keyword, then return the keyword token.
+ (let ((word (opascal-charset-token-at p opascal-word-chars 'word)))
+ (when word
+ (let* ((word-image (downcase (opascal-token-string word)))
+ (keyword (intern-soft word-image)))
+ (when (and (or keyword (string= "nil" word-image))
+ (opascal-is keyword opascal-keywords))
+ (opascal-set-token-kind word keyword))
+ word))))
+
+(defun opascal-explicit-token-at (p token-string kind)
+ ;; If point p is anywhere in the token string then returns the resulting
+ ;; token.
+ (let ((token (opascal-charset-token-at p token-string kind)))
+ (when (and token (string= token-string (opascal-token-string token)))
+ token)))
+
+(defun opascal-token-at (p)
+ ;; Returns the token from parsing text at point p.
+ (when (and (<= (point-min) p) (<= p (point-max)))
+ (cond ((opascal-char-token-at p ?\n 'newline))
+
+ ((opascal-literal-token-at p))
+
+ ((opascal-space-token-at p))
+
+ ((opascal-word-token-at p))
+
+ ((opascal-char-token-at p ?\( 'open-group))
+ ((opascal-char-token-at p ?\) 'close-group))
+ ((opascal-char-token-at p ?\[ 'open-group))
+ ((opascal-char-token-at p ?\] 'close-group))
+ ((opascal-char-token-at p ?\; 'semicolon))
+ ((opascal-char-token-at p ?. 'dot))
+ ((opascal-char-token-at p ?, 'comma))
+ ((opascal-char-token-at p ?= 'equals))
+ ((opascal-char-token-at p ?+ 'plus))
+ ((opascal-char-token-at p ?- 'minus))
+ ((opascal-char-token-at p ?* 'times))
+ ((opascal-char-token-at p ?/ 'divides))
+ ((opascal-char-token-at p ?: 'colon))
+
+ ((opascal-explicit-token-at p "<>" 'not-equals))
+
+ ((opascal-point-token-at p 'punctuation)))))
+
+(defun opascal-current-token ()
+ ;; Returns the opascal source token under the current point.
+ (opascal-token-at (point)))
+
+(defun opascal-next-token (token)
+ ;; Returns the token after the specified token.
+ (when token
+ (let ((next (opascal-token-at (opascal-token-end token))))
+ (if next
+ (opascal-step-progress (opascal-token-start next) "Scanning"
+ opascal-scanning-progress-step))
+ next)))
+
+(defun opascal-previous-token (token)
+ ;; Returns the token before the specified token.
+ (when token
+ (let ((previous (opascal-token-at (1- (opascal-token-start token)))))
+ (if previous
+ (opascal-step-progress (opascal-token-start previous) "Scanning"
+ opascal-scanning-progress-step))
+ previous)))
+
+(defun opascal-next-visible-token (token)
+ ;; Returns the first non-space token after the specified token.
+ (let (next-token)
+ (while (progn
+ (setq next-token (opascal-next-token token))
+ (opascal-is (opascal-token-kind next-token) '(space newline))))
+ next-token))
+
+(defun opascal-parse-region (from to)
+ ;; Parses the literal tokens in the region. The point is set to "to".
+ (save-restriction
+ (widen)
+ (goto-char from)
+ (while (< (point) to)
+ (opascal-parse-next-literal to))))
+
+(defun opascal-parse-region-until-stable (from to)
+ ;; Parses at least the literal tokens in the region. After that, parsing
+ ;; continues as long as obsolete literal regions are encountered. The point
+ ;; is set to the encountered stable point.
+ (save-restriction
+ (widen)
+ (opascal-parse-region from to)
+ (while (not (opascal-is-stable-literal (point)))
+ (opascal-parse-next-literal (point-max)))))
+
+(defun opascal-fontify-region (from to &optional verbose)
+ ;; Colors the text in the region according to OPascal rules.
+ (opascal-save-excursion
+ (opascal-save-state
+ (let ((p from)
+ (opascal-verbose verbose)
+ (token nil))
+ (opascal-progress-start)
+ (while (< p to)
+ ;; Color the token and move past it.
+ (setq token (opascal-token-at p))
+ (add-text-properties
+ (opascal-token-start token) (opascal-token-end token)
+ (list 'face (opascal-face-of (opascal-token-kind token)) 'lazy-lock t))
+ (setq p (opascal-token-end token))
+ (opascal-step-progress p "Fontifying" opascal-fontifying-progress-step))
+ (opascal-progress-done)))))
+
+(defun opascal-after-change (change-start change-end _old-length)
+ ;; Called when the buffer has changed. Reparses the changed region.
+ (unless opascal--ignore-changes
+ (let ((opascal--ignore-changes t)) ; Prevent recursive calls.
+ (opascal-save-excursion
+ (opascal-progress-start)
+ ;; Reparse at least from the token previous to the change to the end of
+ ;; line after the change.
+ (opascal-parse-region-until-stable
+ (opascal-token-start (opascal-token-at (1- change-start)))
+ (progn (goto-char change-end) (end-of-line) (point)))
+ (opascal-progress-done)))))
+
+(defun opascal-group-start (from-token)
+ ;; Returns the token that denotes the start of the ()/[] group.
+ (let ((token (opascal-previous-token from-token))
+ (token-kind nil))
+ (catch 'done
+ (while token
+ (setq token-kind (opascal-token-kind token))
+ (cond
+ ;; Skip over nested groups.
+ ((eq 'close-group token-kind) (setq token (opascal-group-start token)))
+ ((eq 'open-group token-kind) (throw 'done token)))
+ (setq token (opascal-previous-token token)))
+ ;; Start not found.
+ nil)))
+
+(defun opascal-group-end (from-token)
+ ;; Returns the token that denotes the end of the ()/[] group.
+ (let ((token (opascal-next-token from-token))
+ (token-kind nil))
+ (catch 'done
+ (while token
+ (setq token-kind (opascal-token-kind token))
+ (cond
+ ;; Skip over nested groups.
+ ((eq 'open-group token-kind) (setq token (opascal-group-end token)))
+ ((eq 'close-group token-kind) (throw 'done token)))
+ (setq token (opascal-next-token token)))
+ ;; end not found.
+ nil)))
+
+(defun opascal-indent-of (token &optional offset)
+ ;; Returns the start column of the token, plus any offset.
+ (let ((indent (+ (opascal-column-of (opascal-token-start token))
+ (if offset offset 0))))
+ (when opascal-debug
+ (opascal-debug-log
+ (concat "\n Indent of: %S %S"
+ "\n column: %d indent: %d offset: %d")
+ token (opascal-token-string token)
+ (opascal-column-of (opascal-token-start token))
+ indent (if offset offset 0)))
+ indent))
+
+(defun opascal-line-indent-of (from-token &optional offset &rest terminators)
+ ;; Returns the column of first non-space character on the token's line, plus
+ ;; any offset. We also stop if one of the terminators or an open ( or [ is
+ ;; encountered.
+ (let ((token (opascal-previous-token from-token))
+ (last-token from-token)
+ (kind nil))
+ (catch 'done
+ (while token
+ (setq kind (opascal-token-kind token))
+ (cond
+ ;; Skip over ()/[] groups.
+ ((eq 'close-group kind) (setq token (opascal-group-start token)))
+
+ ;; Stop at the beginning of the line or an open group.
+ ((opascal-is kind '(newline open-group)) (throw 'done nil))
+
+ ;; Stop at one of the specified terminators.
+ ((opascal-is kind terminators) (throw 'done nil)))
+ (unless (opascal-is kind opascal-whitespace) (setq last-token token))
+ (setq token (opascal-previous-token token))))
+ (opascal-indent-of last-token offset)))
+
+(defun opascal-stmt-line-indent-of (from-token &optional offset)
+ ;; Like `opascal-line-indent-of' except is also stops on a use clause, and
+ ;; colons that precede statements (i.e. case labels).
+ (let ((token (opascal-previous-token from-token))
+ (last-token from-token)
+ (kind nil))
+ (catch 'done
+ (while token
+ (setq kind (opascal-token-kind token))
+ (cond
+ ((and (eq 'colon kind)
+ (opascal-is (opascal-token-kind last-token)
+ `(,@opascal-block-statements
+ ,@opascal-expr-statements)))
+ ;; We hit a label followed by a statement. Indent to the statement.
+ (throw 'done nil))
+
+ ;; Skip over ()/[] groups.
+ ((eq 'close-group kind) (setq token (opascal-group-start token)))
+
+ ((opascal-is kind `(newline open-group ,@opascal-use-clauses))
+ ;; Stop at the beginning of the line, an open group, or a use clause
+ (throw 'done nil)))
+ (unless (opascal-is kind opascal-whitespace) (setq last-token token))
+ (setq token (opascal-previous-token token))))
+ (opascal-indent-of last-token offset)))
+
+(defun opascal-open-group-indent (token last-token &optional offset)
+ ;; Returns the indent relative to an unmatched ( or [.
+ (when (eq 'open-group (opascal-token-kind token))
+ (if last-token
+ (opascal-indent-of last-token offset)
+ ;; There is nothing following the ( or [. Indent from its line.
+ (opascal-stmt-line-indent-of token opascal-indent-level))))
+
+(defun opascal-composite-type-start (token last-token)
+ ;; Returns true (actually the last-token) if the pair equals (= class), (=
+ ;; dispinterface), (= interface), (= object), or (= record), and nil
+ ;; otherwise.
+ (if (and (eq 'equals (opascal-token-kind token))
+ (opascal-is (opascal-token-kind last-token) opascal-composite-types))
+ last-token))
+
+(defun opascal-is-simple-class-type (at-token limit-token)
+ ;; True if at-token is the start of a simple class type. E.g.
+ ;; class of TClass;
+ ;; class (TBaseClass);
+ ;; class;
+ (when (opascal-is (opascal-token-kind at-token) opascal-class-types)
+ (catch 'done
+ ;; Scan until the semi colon.
+ (let ((token (opascal-next-token at-token))
+ (token-kind nil)
+ (limit (opascal-token-start limit-token)))
+ (while (and token (<= (opascal-token-start token) limit))
+ (setq token-kind (opascal-token-kind token))
+ (cond
+ ;; A semicolon delimits the search.
+ ((eq 'semicolon token-kind) (throw 'done token))
+
+ ;; Skip over the inheritance list.
+ ((eq 'open-group token-kind) (setq token (opascal-group-end token)))
+
+ ;; Only allow "of" and whitespace, and an identifier
+ ((opascal-is token-kind `(of word ,@opascal-whitespace)))
+
+ ;; Otherwise we are not in a simple class declaration.
+ ((throw 'done nil)))
+ (setq token (opascal-next-token token)))))))
+
+(defun opascal-block-start (from-token &optional stop-on-class)
+ ;; Returns the token that denotes the start of the block.
+ (let ((token (opascal-previous-token from-token))
+ (last-token nil)
+ (token-kind nil))
+ (catch 'done
+ (while token
+ (setq token-kind (opascal-token-kind token))
+ (cond
+ ;; Skip over nested blocks.
+ ((opascal-is token-kind opascal-end-block-statements)
+ (setq token (opascal-block-start token)))
+
+ ;; Regular block start found.
+ ((opascal-is token-kind opascal-block-statements)
+ (throw 'done
+ ;; As a special case, when a "case" block appears
+ ;; within a record declaration (to denote a variant
+ ;; part), the record declaration should be considered
+ ;; the enclosing block.
+ (if (eq 'case token-kind)
+ (let ((enclosing-token
+ (opascal-block-start token
+ 'stop-on-class)))
+ (if
+ (eq 'record
+ (opascal-token-kind enclosing-token))
+ (if stop-on-class
+ enclosing-token
+ (opascal-previous-token enclosing-token))
+ token))
+ token)))
+
+ ;; A class/record start also begins a block.
+ ((opascal-composite-type-start token last-token)
+ (throw 'done (if stop-on-class last-token token)))
+ )
+ (unless (opascal-is token-kind opascal-whitespace)
+ (setq last-token token))
+ (setq token (opascal-previous-token token)))
+ ;; Start not found.
+ nil)))
+
+(defun opascal-else-start (from-else)
+ ;; Returns the token of the if or case statement.
+ (let ((token (opascal-previous-token from-else))
+ (token-kind nil)
+ (semicolon-count 0))
+ (catch 'done
+ (while token
+ (setq token-kind (opascal-token-kind token))
+ (cond
+ ;; Skip over nested groups.
+ ((eq 'close-group token-kind) (setq token (opascal-group-start token)))
+
+ ;; Skip over any nested blocks.
+ ((opascal-is token-kind opascal-end-block-statements)
+ (setq token (opascal-block-start token)))
+
+ ((eq 'semicolon token-kind)
+ ;; Semicolon means we are looking for an enclosing if, unless we
+ ;; are in a case statement. Keep counts of the semicolons and decide
+ ;; later.
+ (setq semicolon-count (1+ semicolon-count)))
+
+ ((and (eq 'if token-kind) (= semicolon-count 0))
+ ;; We only can match an if when there have been no intervening
+ ;; semicolons.
+ (throw 'done token))
+
+ ((eq 'case token-kind)
+ ;; We have hit a case statement start.
+ (throw 'done token)))
+ (setq token (opascal-previous-token token)))
+ ;; No if or case statement found.
+ nil)))
+
+(defun opascal-comment-content-start (comment)
+ ;; Returns the point of the first non-space character in the comment.
+ (let ((kind (opascal-token-kind comment)))
+ (when (opascal-is kind opascal-comments)
+ (opascal-save-excursion
+ (goto-char (+ (opascal-token-start comment)
+ (length (opascal-literal-start-pattern kind))))
+ (skip-chars-forward opascal-space-chars)
+ (point)))))
+
+(defun opascal-comment-block-start (comment)
+ ;; Returns the starting comment token of a contiguous // comment block. If
+ ;; the comment is multiline (i.e. {...} or (*...*)), the original comment is
+ ;; returned.
+ (if (not (eq 'comment-single-line (opascal-token-kind comment)))
+ comment
+ ;; Scan until we run out of // comments.
+ (let ((prev-comment comment)
+ (start-comment comment))
+ (while (let ((kind (opascal-token-kind prev-comment)))
+ (cond ((eq kind 'space))
+ ((eq kind 'comment-single-line)
+ (setq start-comment prev-comment))
+ (t nil)))
+ (setq prev-comment (opascal-previous-token prev-comment)))
+ start-comment)))
+
+(defun opascal-comment-block-end (comment)
+ ;; Returns the end comment token of a contiguous // comment block. If the
+ ;; comment is multiline (i.e. {...} or (*...*)), the original comment is
+ ;; returned.
+ (if (not (eq 'comment-single-line (opascal-token-kind comment)))
+ comment
+ ;; Scan until we run out of // comments.
+ (let ((next-comment comment)
+ (end-comment comment))
+ (while (let ((kind (opascal-token-kind next-comment)))
+ (cond ((eq kind 'space))
+ ((eq kind 'comment-single-line)
+ (setq end-comment next-comment))
+ (t nil)))
+ (setq next-comment (opascal-next-token next-comment)))
+ end-comment)))
+
+(defun opascal-on-first-comment-line (comment)
+ ;; Returns true if the current point is on the first line of the comment.
+ (save-excursion
+ (let ((comment-start (opascal-token-start comment))
+ (current-point (point)))
+ (goto-char comment-start)
+ (end-of-line)
+ (and (<= comment-start current-point) (<= current-point (point))))))
+
+(defun opascal-comment-indent-of (comment)
+ ;; Returns the correct indentation for the comment.
+ (let ((start-comment (opascal-comment-block-start comment)))
+ (if (and (eq start-comment comment)
+ (opascal-on-first-comment-line comment))
+ ;; Indent as a statement.
+ (opascal-enclosing-indent-of comment)
+ (save-excursion
+ (let ((kind (opascal-token-kind comment)))
+ (beginning-of-line)
+ (cond ((eq 'comment-single-line kind)
+ ;; Indent to the first comment in the // block.
+ (opascal-indent-of start-comment))
+
+ ((looking-at (concat opascal-leading-spaces-re
+ (opascal-literal-stop-pattern kind)))
+ ;; Indent multi-line comment terminators to the comment start.
+ (opascal-indent-of comment))
+
+ ;; Indent according to the comment's content start.
+ ((opascal-column-of (opascal-comment-content-start comment)))))))
+ ))
+
+(defun opascal-is-use-clause-end (at-token last-token last-colon from-kind)
+ ;; True if we are after the end of a uses type clause.
+ (when (and last-token
+ (not last-colon)
+ (eq 'comma (opascal-token-kind at-token))
+ (eq 'semicolon from-kind))
+ ;; Scan for the uses statement, just to be sure.
+ (let ((token (opascal-previous-token at-token))
+ (token-kind nil))
+ (catch 'done
+ (while token
+ (setq token-kind (opascal-token-kind token))
+ (cond ((opascal-is token-kind opascal-use-clauses)
+ (throw 'done t))
+
+ ;; Whitespace, identifiers, strings, "in" keyword, and commas
+ ;; are allowed in use clauses.
+ ((or (opascal-is token-kind '(word comma in newline))
+ (opascal-is token-kind opascal-whitespace)
+ (opascal-is token-kind opascal-strings)))
+
+ ;; Nothing else is.
+ ((throw 'done nil)))
+ (setq token (opascal-previous-token token)))
+ nil))))
+
+(defun opascal-is-block-after-expr-statement (token)
+ ;; Returns true if we have a block token trailing an expression delimiter (of
+ ;; presumably an expression statement).
+ (when (opascal-is (opascal-token-kind token) opascal-block-statements)
+ (let ((previous (opascal-previous-token token))
+ (previous-kind nil))
+ (while (progn
+ (setq previous-kind (opascal-token-kind previous))
+ (eq previous-kind 'space))
+ (setq previous (opascal-previous-token previous)))
+ (or (opascal-is previous-kind opascal-expr-delimiters)
+ (eq previous-kind 'else)))))
+
+(defun opascal-previous-indent-of (from-token)
+ ;; Returns the indentation of the previous statement of the token.
+ (let ((token (opascal-previous-token from-token))
+ (token-kind nil)
+ (from-kind (opascal-token-kind from-token))
+ (last-colon nil)
+ (last-of nil)
+ (last-token nil))
+ (catch 'done
+ (while token
+ (setq token-kind (opascal-token-kind token))
+ (cond
+ ;; An open ( or [ always is an indent point.
+ ((eq 'open-group token-kind)
+ (throw 'done (opascal-open-group-indent token last-token)))
+
+ ;; Skip over any ()/[] groups.
+ ((eq 'close-group token-kind) (setq token (opascal-group-start token)))
+
+ ((opascal-is token-kind opascal-end-block-statements)
+ (if (eq 'newline (opascal-token-kind (opascal-previous-token token)))
+ ;; We can stop at an end token that is right up against the
+ ;; margin.
+ (throw 'done 0)
+ ;; Otherwise, skip over any nested blocks.
+ (setq token (opascal-block-start token))))
+
+ ;; Special case: if we encounter a ", word;" then we assume that we
+ ;; are in some kind of uses clause, and thus indent to column 0. This
+ ;; works because no other constructs are known to have that form.
+ ;; This fixes the irritating case of having indents after a uses
+ ;; clause look like:
+ ;; uses
+ ;; someUnit,
+ ;; someOtherUnit;
+ ;; // this should be at column 0!
+ ((opascal-is-use-clause-end token last-token last-colon from-kind)
+ (throw 'done 0))
+
+ ;; A previous terminator means we can stop. If we are on a directive,
+ ;; however, then we are not actually encountering a new statement.
+ ((and last-token
+ (opascal-is token-kind opascal-previous-terminators)
+ (not (opascal-is (opascal-token-kind last-token)
+ opascal-directives)))
+ (throw 'done (opascal-stmt-line-indent-of last-token 0)))
+
+ ;; Ignore whitespace.
+ ((opascal-is token-kind opascal-whitespace))
+
+ ;; Remember any "of" we encounter, since that affects how we
+ ;; indent to a case statement within a record declaration
+ ;; (i.e. a variant part).
+ ((eq 'of token-kind)
+ (setq last-of token))
+
+ ;; Remember any ':' we encounter (until we reach an "of"),
+ ;; since that affects how we indent to case statements in
+ ;; general.
+ ((eq 'colon token-kind)
+ (unless last-of (setq last-colon token)))
+
+ ;; A case statement delimits a previous statement. We indent labels
+ ;; specially.
+ ((eq 'case token-kind)
+ (throw 'done
+ (if last-colon (opascal-line-indent-of last-colon)
+ (opascal-line-indent-of token opascal-case-label-indent))))
+
+ ;; If we are in a use clause then commas mark an enclosing rather than
+ ;; a previous statement.
+ ((opascal-is token-kind opascal-use-clauses)
+ (throw 'done
+ (if (eq 'comma from-kind)
+ (if last-token
+ ;; Indent to first unit in use clause.
+ (opascal-indent-of last-token)
+ ;; Indent from use clause keyword.
+ (opascal-line-indent-of token opascal-indent-level))
+ ;; Indent to use clause keyword.
+ (opascal-line-indent-of token))))
+
+ ;; Assembly sections always indent in from the asm keyword.
+ ((eq token-kind 'asm)
+ (throw 'done (opascal-stmt-line-indent-of token opascal-indent-level)))
+
+ ;; An enclosing statement delimits a previous statement.
+ ;; We try to use the existing indent of the previous statement,
+ ;; otherwise we calculate from the enclosing statement.
+ ((opascal-is token-kind opascal-previous-enclosing-statements)
+ (throw 'done (if last-token
+ ;; Otherwise indent to the last token
+ (opascal-line-indent-of last-token)
+ ;; Just indent from the enclosing keyword
+ (opascal-line-indent-of token opascal-indent-level))))
+
+ ;; A class or record declaration also delimits a previous statement.
+ ((opascal-composite-type-start token last-token)
+ (throw
+ 'done
+ (if (opascal-is-simple-class-type last-token from-token)
+ ;; c = class; or c = class of T; are previous statements.
+ (opascal-line-indent-of token)
+ ;; Otherwise c = class ... or r = record ... are enclosing
+ ;; statements.
+ (opascal-line-indent-of last-token opascal-indent-level))))
+
+ ;; We have a definite previous statement delimiter.
+ ((opascal-is token-kind opascal-previous-statements)
+ (throw 'done (opascal-stmt-line-indent-of token 0)))
+ )
+ (unless (opascal-is token-kind opascal-whitespace)
+ (setq last-token token))
+ (setq token (opascal-previous-token token)))
+ ;; We ran out of tokens. Indent to column 0.
+ 0)))
+
+(defun opascal-section-indent-of (section-token)
+ ;; Returns the indentation appropriate for begin/var/const/type/label
+ ;; tokens.
+ (let* ((token (opascal-previous-token section-token))
+ (token-kind nil)
+ (last-token nil)
+ (nested-block-count 0)
+ (expr-delimited nil)
+ (last-terminator nil))
+ (catch 'done
+ (while token
+ (setq token-kind (opascal-token-kind token))
+ (cond
+ ;; Always stop at unmatched ( or [.
+ ((eq token-kind 'open-group)
+ (throw 'done (opascal-open-group-indent token last-token)))
+
+ ;; Skip over any ()/[] groups.
+ ((eq 'close-group token-kind) (setq token (opascal-group-start token)))
+
+ ((opascal-is token-kind opascal-end-block-statements)
+ (if (eq 'newline (opascal-token-kind (opascal-previous-token token)))
+ ;; We can stop at an end token that is right up against the
+ ;; margin.
+ (throw 'done 0)
+ ;; Otherwise, skip over any nested blocks.
+ (setq token (opascal-block-start token)
+ nested-block-count (1+ nested-block-count))))
+
+ ;; Remember if we have encountered any forward routine declarations.
+ ((eq 'forward token-kind)
+ (setq nested-block-count (1+ nested-block-count)))
+
+ ;; Mark the completion of a nested routine traversal.
+ ((and (opascal-is token-kind opascal-routine-statements)
+ (> nested-block-count 0))
+ (setq nested-block-count (1- nested-block-count)))
+
+ ;; Remember if we have encountered any statement terminators.
+ ((eq 'semicolon token-kind) (setq last-terminator token))
+
+ ;; Remember if we have encountered any expression delimiters.
+ ((opascal-is token-kind opascal-expr-delimiters)
+ (setq expr-delimited token))
+
+ ;; Enclosing body statements are delimiting. We indent the compound
+ ;; bodies specially.
+ ((and (not last-terminator)
+ (opascal-is token-kind opascal-body-statements))
+ (throw 'done
+ (opascal-stmt-line-indent-of token opascal-compound-block-indent)))
+
+ ;; An enclosing ":" means a label.
+ ((and (eq 'colon token-kind)
+ (opascal-is (opascal-token-kind section-token)
+ opascal-block-statements)
+ (not last-terminator)
+ (not expr-delimited)
+ (not (eq 'equals (opascal-token-kind last-token))))
+ (throw 'done
+ (opascal-stmt-line-indent-of token opascal-indent-level)))
+
+ ;; Block and mid block tokens are always enclosing
+ ((opascal-is token-kind opascal-begin-enclosing-tokens)
+ (throw 'done
+ (opascal-stmt-line-indent-of token opascal-indent-level)))
+
+ ;; Declaration sections and routines are delimiters, unless they
+ ;; are part of a nested routine.
+ ((and (opascal-is token-kind opascal-decl-delimiters)
+ (= 0 nested-block-count))
+ (throw 'done (opascal-line-indent-of token 0)))
+
+ ;; Unit statements mean we indent right to the left.
+ ((opascal-is token-kind opascal-unit-statements) (throw 'done 0))
+ )
+ (unless (opascal-is token-kind opascal-whitespace)
+ (setq last-token token))
+ (setq token (opascal-previous-token token)))
+ ;; We ran out of tokens. Indent to column 0.
+ 0)))
+
+(defun opascal-enclosing-indent-of (from-token)
+ ;; Returns the indentation offset from the enclosing statement of the token.
+ (let ((token (opascal-previous-token from-token))
+ (from-kind (opascal-token-kind from-token))
+ (token-kind nil)
+ (stmt-start nil)
+ (last-token nil)
+ (equals-encountered nil)
+ (before-equals nil)
+ (expr-delimited nil))
+ (catch 'done
+ (while token
+ (setq token-kind (opascal-token-kind token))
+ (cond
+ ;; An open ( or [ always is an indent point.
+ ((eq 'open-group token-kind)
+ (throw 'done
+ (opascal-open-group-indent
+ token last-token
+ (if (opascal-is from-kind opascal-binary-ops)
+ ;; Keep binary operations aligned with the open group.
+ 0
+ opascal-indent-level))))
+
+ ;; Skip over any ()/[] groups.
+ ((eq 'close-group token-kind) (setq token (opascal-group-start token)))
+
+ ;; Skip over any nested blocks.
+ ((opascal-is token-kind opascal-end-block-statements)
+ (setq token (opascal-block-start token)))
+
+ ;; An expression delimiter affects indentation depending on whether
+ ;; the point is before or after it. Remember that we encountered one.
+ ;; Also remember the last encountered token, since if it exists it
+ ;; should be the actual indent point.
+ ((opascal-is token-kind opascal-expr-delimiters)
+ (setq expr-delimited token stmt-start last-token))
+
+ ;; With a non-delimited expression statement we indent after the
+ ;; statement's keyword, unless we are on the delimiter itself.
+ ((and (not expr-delimited)
+ (opascal-is token-kind opascal-expr-statements))
+ (throw 'done
+ (cond ((opascal-is from-kind opascal-expr-delimiters)
+ ;; We are indenting a delimiter. Indent to the statement.
+ (opascal-stmt-line-indent-of token 0))
+
+ ((and last-token (opascal-is from-kind opascal-binary-ops))
+ ;; Align binary ops with the expression.
+ (opascal-indent-of last-token))
+
+ (last-token
+ ;; Indent in from the expression.
+ (opascal-indent-of last-token opascal-indent-level))
+
+ ;; Indent in from the statement's keyword.
+ ((opascal-indent-of token opascal-indent-level)))))
+
+ ;; A delimited case statement indents the label according to
+ ;; a special rule.
+ ((eq 'case token-kind)
+ (throw 'done
+ (if stmt-start
+ ;; We are not actually indenting to the case statement,
+ ;; but are within a label expression.
+ (opascal-stmt-line-indent-of
+ stmt-start opascal-indent-level)
+ ;; Indent from the case keyword.
+ (opascal-stmt-line-indent-of
+ token opascal-case-label-indent))))
+
+ ;; Body expression statements are enclosing. Indent from the
+ ;; statement's keyword, unless we have a non-block statement following
+ ;; it.
+ ((opascal-is token-kind opascal-body-expr-statements)
+ (throw 'done
+ (opascal-stmt-line-indent-of
+ (or stmt-start token) opascal-indent-level)))
+
+ ;; An else statement is enclosing, but it doesn't have an expression.
+ ;; Thus we take into account last-token instead of stmt-start.
+ ((eq 'else token-kind)
+ (throw 'done (opascal-stmt-line-indent-of
+ (or last-token token) opascal-indent-level)))
+
+ ;; We indent relative to an enclosing declaration section.
+ ((opascal-is token-kind opascal-decl-sections)
+ (throw 'done (opascal-indent-of (if last-token last-token token)
+ opascal-indent-level)))
+
+ ;; In unit sections we indent right to the left.
+ ((opascal-is token-kind opascal-unit-sections)
+ (throw 'done
+ ;; Handle specially the case of "interface", which can be used
+ ;; to start either a unit section or an interface definition.
+ (if (opascal-is token-kind opascal-interface-types)
+ (progn
+ ;; Find the previous non-whitespace token.
+ (while (progn
+ (setq last-token token
+ token (opascal-previous-token token)
+ token-kind (opascal-token-kind token))
+ (and token
+ (opascal-is token-kind
+ opascal-whitespace))))
+ ;; If this token is an equals sign, "interface" is being
+ ;; used to start an interface definition and we should
+ ;; treat it as a composite type; otherwise, we should
+ ;; consider it the start of a unit section.
+ (if (and token (eq token-kind 'equals))
+ (opascal-line-indent-of last-token
+ opascal-indent-level)
+ 0))
+ 0)))
+
+ ;; A previous terminator means we can stop.
+ ((opascal-is token-kind opascal-previous-terminators)
+ (throw 'done
+ (cond ((and last-token
+ (eq 'comma token-kind)
+ (opascal-is from-kind opascal-binary-ops))
+ ;; Align binary ops with the expression.
+ (opascal-indent-of last-token))
+
+ (last-token
+ ;; Indent in from the expression.
+ (opascal-indent-of last-token opascal-indent-level))
+
+ ;; No enclosing expression; use the previous statement's
+ ;; indent.
+ ((opascal-previous-indent-of token)))))
+
+ ;; A block statement after an expression delimiter has its start
+ ;; column as the expression statement. E.g.
+ ;; if (a = b)
+ ;; and (a != c) then begin
+ ;; //...
+ ;; end;
+ ;; Remember it for when we encounter the expression statement start.
+ ((opascal-is-block-after-expr-statement token)
+ (throw 'done
+ (cond (last-token (opascal-indent-of last-token opascal-indent-level))
+
+ ((+ (opascal-section-indent-of token) opascal-indent-level)))))
+
+ ;; Assembly sections always indent in from the asm keyword.
+ ((eq token-kind 'asm)
+ (throw 'done (opascal-stmt-line-indent-of token opascal-indent-level)))
+
+ ;; Stop at an enclosing statement and indent from it.
+ ((opascal-is token-kind opascal-enclosing-statements)
+ (throw 'done (opascal-stmt-line-indent-of
+ (or last-token token) opascal-indent-level)))
+
+ ;; A class/record declaration is also enclosing.
+ ((opascal-composite-type-start token last-token)
+ (throw 'done
+ (opascal-line-indent-of last-token opascal-indent-level)))
+
+ ;; A ":" we indent relative to its line beginning. If we are in a
+ ;; parameter list, then stop also if we hit a ";".
+ ((and (eq token-kind 'colon)
+ (not expr-delimited)
+ (not (opascal-is from-kind opascal-expr-delimiters))
+ (not equals-encountered)
+ (not (eq from-kind 'equals)))
+ (throw 'done
+ (if last-token
+ (opascal-indent-of last-token opascal-indent-level)
+ (opascal-line-indent-of token opascal-indent-level 'semicolon))))
+
+ ;; If the ":" was not processed above and we have token after the "=",
+ ;; then indent from the "=". Ignore :=, however.
+ ((and (eq token-kind 'colon) equals-encountered before-equals)
+ (cond
+ ;; Ignore binary ops for now. It would do, for example:
+ ;; val := 1 + 2
+ ;; + 3;
+ ;; which is good, but also
+ ;; val := Foo
+ ;; (foo, args)
+ ;; + 2;
+ ;; which doesn't look right.
+ ;;;; Align binary ops with the before token.
+ ;;((opascal-is from-kind opascal-binary-ops)
+ ;;(throw 'done (opascal-indent-of before-equals 0)))
+
+ ;; Assignments (:=) we skip over to get a normal indent.
+ ((eq (opascal-token-kind last-token) 'equals))
+
+ ;; Otherwise indent in from the equals.
+ ((throw 'done
+ (opascal-indent-of before-equals opascal-indent-level)))))
+
+ ;; Remember any "=" we encounter if it has not already been processed.
+ ((eq token-kind 'equals)
+ (setq equals-encountered token
+ before-equals last-token))
+ )
+ (unless (opascal-is token-kind opascal-whitespace)
+ (setq last-token token))
+ (setq token (opascal-previous-token token)))
+ ;; We ran out of tokens. Indent to column 0.
+ 0)))
+
+(defun opascal-corrected-indentation ()
+ ;; Returns the corrected indentation for the current line.
+ (opascal-save-excursion
+ (opascal-progress-start)
+ ;; Move to the first token on the line.
+ (beginning-of-line)
+ (skip-chars-forward opascal-space-chars)
+ (let* ((token (opascal-current-token))
+ (token-kind (opascal-token-kind token))
+ (indent
+ (cond ((eq 'close-group token-kind)
+ ;; Indent to the matching start ( or [.
+ (opascal-indent-of (opascal-group-start token)))
+
+ ((opascal-is token-kind opascal-unit-statements) 0)
+
+ ((opascal-is token-kind opascal-comments)
+ ;; In a comment.
+ (opascal-comment-indent-of token))
+
+ ((opascal-is token-kind opascal-decl-matchers)
+ ;; Use a previous section/routine's indent.
+ (opascal-section-indent-of token))
+
+ ((opascal-is token-kind opascal-match-block-statements)
+ ;; Use the block's indentation.
+ (let ((block-start
+ (opascal-block-start token 'stop-on-class)))
+ (cond
+ ;; When trailing a body statement, indent to
+ ;; the statement's keyword.
+ ((opascal-is-block-after-expr-statement block-start)
+ (opascal-section-indent-of block-start))
+
+ ;; Otherwise just indent to the block start.
+ ((opascal-stmt-line-indent-of block-start 0)))))
+
+ ((eq 'else token-kind)
+ ;; Find the start of the if or case statement.
+ (opascal-stmt-line-indent-of (opascal-else-start token) 0))
+
+ ;; Otherwise indent in from enclosing statement.
+ ((opascal-enclosing-indent-of
+ (if token token (opascal-token-at (1- (point)))))))))
+ (opascal-progress-done)
+ indent)))
+
+(defun opascal-indent-line ()
+ "Indent the current line according to the current language construct.
+If before the indent, the point is moved to the indent."
+ (interactive)
+ (save-match-data
+ (let ((marked-point (point-marker)) ; Maintain our position reliably.
+ (line-start nil)
+ (old-indent 0)
+ (new-indent 0))
+ (beginning-of-line)
+ (setq line-start (point))
+ (skip-chars-forward opascal-space-chars)
+ (setq old-indent (current-column))
+ (setq new-indent (opascal-corrected-indentation))
+ (if (< marked-point (point))
+ ;; If before the indent column, then move to it.
+ (set-marker marked-point (point)))
+ ;; Advance our marked point after inserted spaces.
+ (set-marker-insertion-type marked-point t)
+ (when (/= old-indent new-indent)
+ (delete-region line-start (point))
+ (insert (make-string new-indent ?\s)))
+ (goto-char marked-point)
+ (set-marker marked-point nil))))
+
+(defvar opascal-mode-abbrev-table nil
+ "Abbrev table in use in OPascal mode buffers.")
+(define-abbrev-table 'opascal-mode-abbrev-table ())
+
+(defmacro opascal-ensure-buffer (buffer-var buffer-name)
+ ;; Ensures there exists a buffer of the specified name in the specified
+ ;; variable.
+ `(when (not (buffer-live-p ,buffer-var))
+ (setq ,buffer-var (get-buffer-create ,buffer-name))))
+
+(defun opascal-log-msg (to-buffer the-msg)
+ ;; Writes a message to the end of the specified buffer.
+ (with-current-buffer to-buffer
+ (save-selected-window
+ (switch-to-buffer-other-window to-buffer)
+ (goto-char (point-max))
+ (set-window-point (get-buffer-window to-buffer) (point))
+ (insert the-msg))))
+
+;; Debugging helpers:
+
+(defvar opascal-debug-buffer nil
+ "Buffer to write OPascal mode debug messages to. Created on demand.")
+
+(defun opascal-debug-log (format-string &rest args)
+ ;; Writes a message to the log buffer.
+ (when opascal-debug
+ (opascal-ensure-buffer opascal-debug-buffer "*OPascal Debug Log*")
+ (opascal-log-msg opascal-debug-buffer
+ (concat (format-time-string "%H:%M:%S " (current-time))
+ (apply #'format (cons format-string args))
+ "\n"))))
+
+(defun opascal-debug-token-string (token)
+ (let* ((image (opascal-token-string token))
+ (has-newline (string-match "^\\([^\n]*\\)\n\\(.+\\)?$" image)))
+ (when has-newline
+ (setq image (concat (match-string 1 image)
+ (if (match-beginning 2) "..."))))
+ image))
+
+(defun opascal-debug-show-current-token ()
+ (interactive)
+ (let ((token (opascal-current-token)))
+ (opascal-debug-log "Token: %S %S" token (opascal-debug-token-string token))))
+
+(defun opascal-debug-goto-point (p)
+ (interactive "NGoto char: ")
+ (goto-char p))
+
+(defun opascal-debug-goto-next-token ()
+ (interactive)
+ (goto-char (opascal-token-start (opascal-next-token (opascal-current-token)))))
+
+(defun opascal-debug-goto-previous-token ()
+ (interactive)
+ (goto-char
+ (opascal-token-start (opascal-previous-token (opascal-current-token)))))
+
+(defun opascal-debug-show-current-string (from to)
+ (interactive "r")
+ (opascal-debug-log "String: %S" (buffer-substring from to)))
+
+(defun opascal-debug-show-is-stable ()
+ (interactive)
+ (opascal-debug-log "stable: %S prev: %S next: %S"
+ (opascal-is-stable-literal (point))
+ (opascal-literal-kind (1- (point)))
+ (opascal-literal-kind (point))))
+
+(defun opascal-debug-unparse-buffer ()
+ (interactive)
+ (opascal-set-text-properties (point-min) (point-max) nil))
+
+(defun opascal-debug-parse-region (from to)
+ (interactive "r")
+ (let ((opascal-verbose t))
+ (opascal-save-excursion
+ (opascal-progress-start)
+ (opascal-parse-region from to)
+ (opascal-progress-done "Parsing done"))))
+
+(defun opascal-debug-parse-window ()
+ (interactive)
+ (opascal-debug-parse-region (window-start) (window-end)))
+
+(defun opascal-debug-parse-buffer ()
+ (interactive)
+ (opascal-debug-parse-region (point-min) (point-max)))
+
+(defun opascal-debug-fontify-window ()
+ (interactive)
+ (opascal-fontify-region (window-start) (window-end) t))
+
+(defun opascal-debug-fontify-buffer ()
+ (interactive)
+ (opascal-fontify-region (point-min) (point-max) t))
+
+(defun opascal-debug-tokenize-region (from to)
+ (interactive)
+ (opascal-save-excursion
+ (opascal-progress-start)
+ (goto-char from)
+ (while (< (point) to)
+ (goto-char (opascal-token-end (opascal-current-token)))
+ (opascal-step-progress (point) "Tokenizing" opascal-scanning-progress-step))
+ (opascal-progress-done "Tokenizing done")))
+
+(defun opascal-debug-tokenize-buffer ()
+ (interactive)
+ (opascal-debug-tokenize-region (point-min) (point-max)))
+
+(defun opascal-debug-tokenize-window ()
+ (interactive)
+ (opascal-debug-tokenize-region (window-start) (window-end)))
+
+
+(defun opascal-tab ()
+ "Indent the region, when Transient Mark mode is enabled and the region is
+active. Otherwise, indent the current line or insert a TAB, depending on the
+value of `opascal-tab-always-indents' and the current line position."
+ (interactive)
+ (cond ((use-region-p)
+ ;; If Transient Mark mode is enabled and the region is active, indent
+ ;; the entire region.
+ (indent-region (region-beginning) (region-end)))
+ ((or opascal-tab-always-indents
+ (save-excursion (skip-chars-backward opascal-space-chars) (bolp)))
+ ;; Otherwise, if we are configured always to indent (regardless of the
+ ;; point's position in the line) or we are before the first non-space
+ ;; character on the line, indent the line.
+ (opascal-indent-line))
+ (t
+ ;; Otherwise, insert a tab character.
+ (insert "\t"))))
+
+
+(defun opascal-is-directory (path)
+ ;; True if the specified path is an existing directory.
+ (let ((attributes (file-attributes path)))
+ (and attributes (car attributes))))
+
+(defun opascal-is-file (path)
+ ;; True if the specified file exists as a file.
+ (let ((attributes (file-attributes path)))
+ (and attributes (null (car attributes)))))
+
+(defun opascal-search-directory (unit dir &optional recurse)
+ ;; Searches for the unit in the specified directory. If recurse is true, then
+ ;; the directory is recursively searched. File name comparison is done in a
+ ;; case insensitive manner.
+ (when (opascal-is-directory dir)
+ (let ((files (directory-files dir))
+ (unit-file (downcase unit)))
+ (catch 'done
+ ;; Search for the file.
+ (dolist (file files)
+ (let ((path (concat dir "/" file)))
+ (if (and (string= unit-file (downcase file))
+ (opascal-is-file path))
+ (throw 'done path))))
+
+ ;; Not found. Search subdirectories.
+ (when recurse
+ (dolist (subdir files)
+ (unless (member subdir '("." ".."))
+ (let ((path (opascal-search-directory
+ unit (concat dir "/" subdir) recurse)))
+ (if path (throw 'done path))))))
+
+ ;; Not found.
+ nil))))
+
+
+(defun opascal-find-unit-in-directory (unit dir)
+ ;; Searches for the unit in the specified directory. If the directory ends
+ ;; in \"...\", then it is recursively searched.
+ (let ((dir-name dir)
+ (recurse nil))
+ ;; Check if we need to recursively search the directory.
+ (if (string-match "^\\(.+\\)\\.\\.\\.$" dir-name)
+ (setq dir-name (match-string 1 dir-name)
+ recurse t))
+ ;; Ensure the trailing slash is removed.
+ (if (string-match "^\\(.+\\)[\\\\/]$" dir-name)
+ (setq dir-name (match-string 1 dir-name)))
+ (opascal-search-directory unit dir-name recurse)))
+
+(defun opascal-find-unit-file (unit)
+ ;; Finds the specified opascal source file according to `opascal-search-path'.
+ ;; If found, the full path is returned, otherwise nil is returned.
+ (catch 'done
+ (cond ((null opascal-search-path)
+ (opascal-find-unit-in-directory unit "."))
+
+ ((stringp opascal-search-path)
+ (opascal-find-unit-in-directory unit opascal-search-path))
+
+ ((dolist (dir opascal-search-path)
+ (let ((file (opascal-find-unit-in-directory unit dir)))
+ (if file (throw 'done file))))))
+ nil))
+
+(defun opascal-find-unit (unit)
+ "Find the specified OPascal source file according to `opascal-search-path'.
+If no extension is specified, .pas is assumed. Creates a buffer for the unit."
+ (interactive "sOPascal unit name: ")
+ (let* ((unit-file (if (string-match "^\\(.*\\)\\.[a-z]+$" unit)
+ unit
+ (concat unit ".pas")))
+ (file (opascal-find-unit-file unit-file)))
+ (if (null file)
+ (error "unit not found: %s" unit-file)
+ (find-file file)
+ (if (not (derived-mode-p 'opascal-mode))
+ (opascal-mode)))
+ file))
+
+(defun opascal-find-current-def ()
+ "Find the definition of the identifier under the current point."
+ (interactive)
+ (error "opascal-find-current-def: not implemented yet"))
+
+(defun opascal-find-current-xdef ()
+ "Find the definition of the identifier under the current point, searching
+in external units if necessary (as listed in the current unit's use clause).
+The set of directories to search for a unit is specified by the global variable
+`opascal-search-path'."
+ (interactive)
+ (error "opascal-find-current-xdef: not implemented yet"))
+
+(defun opascal-find-current-body ()
+ "Find the body of the identifier under the current point, assuming
+it is a routine."
+ (interactive)
+ (error "opascal-find-current-body: not implemented yet"))
+
+(defun opascal-fill-comment ()
+ "Fill the text of the current comment, according to `fill-column'.
+An error is raised if not in a comment."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (let* ((comment (opascal-current-token))
+ (comment-kind (opascal-token-kind comment)))
+ (if (not (opascal-is comment-kind opascal-comments))
+ (error "Not in a comment")
+ (let* ((start-comment (opascal-comment-block-start comment))
+ (end-comment (opascal-comment-block-end comment))
+ (comment-start (opascal-token-start start-comment))
+ (comment-end (opascal-token-end end-comment))
+ (content-start (opascal-comment-content-start start-comment))
+ (content-indent (opascal-column-of content-start))
+ (content-prefix (make-string content-indent ?\s))
+ (content-prefix-re opascal-leading-spaces-re)
+ (p nil)
+ (marked-point (point-marker))) ; Maintain our position reliably.
+ (when (eq 'comment-single-line comment-kind)
+ ;; // style comments need more work.
+ (setq content-prefix
+ (let ((comment-indent (opascal-column-of comment-start)))
+ (concat (make-string comment-indent ?\s) "//"
+ (make-string (- content-indent comment-indent 2)
+ ?\s)))
+ content-prefix-re (concat opascal-leading-spaces-re
+ "//"
+ opascal-spaces-re)
+ comment-end (if (opascal-is-literal-end comment-end)
+ ;; Don't include the trailing newline.
+ (1- comment-end)
+ comment-end)))
+
+ ;; Advance our marked point after inserted spaces.
+ (set-marker-insertion-type marked-point t)
+
+ ;; Ensure we can modify the buffer
+ (goto-char content-start)
+ (insert " ")
+ (delete-char -1)
+
+ (narrow-to-region content-start comment-end)
+
+ ;; Strip off the comment prefixes
+ (setq p (point-min))
+ (while (when (< p (point-max))
+ (goto-char p)
+ (re-search-forward content-prefix-re nil t))
+ (replace-match "" nil nil)
+ (setq p (1+ (point))))
+
+ ;; add an extra line to prevent the fill from doing it for us.
+ (goto-char (point-max))
+ (insert "\n")
+
+ ;; Fill the comment contents.
+ (let ((fill-column (- fill-column content-indent)))
+ (fill-region (point-min) (point-max)))
+
+ (goto-char (point-max))
+ (delete-char -1)
+
+ ;; Restore comment prefixes.
+ (goto-char (point-min))
+ (end-of-line) ; Don't reset the first line.
+ (setq p (point))
+ (while (when (< p (point-max))
+ (goto-char p)
+ (re-search-forward "^" nil t))
+ (replace-match content-prefix nil nil)
+ (setq p (1+ (point))))
+
+ (setq comment-end (point-max))
+ (widen)
+
+ ;; Restore our position
+ (goto-char marked-point)
+ (set-marker marked-point nil)
+
+ ;; React to the entire fill change as a whole.
+ (opascal-progress-start)
+ (opascal-parse-region comment-start comment-end)
+ (opascal-progress-done)))))))
+
+(defun opascal-new-comment-line ()
+ "If in a // comment, do a newline, indented such that one is still in the
+comment block. If not in a // comment, just does a normal newline."
+ (interactive)
+ (let ((comment (opascal-current-token)))
+ (if (not (eq 'comment-single-line (opascal-token-kind comment)))
+ ;; Not in a // comment. Just do the normal newline.
+ (newline)
+ (let* ((start-comment (opascal-comment-block-start comment))
+ (comment-start (opascal-token-start start-comment))
+ (content-start (opascal-comment-content-start start-comment))
+ (prefix
+ (concat (make-string (opascal-column-of comment-start) ?\s) "//"
+ (make-string (- content-start comment-start 2) ?\s))))
+ (delete-horizontal-space)
+ (insert "\n" prefix)))))
+
+(defun opascal-match-token (token limit)
+ ;; Sets the match region used by (match-string 0) and friends to the token's
+ ;; region. Sets the current point to the end of the token (or limit).
+ (set-match-data nil)
+ (if token
+ (let ((end (min (opascal-token-end token) limit)))
+ (set-match-data (list (opascal-token-start token) end))
+ (goto-char end)
+ token)))
+
+(defconst opascal-font-lock-defaults
+ '(nil ; We have our own fontify routine, so keywords don't apply.
+ t ; Syntactic fontification doesn't apply.
+ nil ; Don't care about case since we don't use regexps to find tokens.
+ nil ; Syntax alists don't apply.
+ nil ; Syntax begin movement doesn't apply
+ (font-lock-fontify-region-function . opascal-fontify-region)
+ (font-lock-verbose . opascal-fontifying-progress-step))
+ "OPascal mode font-lock defaults. Syntactic fontification is ignored.")
+
+(defvar opascal-debug-mode-map
+ (let ((kmap (make-sparse-keymap)))
+ (dolist (binding '(("n" opascal-debug-goto-next-token)
+ ("p" opascal-debug-goto-previous-token)
+ ("t" opascal-debug-show-current-token)
+ ("T" opascal-debug-tokenize-buffer)
+ ("W" opascal-debug-tokenize-window)
+ ("g" opascal-debug-goto-point)
+ ("s" opascal-debug-show-current-string)
+ ("a" opascal-debug-parse-buffer)
+ ("w" opascal-debug-parse-window)
+ ("f" opascal-debug-fontify-window)
+ ("F" opascal-debug-fontify-buffer)
+ ("r" opascal-debug-parse-region)
+ ("c" opascal-debug-unparse-buffer)
+ ("x" opascal-debug-show-is-stable)))
+ (define-key kmap (car binding) (cadr binding)))
+ kmap)
+ "Keystrokes for OPascal mode debug commands.")
+
+(defvar opascal-mode-map
+ (let ((kmap (make-sparse-keymap)))
+ (dolist (binding
+ (list ;; '("\C-cd" opascal-find-current-def)
+ ;; '("\C-cx" opascal-find-current-xdef)
+ ;; '("\C-cb" opascal-find-current-body)
+ '("\C-cu" opascal-find-unit)
+ '("\M-q" opascal-fill-comment)
+ '("\M-j" opascal-new-comment-line)
+ ;; Debug bindings:
+ (list "\C-c\C-d" opascal-debug-mode-map)))
+ (define-key kmap (car binding) (cadr binding)))
+ kmap)
+ "Keymap used in OPascal mode.")
+
+(define-obsolete-variable-alias 'delphi-mode-hook 'opascal-mode-hook "24.4")
+;;;###autoload
+(define-obsolete-function-alias 'delphi-mode 'opascal-mode "24.4")
+;;;###autoload
+(define-derived-mode opascal-mode prog-mode "OPascal"
+ "Major mode for editing OPascal code. \\<opascal-mode-map>
+\\[opascal-find-unit]\t- Search for a OPascal source file.
+\\[opascal-fill-comment]\t- Fill the current comment.
+\\[opascal-new-comment-line]\t- If in a // comment, do a new comment line.
+
+\\[indent-region] also works for indenting a whole region.
+
+Customization:
+
+ `opascal-indent-level' (default 3)
+ Indentation of OPascal statements with respect to containing block.
+ `opascal-compound-block-indent' (default 0)
+ Extra indentation for blocks in compound statements.
+ `opascal-case-label-indent' (default 0)
+ Extra indentation for case statement labels.
+ `opascal-tab-always-indents' (default `tab-always-indents')
+ Non-nil means TAB in OPascal mode should always reindent the current line,
+ regardless of where in the line point is when the TAB command is used.
+ `opascal-search-path' (default .)
+ Directories to search when finding external units.
+ `opascal-verbose' (default nil)
+ If true then OPascal token processing progress is reported to the user.
+
+Coloring:
+
+ `opascal-comment-face' (default font-lock-comment-face)
+ Face used to color OPascal comments.
+ `opascal-string-face' (default font-lock-string-face)
+ Face used to color OPascal strings.
+ `opascal-keyword-face' (default font-lock-keyword-face)
+ Face used to color OPascal keywords.
+ `opascal-other-face' (default nil)
+ Face used to color everything else.
+
+Turning on OPascal mode calls the value of the variable `opascal-mode-hook'
+with no args, if that value is non-nil."
+
+ ;; Buffer locals:
+ (setq-local indent-line-function #'opascal-indent-line)
+ (setq-local comment-indent-function #'opascal-indent-line)
+ (setq-local case-fold-search t)
+ (setq-local opascal-progress-last-reported-point nil)
+ (setq-local opascal--ignore-changes nil)
+ (setq-local font-lock-defaults opascal-font-lock-defaults)
+ (setq-local tab-always-indent opascal-tab-always-indents)
+
+ ;; FIXME: Use syntax-propertize-function to tokenize, maybe?
+
+ ;; We need to keep track of changes to the buffer to determine if we need
+ ;; to retokenize changed text.
+ (add-hook 'after-change-functions #'opascal-after-change nil t)
+
+ (opascal-save-excursion
+ (let ((opascal-verbose t))
+ (opascal-progress-start)
+ (opascal-parse-region (point-min) (point-max))
+ (opascal-progress-done))))
+
+(provide 'opascal)
+;;; opascal.el ends here
{$gnu-pascal,I+}
+// Free-pascal style comment.
+
program CRTDemo;
uses GPC, CRT;
projects / emacs.git / commitdiff