code.delx.au - gnu-emacs-elpa/blob - packages/ada-mode/ada-wisi.el

   1 ;;; An indentation engine for Ada mode, using the wisi generalized LALR parser
   2 ;;
   3 ;; [1] ISO/IEC 8652:2012(E); Ada 2012 reference manual
   4 ;;
   5 ;; Copyright (C) 2012 - 2014  Free Software Foundation, Inc.
   6 ;;
   7 ;; Author: Stephen Leake <stephen_leake@member.fsf.org>
   8 ;;
   9 ;; This file is part of GNU Emacs.
  10 ;;
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15 ;;
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23 ;;
  24 ;;; History:
  25 ;;
  26 ;; implementation started Jan 2013
  27 ;;
  28 ;;;;
  29
  30 (require 'ada-fix-error)
  31 (require 'ada-grammar-wy)
  32 (require 'ada-indent-user-options)
  33 (require 'cl-lib)
  34 (require 'wisi)
  35
  36 (defcustom ada-wisi-font-lock-size-threshold 100000
  37   "Max size (in characters) for using wisi parser results for syntax highlighting."
  38   :type 'integer
  39   :group 'ada-indentation
  40   :safe 'integerp)
  41
  42 (defconst ada-wisi-class-list
  43   '(
  44     block-end
  45     block-middle ;; not start of statement
  46     block-start ;; start of block is start of statement
  47     close-paren
  48     keyword    ;; cached only for face; not used in indentation
  49     list-break
  50     name
  51     name-paren ;; anything that looks like a procedure call, since the grammar can't distinguish most of them
  52     open-paren
  53     return
  54     return-1
  55     return-2
  56     statement-end
  57     statement-other
  58     statement-start
  59     ))
  60
  61 ;;;; indentation
  62
  63 (defun ada-wisi-current-indentation ()
  64   "Return indentation appropriate for point on current line:
  65 if not in paren, beginning of line
  66 if in paren, pos following paren."
  67   (if (not (ada-in-paren-p))
  68       (current-indentation)
  69
  70     (or
  71      (save-excursion
  72        (let ((line (line-number-at-pos)))
  73          (ada-goto-open-paren 1)
  74          (when (= line (line-number-at-pos))
  75            (current-column))))
  76      (save-excursion
  77        (back-to-indentation)
  78        (current-column)))
  79     ))
  80
  81 (defun ada-wisi-indent-cache (offset cache)
  82   "Return indentation of OFFSET plus indentation of line containing point. Point must be at CACHE."
  83   (let ((indent (current-indentation)))
  84     (cond
  85      ;; special cases
  86      ;;
  87      ((eq 'LEFT_PAREN (wisi-cache-token cache))
  88       ;; test/ada_mode-long_paren.adb
  89       ;; (RT                            => RT,
  90       ;;  Monitor                       => True,
  91       ;;  RX_Enable                     =>
  92       ;;    (RX_Torque_Subaddress |
  93       ;;   indenting '(RX_'
  94       ;;
  95       ;; test/ada_mode-parens.adb
  96       ;; return Float (
  97       ;;               Integer'Value
  98       ;;                 (Local_6));
  99       ;;   indenting '(local_6)'; 'offset' = ada-indent - 1
 100       (+ (current-column) 1 offset))
 101
 102      ((save-excursion
 103         (let ((containing (wisi-goto-containing-paren cache)))
 104           (and containing
 105                ;; test/ada_mode-conditional_expressions.adb
 106                ;; K2 : Integer := (if J > 42
 107                ;;                  then -1
 108                ;;   indenting 'then'; offset = 0
 109                ;;
 110                ;; L1 : Integer := (case J is
 111                ;;                     when 42 => -1,
 112                ;;
 113                ;; test/indent.ads
 114                ;; C_S_Controls : constant
 115                ;;   CSCL_Type :=
 116                ;;     CSCL_Type'
 117                ;;       (
 118                ;;        1 =>  --  Used to be aligned on "CSCL_Type'"
 119                ;;              --  aligned with previous comment.
 120                ;;          IO_CPU_Control_State_S_Pkg.CPU2_Fault_Status_Type'
 121                ;;            (Unused2  => 10,  -- Used to be aligned on "1 =>"
 122                ;;  indenting '(Unused2'
 123                (+ (current-column) offset)))))
 124
 125      ;; all other structures
 126      (t
 127       ;; current cache may be preceded by something on same
 128       ;; line. Handle common cases nicely.
 129       (while (and cache
 130                   (or
 131                    (not (= (current-column) indent))
 132                    (eq 'EQUAL_GREATER (wisi-cache-token cache))))
 133         (when (and
 134                (eq 'WHEN (wisi-cache-token cache))
 135                (not (eq 'exit_statement (wisi-cache-nonterm cache))))
 136           (setq offset (+ offset ada-indent-when)))
 137         (setq cache (wisi-goto-containing cache))
 138         (setq indent (current-indentation)))
 139
 140       (cond
 141        ((null cache)
 142         ;; test/ada_mode-opentoken.ads
 143         ;; private package GDS.Commands.Add_Statement is
 144         ;;    type Instance is new Nonterminal.Instance with null record;
 145         offset)
 146
 147        ((eq 'label_opt (wisi-cache-token cache))
 148         (+ indent (- ada-indent-label) offset))
 149
 150        (t
 151         ;; test/ada_mode-generic_instantiation.ads
 152         ;; function Function_1 is new Instance.Generic_Function
 153         ;;   (Param_Type  => Integer,
 154         ;;
 155         ;; test/ada_mode-nested_packages.adb
 156         ;; function Create (Model   : in Integer;
 157         ;;                  Context : in String) return String is
 158         ;;    ...
 159         ;;    Cache : array (1 .. 10) of Boolean := (True, False, others => False);
 160         (+ indent offset))
 161        ))
 162      )))
 163
 164 (defun ada-wisi-indent-containing (offset cache &optional before)
 165   "Return indentation of OFFSET plus indentation of token containing CACHE.
 166 BEFORE should be t when called from ada-wisi-before-cache, nil otherwise."
 167   (save-excursion
 168     (cond
 169      ((markerp (wisi-cache-containing cache))
 170       (ada-wisi-indent-cache offset (wisi-goto-containing cache)))
 171
 172      (t
 173       (cond
 174        ((ada-in-paren-p)
 175         (ada-goto-open-paren 1)
 176         (+ (current-column) offset))
 177
 178        (t
 179         ;; at outermost containing statement. If called from
 180         ;; ada-wisi-before-cache, we want to ignore OFFSET (indenting
 181         ;; 'package' in a package spec). If called from
 182         ;; ada-wisi-after-cache, we want to include offset (indenting
 183         ;; first declaration in the package).
 184         (if before 0 offset))
 185        ))
 186       )))
 187
 188 (defun ada-wisi-indent-list-break (cache prev-token)
 189   "Return indentation for a token contained by CACHE, which must be a list-break.
 190 point must be on CACHE. PREV-TOKEN is the token before the one being indented."
 191   (let ((break-point (point))
 192         (containing (wisi-goto-containing cache)))
 193     (cl-ecase (wisi-cache-token containing)
 194       (LEFT_PAREN
 195        (if (equal break-point (cl-caddr prev-token))
 196            ;; we are indenting the first token after the list-break; not hanging.
 197            ;;
 198            ;; test/parent.adb
 199            ;; Append_To (Formals,
 200            ;;            Make_Parameter_Specification (Loc,
 201            ;; indenting 'Make_...'
 202            ;;
 203            ;; test/ada_mode-generic_instantiation.ads
 204            ;; function Function_1 is new Instance.Generic_Function
 205            ;;   (Param_Type  => Integer,
 206            ;;    Result_Type => Boolean,
 207            ;;    Threshold   => 2);
 208            ;; indenting 'Result_Type'
 209            (+ (current-column) 1)
 210          ;; else hanging
 211          ;;
 212          ;; test/ada_mode-parens.adb
 213          ;; A :=
 214          ;;   (1 |
 215          ;;      2 => (1, 1, 1),
 216          ;;    3 |
 217          ;;      4 => (2, 2, 2));
 218          ;; indenting '4 =>'
 219          (+ (current-column) 1 ada-indent-broken)))
 220
 221       (IS
 222        ;; test/ada_mode-conditional_expressions.adb
 223        ;; L1 : Integer := (case J is
 224        ;;                     when 42 => -1,
 225        ;;                     -- comment aligned with 'when'
 226        ;; indenting '-- comment'
 227        (wisi-indent-paren (+ 1 ada-indent-when)))
 228
 229       (WITH
 230        (cl-ecase (wisi-cache-nonterm containing)
 231          (aggregate
 232           ;; test/ada_mode-nominal-child.ads
 233           ;; (Default_Parent with
 234           ;;  Child_Element_1 => 10,
 235           ;;  Child_Element_2 => 12.0,
 236           ;; indenting 'Child_Element_2'
 237           (wisi-indent-paren 1))
 238
 239          (aspect_specification_opt
 240           ;; test/aspects.ads:
 241           ;; type Vector is tagged private
 242           ;; with
 243           ;;   Constant_Indexing => Constant_Reference,
 244           ;;   Variable_Indexing => Reference,
 245           ;; indenting 'Variable_Indexing'
 246           (+ (current-indentation) ada-indent-broken))
 247          ))
 248       )
 249     ))
 250
 251 (defun ada-wisi-before-cache ()
 252   "Point is at indentation, before a cached token. Return new indentation for point."
 253   (let ((pos-0 (point))
 254         (cache (wisi-get-cache (point)))
 255         (prev-token (save-excursion (wisi-backward-token)))
 256         )
 257     (when cache
 258       (cl-ecase (wisi-cache-class cache)
 259         (block-start
 260          (cl-case (wisi-cache-token cache)
 261            (IS ;; subprogram body
 262             (ada-wisi-indent-containing 0 cache t))
 263
 264            (RECORD
 265             ;; test/ada_mode-nominal.ads; ada-indent-record-rel-type = 3
 266             ;; type Private_Type_2 is abstract tagged limited
 267             ;;    record
 268             ;; indenting 'record'
 269             ;;
 270             ;; type Limited_Derived_Type_1d is
 271             ;;    abstract limited new Private_Type_1 with
 272             ;; record
 273             ;; indenting 'record'
 274             ;;
 275             ;; for Record_Type_1 use
 276             ;;   record
 277             ;;   indenting 'record'
 278             (let ((containing (wisi-goto-containing cache)))
 279               (while (not (memq (wisi-cache-token containing) '(FOR TYPE)))
 280                 (setq containing (wisi-goto-containing containing)))
 281               (+ (current-column) ada-indent-record-rel-type)))
 282
 283            (t ;; other
 284             (ada-wisi-indent-containing ada-indent cache t))))
 285
 286         (block-end
 287          (cl-case (wisi-cache-nonterm cache)
 288            (record_definition
 289             (save-excursion
 290               (wisi-goto-containing cache);; now on 'record'
 291               (current-indentation)))
 292
 293            (t
 294             (ada-wisi-indent-containing 0 cache t))
 295            ))
 296
 297         (block-middle
 298          (cl-case (wisi-cache-token cache)
 299            (WHEN
 300             (ada-wisi-indent-containing ada-indent-when cache t))
 301
 302            (t
 303             (ada-wisi-indent-containing 0 cache t))
 304            ))
 305
 306         (close-paren (wisi-indent-paren 0))
 307
 308         (keyword
 309          ;; defer to after-cache)
 310          nil)
 311
 312         (name
 313          (cl-case (wisi-cache-nonterm cache)
 314            ((function_specification procedure_specification)
 315             ;; test/ada_mode-nominal.ads
 316             ;; not
 317             ;; overriding
 318             ;; procedure
 319             ;;   Procedure_1c (Item  : in out Parent_Type_1);
 320             ;; indenting 'Procedure_1c'
 321             ;;
 322             ;; not overriding function
 323             ;;   Function_2e (Param : in Parent_Type_1) return Float;
 324             ;; indenting 'Function_2e'
 325             (ada-wisi-indent-containing ada-indent-broken cache t))
 326
 327            (t
 328             ;; defer to ada-wisi-after-cache, for consistency
 329             nil)
 330            ))
 331
 332         (name-paren
 333          ;; defer to ada-wisi-after-cache, for consistency
 334          nil)
 335
 336         (open-paren
 337          (let ((containing (wisi-goto-containing cache)))
 338            (cl-case (wisi-cache-token containing)
 339              (COMMA
 340               ;; test/ada_mode-parens.adb
 341               ;; A : Matrix_Type :=
 342               ;;   ((1, 2, 3),
 343               ;;    (4, 5, 6),
 344               ;; indenting (4
 345               (ada-wisi-indent-containing 0 containing))
 346
 347              (EQUAL_GREATER
 348               (setq containing (wisi-goto-containing containing))
 349               (cl-ecase (wisi-cache-token containing)
 350                 (COMMA
 351                  ;; test/ada_mode-long_paren.adb
 352                  ;; (RT                            => RT,
 353                  ;;  Monitor                       => True,
 354                  ;;  RX_Enable                     =>
 355                  ;;    (RX_Torque_Subaddress |
 356                  ;; indenting (RX_Torque
 357                  (ada-wisi-indent-containing ada-indent-broken containing t))
 358                 (LEFT_PAREN
 359                  ;; test/ada_mode-parens.adb
 360                  ;; (1 =>
 361                  ;;    (1 => 12,
 362                  ;; indenting '(1 => 12'; containing is '=>'
 363                  (ada-wisi-indent-cache (1- ada-indent) containing))
 364                 (WHEN
 365                  ;; test/ada_mode-conditional_expressions.adb
 366                  ;;  when 1 =>
 367                  ;;    (if J > 42
 368                  ;; indenting '(if'; containing is '=>'
 369                  (+ (current-column) -1 ada-indent))
 370                 ))
 371
 372              ((FUNCTION PROCEDURE)
 373               ;; test/ada_mode-nominal.adb
 374               ;; function Function_Access_11
 375               ;;   (A_Param : in Float)
 376               ;;   --  EMACSCMD:(test-face "function" font-lock-keyword-face)
 377               ;;   return access function
 378               ;;     (A_Param : in Float)
 379               ;;     return
 380               ;;     Standard.Float -- Ada mode 4.01, GPS do this differently
 381               ;; indenting second '(A_Param)
 382               (+ (current-indentation) -1 ada-indent))
 383
 384              (LEFT_PAREN
 385               ;; test/ada_mode-parens.adb
 386               ;; or else ((B.all
 387               ;;             and then C)
 388               ;;            or else
 389               ;;            (D
 390               ;; indenting (D
 391               (+ (current-column) 1 ada-indent-broken))
 392
 393              (WHEN
 394               ;; test/ada_mode-nominal.adb
 395               ;;
 396               ;; when Local_1 = 0 and not
 397               ;;   (Local_2 = 1)
 398               ;; indenting (Local_2
 399               ;;
 400               ;; entry E3
 401               ;;   (X : Integer) when Local_1 = 0 and not
 402               ;;     (Local_2 = 1)
 403               (+ (ada-wisi-current-indentation) ada-indent-broken))
 404
 405              ((IDENTIFIER selected_component name)
 406               ;; test/indent.ads
 407               ;; CSCL_Type'
 408               ;;   (
 409               ;; identing (
 410               ;;
 411               ;; test/ada_mode-parens.adb
 412               ;; Check
 413               ;;   ("foo bar",
 414               ;;    A
 415               ;;      (1),
 416               ;;    A(2));
 417               ;; indenting (1)
 418               ;;
 419               ;; test/ada_mode-parens.adb
 420               ;; Local_11 : Local_11_Type := Local_11_Type'
 421               ;;   (A => Integer
 422               ;;      (1.0),
 423               ;;    B => Integer
 424               ;;      (2.0));
 425               ;;
 426               ;; test/ada_mode-parens.adb
 427               ;; Local_12 : Local_11_Type
 428               ;;   := Local_11_Type'(A => Integer
 429               ;;     (1.0),
 430               ;; indenting (1.0)
 431               (+ (ada-wisi-current-indentation) ada-indent-broken))
 432
 433              (t
 434               (cond
 435                 ((memq (wisi-cache-class containing) '(block-start statement-start))
 436                  ;; test/ada_mode-nominal.adb
 437                  ;; entry E2
 438                  ;;   (X : Integer)
 439                  ;; indenting (X
 440                  (ada-wisi-indent-cache ada-indent-broken containing))
 441
 442                 (t
 443                  ;; Open paren in an expression.
 444                  ;;
 445                  ;; test/ada_mode-conditional_expressions.adb
 446                  ;; L0 : Integer :=
 447                  ;;   (case J is when 42 => -1, when Integer'First .. 41 => 0, when others => 1);
 448                  ;; indenting (case
 449                  (ada-wisi-indent-containing ada-indent-broken containing t))
 450                 ))
 451              )))
 452
 453         (return-1;; parameter list
 454          (let ((return-pos (point)))
 455            (wisi-goto-containing cache nil) ;; matching 'function'
 456            (cond
 457             ((<= ada-indent-return 0)
 458              ;; indent relative to "("
 459              (wisi-forward-find-class 'open-paren return-pos)
 460              (+ (current-column) (- ada-indent-return)))
 461
 462             (t
 463              (+ (current-column) ada-indent-return))
 464             )))
 465
 466         (return-2;; no parameter list
 467          (wisi-goto-containing cache nil) ;; matching 'function'
 468          (+ (current-column) ada-indent-broken))
 469
 470         (statement-end
 471          (ada-wisi-indent-containing ada-indent-broken cache t))
 472
 473         (statement-other
 474          (let ((containing (wisi-goto-containing cache nil)))
 475            (cl-case (wisi-cache-token cache)
 476              (EQUAL_GREATER
 477               (+ (current-column) ada-indent-broken))
 478
 479              (ELSIF
 480               ;; test/g-comlin.adb
 481               ;;   elsif Current_Argument < CL.Argument_Count then
 482               (ada-wisi-indent-cache 0 containing))
 483
 484              (RENAMES
 485               (cl-ecase (wisi-cache-nonterm containing)
 486                 ((generic_renaming_declaration subprogram_renaming_declaration)
 487                  (wisi-forward-find-token '(FUNCTION PROCEDURE) pos-0)
 488                  (let ((pos-subprogram (point))
 489                        (has-params
 490                         ;; this is wrong for one return access
 491                         ;; function case: overriding function Foo
 492                         ;; return access Bar (...) renames ...;
 493                         (wisi-forward-find-token 'LEFT_PAREN pos-0 t)))
 494                    (if has-params
 495                        (if (<= ada-indent-renames 0)
 496                            ;; indent relative to paren
 497                            (+ (current-column) (- ada-indent-renames))
 498                          ;; else relative to line containing keyword
 499                          (goto-char pos-subprogram)
 500                          (+ (current-indentation) ada-indent-renames))
 501
 502                      ;; no params
 503                      (goto-char pos-subprogram)
 504                      (+ (current-indentation) ada-indent-broken))
 505                    ))
 506
 507                 (object_renaming_declaration
 508                  (+ (current-indentation) ada-indent-broken))
 509                 ))
 510
 511              (t
 512               (while (not (wisi-cache-nonterm containing))
 513                 (setq containing (wisi-goto-containing containing)))
 514
 515               (cl-ecase (wisi-cache-nonterm containing)
 516                 (aggregate
 517                  ;; indenting 'with'
 518                  (+ (current-column) 1))
 519
 520                 (association_list
 521                  ;; test/ada_mode-parens.adb
 522                  ;; Local_13 : Local_11_Type
 523                  ;;   := (Integer'(1),
 524                  ;;       Integer'(2));
 525                  (ada-wisi-indent-cache 0 containing))
 526
 527                 (association_opt
 528                  ;; test/indent.ads
 529                  ;; 1 =>  --  Used to be aligned on "CSCL_Type'"
 530                  ;;       --  aligned with previous comment.
 531                  ;;   IO_CPU_Control_State_S_Pkg.CPU2_Fault_Status_Type'
 532                  (ada-wisi-indent-cache ada-indent-broken containing))
 533
 534                 (asynchronous_select
 535                  ;; indenting 'abort'
 536                  (+ (current-column) ada-indent-broken))
 537
 538                 (component_declaration
 539                  ;; test/ada_mode-nominal.ads record_type_3
 540                  (+ (current-column) ada-indent-broken))
 541
 542                 (entry_body
 543                  ;; indenting 'when'
 544                  (+ (current-column) ada-indent-broken))
 545
 546                 (formal_package_declaration
 547                  ;; test/ada_mode-generic_package.ads
 548                  ;; with package A_Package_7 is
 549                  ;;   new Ada.Text_IO.Integer_IO (Num => Formal_Signed_Integer_Type);
 550                  ;; indenting 'new'
 551                  (+ (current-column) ada-indent-broken))
 552
 553                 (full_type_declaration
 554                  ;; test/ada_mode-nominal.ads
 555                  ;; type Unconstrained_Array_Type_3 is array (Integer range <>, Standard.Character range <>)
 556                  ;;   of Object_Access_Type_1;
 557                  ;; indenting 'of'
 558                  ;;
 559                  ;; type Object_Access_Type_7
 560                  ;;   is access all Integer;
 561                  ;; indenting 'is'
 562                  ;;
 563                  ;; type Limited_Derived_Type_1 is abstract limited new Private_Type_1 with
 564                  ;; record
 565                  ;; indenting 'record'
 566                  ;;
 567                  ;; type Limited_Derived_Type_3 is abstract limited new Private_Type_1
 568                  ;;   with null record;
 569                  ;; indenting 'with'
 570                  ;;
 571                  ;; type Limited_Derived_Type_2a is abstract limited new Private_Type_1
 572                  ;; with record
 573                  ;; indenting 'with record'
 574                  ;;
 575                  ;; test/access_in_record.ads
 576                  ;; type A
 577                  ;;    is new Ada.Streams.Root_Stream_Type with record
 578                  ;; FIXME: line with 'record' use ada-indent-record-rel-type
 579
 580                  (while (not (eq 'TYPE (wisi-cache-token containing)))
 581                    (setq containing (wisi-goto-containing containing)))
 582
 583                  (cond
 584                   ((eq (wisi-cache-token cache) 'RECORD)
 585                    (+ (current-column) ada-indent-record-rel-type))
 586
 587                   ((eq (wisi-cache-token cache) 'WITH)
 588                    (let ((type-col (current-column)))
 589                      (wisi-goto-end-1 cache)
 590                      (if (eq 'WITH (wisi-cache-token (wisi-backward-cache)))
 591                          ;; 'with null record;' or 'with private;'
 592                          (+ type-col ada-indent-broken)
 593                        (+ type-col ada-indent-record-rel-type))))
 594
 595                   (t
 596                    (+ (current-column) ada-indent-broken))
 597                   ))
 598
 599                 (generic_instantiation
 600                  ;; test/ada_mode-generic_instantiation.ads
 601                  ;; procedure Procedure_7 is
 602                  ;;   new Instance.Generic_Procedure (Integer, Function_1);
 603                  ;; indenting 'new'
 604                  (+ (current-column) ada-indent-broken))
 605
 606                 (generic_renaming_declaration
 607                  ;; indenting keyword following 'generic'
 608                  (current-column))
 609
 610                 (object_declaration
 611                  (cl-ecase (wisi-cache-token containing)
 612                    (COLON
 613                     ;; test/ada_mode-nominal.ads
 614                     ;; Anon_Array_3 : array (1 .. 10)
 615                     ;;   of Integer;
 616                     ;; indenting 'of'
 617                     (+ (current-indentation) ada-indent-broken))
 618
 619                    (COLON_EQUAL
 620                     ;; test/indent.ads
 621                     ;; C_S_Controls : constant
 622                     ;;   CSCL_Type :=
 623                     ;;     CSCL_Type'
 624                     ;; indenting 'CSCL_Type'
 625                     (+ (current-indentation) ada-indent-broken))
 626
 627                    (identifier_list
 628                     ;; test/ada_mode-nominal.adb
 629                     ;; Local_2 : constant Float
 630                     ;;   := Local_1;
 631                     (+ (current-indentation) ada-indent-broken))
 632                    ))
 633
 634                 (private_extension_declaration
 635                  ;; test/ada_mode-nominal.ads
 636                  ;; type Limited_Derived_Type_3 is abstract limited
 637                  ;;   new Private_Type_1 with private;
 638                  (+ (current-indentation) ada-indent-broken))
 639
 640                 (private_type_declaration
 641                  ;; test/aspects.ads
 642                  ;; type Vector is tagged private
 643                  ;; with
 644                  ;; indenting 'with'
 645                  (current-indentation))
 646
 647                 (qualified_expression
 648                  ;; test/ada_mode-nominal-child.ads
 649                  ;; Child_Obj_5 : constant Child_Type_1 :=
 650                  ;;   (Parent_Type_1'
 651                  ;;     (Parent_Element_1 => 1,
 652                  (ada-wisi-indent-cache ada-indent-broken containing))
 653
 654                 (statement
 655                  (cl-case (wisi-cache-token containing)
 656                    (label_opt
 657                     (- (current-column) ada-indent-label))
 658
 659                    (t
 660                     ;; test/ada_mode-nominal.adb
 661                     ;; select
 662                     ;;    delay 1.0;
 663                     ;; then
 664                     ;;    -- ...
 665                     ;;   abort
 666                     (ada-wisi-indent-cache ada-indent-broken cache))
 667                    ))
 668
 669                 ((subprogram_body subprogram_declaration subprogram_specification null_procedure_declaration)
 670                  (cl-ecase (wisi-cache-token cache)
 671                    (OVERRIDING
 672                     ;; indenting 'overriding' following 'not'
 673                     (current-column))
 674
 675                    ((PROCEDURE FUNCTION)
 676                     ;; indenting 'procedure' or 'function following 'overriding'
 677                     (current-column))
 678
 679                    (WITH
 680                     ;; indenting aspect specification on subprogram declaration
 681                     ;; test/aspects.ads
 682                     ;; procedure Foo (X : Integer;
 683                     ;;                Y : out Integer)
 684                     ;; with Pre => X > 10 and
 685                     ;; indenting 'with'
 686                     (current-column))
 687                    ))
 688
 689                 (subtype_declaration
 690                  ;; test/adacore_9717_001.ads A_Long_Name
 691                  (+ (current-column) ada-indent-broken))
 692
 693                 ))))) ;; end statement-other
 694
 695         (statement-start
 696          (cond
 697           ((eq 'label_opt (wisi-cache-token cache))
 698            (ada-wisi-indent-containing (+ ada-indent-label ada-indent) cache t))
 699
 700           (t
 701            (let ((containing-cache (wisi-get-containing-cache cache)))
 702              (if (not containing-cache)
 703                  ;; at bob
 704                  0
 705                ;; not at bob
 706                (cl-case (wisi-cache-class containing-cache)
 707                  ((block-start block-middle)
 708                   (wisi-goto-containing cache)
 709                   (cl-case (wisi-cache-nonterm containing-cache)
 710                     (record_definition
 711                      (+ (current-indentation) ada-indent))
 712
 713                     (t
 714                      (ada-wisi-indent-cache ada-indent containing-cache))
 715                     ))
 716
 717                  (list-break
 718                   (ada-wisi-indent-list-break cache prev-token))
 719
 720                  (statement-other
 721                   ;; defer to ada-wisi-after-cache
 722                   nil)
 723                  ))))
 724              ))
 725         ))
 726     ))
 727
 728 (defun ada-wisi-after-cache ()
 729   "Point is at indentation, not before a cached token. Find previous
 730 cached token, return new indentation for point."
 731   (let ((start (point))
 732         (prev-token (save-excursion (wisi-backward-token)))
 733         (cache (wisi-backward-cache)))
 734
 735     (cond
 736      ((not cache) ;; bob
 737         0)
 738
 739      (t
 740       (while (memq (wisi-cache-class cache) '(keyword name name-paren type))
 741         ;; not useful for indenting
 742         (setq cache (wisi-backward-cache)))
 743
 744       (cl-ecase (wisi-cache-class cache)
 745         (block-end
 746          ;; indenting block/subprogram name after 'end'
 747          (wisi-indent-current ada-indent-broken))
 748
 749         (block-middle
 750          (cl-case (wisi-cache-token cache)
 751            (IS
 752             (cl-case (wisi-cache-nonterm cache)
 753               (case_statement
 754                ;; between 'case .. is' and first 'when'; most likely a comment
 755                (ada-wisi-indent-containing 0 cache t))
 756
 757               (t
 758                (+ (ada-wisi-indent-containing ada-indent cache t)))
 759               ))
 760
 761            ((THEN ELSE)
 762             (let ((indent
 763                    (cl-ecase (wisi-cache-nonterm (wisi-get-containing-cache cache))
 764                      ((statement if_statement elsif_statement_item) ada-indent)
 765                      ((if_expression elsif_expression_item) ada-indent-broken))))
 766               (ada-wisi-indent-containing indent cache t)))
 767
 768            (WHEN
 769             ;; between 'when' and '=>'
 770             (+ (current-column) ada-indent-broken))
 771
 772            (t
 773             ;; block-middle keyword may not be on separate line:
 774             ;;       function Create (Model   : in Integer;
 775             ;;                        Context : in String) return String is
 776             (ada-wisi-indent-containing ada-indent cache nil))
 777            ))
 778
 779         (block-start
 780          (cl-case (wisi-cache-nonterm cache)
 781            (exception_handler
 782             ;; between 'when' and '=>'
 783             (+ (current-column) ada-indent-broken))
 784
 785            (if_expression
 786             (ada-wisi-indent-containing ada-indent-broken cache nil))
 787
 788            (select_alternative
 789             (ada-wisi-indent-containing (+ ada-indent-when ada-indent-broken) cache nil))
 790
 791            (t ;; other; normal block statement
 792             (ada-wisi-indent-cache ada-indent cache))
 793            ))
 794
 795         (close-paren
 796          ;; actual_parameter_part: test/ada_mode-nominal.adb
 797          ;; return 1.0 +
 798          ;;   Foo (Bar) + -- multi-line expression that happens to have a cache at a line start
 799          ;;   12;
 800          ;; indenting '12'; don't indent relative to containing function name
 801          ;;
 802          ;; attribute_designator: test/ada_mode-nominal.adb
 803          ;; raise Constraint_Error with Count'Image (Line (File)) &
 804          ;;    "foo";
 805          ;; indenting '"foo"'; relative to raise
 806          ;;
 807          ;; test/ada_mode-slices.adb
 808          ;; Put_Line(Day'Image(D1) & " - " & Day'Image(D2) & " = " &
 809          ;;            Integer'Image(N));
 810          ;; indenting 'Integer'
 811          (when (memq (wisi-cache-nonterm cache)
 812                      '(actual_parameter_part attribute_designator))
 813            (setq cache (wisi-goto-containing cache)))
 814          (ada-wisi-indent-containing ada-indent-broken cache nil))
 815
 816         (list-break
 817          (ada-wisi-indent-list-break cache prev-token))
 818
 819         (open-paren
 820          ;; 1) A parenthesized expression, or the first item in an aggregate:
 821          ;;
 822          ;;    (foo +
 823          ;;       bar)
 824          ;;    (foo =>
 825          ;;       bar)
 826          ;;
 827          ;;     we are indenting 'bar'
 828          ;;
 829          ;; 2) A parenthesized expression, or the first item in an
 830          ;;    aggregate, and there is whitespace between
 831          ;;    ( and the first token:
 832          ;;
 833          ;; test/ada_mode-parens.adb
 834          ;; Local_9 : String := (
 835          ;;                      "123"
 836          ;;
 837          ;; 3) A parenthesized expression, or the first item in an
 838          ;;    aggregate, and there is a comment between
 839          ;;    ( and the first token:
 840          ;;
 841          ;; test/ada_mode-nominal.adb
 842          ;; A :=
 843          ;;   (
 844          ;;    -- a comment between paren and first association
 845          ;;    1 =>
 846          ;;
 847          ;; test/ada_mode-parens.adb
 848          ;; return Float (
 849          ;;               Integer'Value
 850          ;; indenting 'Integer'
 851          (let ((paren-column (current-column))
 852                (start-is-comment (save-excursion (goto-char start) (looking-at comment-start-skip))))
 853            (wisi-forward-token t); point is now after paren
 854            (if start-is-comment
 855                (skip-syntax-forward " >"); point is now on comment
 856              (forward-comment (point-max)); point is now on first token
 857              )
 858            (if (= (point) start)
 859                ;; case 2) or 3)
 860                (1+ paren-column)
 861              ;; 1)
 862              (+ paren-column 1 ada-indent-broken))))
 863
 864         ((return-1 return-2)
 865          ;; test/ada_mode-nominal.adb
 866          ;; function Function_Access_1
 867          ;;   (A_Param : in Float)
 868          ;;   return
 869          ;;     Standard.Float
 870          ;; indenting 'Standard.Float'
 871          ;;
 872          ;; test/ada_mode-expression_functions.ads
 873          ;; function Square (A : in Float) return Float
 874          ;;   is (A * A);
 875          ;; indenting 'is'
 876          ;;
 877          ;; test/ada_mode-nominal.ads
 878          ;; function Function_2g
 879          ;;   (Param : in Private_Type_1)
 880          ;;   return Float
 881          ;;   is abstract;
 882          ;; indenting 'is'
 883          (back-to-indentation)
 884          (+ (current-column) ada-indent-broken))
 885
 886         (statement-end
 887          (ada-wisi-indent-containing 0 cache nil))
 888
 889         (statement-other
 890          (cl-ecase (wisi-cache-token cache)
 891            (ABORT
 892             ;; select
 893             ;;    Please_Abort;
 894             ;; then
 895             ;;   abort
 896             ;;    -- 'abort' indented with ada-indent-broken, since this is part
 897             ;;    Titi;
 898             (ada-wisi-indent-containing ada-indent cache))
 899
 900             ;; test/subdir/ada_mode-separate_task_body.adb
 901            ((COLON COLON_EQUAL)
 902             ;; Local_3 : constant Float :=
 903             ;;   Local_2;
 904             (ada-wisi-indent-cache ada-indent-broken cache))
 905
 906            (COMMA
 907             (cl-ecase (wisi-cache-nonterm cache)
 908               (name_list
 909                (cl-ecase (wisi-cache-nonterm (wisi-get-containing-cache cache))
 910                  (use_clause
 911                   ;; test/with_use1.adb
 912                   (ada-wisi-indent-containing ada-indent-use cache))
 913
 914                  (with_clause
 915                   ;; test/ada_mode-nominal.ads
 916                   ;; limited private with Ada.Strings.Bounded,
 917                   ;;   --EMACSCMD:(test-face "Ada.Containers" 'default)
 918                   ;;   Ada.Containers;
 919                   ;;
 920                   ;; test/with_use1.adb
 921                   (ada-wisi-indent-containing ada-indent-with cache))
 922                  ))
 923               ))
 924
 925            (ELSIF
 926             ;; test/g-comlin.adb
 927             ;; elsif Index_Switches + Max_Length <= Switches'Last
 928             ;;   and then Switches (Index_Switches + Max_Length) = '?'
 929             (ada-wisi-indent-cache ada-indent-broken cache))
 930
 931            (EQUAL_GREATER
 932             (let ((cache-col (current-column))
 933                   (cache-pos (point))
 934                   (line-end-pos (line-end-position))
 935                   (containing (wisi-goto-containing cache nil)))
 936               (while (eq (wisi-cache-nonterm containing) 'association_list)
 937                 (setq containing (wisi-goto-containing containing nil)))
 938
 939               (cl-ecase (wisi-cache-nonterm containing)
 940                 ((actual_parameter_part aggregate)
 941                  ;; ada_mode-generic_package.ads
 942                  ;; with package A_Package_2 is new Ada.Text_IO.Integer_IO (Num =>
 943                  ;;                                                           Formal_Signed_Integer_Type);
 944                  ;;  indenting 'Formal_Signed_...', point on '(Num'
 945                  ;;
 946                  ;; test/ada_mode-parens.adb
 947                  ;; (1      =>
 948                  ;;    1,
 949                  ;;  2      =>
 950                  ;;    1 + 2 * 3,
 951                  ;; indenting '1,' or '1 +'; point on '(1'
 952                  (+ (current-column) 1 ada-indent-broken))
 953
 954                 (aspect_specification_opt
 955                  ;; test/aspects.ads
 956                  ;; with Pre => X > 10 and
 957                  ;;             X < 50 and
 958                  ;;             F (X),
 959                  ;;   Post =>
 960                  ;;     Y >= X and
 961                  ;; indenting 'X < 50' or 'Y >= X'; cache is '=>', point is on '=>'
 962                  ;; or indenting 'Post =>'; cache is ',', point is on 'with'
 963                  (cl-ecase (wisi-cache-token cache)
 964                    (COMMA
 965                     (+ (current-indentation) ada-indent-broken))
 966
 967                    (EQUAL_GREATER
 968                     (if (= (+ 2 cache-pos) line-end-pos)
 969                         ;;   Post =>
 970                         ;;     Y >= X and
 971                         (progn
 972                           (goto-char cache-pos)
 973                           (+ (current-indentation) ada-indent-broken))
 974                       ;; with Pre => X > 10 and
 975                       ;;             X < 50 and
 976                       (+ 3 cache-col)))
 977                    ))
 978
 979                 (association_list
 980                  (cl-ecase (save-excursion (wisi-cache-token (wisi-goto-containing cache nil)))
 981                    (COMMA
 982                     (ada-wisi-indent-containing (* 2 ada-indent-broken) cache))
 983                    ))
 984
 985                 ((case_expression_alternative case_statement_alternative exception_handler)
 986                  ;; containing is 'when'
 987                  (+ (current-column) ada-indent))
 988
 989                 (generic_renaming_declaration
 990                  ;; not indenting keyword following 'generic'
 991                  (+ (current-column) ada-indent-broken))
 992
 993                 (primary
 994                  ;; test/ada_mode-quantified_expressions.adb
 995                  ;; if (for some J in 1 .. 10 =>
 996                  ;;       J/2 = 0)
 997                  (ada-wisi-indent-containing ada-indent-broken cache))
 998
 999
1000                 (select_alternative
1001                  ;; test/ada_mode-nominal.adb
1002                  ;; or when Started
1003                  ;;      =>
1004                  ;;       accept Finish;
1005                  ;; indenting 'accept'; point is on 'when'
1006                  (+ (current-column) ada-indent))
1007
1008                 (variant
1009                  ;; test/generic_param.adb
1010                  ;; case Item_Type is
1011                  ;;    when Fix | Airport =>
1012                  ;;       null;
1013                  ;; indenting 'null'
1014                  (+ (current-column) ada-indent))
1015
1016                 )))
1017
1018            (IS
1019             (setq cache (wisi-goto-containing cache))
1020             (cl-ecase (wisi-cache-nonterm cache)
1021               (full_type_declaration
1022                ;; ada_mode/nominal.ads
1023                ;; type Limited_Derived_Type_1a is abstract limited new
1024                ;;    Private_Type_1 with record
1025                ;;       Component_1 : Integer;
1026                ;; indenting 'Private_Type_1'; look for 'record'
1027                (let ((type-column (current-column)))
1028                  (goto-char start)
1029                  (if (wisi-forward-find-token 'RECORD (line-end-position) t)
1030                      ;; 'record' on line being indented
1031                      (+ type-column ada-indent-record-rel-type)
1032                    ;; 'record' on later line
1033                    (+ type-column ada-indent-broken))))
1034
1035               ((formal_type_declaration
1036                 ;; test/ada_mode-generic_package.ads
1037                 ;; type Synchronized_Formal_Derived_Type is abstract synchronized new Formal_Private_Type and Interface_Type
1038                 ;;   with private;
1039
1040                 subtype_declaration)
1041                 ;; test/ada_mode-nominal.ads
1042                 ;;    subtype Subtype_2 is Signed_Integer_Type range 10 ..
1043                 ;;      20;
1044
1045                (+ (current-column) ada-indent-broken))
1046               ))
1047
1048            (LEFT_PAREN
1049             ;; test/indent.ads
1050             ;; C_S_Controls : constant
1051             ;;   CSCL_Type :=
1052             ;;     CSCL_Type'
1053             ;;       (
1054             ;;        1 =>
1055             (+ (current-column) 1))
1056
1057            (NEW
1058             ;; ada_mode-nominal.ads
1059             ;; type Limited_Derived_Type_2 is abstract limited new Private_Type_1 with
1060             ;;   private;
1061             ;;
1062             ;; test/ada_mode-generic_instantiation.ads
1063             ;;   procedure Procedure_6 is new
1064             ;;     Instance.Generic_Procedure (Integer, Function_1);
1065             ;; indenting 'Instance'; containing is 'new'
1066             (ada-wisi-indent-containing ada-indent-broken cache))
1067
1068            (OF
1069             ;; ada_mode-nominal.ads
1070             ;; Anon_Array_2 : array (1 .. 10) of
1071             ;;   Integer;
1072             (ada-wisi-indent-containing ada-indent-broken cache))
1073
1074            (WHEN
1075             ;; test/ada_mode-parens.adb
1076             ;; exit when A.all
1077             ;;   or else B.all
1078             (ada-wisi-indent-containing ada-indent-broken cache))
1079
1080            (WITH
1081             (cl-case (wisi-cache-nonterm cache)
1082               (aggregate
1083                ;; test/ada_mode-nominal-child.ads
1084                ;;   (Default_Parent with
1085                ;;    10, 12.0, True);
1086                ;; indenting '10'; containing is '('
1087                (ada-wisi-indent-containing 0 cache nil))
1088
1089               (aspect_specification_opt
1090                ;; test/aspects.ads
1091                ;; type Vector is tagged private
1092                ;; with
1093                ;;   Constant_Indexing => Constant_Reference,
1094                ;; indenting 'Constant_Indexing'; point is on 'with'
1095                (+ (current-indentation) ada-indent-broken))
1096               ))
1097
1098            ;; otherwise just hanging
1099            ((ACCEPT FUNCTION PROCEDURE RENAMES)
1100             (back-to-indentation)
1101             (+ (current-column) ada-indent-broken))
1102
1103           ))
1104
1105         (statement-start
1106          (cl-case (wisi-cache-token cache)
1107            (WITH ;; with_clause
1108             (+ (current-column) ada-indent-with))
1109
1110            (label_opt
1111             ;; comment after label
1112             (+ (current-column) (- ada-indent-label)))
1113
1114            (t
1115             ;; procedure Procedure_8
1116             ;;   is new Instance.Generic_Procedure (Integer, Function_1);
1117             ;; indenting 'is'; hanging
1118             ;;      (+ (current-column) ada-indent-broken))
1119             (ada-wisi-indent-cache ada-indent-broken cache))
1120            ))
1121         )))
1122     ))
1123
1124 (defun ada-wisi-comment ()
1125   "Compute indentation of a comment. For `wisi-indent-calculate-functions'."
1126   ;; We know we are at the first token on a line. We check for comment
1127   ;; syntax, not comment-start, to accomodate gnatprep, skeleton
1128   ;; placeholders, etc.
1129   (when (and (not (= (point) (point-max))) ;; no char after EOB!
1130              (= 11 (syntax-class (syntax-after (point)))))
1131
1132     ;; We are at a comment; indent to previous code or comment.
1133     (cond
1134      ((and ada-indent-comment-col-0
1135            (= 0 (current-column)))
1136       0)
1137
1138      ((or
1139        (save-excursion (forward-line -1) (looking-at "\\s *$"))
1140        (save-excursion (forward-comment -1)(not (looking-at comment-start))))
1141       ;; comment is after a blank line or code; indent as if code
1142       ;;
1143       ;; ada-wisi-before-cache will find the keyword _after_ the
1144       ;; comment, which could be a block-middle or block-end, and that
1145       ;; would align the comment with the block-middle, which is wrong. So
1146       ;; we only call ada-wisi-after-cache.
1147
1148       ;; FIXME: need option to match gnat style check; change indentation to match (ie mod 3)
1149       (ada-wisi-after-cache))
1150
1151       (t
1152        ;; comment is after a comment
1153        (forward-comment -1)
1154        (current-column))
1155       )))
1156
1157 (defun ada-wisi-post-parse-fail ()
1158   "For `wisi-post-parse-fail-hook'."
1159   (save-excursion
1160     (let ((start-cache (wisi-goto-start (or (wisi-get-cache (point)) (wisi-backward-cache)))))
1161       (when start-cache
1162         ;; nil when in a comment at point-min
1163         (indent-region (point) (wisi-cache-end start-cache)))
1164       ))
1165   (back-to-indentation))
1166
1167 ;;;; ada-mode functions (alphabetical)
1168
1169 (defun ada-wisi-declarative-region-start-p (cache)
1170   "Return t if cache is a keyword starting a declarative region."
1171   (cl-case (wisi-cache-token cache)
1172    (DECLARE t)
1173    (IS
1174     (memq (wisi-cache-class cache) '(block-start block-middle)))
1175    (t nil)
1176    ))
1177
1178 (defun ada-wisi-context-clause ()
1179   "For `ada-fix-context-clause'."
1180   (wisi-validate-cache (point-max))
1181   (save-excursion
1182     (goto-char (point-min))
1183     (let ((begin nil)
1184           (end nil)
1185           cache)
1186
1187       (while (not end)
1188         (setq cache (wisi-forward-cache))
1189         (cl-case (wisi-cache-nonterm cache)
1190           (pragma (wisi-goto-end-1 cache))
1191           (use_clause (wisi-goto-end-1 cache))
1192           (with_clause
1193            (when (not begin)
1194              (setq begin (point-at-bol)))
1195            (wisi-goto-end-1 cache))
1196           (t
1197            ;; start of compilation unit
1198            (setq end (point-at-bol))
1199            (unless begin
1200              (setq begin end)))
1201           ))
1202       (cons begin end)
1203     )))
1204
1205 (defun ada-wisi-on-context-clause ()
1206   "For `ada-on-context-clause'."
1207
1208   (save-excursion
1209     (and (wisi-goto-statement-start)
1210          (memq (wisi-cache-nonterm (wisi-goto-statement-start)) '(use_clause with_clause)))))
1211
1212 (defun ada-wisi-goto-subunit-name ()
1213   "For `ada-goto-subunit-name'."
1214   (wisi-validate-cache (point-max))
1215   (let ((end nil)
1216         cache
1217         (name-pos nil))
1218     (save-excursion
1219       ;; move to top declaration
1220       (goto-char (point-min))
1221       (setq cache (or (wisi-get-cache (point))
1222                       (wisi-forward-cache)))
1223       (while (not end)
1224         (cl-case (wisi-cache-nonterm cache)
1225           ((pragma use_clause with_clause)
1226            (wisi-goto-end-1 cache)
1227            (setq cache (wisi-forward-cache)))
1228           (t
1229            ;; start of compilation unit
1230            (setq end t))
1231           ))
1232       (when (eq (wisi-cache-nonterm cache) 'subunit)
1233         (wisi-forward-find-token '(IDENTIFIER name selected_component) (point-max)) ;; parent name
1234         (wisi-forward-token)
1235         (wisi-forward-find-token '(IDENTIFIER name selected_component) (point-max)) ;; subunit name
1236         (setq name-pos (point)))
1237       )
1238     (when name-pos
1239       (goto-char name-pos))
1240     ))
1241
1242 (defun ada-wisi-goto-declaration-start ()
1243   "For `ada-goto-declaration-start', which see.
1244 Also return cache at start."
1245   (wisi-validate-cache (point))
1246   (let ((cache (wisi-get-cache (point)))
1247         (done nil))
1248     (unless cache
1249       (setq cache (wisi-backward-cache)))
1250     ;; cache is null at bob
1251     (while (not done)
1252       (if cache
1253           (progn
1254             (setq done
1255                   (cl-case (wisi-cache-nonterm cache)
1256                     ((generic_package_declaration generic_subprogram_declaration)
1257                      (eq (wisi-cache-token cache) 'GENERIC))
1258
1259                     ((package_body package_declaration)
1260                      (eq (wisi-cache-token cache) 'PACKAGE))
1261
1262                     ((protected_body protected_type_declaration single_protected_declaration)
1263                      (eq (wisi-cache-token cache) 'PROTECTED))
1264
1265                     ((subprogram_body subprogram_declaration null_procedure_declaration)
1266                      (memq (wisi-cache-token cache) '(NOT OVERRIDING FUNCTION PROCEDURE)))
1267
1268                     (task_type_declaration
1269                      (eq (wisi-cache-token cache) 'TASK))
1270
1271                     ))
1272             (unless done
1273               (setq cache (wisi-goto-containing cache nil))))
1274         (setq done t))
1275         )
1276     cache))
1277
1278 (defun ada-wisi-goto-declaration-end ()
1279   "For `ada-goto-declaration-end', which see."
1280   ;; first goto-declaration-start, so we get the right end, not just
1281   ;; the current statement end.
1282   (wisi-goto-end-1 (ada-wisi-goto-declaration-start)))
1283
1284 (defun ada-wisi-goto-declarative-region-start ()
1285   "For `ada-goto-declarative-region-start', which see."
1286   (wisi-validate-cache (point))
1287   (let ((done nil)
1288         (first t)
1289         (cache
1290          (or
1291           (wisi-get-cache (point))
1292           ;; we use forward-cache here, to handle the case where point is after a subprogram declaration:
1293           ;; declare
1294           ;;     ...
1295           ;;     function ... is ... end;
1296           ;;     <point>
1297           ;;     function ... is ... end;
1298           (wisi-forward-cache))))
1299     (while (not done)
1300       (if (ada-wisi-declarative-region-start-p cache)
1301           (progn
1302             (wisi-forward-token t)
1303             (setq done t))
1304         (cl-case (wisi-cache-class cache)
1305           ((block-middle block-end)
1306            (setq cache (wisi-prev-statement-cache cache)))
1307
1308           (statement-start
1309            ;; 1) test/ada_mode-nominal.adb
1310            ;;    protected body Protected_1 is -- target 2
1311            ;;        <point>
1312            ;;    want target 2
1313            ;;
1314            ;; 2) test/ada_mode-nominal.adb
1315            ;;    function Function_Access_1
1316            ;;      (A_Param <point> : in Float)
1317            ;;      return
1318            ;;        Standard.Float
1319            ;;    is -- target 1
1320            ;;    want target 1
1321            ;;
1322            ;; 3) test/ada_mode-nominal-child.adb
1323            ;;    overriding <point> function Function_2c (Param : in Child_Type_1)
1324            ;;                                    return Float
1325            ;;    is -- target Function_2c
1326            ;;    want target
1327
1328            (if first
1329                ;; case 1
1330                (setq cache (wisi-goto-containing cache t))
1331              ;; case 2, 3
1332              (cl-case (wisi-cache-nonterm cache)
1333                (subprogram_body
1334                 (while (not (eq 'IS (wisi-cache-token cache)))
1335                   (setq cache (wisi-next-statement-cache cache))))
1336                (t
1337                 (setq cache (wisi-goto-containing cache t)))
1338                )))
1339           (t
1340            (setq cache (wisi-goto-containing cache t)))
1341           ))
1342       (when first (setq first nil)))
1343     ))
1344
1345 (defun ada-wisi-in-paramlist-p ()
1346   "For `ada-in-paramlist-p'."
1347   (wisi-validate-cache (point))
1348   ;; (info "(elisp)Parser State" "*syntax-ppss*")
1349   (let* ((parse-result (syntax-ppss))
1350          cache)
1351     (and (> (nth 0 parse-result) 0)
1352          ;; cache is nil if the parse failed
1353          (setq cache (wisi-get-cache (nth 1 parse-result)))
1354          (eq 'formal_part (wisi-cache-nonterm cache)))
1355     ))
1356
1357 (defun ada-wisi-make-subprogram-body ()
1358   "For `ada-make-subprogram-body'."
1359   (wisi-validate-cache (point))
1360   (when wisi-parse-failed
1361     (error "syntax parse failed; cannot create body"))
1362
1363   (let* ((begin (point))
1364          (end (save-excursion (wisi-forward-find-class 'statement-end (point-max)) (point)))
1365          (cache (wisi-forward-find-class 'name end))
1366          (name (buffer-substring-no-properties
1367                 (point)
1368                 (+ (point) (wisi-cache-last cache)))))
1369     (goto-char end)
1370     (newline)
1371     (insert " is begin\nnull;\nend ");; legal syntax; parse does not fail
1372     (insert name)
1373     (forward-char 1)
1374
1375     ;; newline after body to separate from next body
1376     (newline-and-indent)
1377     (indent-region begin (point))
1378     (forward-line -2)
1379     (back-to-indentation); before 'null;'
1380     ))
1381
1382 (defun ada-wisi-scan-paramlist (begin end)
1383   "For `ada-scan-paramlist'."
1384   (wisi-validate-cache end)
1385   (goto-char begin)
1386   (let (token
1387         text
1388         identifiers
1389         (aliased-p nil)
1390         (in-p nil)
1391         (out-p nil)
1392         (not-null-p nil)
1393         (access-p nil)
1394         (constant-p nil)
1395         (protected-p nil)
1396         (type nil)
1397         type-begin
1398         type-end
1399         (default nil)
1400         (default-begin nil)
1401         param
1402         paramlist
1403         (done nil))
1404     (while (not done)
1405       (let ((token-text (wisi-forward-token)))
1406         (setq token (nth 0 token-text))
1407         (setq text  (nth 1 token-text)))
1408       (cond
1409        ((equal token 'COMMA) nil);; multiple identifiers
1410
1411        ((equal token 'COLON)
1412         ;; identifiers done. find type-begin; there may be no mode
1413         (skip-syntax-forward " ")
1414         (setq type-begin (point))
1415         (save-excursion
1416           (while (member (car (wisi-forward-token)) '(ALIASED IN OUT NOT NULL ACCESS CONSTANT PROTECTED))
1417             (skip-syntax-forward " ")
1418             (setq type-begin (point)))))
1419
1420        ((equal token 'ALIASED) (setq aliased-p t))
1421        ((equal token 'IN) (setq in-p t))
1422        ((equal token 'OUT) (setq out-p t))
1423        ((and (not type-end)
1424              (member token '(NOT NULL)))
1425         ;; "not", "null" could be part of the default expression
1426         (setq not-null-p t))
1427        ((equal token 'ACCESS) (setq access-p t))
1428        ((equal token 'CONSTANT) (setq constant-p t))
1429        ((equal token 'PROTECTED) (setq protected-p t))
1430
1431        ((equal token 'COLON_EQUAL)
1432         (setq type-end (save-excursion (backward-char 2) (skip-syntax-backward " ") (point)))
1433         (skip-syntax-forward " ")
1434         (setq default-begin (point))
1435         (wisi-forward-find-token 'SEMICOLON end t))
1436
1437        ((member token '(SEMICOLON RIGHT_PAREN))
1438         (when (not type-end)
1439           (setq type-end (save-excursion (backward-char 1) (skip-syntax-backward " ") (point))))
1440
1441         (setq type (buffer-substring-no-properties type-begin type-end))
1442
1443         (when default-begin
1444           (setq default (buffer-substring-no-properties default-begin (1- (point)))))
1445
1446         (when (equal token 'RIGHT_PAREN)
1447           (setq done t))
1448
1449         (setq param (list (reverse identifiers)
1450                           aliased-p in-p out-p not-null-p access-p constant-p protected-p
1451                           type default))
1452         (cl-pushnew param paramlist :test #'equal)
1453         (setq identifiers nil
1454               aliased-p nil
1455               in-p nil
1456               out-p nil
1457               not-null-p nil
1458               access-p nil
1459               constant-p nil
1460               protected-p nil
1461               type nil
1462               type-begin nil
1463               type-end nil
1464               default nil
1465               default-begin nil))
1466
1467        (t
1468         (when (not type-begin)
1469           (cl-pushnew text identifiers :test #'equal)))
1470        ))
1471     paramlist))
1472
1473 (defun ada-wisi-which-function-1 (keyword add-body)
1474   "used in `ada-wisi-which-function'."
1475   (let (region
1476         result
1477         (cache (wisi-forward-find-class 'name (point-max))))
1478
1479     (setq result (wisi-cache-text cache))
1480
1481     (when (not ff-function-name)
1482       (setq ff-function-name
1483             (concat
1484              keyword
1485              (when add-body "\\s-+body")
1486              "\\s-+"
1487              result
1488              ada-symbol-end)))
1489     result))
1490
1491 (defun ada-wisi-which-function ()
1492   "For `ada-which-function'."
1493   (wisi-validate-cache (point))
1494   (save-excursion
1495     (let ((result nil)
1496           (cache (ada-wisi-goto-declaration-start)))
1497       (if (null cache)
1498           ;; bob
1499           (setq result "")
1500
1501         (cl-case (wisi-cache-nonterm cache)
1502           ((generic_package_declaration generic_subprogram_declaration)
1503            ;; name is after next statement keyword
1504            (wisi-next-statement-cache cache)
1505            (setq cache (wisi-get-cache (point))))
1506           )
1507
1508         ;; add or delete 'body' as needed
1509         (cl-ecase (wisi-cache-nonterm cache)
1510           (package_body
1511            (setq result (ada-wisi-which-function-1 "package" nil)))
1512
1513           ((package_declaration
1514             generic_package_declaration) ;; after 'generic'
1515            (setq result (ada-wisi-which-function-1 "package" t)))
1516
1517           (protected_body
1518            (setq result (ada-wisi-which-function-1 "protected" nil)))
1519
1520           ((protected_type_declaration single_protected_declaration)
1521            (setq result (ada-wisi-which-function-1 "protected" t)))
1522
1523           ((subprogram_declaration
1524             generic_subprogram_declaration ;; after 'generic'
1525             null_procedure_declaration)
1526            (setq result (ada-wisi-which-function-1
1527                          (wisi-cache-text (wisi-forward-find-token '(FUNCTION PROCEDURE) (point-max)))
1528                          nil))) ;; no 'body' keyword in subprogram bodies
1529
1530           (subprogram_body
1531            (setq result (ada-wisi-which-function-1
1532                          (wisi-cache-text (wisi-forward-find-token '(FUNCTION PROCEDURE) (point-max)))
1533                          nil)))
1534
1535           (task_type_declaration
1536            (setq result (ada-wisi-which-function-1 "task" t)))
1537
1538           ))
1539       result)))
1540
1541 ;;;; debugging
1542 (defun ada-wisi-debug-keys ()
1543   "Add debug key definitions to `ada-mode-map'."
1544   (interactive)
1545   (define-key ada-mode-map "\M-e" 'wisi-show-parse-error)
1546   (define-key ada-mode-map "\M-h" 'wisi-show-containing-or-previous-cache)
1547   (define-key ada-mode-map "\M-i" 'wisi-goto-statement-end)
1548   (define-key ada-mode-map "\M-j" 'wisi-show-cache)
1549   (define-key ada-mode-map "\M-k" 'wisi-show-token)
1550   )
1551
1552 (defun ada-wisi-setup ()
1553   "Set up a buffer for parsing Ada files with wisi."
1554   (wisi-setup '(ada-wisi-comment
1555                 ada-wisi-before-cache
1556                 ada-wisi-after-cache)
1557               'ada-wisi-post-parse-fail
1558               ada-wisi-class-list
1559               ada-grammar-wy--keyword-table
1560               ada-grammar-wy--token-table
1561               ada-grammar-wy--parse-table)
1562
1563   ;; Handle escaped quotes in strings
1564   (setq wisi-string-quote-escape-doubled t)
1565
1566   (set (make-local-variable 'comment-indent-function) 'wisi-comment-indent)
1567
1568   (add-hook 'hack-local-variables-hook 'ada-wisi-post-local-vars nil t)
1569   )
1570
1571 (defun ada-wisi-face ()
1572   "Return face for token in match-data 2"
1573   (let (cache)
1574     (when (< (point-max) ada-wisi-font-lock-size-threshold)
1575       (wisi-validate-cache (line-end-position)))
1576
1577     (if (setq cache (wisi-get-cache (match-beginning 2)))
1578         (wisi-cache-face cache)
1579       'default)
1580     ))
1581
1582 (defun ada-wisi-post-local-vars ()
1583   ;; run after file local variables are read because font-lock-add-keywords
1584   ;; evaluates font-lock-defaults, which depends on ada-language-version.
1585   ;;
1586   ;; use parse results to distinguish difficult cases, but don't
1587   ;; require parse just for font-lock
1588   ;;
1589   ;; name is not found if on next line
1590   (font-lock-add-keywords nil
1591    (list
1592     (list
1593      "\\<\\(of[ \t]+reverse\\)\\>"  ;; following word is object
1594      '(1 font-lock-keyword-face)
1595      )
1596     (list
1597      (concat
1598       "\\<\\("
1599       "aliased[ \t]+not[ \t]+null[ \t]+access\\|"
1600       "aliased[ \t]+not[ \t]+null\\|"
1601       "return[ \t]+access[ \t]+constant\\|"
1602       "return[ \t]+access"
1603       "\\)\\>[ \t]*"
1604       ada-name-regexp "?")
1605      '(1 font-lock-keyword-face)
1606      '(2 font-lock-type-face nil t)
1607      )
1608     (list
1609      (concat
1610       "\\<\\("
1611       "aliased\\|"
1612       "and\\|"
1613       "of\\|"
1614       "new\\|"
1615       "renames\\|"
1616       "return"
1617       "\\)\\>[ \t]*"
1618       ada-name-regexp "?")
1619      '(1 font-lock-keyword-face)
1620      '(2 (ada-wisi-face) nil t)
1621      ))
1622    nil ;; add at start of list, so these have precedence
1623    )
1624
1625   )
1626
1627 (add-hook 'ada-mode-hook 'ada-wisi-setup)
1628
1629 (setq ada-fix-context-clause 'ada-wisi-context-clause)
1630 (setq ada-goto-declaration-end 'ada-wisi-goto-declaration-end)
1631 (setq ada-goto-declaration-start 'ada-wisi-goto-declaration-start)
1632 (setq ada-goto-declarative-region-start 'ada-wisi-goto-declarative-region-start)
1633 (setq ada-goto-end 'wisi-goto-statement-end)
1634 (setq ada-goto-subunit-name 'ada-wisi-goto-subunit-name)
1635 (setq ada-in-paramlist-p 'ada-wisi-in-paramlist-p)
1636 (setq ada-indent-statement 'wisi-indent-statement)
1637 (setq ada-make-subprogram-body 'ada-wisi-make-subprogram-body)
1638 (setq ada-next-statement-keyword 'wisi-forward-statement-keyword)
1639 (setq ada-on-context-clause 'ada-wisi-on-context-clause)
1640 (setq ada-prev-statement-keyword 'wisi-backward-statement-keyword)
1641 (setq ada-reset-parser 'wisi-invalidate-cache)
1642 (setq ada-scan-paramlist 'ada-wisi-scan-paramlist)
1643 (setq ada-show-parse-error 'wisi-show-parse-error)
1644 (setq ada-which-function 'ada-wisi-which-function)
1645
1646 (provide 'ada-wisi)
1647 (provide 'ada-indent-engine)
1648
1649 ;; end of file