1 ;;; opascal.el --- major mode for editing Object Pascal source in Emacs -*- lexical-binding: t -*-
3 ;; Copyright (C) 1998-1999, 2001-2013 Free Software Foundation, Inc.
5 ;; Authors: Ray Blaak <blaak@infomatch.com>,
6 ;; Simon South <ssouth@member.fsf.org>
7 ;; Maintainer: Simon South <ssouth@member.fsf.org>
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;; To enter OPascal mode when you find an Object Pascal source file, one must
28 ;; override the auto-mode-alist to associate OPascal with .pas (and .dpr and
29 ;; .dpk) files. Emacs, by default, will otherwise enter Pascal mode. E.g.
31 ;; (autoload 'opascal-mode "opascal")
32 ;; (add-to-list 'auto-mode-alist
33 ;; '("\\.\\(pas\\|dpr\\|dpk\\)\\'" . opascal-mode))
35 ;; When you have entered OPascal mode, you may get more info by pressing
38 ;; This OPascal mode implementation is fairly tolerant of syntax errors,
39 ;; relying as much as possible on the indentation of the previous statement.
40 ;; This also makes it faster and simpler, since there is less searching for
41 ;; properly constructed beginnings.
46 "Major mode for editing OPascal source in Emacs."
50 (defconst opascal-debug nil
51 "True if in debug mode.")
53 (define-obsolete-variable-alias
54 'delphi-search-path
'opascal-search-path
"24.4")
55 (defcustom opascal-search-path
"."
56 "Directories to search when finding external units.
57 It is a list of directory strings. If only a single directory,
58 it can be a single string instead of a list. If a directory
59 ends in \"...\" then that directory is recursively searched."
62 (define-obsolete-variable-alias
63 'delphi-indent-level
'opascal-indent-level
"24.4")
64 (defcustom opascal-indent-level
3
65 "Indentation of OPascal statements with respect to containing block.
69 // This is an indent of 3.
73 (define-obsolete-variable-alias
74 'delphi-compound-block-indent
'opascal-compound-block-indent
"24.4")
75 (defcustom opascal-compound-block-indent
0
76 "Extra indentation for blocks in compound statements. E.g.
78 // block indent = 0 vs // block indent = 2
87 (define-obsolete-variable-alias
88 'delphi-case-label-indent
'opascal-case-label-indent
"24.4")
89 (defcustom opascal-case-label-indent opascal-indent-level
90 "Extra indentation for case statement labels. E.g.
92 // case indent = 0 vs // case indent = 3
93 case value of case value of
94 v1: process_v1; v1: process_v1;
95 v2: process_v2; v2: process_v2;
97 process_else; process_else;
101 (define-obsolete-variable-alias 'delphi-verbose
'opascal-verbose
"24.4")
102 (defcustom opascal-verbose t
; nil
103 "If true then OPascal token processing progress is reported to the user."
106 (define-obsolete-variable-alias
107 'delphi-tab-always-indents
'opascal-tab-always-indents
"24.4")
108 (defcustom opascal-tab-always-indents tab-always-indent
109 "Non-nil means TAB in OPascal mode should always reindent the current line,
110 regardless of where in the line point is when the TAB command is used."
113 (define-obsolete-variable-alias
114 'delphi-comment-face
'opascal-comment-face
"24.4")
115 (defcustom opascal-comment-face
'font-lock-comment-face
116 "Face used to color OPascal comments."
119 (define-obsolete-variable-alias
120 'delphi-string-face
'opascal-string-face
"24.4")
121 (defcustom opascal-string-face
'font-lock-string-face
122 "Face used to color OPascal strings."
125 (define-obsolete-variable-alias
126 'delphi-keyword-face
'opascal-keyword-face
"24.4")
127 (defcustom opascal-keyword-face
'font-lock-keyword-face
128 "Face used to color OPascal keywords."
131 (define-obsolete-variable-alias 'delphi-other-face
'opascal-other-face
"24.4")
132 (defcustom opascal-other-face nil
133 "Face used to color everything else."
134 :type
'(choice (const :tag
"None" nil
) face
))
136 (defconst opascal-directives
137 '(absolute abstract assembler automated cdecl default dispid dynamic
138 export external far forward index inline message name near nodefault
139 overload override pascal private protected public published read readonly
140 register reintroduce resident resourcestring safecall stdcall stored
141 virtual write writeonly
)
142 "OPascal4 directives.")
144 (defconst opascal-keywords
147 and array as asm at begin case class const constructor contains
148 destructor dispinterface div do downto else end except exports
149 file finalization finally for function goto if implementation implements
150 in inherited initialization interface is label library mod nil not
151 of object on or out package packed procedure program property
152 raise record repeat requires result self set shl shr then threadvar
153 to try type unit uses until var while with xor
155 ;; These routines should be keywords, if Borland had the balls.
158 ;; We want directives to look like keywords.
160 "OPascal4 keywords.")
162 (defconst opascal-previous-terminators
`(semicolon comma
)
163 "Expression/statement terminators that denote a previous expression.")
165 (defconst opascal-comments
166 '(comment-single-line comment-multi-line-1 comment-multi-line-2
)
167 "Tokens that represent comments.")
169 (defconst opascal-strings
170 '(string double-quoted-string
)
171 "Tokens that represent string literals.")
173 (defconst opascal-whitespace
`(space newline
,@opascal-comments
)
174 "Tokens that are considered whitespace.")
176 (defconst opascal-routine-statements
177 '(procedure function constructor destructor property
)
178 "Marks the start of a routine, or routine-ish looking expression.")
180 (defconst opascal-body-expr-statements
'(if while for on
)
181 "Statements that have either a single statement or a block as a body and also
182 are followed by an expression.")
184 (defconst opascal-expr-statements
`(case ,@opascal-body-expr-statements
)
185 "Expression statements contain expressions after their keyword.")
187 (defconst opascal-body-statements
`(else ,@opascal-body-expr-statements
)
188 "Statements that have either a single statement or a block as a body.")
190 (defconst opascal-expr-delimiters
'(then do of
)
191 "Expression delimiter tokens.")
193 (defconst opascal-binary-ops
194 '(plus minus equals not-equals times divides div mod and or xor
)
195 "OPascal binary operations.")
197 (defconst opascal-visibilities
'(public private protected published automated
)
198 "Class visibilities.")
200 (defconst opascal-block-statements
201 '(begin try case repeat initialization finalization asm
)
202 "Statements that contain multiple substatements.")
204 (defconst opascal-mid-block-statements
205 `(except finally
,@opascal-visibilities
)
206 "Statements that mark mid sections of the enclosing block.")
208 (defconst opascal-end-block-statements
`(end until
)
209 "Statements that end block sections.")
211 (defconst opascal-match-block-statements
212 `(,@opascal-end-block-statements
,@opascal-mid-block-statements
)
213 "Statements that match the indentation of the parent block.")
215 (defconst opascal-decl-sections
'(type const var label resourcestring
)
216 "Denotes the start of a declaration section.")
218 (defconst opascal-interface-types
'(dispinterface interface
)
221 (defconst opascal-class-types
'(class object
)
224 (defconst opascal-composite-types
225 `(,@opascal-class-types
,@opascal-interface-types record
)
226 "Types that contain declarations within them.")
228 (defconst opascal-unit-sections
229 '(interface implementation program library package
)
230 "Unit sections within which the indent is 0.")
232 (defconst opascal-use-clauses
`(uses requires exports contains
)
233 "Statements that refer to foreign symbols.")
235 (defconst opascal-unit-statements
236 `(,@opascal-use-clauses
,@opascal-unit-sections initialization finalization
)
237 "Statements indented at level 0.")
239 (defconst opascal-decl-delimiters
240 `(,@opascal-decl-sections
,@opascal-unit-statements
241 ,@opascal-routine-statements
)
242 "Statements that a declaration statement should align with.")
244 (defconst opascal-decl-matchers
245 `(begin ,@opascal-decl-sections
)
246 "Statements that should match to declaration statement indentation.")
248 (defconst opascal-enclosing-statements
249 `(,@opascal-block-statements
,@opascal-mid-block-statements
250 ,@opascal-decl-sections
,@opascal-use-clauses
,@opascal-routine-statements
)
251 "Delimits an enclosing statement.")
253 (defconst opascal-previous-statements
254 `(,@opascal-unit-statements
,@opascal-routine-statements
)
255 "Delimits a previous statement.")
257 (defconst opascal-previous-enclosing-statements
258 `(,@opascal-block-statements
,@opascal-mid-block-statements
259 ,@opascal-decl-sections
)
260 "Delimits a previous enclosing statement.")
262 (defconst opascal-begin-enclosing-tokens
263 `(,@opascal-block-statements
,@opascal-mid-block-statements
)
264 "Tokens that a begin token indents from.")
266 (defconst opascal-begin-previous-tokens
267 `(,@opascal-decl-sections
,@opascal-routine-statements
)
268 "Tokens that a begin token aligns with, but only if not part of a nested
271 (defconst opascal-space-chars
"\000-\011\013- ") ; all except \n
272 (defconst opascal-non-space-chars
(concat "^" opascal-space-chars
))
273 (defconst opascal-spaces-re
(concat "[" opascal-space-chars
"]*"))
274 (defconst opascal-leading-spaces-re
(concat "^" opascal-spaces-re
))
275 (defconst opascal-word-chars
"a-zA-Z0-9_")
277 (defmacro opascal-save-excursion
(&rest forms
)
278 ;; Executes the forms such that any movements have no effect, including
282 (let ((inhibit-point-motion-hooks t
)
283 (deactivate-mark nil
))
286 (defmacro opascal-save-state
(&rest forms
)
287 ;; Executes the forms such that any buffer modifications do not have any side
288 ;; effects beyond the buffer's actual content changes.
289 `(let ((opascal--ignore-changes t
))
290 (with-silent-modifications
293 (defsubst opascal-is
(element in-set
)
294 ;; If the element is in the set, the element cdr is returned, otherwise nil.
295 (memq element in-set
))
297 (defun opascal-string-of (start end
)
298 ;; Returns the buffer string from start to end.
299 (buffer-substring-no-properties start end
))
301 (defun opascal-looking-at-string (p s
)
302 ;; True if point p marks the start of string s. s is not a regular
304 (let ((limit (+ p
(length s
))))
305 (and (<= limit
(point-max))
306 (string= s
(opascal-string-of p limit
)))))
308 (defun opascal-token-of (kind start end
)
309 ;; Constructs a token from a kind symbol and its start/end points.
310 `[,kind
,start
,end
])
312 (defsubst opascal-token-kind
(token)
313 ;; Returns the kind symbol of the token.
314 (if token
(aref token
0) nil
))
316 (defun opascal-set-token-kind (token to-kind
)
317 ;; Sets the kind symbol of the token.
318 (if token
(aset token
0 to-kind
)))
320 (defsubst opascal-token-start
(token)
321 ;; Returns the start point of the token.
322 (if token
(aref token
1) (point-min)))
324 (defsubst opascal-token-end
(token)
325 ;; Returns the end point of the token.
326 (if token
(aref token
2) (point-min)))
328 (defun opascal-set-token-start (token start
)
329 ;; Sets the start point of the token.
330 (if token
(aset token
1 start
)))
332 (defun opascal-set-token-end (token end
)
333 ;; Sets the end point of the token.
334 (if token
(aset token
2 end
)))
336 (defun opascal-token-string (token)
337 ;; Returns the string image of the token.
339 (opascal-string-of (opascal-token-start token
) (opascal-token-end token
))
342 (defun opascal-in-token (p token
)
343 ;; Returns true if the point p is within the token's start/end points.
344 (and (<= (opascal-token-start token
) p
) (< p
(opascal-token-end token
))))
346 (defun opascal-column-of (p)
347 ;; Returns the column of the point p.
348 (save-excursion (goto-char p
) (current-column)))
350 (defun opascal-face-of (token-kind)
351 ;; Returns the face property appropriate for the token kind.
352 (cond ((opascal-is token-kind opascal-comments
) opascal-comment-face
)
353 ((opascal-is token-kind opascal-strings
) opascal-string-face
)
354 ((opascal-is token-kind opascal-keywords
) opascal-keyword-face
)
355 (opascal-other-face)))
357 (defvar opascal-progress-last-reported-point nil
358 "The last point at which progress was reported.")
360 (defconst opascal-parsing-progress-step
16384
361 "Number of chars to process before the next parsing progress report.")
362 (defconst opascal-scanning-progress-step
2048
363 "Number of chars to process before the next scanning progress report.")
364 (defconst opascal-fontifying-progress-step opascal-scanning-progress-step
365 "Number of chars to process before the next fontification progress report.")
367 (defun opascal-progress-start ()
368 ;; Initializes progress reporting.
369 (setq opascal-progress-last-reported-point nil
))
371 (defun opascal-progress-done (&rest msgs
)
372 ;; Finalizes progress reporting.
373 (setq opascal-progress-last-reported-point nil
)
374 (when opascal-verbose
377 (apply #'message msgs
))))
379 (defun opascal-step-progress (p desc step-size
)
380 ;; If enough distance has elapsed since the last reported point, then report
381 ;; the current progress to the user.
382 (cond ((null opascal-progress-last-reported-point
)
383 ;; This is the first progress step.
384 (setq opascal-progress-last-reported-point p
))
386 ((and opascal-verbose
387 (>= (abs (- p opascal-progress-last-reported-point
)) step-size
))
388 ;; Report the percentage complete.
389 (setq opascal-progress-last-reported-point p
)
390 (message "%s %s ... %d%%"
391 desc
(buffer-name) (/ (* 100 p
) (point-max))))))
393 (defun opascal-next-line-start (&optional from-point
)
394 ;; Returns the first point of the next line.
395 (let ((curr-point (point))
397 (if from-point
(goto-char from-point
))
399 (setq next
(min (1+ (point)) (point-max)))
400 (goto-char curr-point
)
403 (defvar opascal--ignore-changes t
404 "Internal flag to control if the OPascal mode responds to buffer changes.
405 Defaults to t in case the `opascal-after-change' function is called on a
406 non-OPascal buffer. Set to nil in OPascal buffers. To override, just do:
407 (let ((opascal--ignore-changes t)) ...)")
409 (defun opascal-set-text-properties (from to properties
)
410 ;; Like `set-text-properties', except we do not consider this to be a buffer
413 (set-text-properties from to properties
)))
415 (defun opascal-literal-kind (p)
416 ;; Returns the literal kind the point p is in (or nil if not in a literal).
417 (if (and (<= (point-min) p
) (<= p
(point-max)))
418 (get-text-property p
'token
)))
420 (defun opascal-literal-start-pattern (literal-kind)
421 ;; Returns the start pattern of the literal kind.
422 (cdr (assoc literal-kind
423 '((comment-single-line .
"//")
424 (comment-multi-line-1 .
"{")
425 (comment-multi-line-2 .
"(*")
427 (double-quoted-string .
"\"")))))
429 (defun opascal-literal-end-pattern (literal-kind)
430 ;; Returns the end pattern of the literal kind.
431 (cdr (assoc literal-kind
432 '((comment-single-line .
"\n")
433 (comment-multi-line-1 .
"}")
434 (comment-multi-line-2 .
"*)")
436 (double-quoted-string .
"\"")))))
438 (defun opascal-literal-stop-pattern (literal-kind)
439 ;; Returns the pattern that delimits end of the search for the literal kind.
440 ;; These are regular expressions.
441 (cdr (assoc literal-kind
442 '((comment-single-line .
"\n")
443 (comment-multi-line-1 .
"}")
444 (comment-multi-line-2 .
"\\*)")
445 ;; Strings cannot span lines.
447 (double-quoted-string .
"[\"\n]")))))
449 (defun opascal-is-literal-start (p)
450 ;; True if the point p is at the start point of a (completed) literal.
451 (let* ((kind (opascal-literal-kind p
))
452 (pattern (opascal-literal-start-pattern kind
)))
453 (or (null kind
) ; Non-literals are considered as start points.
454 (opascal-looking-at-string p pattern
))))
456 (defun opascal-is-literal-end (p)
457 ;; True if the point p is at the end point of a (completed) literal.
458 (let* ((kind (opascal-literal-kind (1- p
)))
459 (pattern (opascal-literal-end-pattern kind
)))
460 (or (null kind
) ; Non-literals are considered as end points.
462 (and (opascal-looking-at-string (- p
(length pattern
)) pattern
)
463 (or (not (opascal-is kind opascal-strings
))
464 ;; Special case: string delimiters are start/end ambiguous.
465 ;; We have an end only if there is some string content (at
466 ;; least a starting delimiter).
467 (not (opascal-is-literal-end (1- p
)))))
469 ;; Special case: strings cannot span lines.
470 (and (opascal-is kind opascal-strings
) (eq ?
\n (char-after (1- p
)))))))
472 (defun opascal-is-stable-literal (p)
473 ;; True if the point p marks a stable point. That is, a point outside of a
474 ;; literal region, inside of a literal region, or adjacent to completed
476 (let ((at-start (opascal-is-literal-start p
))
477 (at-end (opascal-is-literal-end p
)))
478 (or (>= p
(point-max))
479 (and at-start at-end
)
480 (and (not at-start
) (not at-end
)
481 (eq (opascal-literal-kind (1- p
)) (opascal-literal-kind p
))))))
483 (defun opascal-complete-literal (literal-kind limit
)
484 ;; Continues the search for a literal's true end point and returns the
485 ;; point past the end pattern (if found) or the limit (if not found).
486 (let ((pattern (opascal-literal-stop-pattern literal-kind
)))
487 (if (not (stringp pattern
))
488 (error "Invalid literal kind %S" literal-kind
)
489 ;; Search up to the limit.
490 (re-search-forward pattern limit
'goto-limit-on-fail
)
493 (defun opascal-literal-text-properties (kind)
494 ;; Creates a list of text properties for the literal kind.
495 (if (and (boundp 'font-lock-mode
)
497 (list 'token kind
'face
(opascal-face-of kind
) 'lazy-lock t
)
500 (defun opascal-parse-next-literal (limit)
501 ;; Searches for the next literal region (i.e. comment or string) and sets the
502 ;; the point to its end (or the limit, if not found). The literal region is
503 ;; marked as such with a text property, to speed up tokenizing during face
504 ;; coloring and indentation scanning.
505 (let ((search-start (point)))
506 (cond ((not (opascal-is-literal-end search-start
))
507 ;; We are completing an incomplete literal.
508 (let ((kind (opascal-literal-kind (1- search-start
))))
509 (opascal-complete-literal kind limit
)
510 (opascal-set-text-properties
511 search-start
(point) (opascal-literal-text-properties kind
))))
514 "\\(//\\)\\|\\({\\)\\|\\((\\*\\)\\|\\('\\)\\|\\(\"\\)"
515 limit
'goto-limit-on-fail
)
516 ;; We found the start of a new literal. Find its end and mark it.
517 (let ((kind (cond ((match-beginning 1) 'comment-single-line
)
518 ((match-beginning 2) 'comment-multi-line-1
)
519 ((match-beginning 3) 'comment-multi-line-2
)
520 ((match-beginning 4) 'string
)
521 ((match-beginning 5) 'double-quoted-string
)))
522 (start (match-beginning 0)))
523 (opascal-set-text-properties search-start start nil
)
524 (opascal-complete-literal kind limit
)
525 (opascal-set-text-properties
526 start
(point) (opascal-literal-text-properties kind
))))
528 ;; Nothing found. Mark it as a non-literal.
529 ((opascal-set-text-properties search-start limit nil
)))
530 (opascal-step-progress (point) "Parsing" opascal-parsing-progress-step
)))
532 (defun opascal-literal-token-at (p)
533 ;; Returns the literal token surrounding the point p, or nil if none.
534 (let ((kind (opascal-literal-kind p
)))
536 (let ((start (previous-single-property-change (1+ p
) 'token
))
537 (end (next-single-property-change p
'token
)))
538 (opascal-token-of kind
(or start
(point-min)) (or end
(point-max)))))))
540 (defun opascal-point-token-at (p kind
)
541 ;; Returns the single character token at the point p.
542 (opascal-token-of kind p
(1+ p
)))
544 (defsubst opascal-char-token-at
(p char kind
)
545 ;; Returns the token at the point p that describes the specified character.
546 ;; If not actually over such a character, nil is returned.
547 (when (eq char
(char-after p
))
548 (opascal-token-of kind p
(1+ p
))))
550 (defun opascal-charset-token-at (p charset kind
)
551 ;; Returns the token surrounding point p that contains only members of the
553 (let ((currp (point))
557 (when (> (skip-chars-forward charset
) 0)
560 (skip-chars-backward charset
)
561 (setq token
(opascal-token-of kind
(point) end
)))
565 (defun opascal-space-token-at (p)
566 ;; If point p is surrounded by space characters, then return the token of the
567 ;; contiguous spaces.
568 (opascal-charset-token-at p opascal-space-chars
'space
))
570 (defun opascal-word-token-at (p)
571 ;; If point p is over a word (i.e. identifier characters), then return a word
572 ;; token. If the word is actually a keyword, then return the keyword token.
573 (let ((word (opascal-charset-token-at p opascal-word-chars
'word
)))
575 (let* ((word-image (downcase (opascal-token-string word
)))
576 (keyword (intern-soft word-image
)))
577 (when (and (or keyword
(string= "nil" word-image
))
578 (opascal-is keyword opascal-keywords
))
579 (opascal-set-token-kind word keyword
))
582 (defun opascal-explicit-token-at (p token-string kind
)
583 ;; If point p is anywhere in the token string then returns the resulting
585 (let ((token (opascal-charset-token-at p token-string kind
)))
586 (when (and token
(string= token-string
(opascal-token-string token
)))
589 (defun opascal-token-at (p)
590 ;; Returns the token from parsing text at point p.
591 (when (and (<= (point-min) p
) (<= p
(point-max)))
592 (cond ((opascal-char-token-at p ?
\n 'newline
))
594 ((opascal-literal-token-at p
))
596 ((opascal-space-token-at p
))
598 ((opascal-word-token-at p
))
600 ((opascal-char-token-at p ?\
( 'open-group
))
601 ((opascal-char-token-at p ?\
) 'close-group
))
602 ((opascal-char-token-at p ?\
[ 'open-group
))
603 ((opascal-char-token-at p ?\
] 'close-group
))
604 ((opascal-char-token-at p ?\
; 'semicolon))
605 ((opascal-char-token-at p ?.
'dot
))
606 ((opascal-char-token-at p ?
, 'comma
))
607 ((opascal-char-token-at p ?
= 'equals
))
608 ((opascal-char-token-at p ?
+ 'plus
))
609 ((opascal-char-token-at p ?-
'minus
))
610 ((opascal-char-token-at p ?
* 'times
))
611 ((opascal-char-token-at p ?
/ 'divides
))
612 ((opascal-char-token-at p ?
: 'colon
))
614 ((opascal-explicit-token-at p
"<>" 'not-equals
))
616 ((opascal-point-token-at p
'punctuation
)))))
618 (defun opascal-current-token ()
619 ;; Returns the opascal source token under the current point.
620 (opascal-token-at (point)))
622 (defun opascal-next-token (token)
623 ;; Returns the token after the specified token.
625 (let ((next (opascal-token-at (opascal-token-end token
))))
627 (opascal-step-progress (opascal-token-start next
) "Scanning"
628 opascal-scanning-progress-step
))
631 (defun opascal-previous-token (token)
632 ;; Returns the token before the specified token.
634 (let ((previous (opascal-token-at (1- (opascal-token-start token
)))))
636 (opascal-step-progress (opascal-token-start previous
) "Scanning"
637 opascal-scanning-progress-step
))
640 (defun opascal-next-visible-token (token)
641 ;; Returns the first non-space token after the specified token.
644 (setq next-token
(opascal-next-token token
))
645 (opascal-is (opascal-token-kind next-token
) '(space newline
))))
648 (defun opascal-parse-region (from to
)
649 ;; Parses the literal tokens in the region. The point is set to "to".
653 (while (< (point) to
)
654 (opascal-parse-next-literal to
))))
656 (defun opascal-parse-region-until-stable (from to
)
657 ;; Parses at least the literal tokens in the region. After that, parsing
658 ;; continues as long as obsolete literal regions are encountered. The point
659 ;; is set to the encountered stable point.
662 (opascal-parse-region from to
)
663 (while (not (opascal-is-stable-literal (point)))
664 (opascal-parse-next-literal (point-max)))))
666 (defun opascal-fontify-region (from to
&optional verbose
)
667 ;; Colors the text in the region according to OPascal rules.
668 (opascal-save-excursion
671 (opascal-verbose verbose
)
673 (opascal-progress-start)
675 ;; Color the token and move past it.
676 (setq token
(opascal-token-at p
))
678 (opascal-token-start token
) (opascal-token-end token
)
679 (list 'face
(opascal-face-of (opascal-token-kind token
)) 'lazy-lock t
))
680 (setq p
(opascal-token-end token
))
681 (opascal-step-progress p
"Fontifying" opascal-fontifying-progress-step
))
682 (opascal-progress-done)))))
684 (defun opascal-after-change (change-start change-end _old-length
)
685 ;; Called when the buffer has changed. Reparses the changed region.
686 (unless opascal--ignore-changes
687 (let ((opascal--ignore-changes t
)) ; Prevent recursive calls.
688 (opascal-save-excursion
689 (opascal-progress-start)
690 ;; Reparse at least from the token previous to the change to the end of
691 ;; line after the change.
692 (opascal-parse-region-until-stable
693 (opascal-token-start (opascal-token-at (1- change-start
)))
694 (progn (goto-char change-end
) (end-of-line) (point)))
695 (opascal-progress-done)))))
697 (defun opascal-group-start (from-token)
698 ;; Returns the token that denotes the start of the ()/[] group.
699 (let ((token (opascal-previous-token from-token
))
703 (setq token-kind
(opascal-token-kind token
))
705 ;; Skip over nested groups.
706 ((eq 'close-group token-kind
) (setq token
(opascal-group-start token
)))
707 ((eq 'open-group token-kind
) (throw 'done token
)))
708 (setq token
(opascal-previous-token token
)))
712 (defun opascal-group-end (from-token)
713 ;; Returns the token that denotes the end of the ()/[] group.
714 (let ((token (opascal-next-token from-token
))
718 (setq token-kind
(opascal-token-kind token
))
720 ;; Skip over nested groups.
721 ((eq 'open-group token-kind
) (setq token
(opascal-group-end token
)))
722 ((eq 'close-group token-kind
) (throw 'done token
)))
723 (setq token
(opascal-next-token token
)))
727 (defun opascal-indent-of (token &optional offset
)
728 ;; Returns the start column of the token, plus any offset.
729 (let ((indent (+ (opascal-column-of (opascal-token-start token
))
730 (if offset offset
0))))
733 (concat "\n Indent of: %S %S"
734 "\n column: %d indent: %d offset: %d")
735 token
(opascal-token-string token
)
736 (opascal-column-of (opascal-token-start token
))
737 indent
(if offset offset
0)))
740 (defun opascal-line-indent-of (from-token &optional offset
&rest terminators
)
741 ;; Returns the column of first non-space character on the token's line, plus
742 ;; any offset. We also stop if one of the terminators or an open ( or [ is
744 (let ((token (opascal-previous-token from-token
))
745 (last-token from-token
)
749 (setq kind
(opascal-token-kind token
))
751 ;; Skip over ()/[] groups.
752 ((eq 'close-group kind
) (setq token
(opascal-group-start token
)))
754 ;; Stop at the beginning of the line or an open group.
755 ((opascal-is kind
'(newline open-group
)) (throw 'done nil
))
757 ;; Stop at one of the specified terminators.
758 ((opascal-is kind terminators
) (throw 'done nil
)))
759 (unless (opascal-is kind opascal-whitespace
) (setq last-token token
))
760 (setq token
(opascal-previous-token token
))))
761 (opascal-indent-of last-token offset
)))
763 (defun opascal-stmt-line-indent-of (from-token &optional offset
)
764 ;; Like `opascal-line-indent-of' except is also stops on a use clause, and
765 ;; colons that precede statements (i.e. case labels).
766 (let ((token (opascal-previous-token from-token
))
767 (last-token from-token
)
771 (setq kind
(opascal-token-kind token
))
773 ((and (eq 'colon kind
)
774 (opascal-is (opascal-token-kind last-token
)
775 `(,@opascal-block-statements
776 ,@opascal-expr-statements
)))
777 ;; We hit a label followed by a statement. Indent to the statement.
780 ;; Skip over ()/[] groups.
781 ((eq 'close-group kind
) (setq token
(opascal-group-start token
)))
783 ((opascal-is kind
`(newline open-group
,@opascal-use-clauses
))
784 ;; Stop at the beginning of the line, an open group, or a use clause
786 (unless (opascal-is kind opascal-whitespace
) (setq last-token token
))
787 (setq token
(opascal-previous-token token
))))
788 (opascal-indent-of last-token offset
)))
790 (defun opascal-open-group-indent (token last-token
&optional offset
)
791 ;; Returns the indent relative to an unmatched ( or [.
792 (when (eq 'open-group
(opascal-token-kind token
))
794 (opascal-indent-of last-token offset
)
795 ;; There is nothing following the ( or [. Indent from its line.
796 (opascal-stmt-line-indent-of token opascal-indent-level
))))
798 (defun opascal-composite-type-start (token last-token
)
799 ;; Returns true (actually the last-token) if the pair equals (= class), (=
800 ;; dispinterface), (= interface), (= object), or (= record), and nil
802 (if (and (eq 'equals
(opascal-token-kind token
))
803 (opascal-is (opascal-token-kind last-token
) opascal-composite-types
))
806 (defun opascal-is-simple-class-type (at-token limit-token
)
807 ;; True if at-token is the start of a simple class type. E.g.
809 ;; class (TBaseClass);
811 (when (opascal-is (opascal-token-kind at-token
) opascal-class-types
)
813 ;; Scan until the semi colon.
814 (let ((token (opascal-next-token at-token
))
816 (limit (opascal-token-start limit-token
)))
817 (while (and token
(<= (opascal-token-start token
) limit
))
818 (setq token-kind
(opascal-token-kind token
))
820 ;; A semicolon delimits the search.
821 ((eq 'semicolon token-kind
) (throw 'done token
))
823 ;; Skip over the inheritance list.
824 ((eq 'open-group token-kind
) (setq token
(opascal-group-end token
)))
826 ;; Only allow "of" and whitespace, and an identifier
827 ((opascal-is token-kind
`(of word
,@opascal-whitespace
)))
829 ;; Otherwise we are not in a simple class declaration.
831 (setq token
(opascal-next-token token
)))))))
833 (defun opascal-block-start (from-token &optional stop-on-class
)
834 ;; Returns the token that denotes the start of the block.
835 (let ((token (opascal-previous-token from-token
))
840 (setq token-kind
(opascal-token-kind token
))
842 ;; Skip over nested blocks.
843 ((opascal-is token-kind opascal-end-block-statements
)
844 (setq token
(opascal-block-start token
)))
846 ;; Regular block start found.
847 ((opascal-is token-kind opascal-block-statements
)
849 ;; As a special case, when a "case" block appears
850 ;; within a record declaration (to denote a variant
851 ;; part), the record declaration should be considered
852 ;; the enclosing block.
853 (if (eq 'case token-kind
)
854 (let ((enclosing-token
855 (opascal-block-start token
859 (opascal-token-kind enclosing-token
))
862 (opascal-previous-token enclosing-token
))
866 ;; A class/record start also begins a block.
867 ((opascal-composite-type-start token last-token
)
868 (throw 'done
(if stop-on-class last-token token
)))
870 (unless (opascal-is token-kind opascal-whitespace
)
871 (setq last-token token
))
872 (setq token
(opascal-previous-token token
)))
876 (defun opascal-else-start (from-else)
877 ;; Returns the token of the if or case statement.
878 (let ((token (opascal-previous-token from-else
))
883 (setq token-kind
(opascal-token-kind token
))
885 ;; Skip over nested groups.
886 ((eq 'close-group token-kind
) (setq token
(opascal-group-start token
)))
888 ;; Skip over any nested blocks.
889 ((opascal-is token-kind opascal-end-block-statements
)
890 (setq token
(opascal-block-start token
)))
892 ((eq 'semicolon token-kind
)
893 ;; Semicolon means we are looking for an enclosing if, unless we
894 ;; are in a case statement. Keep counts of the semicolons and decide
896 (setq semicolon-count
(1+ semicolon-count
)))
898 ((and (eq 'if token-kind
) (= semicolon-count
0))
899 ;; We only can match an if when there have been no intervening
903 ((eq 'case token-kind
)
904 ;; We have hit a case statement start.
905 (throw 'done token
)))
906 (setq token
(opascal-previous-token token
)))
907 ;; No if or case statement found.
910 (defun opascal-comment-content-start (comment)
911 ;; Returns the point of the first non-space character in the comment.
912 (let ((kind (opascal-token-kind comment
)))
913 (when (opascal-is kind opascal-comments
)
914 (opascal-save-excursion
915 (goto-char (+ (opascal-token-start comment
)
916 (length (opascal-literal-start-pattern kind
))))
917 (skip-chars-forward opascal-space-chars
)
920 (defun opascal-comment-block-start (comment)
921 ;; Returns the starting comment token of a contiguous // comment block. If
922 ;; the comment is multiline (i.e. {...} or (*...*)), the original comment is
924 (if (not (eq 'comment-single-line
(opascal-token-kind comment
)))
926 ;; Scan until we run out of // comments.
927 (let ((prev-comment comment
)
928 (start-comment comment
))
929 (while (let ((kind (opascal-token-kind prev-comment
)))
930 (cond ((eq kind
'space
))
931 ((eq kind
'comment-single-line
)
932 (setq start-comment prev-comment
))
934 (setq prev-comment
(opascal-previous-token prev-comment
)))
937 (defun opascal-comment-block-end (comment)
938 ;; Returns the end comment token of a contiguous // comment block. If the
939 ;; comment is multiline (i.e. {...} or (*...*)), the original comment is
941 (if (not (eq 'comment-single-line
(opascal-token-kind comment
)))
943 ;; Scan until we run out of // comments.
944 (let ((next-comment comment
)
945 (end-comment comment
))
946 (while (let ((kind (opascal-token-kind next-comment
)))
947 (cond ((eq kind
'space
))
948 ((eq kind
'comment-single-line
)
949 (setq end-comment next-comment
))
951 (setq next-comment
(opascal-next-token next-comment
)))
954 (defun opascal-on-first-comment-line (comment)
955 ;; Returns true if the current point is on the first line of the comment.
957 (let ((comment-start (opascal-token-start comment
))
958 (current-point (point)))
959 (goto-char comment-start
)
961 (and (<= comment-start current-point
) (<= current-point
(point))))))
963 (defun opascal-comment-indent-of (comment)
964 ;; Returns the correct indentation for the comment.
965 (let ((start-comment (opascal-comment-block-start comment
)))
966 (if (and (eq start-comment comment
)
967 (opascal-on-first-comment-line comment
))
968 ;; Indent as a statement.
969 (opascal-enclosing-indent-of comment
)
971 (let ((kind (opascal-token-kind comment
)))
973 (cond ((eq 'comment-single-line kind
)
974 ;; Indent to the first comment in the // block.
975 (opascal-indent-of start-comment
))
977 ((looking-at (concat opascal-leading-spaces-re
978 (opascal-literal-stop-pattern kind
)))
979 ;; Indent multi-line comment terminators to the comment start.
980 (opascal-indent-of comment
))
982 ;; Indent according to the comment's content start.
983 ((opascal-column-of (opascal-comment-content-start comment
)))))))
986 (defun opascal-is-use-clause-end (at-token last-token last-colon from-kind
)
987 ;; True if we are after the end of a uses type clause.
988 (when (and last-token
990 (eq 'comma
(opascal-token-kind at-token
))
991 (eq 'semicolon from-kind
))
992 ;; Scan for the uses statement, just to be sure.
993 (let ((token (opascal-previous-token at-token
))
997 (setq token-kind
(opascal-token-kind token
))
998 (cond ((opascal-is token-kind opascal-use-clauses
)
1001 ;; Whitespace, identifiers, strings, "in" keyword, and commas
1002 ;; are allowed in use clauses.
1003 ((or (opascal-is token-kind
'(word comma in newline
))
1004 (opascal-is token-kind opascal-whitespace
)
1005 (opascal-is token-kind opascal-strings
)))
1008 ((throw 'done nil
)))
1009 (setq token
(opascal-previous-token token
)))
1012 (defun opascal-is-block-after-expr-statement (token)
1013 ;; Returns true if we have a block token trailing an expression delimiter (of
1014 ;; presumably an expression statement).
1015 (when (opascal-is (opascal-token-kind token
) opascal-block-statements
)
1016 (let ((previous (opascal-previous-token token
))
1017 (previous-kind nil
))
1019 (setq previous-kind
(opascal-token-kind previous
))
1020 (eq previous-kind
'space
))
1021 (setq previous
(opascal-previous-token previous
)))
1022 (or (opascal-is previous-kind opascal-expr-delimiters
)
1023 (eq previous-kind
'else
)))))
1025 (defun opascal-previous-indent-of (from-token)
1026 ;; Returns the indentation of the previous statement of the token.
1027 (let ((token (opascal-previous-token from-token
))
1029 (from-kind (opascal-token-kind from-token
))
1035 (setq token-kind
(opascal-token-kind token
))
1037 ;; An open ( or [ always is an indent point.
1038 ((eq 'open-group token-kind
)
1039 (throw 'done
(opascal-open-group-indent token last-token
)))
1041 ;; Skip over any ()/[] groups.
1042 ((eq 'close-group token-kind
) (setq token
(opascal-group-start token
)))
1044 ((opascal-is token-kind opascal-end-block-statements
)
1045 (if (eq 'newline
(opascal-token-kind (opascal-previous-token token
)))
1046 ;; We can stop at an end token that is right up against the
1049 ;; Otherwise, skip over any nested blocks.
1050 (setq token
(opascal-block-start token
))))
1052 ;; Special case: if we encounter a ", word;" then we assume that we
1053 ;; are in some kind of uses clause, and thus indent to column 0. This
1054 ;; works because no other constructs are known to have that form.
1055 ;; This fixes the irritating case of having indents after a uses
1056 ;; clause look like:
1060 ;; // this should be at column 0!
1061 ((opascal-is-use-clause-end token last-token last-colon from-kind
)
1064 ;; A previous terminator means we can stop. If we are on a directive,
1065 ;; however, then we are not actually encountering a new statement.
1067 (opascal-is token-kind opascal-previous-terminators
)
1068 (not (opascal-is (opascal-token-kind last-token
)
1069 opascal-directives
)))
1070 (throw 'done
(opascal-stmt-line-indent-of last-token
0)))
1072 ;; Ignore whitespace.
1073 ((opascal-is token-kind opascal-whitespace
))
1075 ;; Remember any "of" we encounter, since that affects how we
1076 ;; indent to a case statement within a record declaration
1077 ;; (i.e. a variant part).
1078 ((eq 'of token-kind
)
1079 (setq last-of token
))
1081 ;; Remember any ':' we encounter (until we reach an "of"),
1082 ;; since that affects how we indent to case statements in
1084 ((eq 'colon token-kind
)
1085 (unless last-of
(setq last-colon token
)))
1087 ;; A case statement delimits a previous statement. We indent labels
1089 ((eq 'case token-kind
)
1091 (if last-colon
(opascal-line-indent-of last-colon
)
1092 (opascal-line-indent-of token opascal-case-label-indent
))))
1094 ;; If we are in a use clause then commas mark an enclosing rather than
1095 ;; a previous statement.
1096 ((opascal-is token-kind opascal-use-clauses
)
1098 (if (eq 'comma from-kind
)
1100 ;; Indent to first unit in use clause.
1101 (opascal-indent-of last-token
)
1102 ;; Indent from use clause keyword.
1103 (opascal-line-indent-of token opascal-indent-level
))
1104 ;; Indent to use clause keyword.
1105 (opascal-line-indent-of token
))))
1107 ;; Assembly sections always indent in from the asm keyword.
1108 ((eq token-kind
'asm
)
1109 (throw 'done
(opascal-stmt-line-indent-of token opascal-indent-level
)))
1111 ;; An enclosing statement delimits a previous statement.
1112 ;; We try to use the existing indent of the previous statement,
1113 ;; otherwise we calculate from the enclosing statement.
1114 ((opascal-is token-kind opascal-previous-enclosing-statements
)
1115 (throw 'done
(if last-token
1116 ;; Otherwise indent to the last token
1117 (opascal-line-indent-of last-token
)
1118 ;; Just indent from the enclosing keyword
1119 (opascal-line-indent-of token opascal-indent-level
))))
1121 ;; A class or record declaration also delimits a previous statement.
1122 ((opascal-composite-type-start token last-token
)
1125 (if (opascal-is-simple-class-type last-token from-token
)
1126 ;; c = class; or c = class of T; are previous statements.
1127 (opascal-line-indent-of token
)
1128 ;; Otherwise c = class ... or r = record ... are enclosing
1130 (opascal-line-indent-of last-token opascal-indent-level
))))
1132 ;; We have a definite previous statement delimiter.
1133 ((opascal-is token-kind opascal-previous-statements
)
1134 (throw 'done
(opascal-stmt-line-indent-of token
0)))
1136 (unless (opascal-is token-kind opascal-whitespace
)
1137 (setq last-token token
))
1138 (setq token
(opascal-previous-token token
)))
1139 ;; We ran out of tokens. Indent to column 0.
1142 (defun opascal-section-indent-of (section-token)
1143 ;; Returns the indentation appropriate for begin/var/const/type/label
1145 (let* ((token (opascal-previous-token section-token
))
1148 (nested-block-count 0)
1149 (expr-delimited nil
)
1150 (last-terminator nil
))
1153 (setq token-kind
(opascal-token-kind token
))
1155 ;; Always stop at unmatched ( or [.
1156 ((eq token-kind
'open-group
)
1157 (throw 'done
(opascal-open-group-indent token last-token
)))
1159 ;; Skip over any ()/[] groups.
1160 ((eq 'close-group token-kind
) (setq token
(opascal-group-start token
)))
1162 ((opascal-is token-kind opascal-end-block-statements
)
1163 (if (eq 'newline
(opascal-token-kind (opascal-previous-token token
)))
1164 ;; We can stop at an end token that is right up against the
1167 ;; Otherwise, skip over any nested blocks.
1168 (setq token
(opascal-block-start token
)
1169 nested-block-count
(1+ nested-block-count
))))
1171 ;; Remember if we have encountered any forward routine declarations.
1172 ((eq 'forward token-kind
)
1173 (setq nested-block-count
(1+ nested-block-count
)))
1175 ;; Mark the completion of a nested routine traversal.
1176 ((and (opascal-is token-kind opascal-routine-statements
)
1177 (> nested-block-count
0))
1178 (setq nested-block-count
(1- nested-block-count
)))
1180 ;; Remember if we have encountered any statement terminators.
1181 ((eq 'semicolon token-kind
) (setq last-terminator token
))
1183 ;; Remember if we have encountered any expression delimiters.
1184 ((opascal-is token-kind opascal-expr-delimiters
)
1185 (setq expr-delimited token
))
1187 ;; Enclosing body statements are delimiting. We indent the compound
1188 ;; bodies specially.
1189 ((and (not last-terminator
)
1190 (opascal-is token-kind opascal-body-statements
))
1192 (opascal-stmt-line-indent-of token opascal-compound-block-indent
)))
1194 ;; An enclosing ":" means a label.
1195 ((and (eq 'colon token-kind
)
1196 (opascal-is (opascal-token-kind section-token
)
1197 opascal-block-statements
)
1198 (not last-terminator
)
1199 (not expr-delimited
)
1200 (not (eq 'equals
(opascal-token-kind last-token
))))
1202 (opascal-stmt-line-indent-of token opascal-indent-level
)))
1204 ;; Block and mid block tokens are always enclosing
1205 ((opascal-is token-kind opascal-begin-enclosing-tokens
)
1207 (opascal-stmt-line-indent-of token opascal-indent-level
)))
1209 ;; Declaration sections and routines are delimiters, unless they
1210 ;; are part of a nested routine.
1211 ((and (opascal-is token-kind opascal-decl-delimiters
)
1212 (= 0 nested-block-count
))
1213 (throw 'done
(opascal-line-indent-of token
0)))
1215 ;; Unit statements mean we indent right to the left.
1216 ((opascal-is token-kind opascal-unit-statements
) (throw 'done
0))
1218 (unless (opascal-is token-kind opascal-whitespace
)
1219 (setq last-token token
))
1220 (setq token
(opascal-previous-token token
)))
1221 ;; We ran out of tokens. Indent to column 0.
1224 (defun opascal-enclosing-indent-of (from-token)
1225 ;; Returns the indentation offset from the enclosing statement of the token.
1226 (let ((token (opascal-previous-token from-token
))
1227 (from-kind (opascal-token-kind from-token
))
1231 (equals-encountered nil
)
1233 (expr-delimited nil
))
1236 (setq token-kind
(opascal-token-kind token
))
1238 ;; An open ( or [ always is an indent point.
1239 ((eq 'open-group token-kind
)
1241 (opascal-open-group-indent
1243 (if (opascal-is from-kind opascal-binary-ops
)
1244 ;; Keep binary operations aligned with the open group.
1246 opascal-indent-level
))))
1248 ;; Skip over any ()/[] groups.
1249 ((eq 'close-group token-kind
) (setq token
(opascal-group-start token
)))
1251 ;; Skip over any nested blocks.
1252 ((opascal-is token-kind opascal-end-block-statements
)
1253 (setq token
(opascal-block-start token
)))
1255 ;; An expression delimiter affects indentation depending on whether
1256 ;; the point is before or after it. Remember that we encountered one.
1257 ;; Also remember the last encountered token, since if it exists it
1258 ;; should be the actual indent point.
1259 ((opascal-is token-kind opascal-expr-delimiters
)
1260 (setq expr-delimited token stmt-start last-token
))
1262 ;; With a non-delimited expression statement we indent after the
1263 ;; statement's keyword, unless we are on the delimiter itself.
1264 ((and (not expr-delimited
)
1265 (opascal-is token-kind opascal-expr-statements
))
1267 (cond ((opascal-is from-kind opascal-expr-delimiters
)
1268 ;; We are indenting a delimiter. Indent to the statement.
1269 (opascal-stmt-line-indent-of token
0))
1271 ((and last-token
(opascal-is from-kind opascal-binary-ops
))
1272 ;; Align binary ops with the expression.
1273 (opascal-indent-of last-token
))
1276 ;; Indent in from the expression.
1277 (opascal-indent-of last-token opascal-indent-level
))
1279 ;; Indent in from the statement's keyword.
1280 ((opascal-indent-of token opascal-indent-level
)))))
1282 ;; A delimited case statement indents the label according to
1284 ((eq 'case token-kind
)
1287 ;; We are not actually indenting to the case statement,
1288 ;; but are within a label expression.
1289 (opascal-stmt-line-indent-of
1290 stmt-start opascal-indent-level
)
1291 ;; Indent from the case keyword.
1292 (opascal-stmt-line-indent-of
1293 token opascal-case-label-indent
))))
1295 ;; Body expression statements are enclosing. Indent from the
1296 ;; statement's keyword, unless we have a non-block statement following
1298 ((opascal-is token-kind opascal-body-expr-statements
)
1300 (opascal-stmt-line-indent-of
1301 (or stmt-start token
) opascal-indent-level
)))
1303 ;; An else statement is enclosing, but it doesn't have an expression.
1304 ;; Thus we take into account last-token instead of stmt-start.
1305 ((eq 'else token-kind
)
1306 (throw 'done
(opascal-stmt-line-indent-of
1307 (or last-token token
) opascal-indent-level
)))
1309 ;; We indent relative to an enclosing declaration section.
1310 ((opascal-is token-kind opascal-decl-sections
)
1311 (throw 'done
(opascal-indent-of (if last-token last-token token
)
1312 opascal-indent-level
)))
1314 ;; In unit sections we indent right to the left.
1315 ((opascal-is token-kind opascal-unit-sections
)
1317 ;; Handle specially the case of "interface", which can be used
1318 ;; to start either a unit section or an interface definition.
1319 (if (opascal-is token-kind opascal-interface-types
)
1321 ;; Find the previous non-whitespace token.
1323 (setq last-token token
1324 token
(opascal-previous-token token
)
1325 token-kind
(opascal-token-kind token
))
1327 (opascal-is token-kind
1328 opascal-whitespace
))))
1329 ;; If this token is an equals sign, "interface" is being
1330 ;; used to start an interface definition and we should
1331 ;; treat it as a composite type; otherwise, we should
1332 ;; consider it the start of a unit section.
1333 (if (and token
(eq token-kind
'equals
))
1334 (opascal-line-indent-of last-token
1335 opascal-indent-level
)
1339 ;; A previous terminator means we can stop.
1340 ((opascal-is token-kind opascal-previous-terminators
)
1342 (cond ((and last-token
1343 (eq 'comma token-kind
)
1344 (opascal-is from-kind opascal-binary-ops
))
1345 ;; Align binary ops with the expression.
1346 (opascal-indent-of last-token
))
1349 ;; Indent in from the expression.
1350 (opascal-indent-of last-token opascal-indent-level
))
1352 ;; No enclosing expression; use the previous statement's
1354 ((opascal-previous-indent-of token
)))))
1356 ;; A block statement after an expression delimiter has its start
1357 ;; column as the expression statement. E.g.
1359 ;; and (a != c) then begin
1362 ;; Remember it for when we encounter the expression statement start.
1363 ((opascal-is-block-after-expr-statement token
)
1365 (cond (last-token (opascal-indent-of last-token opascal-indent-level
))
1367 ((+ (opascal-section-indent-of token
) opascal-indent-level
)))))
1369 ;; Assembly sections always indent in from the asm keyword.
1370 ((eq token-kind
'asm
)
1371 (throw 'done
(opascal-stmt-line-indent-of token opascal-indent-level
)))
1373 ;; Stop at an enclosing statement and indent from it.
1374 ((opascal-is token-kind opascal-enclosing-statements
)
1375 (throw 'done
(opascal-stmt-line-indent-of
1376 (or last-token token
) opascal-indent-level
)))
1378 ;; A class/record declaration is also enclosing.
1379 ((opascal-composite-type-start token last-token
)
1381 (opascal-line-indent-of last-token opascal-indent-level
)))
1383 ;; A ":" we indent relative to its line beginning. If we are in a
1384 ;; parameter list, then stop also if we hit a ";".
1385 ((and (eq token-kind
'colon
)
1386 (not expr-delimited
)
1387 (not (opascal-is from-kind opascal-expr-delimiters
))
1388 (not equals-encountered
)
1389 (not (eq from-kind
'equals
)))
1392 (opascal-indent-of last-token opascal-indent-level
)
1393 (opascal-line-indent-of token opascal-indent-level
'semicolon
))))
1395 ;; If the ":" was not processed above and we have token after the "=",
1396 ;; then indent from the "=". Ignore :=, however.
1397 ((and (eq token-kind
'colon
) equals-encountered before-equals
)
1399 ;; Ignore binary ops for now. It would do, for example:
1402 ;; which is good, but also
1406 ;; which doesn't look right.
1407 ;;;; Align binary ops with the before token.
1408 ;;((opascal-is from-kind opascal-binary-ops)
1409 ;;(throw 'done (opascal-indent-of before-equals 0)))
1411 ;; Assignments (:=) we skip over to get a normal indent.
1412 ((eq (opascal-token-kind last-token
) 'equals
))
1414 ;; Otherwise indent in from the equals.
1416 (opascal-indent-of before-equals opascal-indent-level
)))))
1418 ;; Remember any "=" we encounter if it has not already been processed.
1419 ((eq token-kind
'equals
)
1420 (setq equals-encountered token
1421 before-equals last-token
))
1423 (unless (opascal-is token-kind opascal-whitespace
)
1424 (setq last-token token
))
1425 (setq token
(opascal-previous-token token
)))
1426 ;; We ran out of tokens. Indent to column 0.
1429 (defun opascal-corrected-indentation ()
1430 ;; Returns the corrected indentation for the current line.
1431 (opascal-save-excursion
1432 (opascal-progress-start)
1433 ;; Move to the first token on the line.
1435 (skip-chars-forward opascal-space-chars
)
1436 (let* ((token (opascal-current-token))
1437 (token-kind (opascal-token-kind token
))
1439 (cond ((eq 'close-group token-kind
)
1440 ;; Indent to the matching start ( or [.
1441 (opascal-indent-of (opascal-group-start token
)))
1443 ((opascal-is token-kind opascal-unit-statements
) 0)
1445 ((opascal-is token-kind opascal-comments
)
1447 (opascal-comment-indent-of token
))
1449 ((opascal-is token-kind opascal-decl-matchers
)
1450 ;; Use a previous section/routine's indent.
1451 (opascal-section-indent-of token
))
1453 ((opascal-is token-kind opascal-match-block-statements
)
1454 ;; Use the block's indentation.
1456 (opascal-block-start token
'stop-on-class
)))
1458 ;; When trailing a body statement, indent to
1459 ;; the statement's keyword.
1460 ((opascal-is-block-after-expr-statement block-start
)
1461 (opascal-section-indent-of block-start
))
1463 ;; Otherwise just indent to the block start.
1464 ((opascal-stmt-line-indent-of block-start
0)))))
1466 ((eq 'else token-kind
)
1467 ;; Find the start of the if or case statement.
1468 (opascal-stmt-line-indent-of (opascal-else-start token
) 0))
1470 ;; Otherwise indent in from enclosing statement.
1471 ((opascal-enclosing-indent-of
1472 (if token token
(opascal-token-at (1- (point)))))))))
1473 (opascal-progress-done)
1476 (defun opascal-indent-line ()
1477 "Indent the current line according to the current language construct.
1478 If before the indent, the point is moved to the indent."
1481 (let ((marked-point (point-marker)) ; Maintain our position reliably.
1486 (setq line-start
(point))
1487 (skip-chars-forward opascal-space-chars
)
1488 (setq old-indent
(current-column))
1489 (setq new-indent
(opascal-corrected-indentation))
1490 (if (< marked-point
(point))
1491 ;; If before the indent column, then move to it.
1492 (set-marker marked-point
(point)))
1493 ;; Advance our marked point after inserted spaces.
1494 (set-marker-insertion-type marked-point t
)
1495 (when (/= old-indent new-indent
)
1496 (delete-region line-start
(point))
1497 (insert (make-string new-indent ?\s
)))
1498 (goto-char marked-point
)
1499 (set-marker marked-point nil
))))
1501 (defvar opascal-mode-abbrev-table nil
1502 "Abbrev table in use in OPascal mode buffers.")
1503 (define-abbrev-table 'opascal-mode-abbrev-table
())
1505 (defmacro opascal-ensure-buffer
(buffer-var buffer-name
)
1506 ;; Ensures there exists a buffer of the specified name in the specified
1508 `(when (not (buffer-live-p ,buffer-var
))
1509 (setq ,buffer-var
(get-buffer-create ,buffer-name
))))
1511 (defun opascal-log-msg (to-buffer the-msg
)
1512 ;; Writes a message to the end of the specified buffer.
1513 (with-current-buffer to-buffer
1514 (save-selected-window
1515 (switch-to-buffer-other-window to-buffer
)
1516 (goto-char (point-max))
1517 (set-window-point (get-buffer-window to-buffer
) (point))
1520 ;; Debugging helpers:
1522 (defvar opascal-debug-buffer nil
1523 "Buffer to write OPascal mode debug messages to. Created on demand.")
1525 (defun opascal-debug-log (format-string &rest args
)
1526 ;; Writes a message to the log buffer.
1528 (opascal-ensure-buffer opascal-debug-buffer
"*OPascal Debug Log*")
1529 (opascal-log-msg opascal-debug-buffer
1530 (concat (format-time-string "%H:%M:%S " (current-time))
1531 (apply #'format
(cons format-string args
))
1534 (defun opascal-debug-token-string (token)
1535 (let* ((image (opascal-token-string token
))
1536 (has-newline (string-match "^\\([^\n]*\\)\n\\(.+\\)?$" image
)))
1538 (setq image
(concat (match-string 1 image
)
1539 (if (match-beginning 2) "..."))))
1542 (defun opascal-debug-show-current-token ()
1544 (let ((token (opascal-current-token)))
1545 (opascal-debug-log "Token: %S %S" token
(opascal-debug-token-string token
))))
1547 (defun opascal-debug-goto-point (p)
1548 (interactive "NGoto char: ")
1551 (defun opascal-debug-goto-next-token ()
1553 (goto-char (opascal-token-start (opascal-next-token (opascal-current-token)))))
1555 (defun opascal-debug-goto-previous-token ()
1558 (opascal-token-start (opascal-previous-token (opascal-current-token)))))
1560 (defun opascal-debug-show-current-string (from to
)
1562 (opascal-debug-log "String: %S" (buffer-substring from to
)))
1564 (defun opascal-debug-show-is-stable ()
1566 (opascal-debug-log "stable: %S prev: %S next: %S"
1567 (opascal-is-stable-literal (point))
1568 (opascal-literal-kind (1- (point)))
1569 (opascal-literal-kind (point))))
1571 (defun opascal-debug-unparse-buffer ()
1573 (opascal-set-text-properties (point-min) (point-max) nil
))
1575 (defun opascal-debug-parse-region (from to
)
1577 (let ((opascal-verbose t
))
1578 (opascal-save-excursion
1579 (opascal-progress-start)
1580 (opascal-parse-region from to
)
1581 (opascal-progress-done "Parsing done"))))
1583 (defun opascal-debug-parse-window ()
1585 (opascal-debug-parse-region (window-start) (window-end)))
1587 (defun opascal-debug-parse-buffer ()
1589 (opascal-debug-parse-region (point-min) (point-max)))
1591 (defun opascal-debug-fontify-window ()
1593 (opascal-fontify-region (window-start) (window-end) t
))
1595 (defun opascal-debug-fontify-buffer ()
1597 (opascal-fontify-region (point-min) (point-max) t
))
1599 (defun opascal-debug-tokenize-region (from to
)
1601 (opascal-save-excursion
1602 (opascal-progress-start)
1604 (while (< (point) to
)
1605 (goto-char (opascal-token-end (opascal-current-token)))
1606 (opascal-step-progress (point) "Tokenizing" opascal-scanning-progress-step
))
1607 (opascal-progress-done "Tokenizing done")))
1609 (defun opascal-debug-tokenize-buffer ()
1611 (opascal-debug-tokenize-region (point-min) (point-max)))
1613 (defun opascal-debug-tokenize-window ()
1615 (opascal-debug-tokenize-region (window-start) (window-end)))
1618 (defun opascal-tab ()
1619 "Indent the region, when Transient Mark mode is enabled and the region is
1620 active. Otherwise, indent the current line or insert a TAB, depending on the
1621 value of `opascal-tab-always-indents' and the current line position."
1623 (cond ((use-region-p)
1624 ;; If Transient Mark mode is enabled and the region is active, indent
1625 ;; the entire region.
1626 (indent-region (region-beginning) (region-end)))
1627 ((or opascal-tab-always-indents
1628 (save-excursion (skip-chars-backward opascal-space-chars
) (bolp)))
1629 ;; Otherwise, if we are configured always to indent (regardless of the
1630 ;; point's position in the line) or we are before the first non-space
1631 ;; character on the line, indent the line.
1632 (opascal-indent-line))
1634 ;; Otherwise, insert a tab character.
1638 (defun opascal-is-directory (path)
1639 ;; True if the specified path is an existing directory.
1640 (let ((attributes (file-attributes path
)))
1641 (and attributes
(car attributes
))))
1643 (defun opascal-is-file (path)
1644 ;; True if the specified file exists as a file.
1645 (let ((attributes (file-attributes path
)))
1646 (and attributes
(null (car attributes
)))))
1648 (defun opascal-search-directory (unit dir
&optional recurse
)
1649 ;; Searches for the unit in the specified directory. If recurse is true, then
1650 ;; the directory is recursively searched. File name comparison is done in a
1651 ;; case insensitive manner.
1652 (when (opascal-is-directory dir
)
1653 (let ((files (directory-files dir
))
1654 (unit-file (downcase unit
)))
1656 ;; Search for the file.
1657 (dolist (file files
)
1658 (let ((path (concat dir
"/" file
)))
1659 (if (and (string= unit-file
(downcase file
))
1660 (opascal-is-file path
))
1661 (throw 'done path
))))
1663 ;; Not found. Search subdirectories.
1665 (dolist (subdir files
)
1666 (unless (member subdir
'("." ".."))
1667 (let ((path (opascal-search-directory
1668 unit
(concat dir
"/" subdir
) recurse
)))
1669 (if path
(throw 'done path
))))))
1675 (defun opascal-find-unit-in-directory (unit dir
)
1676 ;; Searches for the unit in the specified directory. If the directory ends
1677 ;; in \"...\", then it is recursively searched.
1678 (let ((dir-name dir
)
1680 ;; Check if we need to recursively search the directory.
1681 (if (string-match "^\\(.+\\)\\.\\.\\.$" dir-name
)
1682 (setq dir-name
(match-string 1 dir-name
)
1684 ;; Ensure the trailing slash is removed.
1685 (if (string-match "^\\(.+\\)[\\\\/]$" dir-name
)
1686 (setq dir-name
(match-string 1 dir-name
)))
1687 (opascal-search-directory unit dir-name recurse
)))
1689 (defun opascal-find-unit-file (unit)
1690 ;; Finds the specified opascal source file according to `opascal-search-path'.
1691 ;; If found, the full path is returned, otherwise nil is returned.
1693 (cond ((null opascal-search-path
)
1694 (opascal-find-unit-in-directory unit
"."))
1696 ((stringp opascal-search-path
)
1697 (opascal-find-unit-in-directory unit opascal-search-path
))
1699 ((dolist (dir opascal-search-path
)
1700 (let ((file (opascal-find-unit-in-directory unit dir
)))
1701 (if file
(throw 'done file
))))))
1704 (defun opascal-find-unit (unit)
1705 "Find the specified OPascal source file according to `opascal-search-path'.
1706 If no extension is specified, .pas is assumed. Creates a buffer for the unit."
1707 (interactive "sOPascal unit name: ")
1708 (let* ((unit-file (if (string-match "^\\(.*\\)\\.[a-z]+$" unit
)
1710 (concat unit
".pas")))
1711 (file (opascal-find-unit-file unit-file
)))
1713 (error "unit not found: %s" unit-file
)
1715 (if (not (derived-mode-p 'opascal-mode
))
1719 (defun opascal-find-current-def ()
1720 "Find the definition of the identifier under the current point."
1722 (error "opascal-find-current-def: not implemented yet"))
1724 (defun opascal-find-current-xdef ()
1725 "Find the definition of the identifier under the current point, searching
1726 in external units if necessary (as listed in the current unit's use clause).
1727 The set of directories to search for a unit is specified by the global variable
1728 `opascal-search-path'."
1730 (error "opascal-find-current-xdef: not implemented yet"))
1732 (defun opascal-find-current-body ()
1733 "Find the body of the identifier under the current point, assuming
1736 (error "opascal-find-current-body: not implemented yet"))
1738 (defun opascal-fill-comment ()
1739 "Fill the text of the current comment, according to `fill-column'.
1740 An error is raised if not in a comment."
1744 (let* ((comment (opascal-current-token))
1745 (comment-kind (opascal-token-kind comment
)))
1746 (if (not (opascal-is comment-kind opascal-comments
))
1747 (error "Not in a comment")
1748 (let* ((start-comment (opascal-comment-block-start comment
))
1749 (end-comment (opascal-comment-block-end comment
))
1750 (comment-start (opascal-token-start start-comment
))
1751 (comment-end (opascal-token-end end-comment
))
1752 (content-start (opascal-comment-content-start start-comment
))
1753 (content-indent (opascal-column-of content-start
))
1754 (content-prefix (make-string content-indent ?\s
))
1755 (content-prefix-re opascal-leading-spaces-re
)
1757 (marked-point (point-marker))) ; Maintain our position reliably.
1758 (when (eq 'comment-single-line comment-kind
)
1759 ;; // style comments need more work.
1760 (setq content-prefix
1761 (let ((comment-indent (opascal-column-of comment-start
)))
1762 (concat (make-string comment-indent ?\s
) "//"
1763 (make-string (- content-indent comment-indent
2)
1765 content-prefix-re
(concat opascal-leading-spaces-re
1768 comment-end
(if (opascal-is-literal-end comment-end
)
1769 ;; Don't include the trailing newline.
1773 ;; Advance our marked point after inserted spaces.
1774 (set-marker-insertion-type marked-point t
)
1776 ;; Ensure we can modify the buffer
1777 (goto-char content-start
)
1781 (narrow-to-region content-start comment-end
)
1783 ;; Strip off the comment prefixes
1784 (setq p
(point-min))
1785 (while (when (< p
(point-max))
1787 (re-search-forward content-prefix-re nil t
))
1788 (replace-match "" nil nil
)
1789 (setq p
(1+ (point))))
1791 ;; add an extra line to prevent the fill from doing it for us.
1792 (goto-char (point-max))
1795 ;; Fill the comment contents.
1796 (let ((fill-column (- fill-column content-indent
)))
1797 (fill-region (point-min) (point-max)))
1799 (goto-char (point-max))
1802 ;; Restore comment prefixes.
1803 (goto-char (point-min))
1804 (end-of-line) ; Don't reset the first line.
1806 (while (when (< p
(point-max))
1808 (re-search-forward "^" nil t
))
1809 (replace-match content-prefix nil nil
)
1810 (setq p
(1+ (point))))
1812 (setq comment-end
(point-max))
1815 ;; Restore our position
1816 (goto-char marked-point
)
1817 (set-marker marked-point nil
)
1819 ;; React to the entire fill change as a whole.
1820 (opascal-progress-start)
1821 (opascal-parse-region comment-start comment-end
)
1822 (opascal-progress-done)))))))
1824 (defun opascal-new-comment-line ()
1825 "If in a // comment, do a newline, indented such that one is still in the
1826 comment block. If not in a // comment, just does a normal newline."
1828 (let ((comment (opascal-current-token)))
1829 (if (not (eq 'comment-single-line
(opascal-token-kind comment
)))
1830 ;; Not in a // comment. Just do the normal newline.
1832 (let* ((start-comment (opascal-comment-block-start comment
))
1833 (comment-start (opascal-token-start start-comment
))
1834 (content-start (opascal-comment-content-start start-comment
))
1836 (concat (make-string (opascal-column-of comment-start
) ?\s
) "//"
1837 (make-string (- content-start comment-start
2) ?\s
))))
1838 (delete-horizontal-space)
1839 (insert "\n" prefix
)))))
1841 (defun opascal-match-token (token limit
)
1842 ;; Sets the match region used by (match-string 0) and friends to the token's
1843 ;; region. Sets the current point to the end of the token (or limit).
1844 (set-match-data nil
)
1846 (let ((end (min (opascal-token-end token
) limit
)))
1847 (set-match-data (list (opascal-token-start token
) end
))
1851 (defconst opascal-font-lock-defaults
1852 '(nil ; We have our own fontify routine, so keywords don't apply.
1853 t
; Syntactic fontification doesn't apply.
1854 nil
; Don't care about case since we don't use regexps to find tokens.
1855 nil
; Syntax alists don't apply.
1856 nil
; Syntax begin movement doesn't apply
1857 (font-lock-fontify-region-function . opascal-fontify-region
)
1858 (font-lock-verbose . opascal-fontifying-progress-step
))
1859 "OPascal mode font-lock defaults. Syntactic fontification is ignored.")
1861 (defvar opascal-debug-mode-map
1862 (let ((kmap (make-sparse-keymap)))
1863 (dolist (binding '(("n" opascal-debug-goto-next-token
)
1864 ("p" opascal-debug-goto-previous-token
)
1865 ("t" opascal-debug-show-current-token
)
1866 ("T" opascal-debug-tokenize-buffer
)
1867 ("W" opascal-debug-tokenize-window
)
1868 ("g" opascal-debug-goto-point
)
1869 ("s" opascal-debug-show-current-string
)
1870 ("a" opascal-debug-parse-buffer
)
1871 ("w" opascal-debug-parse-window
)
1872 ("f" opascal-debug-fontify-window
)
1873 ("F" opascal-debug-fontify-buffer
)
1874 ("r" opascal-debug-parse-region
)
1875 ("c" opascal-debug-unparse-buffer
)
1876 ("x" opascal-debug-show-is-stable
)))
1877 (define-key kmap
(car binding
) (cadr binding
)))
1879 "Keystrokes for OPascal mode debug commands.")
1881 (defvar opascal-mode-map
1882 (let ((kmap (make-sparse-keymap)))
1884 (list ;; '("\C-cd" opascal-find-current-def)
1885 ;; '("\C-cx" opascal-find-current-xdef)
1886 ;; '("\C-cb" opascal-find-current-body)
1887 '("\C-cu" opascal-find-unit
)
1888 '("\M-q" opascal-fill-comment
)
1889 '("\M-j" opascal-new-comment-line
)
1891 (list "\C-c\C-d" opascal-debug-mode-map
)))
1892 (define-key kmap
(car binding
) (cadr binding
)))
1894 "Keymap used in OPascal mode.")
1896 (define-obsolete-variable-alias 'delphi-mode-hook
'opascal-mode-hook
"24.4")
1898 (define-obsolete-function-alias 'delphi-mode
'opascal-mode
"24.4")
1900 (define-derived-mode opascal-mode prog-mode
"OPascal"
1901 "Major mode for editing OPascal code. \\<opascal-mode-map>
1902 \\[opascal-find-unit]\t- Search for a OPascal source file.
1903 \\[opascal-fill-comment]\t- Fill the current comment.
1904 \\[opascal-new-comment-line]\t- If in a // comment, do a new comment line.
1906 \\[indent-region] also works for indenting a whole region.
1910 `opascal-indent-level' (default 3)
1911 Indentation of OPascal statements with respect to containing block.
1912 `opascal-compound-block-indent' (default 0)
1913 Extra indentation for blocks in compound statements.
1914 `opascal-case-label-indent' (default 0)
1915 Extra indentation for case statement labels.
1916 `opascal-tab-always-indents' (default `tab-always-indents')
1917 Non-nil means TAB in OPascal mode should always reindent the current line,
1918 regardless of where in the line point is when the TAB command is used.
1919 `opascal-search-path' (default .)
1920 Directories to search when finding external units.
1921 `opascal-verbose' (default nil)
1922 If true then OPascal token processing progress is reported to the user.
1926 `opascal-comment-face' (default font-lock-comment-face)
1927 Face used to color OPascal comments.
1928 `opascal-string-face' (default font-lock-string-face)
1929 Face used to color OPascal strings.
1930 `opascal-keyword-face' (default font-lock-keyword-face)
1931 Face used to color OPascal keywords.
1932 `opascal-other-face' (default nil)
1933 Face used to color everything else.
1935 Turning on OPascal mode calls the value of the variable `opascal-mode-hook'
1936 with no args, if that value is non-nil."
1939 (setq-local indent-line-function
#'opascal-indent-line
)
1940 (setq-local comment-indent-function
#'opascal-indent-line
)
1941 (setq-local case-fold-search t
)
1942 (setq-local opascal-progress-last-reported-point nil
)
1943 (setq-local opascal--ignore-changes nil
)
1944 (setq-local font-lock-defaults opascal-font-lock-defaults
)
1945 (setq-local tab-always-indent opascal-tab-always-indents
)
1947 ;; FIXME: Use syntax-propertize-function to tokenize, maybe?
1949 ;; We need to keep track of changes to the buffer to determine if we need
1950 ;; to retokenize changed text.
1951 (add-hook 'after-change-functions
#'opascal-after-change nil t
)
1953 (opascal-save-excursion
1954 (let ((opascal-verbose t
))
1955 (opascal-progress-start)
1956 (opascal-parse-region (point-min) (point-max))
1957 (opascal-progress-done))))
1960 ;;; opascal.el ends here