]> code.delx.au - gnu-emacs/blob - lisp/progmodes/opascal.el
Merge from origin/emacs-24
[gnu-emacs] / lisp / progmodes / opascal.el
1 ;;; opascal.el --- major mode for editing Object Pascal source in Emacs -*- lexical-binding: t -*-
2
3 ;; Copyright (C) 1998-1999, 2001-2015 Free Software Foundation, Inc.
4
5 ;; Authors: Ray Blaak <blaak@infomatch.com>,
6 ;; Simon South <ssouth@member.fsf.org>
7 ;; Maintainer: Simon South <ssouth@member.fsf.org>
8 ;; Keywords: languages
9
10 ;; This file is part of GNU Emacs.
11
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.
16
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.
21
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/>.
24
25 ;;; Commentary:
26
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.
30 ;;
31 ;; (autoload 'opascal-mode "opascal")
32 ;; (add-to-list 'auto-mode-alist
33 ;; '("\\.\\(pas\\|dpr\\|dpk\\)\\'" . opascal-mode))
34
35 ;; When you have entered OPascal mode, you may get more info by pressing
36 ;; C-h m.
37
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.
42
43 ;;; Code:
44
45 (defgroup opascal nil
46 "Major mode for editing OPascal source in Emacs."
47 :version "24.4"
48 :group 'languages)
49
50 (defconst opascal-debug nil
51 "True if in debug mode.")
52
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."
60 :type 'string)
61
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.
66 E.g.
67
68 begin
69 // This is an indent of 3.
70 end;"
71 :type 'integer)
72
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.
77
78 // block indent = 0 vs // block indent = 2
79 if b then if b then
80 begin begin
81 end else begin end
82 end; else
83 begin
84 end;"
85 :type 'integer)
86
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.
91
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;
96 else else
97 process_else; process_else;
98 end; end;"
99 :type 'integer)
100
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."
104 :type 'boolean)
105
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 `opascal-tab' should always reindent the current line.
110 That is, regardless of where in the line point is at the time."
111 :type 'boolean)
112
113 (make-obsolete-variable 'opascal-tab-always-indents
114 "use `indent-for-tab-command' and `tab-always-indent'."
115 "24.4")
116
117 (defconst opascal-directives
118 '(absolute abstract assembler automated cdecl default dispid dynamic
119 export external far forward index inline message name near nodefault
120 overload override pascal private protected public published read readonly
121 register reintroduce resident resourcestring safecall stdcall stored
122 virtual write writeonly)
123 "OPascal4 directives.")
124
125 (defconst opascal-keywords
126 (append
127 '(;; Keywords.
128 and array as asm at begin case class const constructor contains
129 destructor dispinterface div do downto else end except exports
130 file finalization finally for function goto if implementation implements
131 in inherited initialization interface is label library mod nil not
132 of object on or out package packed procedure program property
133 raise record repeat requires result self set shl shr then threadvar
134 to try type unit uses until var while with xor
135
136 ;; These routines should be keywords, if Borland had the balls.
137 break exit)
138
139 ;; We want directives to look like keywords.
140 opascal-directives)
141 "OPascal4 keywords.")
142
143 (defconst opascal-previous-terminators `(semicolon comma)
144 "Expression/statement terminators that denote a previous expression.")
145
146 (defconst opascal-comments
147 '(comment-single-line comment-multi-line-1 comment-multi-line-2)
148 "Tokens that represent comments.")
149
150 (defconst opascal-strings
151 '(string double-quoted-string)
152 "Tokens that represent string literals.")
153
154 (defconst opascal-whitespace `(space newline ,@opascal-comments)
155 "Tokens that are considered whitespace.")
156
157 (defconst opascal-routine-statements
158 '(procedure function constructor destructor property)
159 "Marks the start of a routine, or routine-ish looking expression.")
160
161 (defconst opascal-body-expr-statements '(if while for on)
162 "Statements that have either a single statement or a block as a body and also
163 are followed by an expression.")
164
165 (defconst opascal-expr-statements `(case ,@opascal-body-expr-statements)
166 "Expression statements contain expressions after their keyword.")
167
168 (defconst opascal-body-statements `(else ,@opascal-body-expr-statements)
169 "Statements that have either a single statement or a block as a body.")
170
171 (defconst opascal-expr-delimiters '(then do of)
172 "Expression delimiter tokens.")
173
174 (defconst opascal-binary-ops
175 '(plus minus equals not-equals times divides div mod and or xor)
176 "OPascal binary operations.")
177
178 (defconst opascal-visibilities '(public private protected published automated)
179 "Class visibilities.")
180
181 (defconst opascal-block-statements
182 '(begin try case repeat initialization finalization asm)
183 "Statements that contain multiple substatements.")
184
185 (defconst opascal-mid-block-statements
186 `(except finally ,@opascal-visibilities)
187 "Statements that mark mid sections of the enclosing block.")
188
189 (defconst opascal-end-block-statements `(end until)
190 "Statements that end block sections.")
191
192 (defconst opascal-match-block-statements
193 `(,@opascal-end-block-statements ,@opascal-mid-block-statements)
194 "Statements that match the indentation of the parent block.")
195
196 (defconst opascal-decl-sections '(type const var label resourcestring)
197 "Denotes the start of a declaration section.")
198
199 (defconst opascal-interface-types '(dispinterface interface)
200 "Interface types.")
201
202 (defconst opascal-class-types '(class object)
203 "Class types.")
204
205 (defconst opascal-composite-types
206 `(,@opascal-class-types ,@opascal-interface-types record)
207 "Types that contain declarations within them.")
208
209 (defconst opascal-unit-sections
210 '(interface implementation program library package)
211 "Unit sections within which the indent is 0.")
212
213 (defconst opascal-use-clauses `(uses requires exports contains)
214 "Statements that refer to foreign symbols.")
215
216 (defconst opascal-unit-statements
217 `(,@opascal-use-clauses ,@opascal-unit-sections initialization finalization)
218 "Statements indented at level 0.")
219
220 (defconst opascal-decl-delimiters
221 `(,@opascal-decl-sections ,@opascal-unit-statements
222 ,@opascal-routine-statements)
223 "Statements that a declaration statement should align with.")
224
225 (defconst opascal-decl-matchers
226 `(begin ,@opascal-decl-sections)
227 "Statements that should match to declaration statement indentation.")
228
229 (defconst opascal-enclosing-statements
230 `(,@opascal-block-statements ,@opascal-mid-block-statements
231 ,@opascal-decl-sections ,@opascal-use-clauses ,@opascal-routine-statements)
232 "Delimits an enclosing statement.")
233
234 (defconst opascal-previous-statements
235 `(,@opascal-unit-statements ,@opascal-routine-statements)
236 "Delimits a previous statement.")
237
238 (defconst opascal-previous-enclosing-statements
239 `(,@opascal-block-statements ,@opascal-mid-block-statements
240 ,@opascal-decl-sections)
241 "Delimits a previous enclosing statement.")
242
243 (defconst opascal-begin-enclosing-tokens
244 `(,@opascal-block-statements ,@opascal-mid-block-statements)
245 "Tokens that a begin token indents from.")
246
247 (defconst opascal-begin-previous-tokens
248 `(,@opascal-decl-sections ,@opascal-routine-statements)
249 "Tokens that a begin token aligns with, but only if not part of a nested
250 routine.")
251
252 (defconst opascal-space-chars "\000-\011\013- ") ; all except \n
253 (defconst opascal-non-space-chars (concat "^" opascal-space-chars))
254 (defconst opascal-spaces-re (concat "[" opascal-space-chars "]*"))
255 (defconst opascal-leading-spaces-re (concat "^" opascal-spaces-re))
256 (defconst opascal-word-chars "a-zA-Z0-9_")
257
258 (defvar opascal-mode-syntax-table
259 (let ((st (make-syntax-table)))
260 ;; Strings.
261 (modify-syntax-entry ?\" "\"" st)
262 (modify-syntax-entry ?\' "\"" st)
263 ;; Comments.
264 (modify-syntax-entry ?\{ "<" st)
265 (modify-syntax-entry ?\} ">" st)
266 (modify-syntax-entry ?\( "()1" st)
267 (modify-syntax-entry ?\) ")(4" st)
268 (modify-syntax-entry ?* ". 23b" st)
269 (modify-syntax-entry ?/ ". 12c" st)
270 (modify-syntax-entry ?\n "> c" st)
271 st))
272
273 (defmacro opascal-save-excursion (&rest forms)
274 ;; Executes the forms such that any movements have no effect, including
275 ;; searches.
276 `(save-excursion
277 (save-match-data
278 (let ((inhibit-point-motion-hooks t)
279 (deactivate-mark nil))
280 (progn ,@forms)))))
281
282 (defsubst opascal-is (element in-set)
283 ;; If the element is in the set, the element cdr is returned, otherwise nil.
284 (memq element in-set))
285
286 (defun opascal-string-of (start end)
287 ;; Returns the buffer string from start to end.
288 (buffer-substring-no-properties start end))
289
290 (defun opascal-looking-at-string (p s)
291 ;; True if point p marks the start of string s. s is not a regular
292 ;; expression.
293 (let ((limit (+ p (length s))))
294 (and (<= limit (point-max))
295 (string= s (opascal-string-of p limit)))))
296
297 (defun opascal-token-of (kind start end)
298 ;; Constructs a token from a kind symbol and its start/end points.
299 `[,kind ,start ,end])
300
301 (defsubst opascal-token-kind (token)
302 ;; Returns the kind symbol of the token.
303 (if token (aref token 0) nil))
304
305 (defun opascal-set-token-kind (token to-kind)
306 ;; Sets the kind symbol of the token.
307 (if token (aset token 0 to-kind)))
308
309 (defsubst opascal-token-start (token)
310 ;; Returns the start point of the token.
311 (if token (aref token 1) (point-min)))
312
313 (defsubst opascal-token-end (token)
314 ;; Returns the end point of the token.
315 (if token (aref token 2) (point-min)))
316
317 (defun opascal-set-token-start (token start)
318 ;; Sets the start point of the token.
319 (if token (aset token 1 start)))
320
321 (defun opascal-set-token-end (token end)
322 ;; Sets the end point of the token.
323 (if token (aset token 2 end)))
324
325 (defun opascal-token-string (token)
326 ;; Returns the string image of the token.
327 (if token
328 (opascal-string-of (opascal-token-start token) (opascal-token-end token))
329 ""))
330
331 (defun opascal-in-token (p token)
332 ;; Returns true if the point p is within the token's start/end points.
333 (and (<= (opascal-token-start token) p) (< p (opascal-token-end token))))
334
335 (defun opascal-column-of (p)
336 ;; Returns the column of the point p.
337 (save-excursion (goto-char p) (current-column)))
338
339 (defvar opascal-progress-last-reported-point nil
340 "The last point at which progress was reported.")
341
342 (defconst opascal-parsing-progress-step 16384
343 "Number of chars to process before the next parsing progress report.")
344 (defconst opascal-scanning-progress-step 2048
345 "Number of chars to process before the next scanning progress report.")
346
347 (defun opascal-progress-start ()
348 ;; Initializes progress reporting.
349 (setq opascal-progress-last-reported-point nil))
350
351 (defun opascal-progress-done (&rest msgs)
352 ;; Finalizes progress reporting.
353 (setq opascal-progress-last-reported-point nil)
354 (when opascal-verbose
355 (if (null msgs)
356 (message "")
357 (apply #'message msgs))))
358
359 (defun opascal-step-progress (p desc step-size)
360 ;; If enough distance has elapsed since the last reported point, then report
361 ;; the current progress to the user.
362 (cond ((null opascal-progress-last-reported-point)
363 ;; This is the first progress step.
364 (setq opascal-progress-last-reported-point p))
365
366 ((and opascal-verbose
367 (>= (abs (- p opascal-progress-last-reported-point)) step-size))
368 ;; Report the percentage complete.
369 (setq opascal-progress-last-reported-point p)
370 (message "%s %s ... %d%%"
371 desc (buffer-name) (/ (* 100 p) (point-max))))))
372
373 (defun opascal-next-line-start (&optional from-point)
374 ;; Returns the first point of the next line.
375 (let ((curr-point (point))
376 (next nil))
377 (if from-point (goto-char from-point))
378 (end-of-line)
379 (setq next (min (1+ (point)) (point-max)))
380 (goto-char curr-point)
381 next))
382
383 (defconst opascal--literal-start-re (regexp-opt '("//" "{" "(*" "'" "\"")))
384
385 (defun opascal-literal-kind (p)
386 ;; Returns the literal kind the point p is in (or nil if not in a literal).
387 (when (and (<= (point-min) p) (<= p (point-max)))
388 (save-excursion
389 (let ((ppss (syntax-ppss p)))
390 ;; We want to return non-nil when right in front
391 ;; of a comment/string.
392 (if (null (nth 8 ppss))
393 (when (looking-at opascal--literal-start-re)
394 (pcase (char-after)
395 (`?/ 'comment-single-line)
396 (`?\{ 'comment-multi-line-1)
397 (`?\( 'comment-multi-line-2)
398 (`?\' 'string)
399 (`?\" 'double-quoted-string)))
400 (if (nth 3 ppss) ;String.
401 (if (eq (nth 3 ppss) ?\")
402 'double-quoted-string 'string)
403 (pcase (nth 7 ppss)
404 (`2 'comment-single-line)
405 (`1 'comment-multi-line-2)
406 (_ 'comment-multi-line-1))))))))
407
408 (defun opascal-literal-start-pattern (literal-kind)
409 ;; Returns the start pattern of the literal kind.
410 (cdr (assoc literal-kind
411 '((comment-single-line . "//")
412 (comment-multi-line-1 . "{")
413 (comment-multi-line-2 . "(*")
414 (string . "'")
415 (double-quoted-string . "\"")))))
416
417 (defun opascal-literal-end-pattern (literal-kind)
418 ;; Returns the end pattern of the literal kind.
419 (cdr (assoc literal-kind
420 '((comment-single-line . "\n")
421 (comment-multi-line-1 . "}")
422 (comment-multi-line-2 . "*)")
423 (string . "'")
424 (double-quoted-string . "\"")))))
425
426 (defun opascal-literal-stop-pattern (literal-kind)
427 ;; Returns the pattern that delimits end of the search for the literal kind.
428 ;; These are regular expressions.
429 (cdr (assoc literal-kind
430 '((comment-single-line . "\n")
431 (comment-multi-line-1 . "}")
432 (comment-multi-line-2 . "\\*)")
433 ;; Strings cannot span lines.
434 (string . "['\n]")
435 (double-quoted-string . "[\"\n]")))))
436
437 (defun opascal-is-literal-end (p)
438 ;; True if the point p is at the end point of a (completed) literal.
439 (save-excursion
440 (and (null (nth 8 (syntax-ppss p)))
441 (nth 8 (syntax-ppss (1- p))))))
442
443 (defun opascal-literal-token-at (p)
444 "Return the literal token surrounding the point P, or nil if none."
445 (save-excursion
446 (let ((ppss (syntax-ppss p)))
447 (when (or (nth 8 ppss) (looking-at opascal--literal-start-re))
448 (let* ((new-start (or (nth 8 ppss) p))
449 (new-end (progn
450 (goto-char new-start)
451 (condition-case nil
452 (if (memq (char-after) '(?\' ?\"))
453 (forward-sexp 1)
454 (forward-comment 1))
455 (scan-error (goto-char (point-max))))
456 (point))))
457 (opascal-token-of (opascal-literal-kind p) new-start new-end))))))
458
459 (defun opascal-point-token-at (p kind)
460 ;; Returns the single character token at the point p.
461 (opascal-token-of kind p (1+ p)))
462
463 (defsubst opascal-char-token-at (p char kind)
464 ;; Returns the token at the point p that describes the specified character.
465 ;; If not actually over such a character, nil is returned.
466 (when (eq char (char-after p))
467 (opascal-token-of kind p (1+ p))))
468
469 (defun opascal-charset-token-at (p charset kind)
470 ;; Returns the token surrounding point p that contains only members of the
471 ;; character set.
472 (let ((currp (point))
473 (end nil)
474 (token nil))
475 (goto-char p)
476 (when (> (skip-chars-forward charset) 0)
477 (setq end (point))
478 (goto-char (1+ p))
479 (skip-chars-backward charset)
480 (setq token (opascal-token-of kind (point) end)))
481 (goto-char currp)
482 token))
483
484 (defun opascal-space-token-at (p)
485 ;; If point p is surrounded by space characters, then return the token of the
486 ;; contiguous spaces.
487 (opascal-charset-token-at p opascal-space-chars 'space))
488
489 (defun opascal-word-token-at (p)
490 ;; If point p is over a word (i.e. identifier characters), then return a word
491 ;; token. If the word is actually a keyword, then return the keyword token.
492 (let ((word (opascal-charset-token-at p opascal-word-chars 'word)))
493 (when word
494 (let* ((word-image (downcase (opascal-token-string word)))
495 (keyword (intern-soft word-image)))
496 (when (and (or keyword (string= "nil" word-image))
497 (opascal-is keyword opascal-keywords))
498 (opascal-set-token-kind word keyword))
499 word))))
500
501 (defun opascal-explicit-token-at (p token-string kind)
502 ;; If point p is anywhere in the token string then returns the resulting
503 ;; token.
504 (let ((token (opascal-charset-token-at p token-string kind)))
505 (when (and token (string= token-string (opascal-token-string token)))
506 token)))
507
508 (defun opascal-token-at (p)
509 ;; Returns the token from parsing text at point p.
510 (when (and (<= (point-min) p) (<= p (point-max)))
511 (cond ((opascal-char-token-at p ?\n 'newline))
512
513 ((opascal-literal-token-at p))
514
515 ((opascal-space-token-at p))
516
517 ((opascal-word-token-at p))
518
519 ((opascal-char-token-at p ?\( 'open-group))
520 ((opascal-char-token-at p ?\) 'close-group))
521 ((opascal-char-token-at p ?\[ 'open-group))
522 ((opascal-char-token-at p ?\] 'close-group))
523 ((opascal-char-token-at p ?\; 'semicolon))
524 ((opascal-char-token-at p ?. 'dot))
525 ((opascal-char-token-at p ?, 'comma))
526 ((opascal-char-token-at p ?= 'equals))
527 ((opascal-char-token-at p ?+ 'plus))
528 ((opascal-char-token-at p ?- 'minus))
529 ((opascal-char-token-at p ?* 'times))
530 ((opascal-char-token-at p ?/ 'divides))
531 ((opascal-char-token-at p ?: 'colon))
532
533 ((opascal-explicit-token-at p "<>" 'not-equals))
534
535 ((opascal-point-token-at p 'punctuation)))))
536
537 (defun opascal-current-token ()
538 ;; Returns the opascal source token under the current point.
539 (opascal-token-at (point)))
540
541 (defun opascal-next-token (token)
542 ;; Returns the token after the specified token.
543 (when token
544 (let ((next (opascal-token-at (opascal-token-end token))))
545 (if next
546 (opascal-step-progress (opascal-token-start next) "Scanning"
547 opascal-scanning-progress-step))
548 next)))
549
550 (defun opascal-previous-token (token)
551 ;; Returns the token before the specified token.
552 (when token
553 (let ((previous (opascal-token-at (1- (opascal-token-start token)))))
554 (if previous
555 (opascal-step-progress (opascal-token-start previous) "Scanning"
556 opascal-scanning-progress-step))
557 previous)))
558
559 (defun opascal-next-visible-token (token)
560 ;; Returns the first non-space token after the specified token.
561 (let (next-token)
562 (while (progn
563 (setq next-token (opascal-next-token token))
564 (opascal-is (opascal-token-kind next-token) '(space newline))))
565 next-token))
566
567 (defun opascal-group-start (from-token)
568 ;; Returns the token that denotes the start of the ()/[] group.
569 (let ((token (opascal-previous-token from-token))
570 (token-kind nil))
571 (catch 'done
572 (while token
573 (setq token-kind (opascal-token-kind token))
574 (cond
575 ;; Skip over nested groups.
576 ((eq 'close-group token-kind) (setq token (opascal-group-start token)))
577 ((eq 'open-group token-kind) (throw 'done token)))
578 (setq token (opascal-previous-token token)))
579 ;; Start not found.
580 nil)))
581
582 (defun opascal-group-end (from-token)
583 ;; Returns the token that denotes the end of the ()/[] group.
584 (let ((token (opascal-next-token from-token))
585 (token-kind nil))
586 (catch 'done
587 (while token
588 (setq token-kind (opascal-token-kind token))
589 (cond
590 ;; Skip over nested groups.
591 ((eq 'open-group token-kind) (setq token (opascal-group-end token)))
592 ((eq 'close-group token-kind) (throw 'done token)))
593 (setq token (opascal-next-token token)))
594 ;; end not found.
595 nil)))
596
597 (defun opascal-indent-of (token &optional offset)
598 ;; Returns the start column of the token, plus any offset.
599 (let ((indent (+ (opascal-column-of (opascal-token-start token))
600 (if offset offset 0))))
601 (when opascal-debug
602 (opascal-debug-log
603 (concat "\n Indent of: %S %S"
604 "\n column: %d indent: %d offset: %d")
605 token (opascal-token-string token)
606 (opascal-column-of (opascal-token-start token))
607 indent (if offset offset 0)))
608 indent))
609
610 (defun opascal-line-indent-of (from-token &optional offset &rest terminators)
611 ;; Returns the column of first non-space character on the token's line, plus
612 ;; any offset. We also stop if one of the terminators or an open ( or [ is
613 ;; encountered.
614 (let ((token (opascal-previous-token from-token))
615 (last-token from-token)
616 (kind nil))
617 (catch 'done
618 (while token
619 (setq kind (opascal-token-kind token))
620 (cond
621 ;; Skip over ()/[] groups.
622 ((eq 'close-group kind) (setq token (opascal-group-start token)))
623
624 ;; Stop at the beginning of the line or an open group.
625 ((opascal-is kind '(newline open-group)) (throw 'done nil))
626
627 ;; Stop at one of the specified terminators.
628 ((opascal-is kind terminators) (throw 'done nil)))
629 (unless (opascal-is kind opascal-whitespace) (setq last-token token))
630 (setq token (opascal-previous-token token))))
631 (opascal-indent-of last-token offset)))
632
633 (defun opascal-stmt-line-indent-of (from-token &optional offset)
634 ;; Like `opascal-line-indent-of' except is also stops on a use clause, and
635 ;; colons that precede statements (i.e. case labels).
636 (let ((token (opascal-previous-token from-token))
637 (last-token from-token)
638 (kind nil))
639 (catch 'done
640 (while token
641 (setq kind (opascal-token-kind token))
642 (cond
643 ((and (eq 'colon kind)
644 (opascal-is (opascal-token-kind last-token)
645 `(,@opascal-block-statements
646 ,@opascal-expr-statements)))
647 ;; We hit a label followed by a statement. Indent to the statement.
648 (throw 'done nil))
649
650 ;; Skip over ()/[] groups.
651 ((eq 'close-group kind) (setq token (opascal-group-start token)))
652
653 ((opascal-is kind `(newline open-group ,@opascal-use-clauses))
654 ;; Stop at the beginning of the line, an open group, or a use clause
655 (throw 'done nil)))
656 (unless (opascal-is kind opascal-whitespace) (setq last-token token))
657 (setq token (opascal-previous-token token))))
658 (opascal-indent-of last-token offset)))
659
660 (defun opascal-open-group-indent (token last-token &optional offset)
661 ;; Returns the indent relative to an unmatched ( or [.
662 (when (eq 'open-group (opascal-token-kind token))
663 (if last-token
664 (opascal-indent-of last-token offset)
665 ;; There is nothing following the ( or [. Indent from its line.
666 (opascal-stmt-line-indent-of token opascal-indent-level))))
667
668 (defun opascal-composite-type-start (token last-token)
669 ;; Returns true (actually the last-token) if the pair equals (= class), (=
670 ;; dispinterface), (= interface), (= object), or (= record), and nil
671 ;; otherwise.
672 (if (and (eq 'equals (opascal-token-kind token))
673 (opascal-is (opascal-token-kind last-token) opascal-composite-types))
674 last-token))
675
676 (defun opascal-is-simple-class-type (at-token limit-token)
677 ;; True if at-token is the start of a simple class type. E.g.
678 ;; class of TClass;
679 ;; class (TBaseClass);
680 ;; class;
681 (when (opascal-is (opascal-token-kind at-token) opascal-class-types)
682 (catch 'done
683 ;; Scan until the semi colon.
684 (let ((token (opascal-next-token at-token))
685 (token-kind nil)
686 (limit (opascal-token-start limit-token)))
687 (while (and token (<= (opascal-token-start token) limit))
688 (setq token-kind (opascal-token-kind token))
689 (cond
690 ;; A semicolon delimits the search.
691 ((eq 'semicolon token-kind) (throw 'done token))
692
693 ;; Skip over the inheritance list.
694 ((eq 'open-group token-kind) (setq token (opascal-group-end token)))
695
696 ;; Only allow "of" and whitespace, and an identifier
697 ((opascal-is token-kind `(of word ,@opascal-whitespace)))
698
699 ;; Otherwise we are not in a simple class declaration.
700 ((throw 'done nil)))
701 (setq token (opascal-next-token token)))))))
702
703 (defun opascal-block-start (from-token &optional stop-on-class)
704 ;; Returns the token that denotes the start of the block.
705 (let ((token (opascal-previous-token from-token))
706 (last-token nil)
707 (token-kind nil))
708 (catch 'done
709 (while token
710 (setq token-kind (opascal-token-kind token))
711 (cond
712 ;; Skip over nested blocks.
713 ((opascal-is token-kind opascal-end-block-statements)
714 (setq token (opascal-block-start token)))
715
716 ;; Regular block start found.
717 ((opascal-is token-kind opascal-block-statements)
718 (throw 'done
719 ;; As a special case, when a "case" block appears
720 ;; within a record declaration (to denote a variant
721 ;; part), the record declaration should be considered
722 ;; the enclosing block.
723 (if (eq 'case token-kind)
724 (let ((enclosing-token
725 (opascal-block-start token
726 'stop-on-class)))
727 (if
728 (eq 'record
729 (opascal-token-kind enclosing-token))
730 (if stop-on-class
731 enclosing-token
732 (opascal-previous-token enclosing-token))
733 token))
734 token)))
735
736 ;; A class/record start also begins a block.
737 ((opascal-composite-type-start token last-token)
738 (throw 'done (if stop-on-class last-token token)))
739 )
740 (unless (opascal-is token-kind opascal-whitespace)
741 (setq last-token token))
742 (setq token (opascal-previous-token token)))
743 ;; Start not found.
744 nil)))
745
746 (defun opascal-else-start (from-else)
747 ;; Returns the token of the if or case statement.
748 (let ((token (opascal-previous-token from-else))
749 (token-kind nil)
750 (semicolon-count 0))
751 (catch 'done
752 (while token
753 (setq token-kind (opascal-token-kind token))
754 (cond
755 ;; Skip over nested groups.
756 ((eq 'close-group token-kind) (setq token (opascal-group-start token)))
757
758 ;; Skip over any nested blocks.
759 ((opascal-is token-kind opascal-end-block-statements)
760 (setq token (opascal-block-start token)))
761
762 ((eq 'semicolon token-kind)
763 ;; Semicolon means we are looking for an enclosing if, unless we
764 ;; are in a case statement. Keep counts of the semicolons and decide
765 ;; later.
766 (setq semicolon-count (1+ semicolon-count)))
767
768 ((and (eq 'if token-kind) (= semicolon-count 0))
769 ;; We only can match an if when there have been no intervening
770 ;; semicolons.
771 (throw 'done token))
772
773 ((eq 'case token-kind)
774 ;; We have hit a case statement start.
775 (throw 'done token)))
776 (setq token (opascal-previous-token token)))
777 ;; No if or case statement found.
778 nil)))
779
780 (defun opascal-comment-content-start (comment)
781 ;; Returns the point of the first non-space character in the comment.
782 (let ((kind (opascal-token-kind comment)))
783 (when (opascal-is kind opascal-comments)
784 (opascal-save-excursion
785 (goto-char (+ (opascal-token-start comment)
786 (length (opascal-literal-start-pattern kind))))
787 (skip-chars-forward opascal-space-chars)
788 (point)))))
789
790 (defun opascal-comment-block-start (comment)
791 ;; Returns the starting comment token of a contiguous // comment block. If
792 ;; the comment is multiline (i.e. {...} or (*...*)), the original comment is
793 ;; returned.
794 (if (not (eq 'comment-single-line (opascal-token-kind comment)))
795 comment
796 ;; Scan until we run out of // comments.
797 (let ((prev-comment comment)
798 (start-comment comment))
799 (while (let ((kind (opascal-token-kind prev-comment)))
800 (cond ((eq kind 'space))
801 ((eq kind 'comment-single-line)
802 (setq start-comment prev-comment))
803 (t nil)))
804 (setq prev-comment (opascal-previous-token prev-comment)))
805 start-comment)))
806
807 (defun opascal-comment-block-end (comment)
808 ;; Returns the end comment token of a contiguous // comment block. If the
809 ;; comment is multiline (i.e. {...} or (*...*)), the original comment is
810 ;; returned.
811 (if (not (eq 'comment-single-line (opascal-token-kind comment)))
812 comment
813 ;; Scan until we run out of // comments.
814 (let ((next-comment comment)
815 (end-comment comment))
816 (while (let ((kind (opascal-token-kind next-comment)))
817 (cond ((eq kind 'space))
818 ((eq kind 'comment-single-line)
819 (setq end-comment next-comment))
820 (t nil)))
821 (setq next-comment (opascal-next-token next-comment)))
822 end-comment)))
823
824 (defun opascal-on-first-comment-line (comment)
825 ;; Returns true if the current point is on the first line of the comment.
826 (save-excursion
827 (let ((comment-start (opascal-token-start comment))
828 (current-point (point)))
829 (goto-char comment-start)
830 (end-of-line)
831 (and (<= comment-start current-point) (<= current-point (point))))))
832
833 (defun opascal-comment-indent-of (comment)
834 ;; Returns the correct indentation for the comment.
835 (let ((start-comment (opascal-comment-block-start comment)))
836 (if (and (eq start-comment comment)
837 (opascal-on-first-comment-line comment))
838 ;; Indent as a statement.
839 (opascal-enclosing-indent-of comment)
840 (save-excursion
841 (let ((kind (opascal-token-kind comment)))
842 (beginning-of-line)
843 (cond ((eq 'comment-single-line kind)
844 ;; Indent to the first comment in the // block.
845 (opascal-indent-of start-comment))
846
847 ((looking-at (concat opascal-leading-spaces-re
848 (opascal-literal-stop-pattern kind)))
849 ;; Indent multi-line comment terminators to the comment start.
850 (opascal-indent-of comment))
851
852 ;; Indent according to the comment's content start.
853 ((opascal-column-of (opascal-comment-content-start comment)))))))
854 ))
855
856 (defun opascal-is-use-clause-end (at-token last-token last-colon from-kind)
857 ;; True if we are after the end of a uses type clause.
858 (when (and last-token
859 (not last-colon)
860 (eq 'comma (opascal-token-kind at-token))
861 (eq 'semicolon from-kind))
862 ;; Scan for the uses statement, just to be sure.
863 (let ((token (opascal-previous-token at-token))
864 (token-kind nil))
865 (catch 'done
866 (while token
867 (setq token-kind (opascal-token-kind token))
868 (cond ((opascal-is token-kind opascal-use-clauses)
869 (throw 'done t))
870
871 ;; Whitespace, identifiers, strings, "in" keyword, and commas
872 ;; are allowed in use clauses.
873 ((or (opascal-is token-kind '(word comma in newline))
874 (opascal-is token-kind opascal-whitespace)
875 (opascal-is token-kind opascal-strings)))
876
877 ;; Nothing else is.
878 ((throw 'done nil)))
879 (setq token (opascal-previous-token token)))
880 nil))))
881
882 (defun opascal-is-block-after-expr-statement (token)
883 ;; Returns true if we have a block token trailing an expression delimiter (of
884 ;; presumably an expression statement).
885 (when (opascal-is (opascal-token-kind token) opascal-block-statements)
886 (let ((previous (opascal-previous-token token))
887 (previous-kind nil))
888 (while (progn
889 (setq previous-kind (opascal-token-kind previous))
890 (eq previous-kind 'space))
891 (setq previous (opascal-previous-token previous)))
892 (or (opascal-is previous-kind opascal-expr-delimiters)
893 (eq previous-kind 'else)))))
894
895 (defun opascal-previous-indent-of (from-token)
896 ;; Returns the indentation of the previous statement of the token.
897 (let ((token (opascal-previous-token from-token))
898 (token-kind nil)
899 (from-kind (opascal-token-kind from-token))
900 (last-colon nil)
901 (last-of nil)
902 (last-token nil))
903 (catch 'done
904 (while token
905 (setq token-kind (opascal-token-kind token))
906 (cond
907 ;; An open ( or [ always is an indent point.
908 ((eq 'open-group token-kind)
909 (throw 'done (opascal-open-group-indent token last-token)))
910
911 ;; Skip over any ()/[] groups.
912 ((eq 'close-group token-kind) (setq token (opascal-group-start token)))
913
914 ((opascal-is token-kind opascal-end-block-statements)
915 (if (eq 'newline (opascal-token-kind (opascal-previous-token token)))
916 ;; We can stop at an end token that is right up against the
917 ;; margin.
918 (throw 'done 0)
919 ;; Otherwise, skip over any nested blocks.
920 (setq token (opascal-block-start token))))
921
922 ;; Special case: if we encounter a ", word;" then we assume that we
923 ;; are in some kind of uses clause, and thus indent to column 0. This
924 ;; works because no other constructs are known to have that form.
925 ;; This fixes the irritating case of having indents after a uses
926 ;; clause look like:
927 ;; uses
928 ;; someUnit,
929 ;; someOtherUnit;
930 ;; // this should be at column 0!
931 ((opascal-is-use-clause-end token last-token last-colon from-kind)
932 (throw 'done 0))
933
934 ;; A previous terminator means we can stop. If we are on a directive,
935 ;; however, then we are not actually encountering a new statement.
936 ((and last-token
937 (opascal-is token-kind opascal-previous-terminators)
938 (not (opascal-is (opascal-token-kind last-token)
939 opascal-directives)))
940 (throw 'done (opascal-stmt-line-indent-of last-token 0)))
941
942 ;; Ignore whitespace.
943 ((opascal-is token-kind opascal-whitespace))
944
945 ;; Remember any "of" we encounter, since that affects how we
946 ;; indent to a case statement within a record declaration
947 ;; (i.e. a variant part).
948 ((eq 'of token-kind)
949 (setq last-of token))
950
951 ;; Remember any ':' we encounter (until we reach an "of"),
952 ;; since that affects how we indent to case statements in
953 ;; general.
954 ((eq 'colon token-kind)
955 (unless last-of (setq last-colon token)))
956
957 ;; A case statement delimits a previous statement. We indent labels
958 ;; specially.
959 ((eq 'case token-kind)
960 (throw 'done
961 (if last-colon (opascal-line-indent-of last-colon)
962 (opascal-line-indent-of token opascal-case-label-indent))))
963
964 ;; If we are in a use clause then commas mark an enclosing rather than
965 ;; a previous statement.
966 ((opascal-is token-kind opascal-use-clauses)
967 (throw 'done
968 (if (eq 'comma from-kind)
969 (if last-token
970 ;; Indent to first unit in use clause.
971 (opascal-indent-of last-token)
972 ;; Indent from use clause keyword.
973 (opascal-line-indent-of token opascal-indent-level))
974 ;; Indent to use clause keyword.
975 (opascal-line-indent-of token))))
976
977 ;; Assembly sections always indent in from the asm keyword.
978 ((eq token-kind 'asm)
979 (throw 'done (opascal-stmt-line-indent-of token opascal-indent-level)))
980
981 ;; An enclosing statement delimits a previous statement.
982 ;; We try to use the existing indent of the previous statement,
983 ;; otherwise we calculate from the enclosing statement.
984 ((opascal-is token-kind opascal-previous-enclosing-statements)
985 (throw 'done (if last-token
986 ;; Otherwise indent to the last token
987 (opascal-line-indent-of last-token)
988 ;; Just indent from the enclosing keyword
989 (opascal-line-indent-of token opascal-indent-level))))
990
991 ;; A class or record declaration also delimits a previous statement.
992 ((opascal-composite-type-start token last-token)
993 (throw
994 'done
995 (if (opascal-is-simple-class-type last-token from-token)
996 ;; c = class; or c = class of T; are previous statements.
997 (opascal-line-indent-of token)
998 ;; Otherwise c = class ... or r = record ... are enclosing
999 ;; statements.
1000 (opascal-line-indent-of last-token opascal-indent-level))))
1001
1002 ;; We have a definite previous statement delimiter.
1003 ((opascal-is token-kind opascal-previous-statements)
1004 (throw 'done (opascal-stmt-line-indent-of token 0)))
1005 )
1006 (unless (opascal-is token-kind opascal-whitespace)
1007 (setq last-token token))
1008 (setq token (opascal-previous-token token)))
1009 ;; We ran out of tokens. Indent to column 0.
1010 0)))
1011
1012 (defun opascal-section-indent-of (section-token)
1013 ;; Returns the indentation appropriate for begin/var/const/type/label
1014 ;; tokens.
1015 (let* ((token (opascal-previous-token section-token))
1016 (token-kind nil)
1017 (last-token nil)
1018 (nested-block-count 0)
1019 (expr-delimited nil)
1020 (last-terminator nil))
1021 (catch 'done
1022 (while token
1023 (setq token-kind (opascal-token-kind token))
1024 (cond
1025 ;; Always stop at unmatched ( or [.
1026 ((eq token-kind 'open-group)
1027 (throw 'done (opascal-open-group-indent token last-token)))
1028
1029 ;; Skip over any ()/[] groups.
1030 ((eq 'close-group token-kind) (setq token (opascal-group-start token)))
1031
1032 ((opascal-is token-kind opascal-end-block-statements)
1033 (if (eq 'newline (opascal-token-kind (opascal-previous-token token)))
1034 ;; We can stop at an end token that is right up against the
1035 ;; margin.
1036 (throw 'done 0)
1037 ;; Otherwise, skip over any nested blocks.
1038 (setq token (opascal-block-start token)
1039 nested-block-count (1+ nested-block-count))))
1040
1041 ;; Remember if we have encountered any forward routine declarations.
1042 ((eq 'forward token-kind)
1043 (setq nested-block-count (1+ nested-block-count)))
1044
1045 ;; Mark the completion of a nested routine traversal.
1046 ((and (opascal-is token-kind opascal-routine-statements)
1047 (> nested-block-count 0))
1048 (setq nested-block-count (1- nested-block-count)))
1049
1050 ;; Remember if we have encountered any statement terminators.
1051 ((eq 'semicolon token-kind) (setq last-terminator token))
1052
1053 ;; Remember if we have encountered any expression delimiters.
1054 ((opascal-is token-kind opascal-expr-delimiters)
1055 (setq expr-delimited token))
1056
1057 ;; Enclosing body statements are delimiting. We indent the compound
1058 ;; bodies specially.
1059 ((and (not last-terminator)
1060 (opascal-is token-kind opascal-body-statements))
1061 (throw 'done
1062 (opascal-stmt-line-indent-of token opascal-compound-block-indent)))
1063
1064 ;; An enclosing ":" means a label.
1065 ((and (eq 'colon token-kind)
1066 (opascal-is (opascal-token-kind section-token)
1067 opascal-block-statements)
1068 (not last-terminator)
1069 (not expr-delimited)
1070 (not (eq 'equals (opascal-token-kind last-token))))
1071 (throw 'done
1072 (opascal-stmt-line-indent-of token opascal-indent-level)))
1073
1074 ;; Block and mid block tokens are always enclosing
1075 ((opascal-is token-kind opascal-begin-enclosing-tokens)
1076 (throw 'done
1077 (opascal-stmt-line-indent-of token opascal-indent-level)))
1078
1079 ;; Declaration sections and routines are delimiters, unless they
1080 ;; are part of a nested routine.
1081 ((and (opascal-is token-kind opascal-decl-delimiters)
1082 (= 0 nested-block-count))
1083 (throw 'done (opascal-line-indent-of token 0)))
1084
1085 ;; Unit statements mean we indent right to the left.
1086 ((opascal-is token-kind opascal-unit-statements) (throw 'done 0))
1087 )
1088 (unless (opascal-is token-kind opascal-whitespace)
1089 (setq last-token token))
1090 (setq token (opascal-previous-token token)))
1091 ;; We ran out of tokens. Indent to column 0.
1092 0)))
1093
1094 (defun opascal-enclosing-indent-of (from-token)
1095 ;; Returns the indentation offset from the enclosing statement of the token.
1096 (let ((token (opascal-previous-token from-token))
1097 (from-kind (opascal-token-kind from-token))
1098 (token-kind nil)
1099 (stmt-start nil)
1100 (last-token nil)
1101 (equals-encountered nil)
1102 (before-equals nil)
1103 (expr-delimited nil))
1104 (catch 'done
1105 (while token
1106 (setq token-kind (opascal-token-kind token))
1107 (cond
1108 ;; An open ( or [ always is an indent point.
1109 ((eq 'open-group token-kind)
1110 (throw 'done
1111 (opascal-open-group-indent
1112 token last-token
1113 (if (opascal-is from-kind opascal-binary-ops)
1114 ;; Keep binary operations aligned with the open group.
1115 0
1116 opascal-indent-level))))
1117
1118 ;; Skip over any ()/[] groups.
1119 ((eq 'close-group token-kind) (setq token (opascal-group-start token)))
1120
1121 ;; Skip over any nested blocks.
1122 ((opascal-is token-kind opascal-end-block-statements)
1123 (setq token (opascal-block-start token)))
1124
1125 ;; An expression delimiter affects indentation depending on whether
1126 ;; the point is before or after it. Remember that we encountered one.
1127 ;; Also remember the last encountered token, since if it exists it
1128 ;; should be the actual indent point.
1129 ((opascal-is token-kind opascal-expr-delimiters)
1130 (setq expr-delimited token stmt-start last-token))
1131
1132 ;; With a non-delimited expression statement we indent after the
1133 ;; statement's keyword, unless we are on the delimiter itself.
1134 ((and (not expr-delimited)
1135 (opascal-is token-kind opascal-expr-statements))
1136 (throw 'done
1137 (cond ((opascal-is from-kind opascal-expr-delimiters)
1138 ;; We are indenting a delimiter. Indent to the statement.
1139 (opascal-stmt-line-indent-of token 0))
1140
1141 ((and last-token (opascal-is from-kind opascal-binary-ops))
1142 ;; Align binary ops with the expression.
1143 (opascal-indent-of last-token))
1144
1145 (last-token
1146 ;; Indent in from the expression.
1147 (opascal-indent-of last-token opascal-indent-level))
1148
1149 ;; Indent in from the statement's keyword.
1150 ((opascal-indent-of token opascal-indent-level)))))
1151
1152 ;; A delimited case statement indents the label according to
1153 ;; a special rule.
1154 ((eq 'case token-kind)
1155 (throw 'done
1156 (if stmt-start
1157 ;; We are not actually indenting to the case statement,
1158 ;; but are within a label expression.
1159 (opascal-stmt-line-indent-of
1160 stmt-start opascal-indent-level)
1161 ;; Indent from the case keyword.
1162 (opascal-stmt-line-indent-of
1163 token opascal-case-label-indent))))
1164
1165 ;; Body expression statements are enclosing. Indent from the
1166 ;; statement's keyword, unless we have a non-block statement following
1167 ;; it.
1168 ((opascal-is token-kind opascal-body-expr-statements)
1169 (throw 'done
1170 (opascal-stmt-line-indent-of
1171 (or stmt-start token) opascal-indent-level)))
1172
1173 ;; An else statement is enclosing, but it doesn't have an expression.
1174 ;; Thus we take into account last-token instead of stmt-start.
1175 ((eq 'else token-kind)
1176 (throw 'done (opascal-stmt-line-indent-of
1177 (or last-token token) opascal-indent-level)))
1178
1179 ;; We indent relative to an enclosing declaration section.
1180 ((opascal-is token-kind opascal-decl-sections)
1181 (throw 'done (opascal-indent-of (if last-token last-token token)
1182 opascal-indent-level)))
1183
1184 ;; In unit sections we indent right to the left.
1185 ((opascal-is token-kind opascal-unit-sections)
1186 (throw 'done
1187 ;; Handle specially the case of "interface", which can be used
1188 ;; to start either a unit section or an interface definition.
1189 (if (opascal-is token-kind opascal-interface-types)
1190 (progn
1191 ;; Find the previous non-whitespace token.
1192 (while (progn
1193 (setq last-token token
1194 token (opascal-previous-token token)
1195 token-kind (opascal-token-kind token))
1196 (and token
1197 (opascal-is token-kind
1198 opascal-whitespace))))
1199 ;; If this token is an equals sign, "interface" is being
1200 ;; used to start an interface definition and we should
1201 ;; treat it as a composite type; otherwise, we should
1202 ;; consider it the start of a unit section.
1203 (if (and token (eq token-kind 'equals))
1204 (opascal-line-indent-of last-token
1205 opascal-indent-level)
1206 0))
1207 0)))
1208
1209 ;; A previous terminator means we can stop.
1210 ((opascal-is token-kind opascal-previous-terminators)
1211 (throw 'done
1212 (cond ((and last-token
1213 (eq 'comma token-kind)
1214 (opascal-is from-kind opascal-binary-ops))
1215 ;; Align binary ops with the expression.
1216 (opascal-indent-of last-token))
1217
1218 (last-token
1219 ;; Indent in from the expression.
1220 (opascal-indent-of last-token opascal-indent-level))
1221
1222 ;; No enclosing expression; use the previous statement's
1223 ;; indent.
1224 ((opascal-previous-indent-of token)))))
1225
1226 ;; A block statement after an expression delimiter has its start
1227 ;; column as the expression statement. E.g.
1228 ;; if (a = b)
1229 ;; and (a != c) then begin
1230 ;; //...
1231 ;; end;
1232 ;; Remember it for when we encounter the expression statement start.
1233 ((opascal-is-block-after-expr-statement token)
1234 (throw 'done
1235 (cond (last-token (opascal-indent-of last-token opascal-indent-level))
1236
1237 ((+ (opascal-section-indent-of token) opascal-indent-level)))))
1238
1239 ;; Assembly sections always indent in from the asm keyword.
1240 ((eq token-kind 'asm)
1241 (throw 'done (opascal-stmt-line-indent-of token opascal-indent-level)))
1242
1243 ;; Stop at an enclosing statement and indent from it.
1244 ((opascal-is token-kind opascal-enclosing-statements)
1245 (throw 'done (opascal-stmt-line-indent-of
1246 (or last-token token) opascal-indent-level)))
1247
1248 ;; A class/record declaration is also enclosing.
1249 ((opascal-composite-type-start token last-token)
1250 (throw 'done
1251 (opascal-line-indent-of last-token opascal-indent-level)))
1252
1253 ;; A ":" we indent relative to its line beginning. If we are in a
1254 ;; parameter list, then stop also if we hit a ";".
1255 ((and (eq token-kind 'colon)
1256 (not expr-delimited)
1257 (not (opascal-is from-kind opascal-expr-delimiters))
1258 (not equals-encountered)
1259 (not (eq from-kind 'equals)))
1260 (throw 'done
1261 (if last-token
1262 (opascal-indent-of last-token opascal-indent-level)
1263 (opascal-line-indent-of token opascal-indent-level 'semicolon))))
1264
1265 ;; If the ":" was not processed above and we have token after the "=",
1266 ;; then indent from the "=". Ignore :=, however.
1267 ((and (eq token-kind 'colon) equals-encountered before-equals)
1268 (cond
1269 ;; Ignore binary ops for now. It would do, for example:
1270 ;; val := 1 + 2
1271 ;; + 3;
1272 ;; which is good, but also
1273 ;; val := Foo
1274 ;; (foo, args)
1275 ;; + 2;
1276 ;; which doesn't look right.
1277 ;;;; Align binary ops with the before token.
1278 ;;((opascal-is from-kind opascal-binary-ops)
1279 ;;(throw 'done (opascal-indent-of before-equals 0)))
1280
1281 ;; Assignments (:=) we skip over to get a normal indent.
1282 ((eq (opascal-token-kind last-token) 'equals))
1283
1284 ;; Otherwise indent in from the equals.
1285 ((throw 'done
1286 (opascal-indent-of before-equals opascal-indent-level)))))
1287
1288 ;; Remember any "=" we encounter if it has not already been processed.
1289 ((eq token-kind 'equals)
1290 (setq equals-encountered token
1291 before-equals last-token))
1292 )
1293 (unless (opascal-is token-kind opascal-whitespace)
1294 (setq last-token token))
1295 (setq token (opascal-previous-token token)))
1296 ;; We ran out of tokens. Indent to column 0.
1297 0)))
1298
1299 (defun opascal-corrected-indentation ()
1300 ;; Returns the corrected indentation for the current line.
1301 (opascal-save-excursion
1302 (opascal-progress-start)
1303 ;; Move to the first token on the line.
1304 (beginning-of-line)
1305 (skip-chars-forward opascal-space-chars)
1306 (let* ((token (opascal-current-token))
1307 (token-kind (opascal-token-kind token))
1308 (indent
1309 (cond ((eq 'close-group token-kind)
1310 ;; Indent to the matching start ( or [.
1311 (opascal-indent-of (opascal-group-start token)))
1312
1313 ((opascal-is token-kind opascal-unit-statements) 0)
1314
1315 ((opascal-is token-kind opascal-comments)
1316 ;; In a comment.
1317 (opascal-comment-indent-of token))
1318
1319 ((opascal-is token-kind opascal-decl-matchers)
1320 ;; Use a previous section/routine's indent.
1321 (opascal-section-indent-of token))
1322
1323 ((opascal-is token-kind opascal-match-block-statements)
1324 ;; Use the block's indentation.
1325 (let ((block-start
1326 (opascal-block-start token 'stop-on-class)))
1327 (cond
1328 ;; When trailing a body statement, indent to
1329 ;; the statement's keyword.
1330 ((opascal-is-block-after-expr-statement block-start)
1331 (opascal-section-indent-of block-start))
1332
1333 ;; Otherwise just indent to the block start.
1334 ((opascal-stmt-line-indent-of block-start 0)))))
1335
1336 ((eq 'else token-kind)
1337 ;; Find the start of the if or case statement.
1338 (opascal-stmt-line-indent-of (opascal-else-start token) 0))
1339
1340 ;; Otherwise indent in from enclosing statement.
1341 ((opascal-enclosing-indent-of
1342 (if token token (opascal-token-at (1- (point)))))))))
1343 (opascal-progress-done)
1344 indent)))
1345
1346 (defun opascal-indent-line ()
1347 "Indent the current line according to the current language construct.
1348 If before the indent, the point is moved to the indent."
1349 (interactive)
1350 (save-match-data
1351 (let ((marked-point (point-marker)) ; Maintain our position reliably.
1352 (line-start nil)
1353 (old-indent 0)
1354 (new-indent 0))
1355 (beginning-of-line)
1356 (setq line-start (point))
1357 (skip-chars-forward opascal-space-chars)
1358 (setq old-indent (current-column))
1359 (setq new-indent (opascal-corrected-indentation))
1360 (if (< marked-point (point))
1361 ;; If before the indent column, then move to it.
1362 (set-marker marked-point (point)))
1363 ;; Advance our marked point after inserted spaces.
1364 (set-marker-insertion-type marked-point t)
1365 (when (/= old-indent new-indent)
1366 (delete-region line-start (point))
1367 (insert (make-string new-indent ?\s)))
1368 (goto-char marked-point)
1369 (set-marker marked-point nil))))
1370
1371 (defvar opascal-mode-abbrev-table nil
1372 "Abbrev table in use in OPascal mode buffers.")
1373 (define-abbrev-table 'opascal-mode-abbrev-table ())
1374
1375 (defmacro opascal-ensure-buffer (buffer-var buffer-name)
1376 ;; Ensures there exists a buffer of the specified name in the specified
1377 ;; variable.
1378 `(when (not (buffer-live-p ,buffer-var))
1379 (setq ,buffer-var (get-buffer-create ,buffer-name))))
1380
1381 (defun opascal-log-msg (to-buffer the-msg)
1382 ;; Writes a message to the end of the specified buffer.
1383 (with-current-buffer to-buffer
1384 (save-selected-window
1385 (switch-to-buffer-other-window to-buffer)
1386 (goto-char (point-max))
1387 (set-window-point (get-buffer-window to-buffer) (point))
1388 (insert the-msg))))
1389
1390 ;; Debugging helpers:
1391
1392 (defvar opascal-debug-buffer nil
1393 "Buffer to write OPascal mode debug messages to. Created on demand.")
1394
1395 (defun opascal-debug-log (format-string &rest args)
1396 ;; Writes a message to the log buffer.
1397 (when opascal-debug
1398 (opascal-ensure-buffer opascal-debug-buffer "*OPascal Debug Log*")
1399 (opascal-log-msg opascal-debug-buffer
1400 (concat (format-time-string "%H:%M:%S ")
1401 (apply #'format (cons format-string args))
1402 "\n"))))
1403
1404 (defun opascal-debug-token-string (token)
1405 (let* ((image (opascal-token-string token))
1406 (has-newline (string-match "^\\([^\n]*\\)\n\\(.+\\)?$" image)))
1407 (when has-newline
1408 (setq image (concat (match-string 1 image)
1409 (if (match-beginning 2) "..."))))
1410 image))
1411
1412 (defun opascal-debug-show-current-token ()
1413 (interactive)
1414 (let ((token (opascal-current-token)))
1415 (opascal-debug-log "Token: %S %S" token (opascal-debug-token-string token))))
1416
1417 (defun opascal-debug-goto-point (p)
1418 (interactive "NGoto char: ")
1419 (goto-char p))
1420
1421 (defun opascal-debug-goto-next-token ()
1422 (interactive)
1423 (goto-char (opascal-token-start (opascal-next-token (opascal-current-token)))))
1424
1425 (defun opascal-debug-goto-previous-token ()
1426 (interactive)
1427 (goto-char
1428 (opascal-token-start (opascal-previous-token (opascal-current-token)))))
1429
1430 (defun opascal-debug-show-current-string (from to)
1431 (interactive "r")
1432 (opascal-debug-log "String: %S" (buffer-substring from to)))
1433
1434 (defun opascal-debug-tokenize-region (from to)
1435 (interactive)
1436 (opascal-save-excursion
1437 (opascal-progress-start)
1438 (goto-char from)
1439 (while (< (point) to)
1440 (goto-char (opascal-token-end (opascal-current-token)))
1441 (opascal-step-progress (point) "Tokenizing" opascal-scanning-progress-step))
1442 (opascal-progress-done "Tokenizing done")))
1443
1444 (defun opascal-debug-tokenize-buffer ()
1445 (interactive)
1446 (opascal-debug-tokenize-region (point-min) (point-max)))
1447
1448 (defun opascal-debug-tokenize-window ()
1449 (interactive)
1450 (opascal-debug-tokenize-region (window-start) (window-end)))
1451
1452
1453 (defun opascal-tab ()
1454 "Indent the region, if Transient Mark mode is on and the region is active.
1455 Otherwise, indent the current line or insert a TAB, depending on the
1456 value of `opascal-tab-always-indents' and the current line position."
1457 (interactive)
1458 (cond ((use-region-p)
1459 ;; If Transient Mark mode is enabled and the region is active, indent
1460 ;; the entire region.
1461 (indent-region (region-beginning) (region-end)))
1462 ((or opascal-tab-always-indents
1463 (save-excursion (skip-chars-backward opascal-space-chars) (bolp)))
1464 ;; Otherwise, if we are configured always to indent (regardless of the
1465 ;; point's position in the line) or we are before the first non-space
1466 ;; character on the line, indent the line.
1467 (opascal-indent-line))
1468 (t
1469 ;; Otherwise, insert a tab character.
1470 (insert "\t"))))
1471
1472 (make-obsolete 'opascal-tab 'indent-for-tab-command "24.4")
1473
1474 (defun opascal-is-directory (path)
1475 ;; True if the specified path is an existing directory.
1476 (let ((attributes (file-attributes path)))
1477 (and attributes (car attributes))))
1478
1479 (defun opascal-is-file (path)
1480 ;; True if the specified file exists as a file.
1481 (let ((attributes (file-attributes path)))
1482 (and attributes (null (car attributes)))))
1483
1484 (defun opascal-search-directory (unit dir &optional recurse)
1485 ;; Searches for the unit in the specified directory. If recurse is true, then
1486 ;; the directory is recursively searched. File name comparison is done in a
1487 ;; case insensitive manner.
1488 (when (opascal-is-directory dir)
1489 (let ((files (directory-files dir))
1490 (unit-file (downcase unit)))
1491 (catch 'done
1492 ;; Search for the file.
1493 (dolist (file files)
1494 (let ((path (concat dir "/" file)))
1495 (if (and (string= unit-file (downcase file))
1496 (opascal-is-file path))
1497 (throw 'done path))))
1498
1499 ;; Not found. Search subdirectories.
1500 (when recurse
1501 (dolist (subdir files)
1502 (unless (member subdir '("." ".."))
1503 (let ((path (opascal-search-directory
1504 unit (concat dir "/" subdir) recurse)))
1505 (if path (throw 'done path))))))
1506
1507 ;; Not found.
1508 nil))))
1509
1510
1511 (defun opascal-find-unit-in-directory (unit dir)
1512 ;; Searches for the unit in the specified directory. If the directory ends
1513 ;; in \"...\", then it is recursively searched.
1514 (let ((dir-name dir)
1515 (recurse nil))
1516 ;; Check if we need to recursively search the directory.
1517 (if (string-match "^\\(.+\\)\\.\\.\\.$" dir-name)
1518 (setq dir-name (match-string 1 dir-name)
1519 recurse t))
1520 ;; Ensure the trailing slash is removed.
1521 (if (string-match "^\\(.+\\)[\\\\/]$" dir-name)
1522 (setq dir-name (match-string 1 dir-name)))
1523 (opascal-search-directory unit dir-name recurse)))
1524
1525 (defun opascal-find-unit-file (unit)
1526 ;; Finds the specified opascal source file according to `opascal-search-path'.
1527 ;; If found, the full path is returned, otherwise nil is returned.
1528 (catch 'done
1529 (cond ((null opascal-search-path)
1530 (opascal-find-unit-in-directory unit "."))
1531
1532 ((stringp opascal-search-path)
1533 (opascal-find-unit-in-directory unit opascal-search-path))
1534
1535 ((dolist (dir opascal-search-path)
1536 (let ((file (opascal-find-unit-in-directory unit dir)))
1537 (if file (throw 'done file))))))
1538 nil))
1539
1540 (defun opascal-find-unit (unit)
1541 "Find the specified OPascal source file according to `opascal-search-path'.
1542 If no extension is specified, .pas is assumed. Creates a buffer for the unit."
1543 (interactive "sOPascal unit name: ")
1544 (let* ((unit-file (if (string-match "^\\(.*\\)\\.[a-z]+$" unit)
1545 unit
1546 (concat unit ".pas")))
1547 (file (opascal-find-unit-file unit-file)))
1548 (if (null file)
1549 (error "unit not found: %s" unit-file)
1550 (find-file file)
1551 (if (not (derived-mode-p 'opascal-mode))
1552 (opascal-mode)))
1553 file))
1554
1555 (defun opascal-find-current-def ()
1556 "Find the definition of the identifier under the current point."
1557 (interactive)
1558 (error "opascal-find-current-def: not implemented yet"))
1559
1560 (defun opascal-find-current-xdef ()
1561 "Find the definition of the identifier under the current point, searching
1562 in external units if necessary (as listed in the current unit's use clause).
1563 The set of directories to search for a unit is specified by the global variable
1564 `opascal-search-path'."
1565 (interactive)
1566 (error "opascal-find-current-xdef: not implemented yet"))
1567
1568 (defun opascal-find-current-body ()
1569 "Find the body of the identifier under the current point, assuming
1570 it is a routine."
1571 (interactive)
1572 (error "opascal-find-current-body: not implemented yet"))
1573
1574 (defun opascal-fill-comment ()
1575 "Fill the text of the current comment, according to `fill-column'.
1576 An error is raised if not in a comment."
1577 (interactive)
1578 (save-excursion
1579 (save-restriction
1580 (let* ((comment (opascal-current-token))
1581 (comment-kind (opascal-token-kind comment)))
1582 (if (not (opascal-is comment-kind opascal-comments))
1583 (error "Not in a comment")
1584 (let* ((start-comment (opascal-comment-block-start comment))
1585 (end-comment (opascal-comment-block-end comment))
1586 ;; FIXME: Don't abuse global variables like `comment-end/start'.
1587 (comment-start (opascal-token-start start-comment))
1588 (comment-end (opascal-token-end end-comment))
1589 (content-start (opascal-comment-content-start start-comment))
1590 (content-indent (opascal-column-of content-start))
1591 (content-prefix (make-string content-indent ?\s))
1592 (content-prefix-re opascal-leading-spaces-re)
1593 (p nil)
1594 (marked-point (point-marker))) ; Maintain our position reliably.
1595 (when (eq 'comment-single-line comment-kind)
1596 ;; // style comments need more work.
1597 (setq content-prefix
1598 (let ((comment-indent (opascal-column-of comment-start)))
1599 (concat (make-string comment-indent ?\s) "//"
1600 (make-string (- content-indent comment-indent 2)
1601 ?\s)))
1602 content-prefix-re (concat opascal-leading-spaces-re
1603 "//"
1604 opascal-spaces-re)
1605 comment-end (if (opascal-is-literal-end comment-end)
1606 ;; Don't include the trailing newline.
1607 (1- comment-end)
1608 comment-end)))
1609
1610 ;; Advance our marked point after inserted spaces.
1611 (set-marker-insertion-type marked-point t)
1612
1613 ;; Ensure we can modify the buffer
1614 (goto-char content-start)
1615 (insert " ")
1616 (delete-char -1)
1617
1618 (narrow-to-region content-start comment-end)
1619
1620 ;; Strip off the comment prefixes
1621 (setq p (point-min))
1622 (while (when (< p (point-max))
1623 (goto-char p)
1624 (re-search-forward content-prefix-re nil t))
1625 (replace-match "" nil nil)
1626 (setq p (1+ (point))))
1627
1628 ;; add an extra line to prevent the fill from doing it for us.
1629 (goto-char (point-max))
1630 (insert "\n")
1631
1632 ;; Fill the comment contents.
1633 (let ((fill-column (- fill-column content-indent)))
1634 (fill-region (point-min) (point-max)))
1635
1636 (goto-char (point-max))
1637 (delete-char -1)
1638
1639 ;; Restore comment prefixes.
1640 (goto-char (point-min))
1641 (end-of-line) ; Don't reset the first line.
1642 (setq p (point))
1643 (while (when (< p (point-max))
1644 (goto-char p)
1645 (re-search-forward "^" nil t))
1646 (replace-match content-prefix nil nil)
1647 (setq p (1+ (point))))
1648
1649 (setq comment-end (point-max))
1650 (widen)
1651
1652 ;; Restore our position
1653 (goto-char marked-point)
1654 (set-marker marked-point nil)))))))
1655
1656 (defun opascal-new-comment-line ()
1657 "If in a // comment, do a newline, indented such that one is still in the
1658 comment block. If not in a // comment, just does a normal newline."
1659 (interactive)
1660 (let ((comment (opascal-current-token)))
1661 (if (not (eq 'comment-single-line (opascal-token-kind comment)))
1662 ;; Not in a // comment. Just do the normal newline.
1663 (newline)
1664 (let* ((start-comment (opascal-comment-block-start comment))
1665 (comment-start (opascal-token-start start-comment))
1666 (content-start (opascal-comment-content-start start-comment))
1667 (prefix
1668 (concat (make-string (opascal-column-of comment-start) ?\s) "//"
1669 (make-string (- content-start comment-start 2) ?\s))))
1670 (delete-horizontal-space)
1671 (insert "\n" prefix)))))
1672
1673 (defun opascal-match-token (token limit)
1674 ;; Sets the match region used by (match-string 0) and friends to the token's
1675 ;; region. Sets the current point to the end of the token (or limit).
1676 (set-match-data nil)
1677 (if token
1678 (let ((end (min (opascal-token-end token) limit)))
1679 (set-match-data (list (opascal-token-start token) end))
1680 (goto-char end)
1681 token)))
1682
1683 (defconst opascal-font-lock-keywords
1684 `(("\\_<\\(function\\|pro\\(cedure\\|gram\\)\\)[ \t]+\\([[:alpha:]][[:alnum:]_]*\\)"
1685 (1 font-lock-keyword-face) (3 font-lock-function-name-face))
1686 ,(concat "\\_<" (regexp-opt (mapcar #'symbol-name opascal-keywords))
1687 "\\_>")))
1688
1689 (defconst opascal-font-lock-defaults
1690 '(opascal-font-lock-keywords
1691 nil ; Syntactic fontification does apply.
1692 nil ; Don't care about case since we don't use regexps to find tokens.
1693 nil ; Syntax alists don't apply.
1694 nil ; Syntax begin movement doesn't apply.
1695 )
1696 "OPascal mode font-lock defaults. Syntactic fontification is ignored.")
1697
1698 (defconst opascal--syntax-propertize
1699 (syntax-propertize-rules
1700 ;; The syntax-table settings are too coarse and end up treating /* and (/
1701 ;; as comment starters. Fix it here by removing the "2" from the syntax
1702 ;; of the second char of such sequences.
1703 ("/\\(\\*\\)" (1 ". 3b"))
1704 ("(\\(\\/\\)" (1 (prog1 ". 1c" (forward-char -1) nil)))
1705 ;; Pascal uses '' and "" rather than \' and \" to escape quotes.
1706 ("''\\|\"\"" (0 (if (save-excursion
1707 (nth 3 (syntax-ppss (match-beginning 0))))
1708 (string-to-syntax ".")
1709 ;; In case of 3 or more quotes in a row, only advance
1710 ;; one quote at a time.
1711 (forward-char -1)
1712 nil)))))
1713
1714 (defvar opascal-debug-mode-map
1715 (let ((kmap (make-sparse-keymap)))
1716 (dolist (binding '(("n" opascal-debug-goto-next-token)
1717 ("p" opascal-debug-goto-previous-token)
1718 ("t" opascal-debug-show-current-token)
1719 ("T" opascal-debug-tokenize-buffer)
1720 ("W" opascal-debug-tokenize-window)
1721 ("g" opascal-debug-goto-point)
1722 ("s" opascal-debug-show-current-string)))
1723 (define-key kmap (car binding) (cadr binding)))
1724 kmap)
1725 "Keystrokes for OPascal mode debug commands.")
1726
1727 (defvar opascal-mode-map
1728 (let ((kmap (make-sparse-keymap)))
1729 (dolist (binding
1730 (list ;; '("\C-cd" opascal-find-current-def)
1731 ;; '("\C-cx" opascal-find-current-xdef)
1732 ;; '("\C-cb" opascal-find-current-body)
1733 '("\C-cu" opascal-find-unit)
1734 '("\M-q" opascal-fill-comment)
1735 '("\M-j" opascal-new-comment-line)
1736 ;; Debug bindings:
1737 (list "\C-c\C-d" opascal-debug-mode-map)))
1738 (define-key kmap (car binding) (cadr binding)))
1739 kmap)
1740 "Keymap used in OPascal mode.")
1741
1742 (define-obsolete-variable-alias 'delphi-mode-hook 'opascal-mode-hook "24.4")
1743 ;;;###autoload
1744 (define-obsolete-function-alias 'delphi-mode 'opascal-mode "24.4")
1745 ;;;###autoload
1746 (define-derived-mode opascal-mode prog-mode "OPascal"
1747 "Major mode for editing OPascal code.\\<opascal-mode-map>
1748 \\[opascal-find-unit]\t- Search for a OPascal source file.
1749 \\[opascal-fill-comment]\t- Fill the current comment.
1750 \\[opascal-new-comment-line]\t- If in a // comment, do a new comment line.
1751
1752 \\[indent-region] also works for indenting a whole region.
1753
1754 Customization:
1755
1756 `opascal-indent-level' (default 3)
1757 Indentation of OPascal statements with respect to containing block.
1758 `opascal-compound-block-indent' (default 0)
1759 Extra indentation for blocks in compound statements.
1760 `opascal-case-label-indent' (default 0)
1761 Extra indentation for case statement labels.
1762 `opascal-search-path' (default .)
1763 Directories to search when finding external units.
1764 `opascal-verbose' (default nil)
1765 If true then OPascal token processing progress is reported to the user.
1766
1767 Coloring:
1768
1769 `opascal-keyword-face' (default `font-lock-keyword-face')
1770 Face used to color OPascal keywords."
1771
1772 ;; Buffer locals:
1773 (setq-local indent-line-function #'opascal-indent-line)
1774 (setq-local comment-indent-function #'opascal-indent-line)
1775 (setq-local case-fold-search t)
1776 (setq-local opascal-progress-last-reported-point nil)
1777 (setq-local font-lock-defaults opascal-font-lock-defaults)
1778 (setq-local tab-always-indent opascal-tab-always-indents)
1779 (setq-local syntax-propertize-function opascal--syntax-propertize)
1780
1781 (setq-local comment-start "// ")
1782 (setq-local comment-start-skip "\\(?://\\|(\\*\\|{\\)[ \t]*")
1783 (setq-local comment-end-skip "[ \t]*\\(?:\n\\|\\*)\\|}\\)"))
1784
1785 (provide 'opascal)
1786 ;;; opascal.el ends here