Mercurial > emacs
comparison lisp/progmodes/ada-mode.el @ 106903:257da94c161b
* ada-mode.el: Really fix bug#5400 (comment in r99362 was erroneous).
(ada-matching-decl-start-re): Move into ada-goto-decl-start.
(ada-goto-decl-start): Rename from ada-goto-matching-decl-start; callers
changed. Delete RECURSIVE parameter; never used. Improve doc string.
Improve comments in "is" portion. Handle null procedure declaration.
(ada-move-to-end): Improve doc string.
author | Juanma Barranquero <lekktu@gmail.com> |
---|---|
date | Tue, 19 Jan 2010 00:10:57 +0100 |
parents | 908cefda5ea2 |
children | 368fd338fecd |
comparison
equal
deleted
inserted
replaced
106902:1748839af981 | 106903:257da94c161b |
---|---|
674 (regexp-opt | 674 (regexp-opt |
675 '("end" "loop" "select" "begin" "case" "do" "declare" | 675 '("end" "loop" "select" "begin" "case" "do" "declare" |
676 "if" "task" "package" "procedure" "function" "record" "protected") t) | 676 "if" "task" "package" "procedure" "function" "record" "protected") t) |
677 "\\>")) | 677 "\\>")) |
678 "Regexp used in `ada-goto-matching-start'.") | 678 "Regexp used in `ada-goto-matching-start'.") |
679 | |
680 (defvar ada-matching-decl-start-re | |
681 (eval-when-compile | |
682 (concat "\\<" | |
683 (regexp-opt | |
684 '("is" "separate" "end" "declare" "if" "new" "begin" "generic" "when") t) | |
685 "\\>")) | |
686 "Regexp used in `ada-goto-matching-decl-start'.") | |
687 | 679 |
688 (defvar ada-loop-start-re | 680 (defvar ada-loop-start-re |
689 "\\<\\(for\\|while\\|loop\\)\\>" | 681 "\\<\\(for\\|while\\|loop\\)\\>" |
690 "Regexp for the start of a loop.") | 682 "Regexp for the start of a loop.") |
691 | 683 |
2474 ;;--------------------------- | 2466 ;;--------------------------- |
2475 | 2467 |
2476 ((and (= (downcase (char-after)) ?b) | 2468 ((and (= (downcase (char-after)) ?b) |
2477 (looking-at "begin\\>")) | 2469 (looking-at "begin\\>")) |
2478 (save-excursion | 2470 (save-excursion |
2479 (if (ada-goto-matching-decl-start t) | 2471 (if (ada-goto-decl-start t) |
2480 (list (progn (back-to-indentation) (point)) 0) | 2472 (list (progn (back-to-indentation) (point)) 0) |
2481 (ada-indent-on-previous-lines nil orgpoint orgpoint)))) | 2473 (ada-indent-on-previous-lines nil orgpoint orgpoint)))) |
2482 | 2474 |
2483 ;;--------------------------- | 2475 ;;--------------------------- |
2484 ;; starting with i (is) | 2476 ;; starting with i (is) |
2853 (save-excursion | 2845 (save-excursion |
2854 (ada-goto-matching-start 0) | 2846 (ada-goto-matching-start 0) |
2855 (if (looking-at "\\<begin\\>") | 2847 (if (looking-at "\\<begin\\>") |
2856 (progn | 2848 (progn |
2857 (setq indent (list (point) 0)) | 2849 (setq indent (list (point) 0)) |
2858 (if (ada-goto-matching-decl-start t) | 2850 (if (ada-goto-decl-start t) |
2859 (list (progn (back-to-indentation) (point)) 0) | 2851 (list (progn (back-to-indentation) (point)) 0) |
2860 indent)) | 2852 indent)) |
2861 (list (progn (back-to-indentation) (point)) 0) | 2853 (list (progn (back-to-indentation) (point)) 0) |
2862 ))) | 2854 ))) |
2863 ;; | 2855 ;; |
3419 | 3411 |
3420 (if found | 3412 (if found |
3421 match-dat | 3413 match-dat |
3422 nil))) | 3414 nil))) |
3423 | 3415 |
3424 | |
3425 (defun ada-goto-next-non-ws (&optional limit skip-goto-label) | 3416 (defun ada-goto-next-non-ws (&optional limit skip-goto-label) |
3426 "Skip to next non-whitespace character. | 3417 "Skip to next non-whitespace character. |
3427 Skips spaces, newlines and comments, and possibly goto labels. | 3418 Skips spaces, newlines and comments, and possibly goto labels. |
3428 Return `point' if moved, nil if not. | 3419 Return `point' if moved, nil if not. |
3429 Stop the search at LIMIT. | 3420 Stop the search at LIMIT. |
3500 ;; named block without a `declare'; ada-goto-matching-start leaves | 3491 ;; named block without a `declare'; ada-goto-matching-start leaves |
3501 ;; point at start of 'begin' for a block. | 3492 ;; point at start of 'begin' for a block. |
3502 (if (save-excursion | 3493 (if (save-excursion |
3503 (ada-goto-previous-word) | 3494 (ada-goto-previous-word) |
3504 (looking-at (concat "\\<" defun-name "\\> *:"))) | 3495 (looking-at (concat "\\<" defun-name "\\> *:"))) |
3505 t ; do nothing | 3496 t ; name matches |
3506 ;; else | 3497 ;; else |
3507 ;; | 3498 ;; |
3508 ;; 'accept' or 'package' ? | 3499 ;; 'accept' or 'package' ? |
3509 ;; | 3500 ;; |
3510 (unless (looking-at ada-subprog-start-re) | 3501 (unless (looking-at ada-subprog-start-re) |
3511 (ada-goto-matching-decl-start)) | 3502 (ada-goto-decl-start)) |
3512 ;; | 3503 ;; |
3513 ;; 'begin' of 'procedure'/'function'/'task' or 'declare' | 3504 ;; 'begin' of 'procedure'/'function'/'task' or 'declare' |
3514 ;; | 3505 ;; |
3515 (save-excursion | 3506 (save-excursion |
3516 ;; | 3507 ;; |
3539 (unless (looking-at (concat "\\<" defun-name "\\>")) | 3530 (unless (looking-at (concat "\\<" defun-name "\\>")) |
3540 (error "Matching defun has different name: %s" | 3531 (error "Matching defun has different name: %s" |
3541 (buffer-substring (point) | 3532 (buffer-substring (point) |
3542 (progn (forward-sexp 1) (point)))))))) | 3533 (progn (forward-sexp 1) (point)))))))) |
3543 | 3534 |
3544 (defun ada-goto-matching-decl-start (&optional noerror recursive) | 3535 (defun ada-goto-decl-start (&optional noerror) |
3545 "Move point to the matching declaration start of the current 'begin'. | 3536 "Move point to the declaration start of the current construct. |
3546 If NOERROR is non-nil, it only returns nil if no match was found." | 3537 If NOERROR is non-nil, return nil if no match was found; |
3538 otherwise throw error." | |
3547 (let ((nest-count 1) | 3539 (let ((nest-count 1) |
3540 (regexp (eval-when-compile | |
3541 (concat "\\<" | |
3542 (regexp-opt | |
3543 '("is" "separate" "end" "declare" "if" "new" "begin" "generic" "when") t) | |
3544 "\\>"))) | |
3548 | 3545 |
3549 ;; first should be set to t if we should stop at the first | 3546 ;; first should be set to t if we should stop at the first |
3550 ;; "begin" we encounter. | 3547 ;; "begin" we encounter. |
3551 (first (not recursive)) | 3548 (first t) |
3552 (count-generic nil) | 3549 (count-generic nil) |
3553 (stop-at-when nil) | 3550 (stop-at-when nil) |
3554 ) | 3551 ) |
3555 | 3552 |
3556 ;; Ignore "when" most of the time, except if we are looking at the | 3553 ;; Ignore "when" most of the time, except if we are looking at the |
3570 (setq count-generic t)) | 3567 (setq count-generic t)) |
3571 | 3568 |
3572 ;; search backward for interesting keywords | 3569 ;; search backward for interesting keywords |
3573 (while (and | 3570 (while (and |
3574 (not (zerop nest-count)) | 3571 (not (zerop nest-count)) |
3575 (ada-search-ignore-string-comment ada-matching-decl-start-re t)) | 3572 (ada-search-ignore-string-comment regexp t)) |
3576 ;; | 3573 ;; |
3577 ;; calculate nest-depth | 3574 ;; calculate nest-depth |
3578 ;; | 3575 ;; |
3579 (cond | 3576 (cond |
3580 ;; | 3577 ;; |
3603 "\\<\\(declare\\|begin\\|end\\|procedure\\|function\\|task\\|package\\)\\>" | 3600 "\\<\\(declare\\|begin\\|end\\|procedure\\|function\\|task\\|package\\)\\>" |
3604 t) | 3601 t) |
3605 | 3602 |
3606 (if (looking-at "end") | 3603 (if (looking-at "end") |
3607 (ada-goto-matching-start 1 noerror t) | 3604 (ada-goto-matching-start 1 noerror t) |
3608 ;; (ada-goto-matching-decl-start noerror t) | |
3609 | 3605 |
3610 (setq loop-again nil) | 3606 (setq loop-again nil) |
3611 (unless (looking-at "begin") | 3607 (unless (looking-at "begin") |
3612 (setq nest-count (1+ nest-count)))) | 3608 (setq nest-count (1+ nest-count)))) |
3613 )) | 3609 )) |
3631 ((looking-at "declare\\|generic") | 3627 ((looking-at "declare\\|generic") |
3632 (setq nest-count (1- nest-count)) | 3628 (setq nest-count (1- nest-count)) |
3633 (setq first t)) | 3629 (setq first t)) |
3634 ;; | 3630 ;; |
3635 ((looking-at "is") | 3631 ((looking-at "is") |
3636 ;; check if it is only a type definition, but not a protected | 3632 ;; look for things to ignore |
3637 ;; type definition, which should be handled like a procedure. | 3633 (if |
3638 (if (or (looking-at "is[ \t]+<>") | 3634 (or |
3639 (save-excursion | 3635 ;; generic formal parameter |
3640 (forward-comment -10000) | 3636 (looking-at "is[ t]+<>") |
3641 (forward-char -1) | 3637 |
3642 | 3638 ;; A type definition, or a case statement. Note that the |
3643 ;; Detect if we have a closing parenthesis (Could be | 3639 ;; goto-matching-start above on 'end record' leaves us at |
3644 ;; either the end of subprogram parameters or (<>) | 3640 ;; 'record', not at 'type'. |
3645 ;; in a type definition | 3641 ;; |
3646 (if (= (char-after) ?\)) | 3642 ;; We get to a case statement here by calling |
3647 (progn | 3643 ;; 'ada-move-to-end' from inside a case statement; then |
3648 (forward-char 1) | 3644 ;; we are not ignoring 'when'. |
3649 (backward-sexp 1) | 3645 (save-excursion |
3650 (forward-comment -10000) | 3646 ;; Skip type discriminants or case argument function call param list |
3651 )) | 3647 (forward-comment -10000) |
3652 (skip-chars-backward "a-zA-Z0-9_.'") | 3648 (forward-char -1) |
3653 (ada-goto-previous-word) | 3649 (if (= (char-after) ?\)) |
3654 (and | 3650 (progn |
3655 (looking-at "\\<\\(sub\\)?type\\|case\\>") | 3651 (forward-char 1) |
3652 (backward-sexp 1) | |
3653 (forward-comment -10000) | |
3654 )) | |
3655 ;; skip type or case argument name | |
3656 (skip-chars-backward "a-zA-Z0-9_.'") | |
3657 (ada-goto-previous-word) | |
3658 (and | |
3659 ;; if it's a protected type, it's the decl start we | |
3660 ;; are looking for; since we didn't see the 'end' | |
3661 ;; above, we are inside it. | |
3662 (looking-at "\\<\\(sub\\)?type\\|case\\>") | |
3656 (save-match-data | 3663 (save-match-data |
3657 (ada-goto-previous-word) | 3664 (ada-goto-previous-word) |
3658 (not (looking-at "\\<protected\\>")))) | 3665 (not (looking-at "\\<protected\\>")))) |
3659 )) ; end of `or' | 3666 ) ; end of type definition p |
3660 (goto-char (match-beginning 0)) | 3667 |
3661 (progn | 3668 ;; null procedure declaration |
3662 (setq nest-count (1- nest-count)) | 3669 (save-excursion (ada-goto-next-word) (looking-at "\\<null\\>")) |
3663 (setq first nil)))) | 3670 );; end or |
3671 ;; skip this construct | |
3672 nil | |
3673 ;; this is the right "is" | |
3674 (setq nest-count (1- nest-count)) | |
3675 (setq first nil))) | |
3664 | 3676 |
3665 ;; | 3677 ;; |
3666 ((looking-at "new") | 3678 ((looking-at "new") |
3667 (if (save-excursion | 3679 (if (save-excursion |
3668 (ada-goto-previous-word) | 3680 (ada-goto-previous-word) |
4113 (defun ada-in-decl-p () | 4125 (defun ada-in-decl-p () |
4114 "Return t if point is inside a declarative part. | 4126 "Return t if point is inside a declarative part. |
4115 Assumes point to be at the end of a statement." | 4127 Assumes point to be at the end of a statement." |
4116 (or (ada-in-paramlist-p) | 4128 (or (ada-in-paramlist-p) |
4117 (save-excursion | 4129 (save-excursion |
4118 (ada-goto-matching-decl-start t)))) | 4130 (ada-goto-decl-start t)))) |
4119 | 4131 |
4120 | 4132 |
4121 (defun ada-looking-at-semi-or () | 4133 (defun ada-looking-at-semi-or () |
4122 "Return t if looking at an 'or' following a semicolon." | 4134 "Return t if looking at an 'or' following a semicolon." |
4123 (save-excursion | 4135 (save-excursion |
4407 ;; | 4419 ;; |
4408 ;; on 'begin' => go on, according to user option | 4420 ;; on 'begin' => go on, according to user option |
4409 ;; | 4421 ;; |
4410 ada-move-to-declaration | 4422 ada-move-to-declaration |
4411 (looking-at "\\<begin\\>") | 4423 (looking-at "\\<begin\\>") |
4412 (ada-goto-matching-decl-start) | 4424 (ada-goto-decl-start) |
4413 (setq pos (point)))) | 4425 (setq pos (point)))) |
4414 | 4426 |
4415 ) ; end of save-excursion | 4427 ) ; end of save-excursion |
4416 | 4428 |
4417 ;; now really move to the found position | 4429 ;; now really move to the found position |
4419 | 4431 |
4420 ;; restore syntax-table | 4432 ;; restore syntax-table |
4421 (set-syntax-table previous-syntax-table)))) | 4433 (set-syntax-table previous-syntax-table)))) |
4422 | 4434 |
4423 (defun ada-move-to-end () | 4435 (defun ada-move-to-end () |
4424 "Move point to the matching end of the block around point. | 4436 "Move point to the end of the block around point. |
4425 Moves to 'begin' if in a declarative part." | 4437 Moves to 'begin' if in a declarative part." |
4426 (interactive) | 4438 (interactive) |
4427 (let ((pos (point)) | 4439 (let ((pos (point)) |
4428 decl-start | 4440 decl-start |
4429 (previous-syntax-table (syntax-table))) | 4441 (previous-syntax-table (syntax-table))) |
4469 (and (ada-goto-stmt-start) | 4481 (and (ada-goto-stmt-start) |
4470 (looking-at "\\<accept\\>" ))) | 4482 (looking-at "\\<accept\\>" ))) |
4471 (ada-goto-matching-end 0)) | 4483 (ada-goto-matching-end 0)) |
4472 ;; package start | 4484 ;; package start |
4473 ((save-excursion | 4485 ((save-excursion |
4474 (setq decl-start (and (ada-goto-matching-decl-start t) (point))) | 4486 (setq decl-start (and (ada-goto-decl-start t) (point))) |
4475 (and decl-start (looking-at "\\<package\\>"))) | 4487 (and decl-start (looking-at "\\<package\\>"))) |
4476 (ada-goto-matching-end 1)) | 4488 (ada-goto-matching-end 1)) |
4477 | 4489 |
4478 ;; On a "declare" keyword | 4490 ;; On a "declare" keyword |
4479 ((save-excursion | 4491 ((save-excursion |