cgit.sxemacs.org Git - packages/blob - xemacs-packages/ada/ada-stmt.el

   1 ;;; ada-stmt.el - An extension to Ada mode for inserting statement templates.
   2
   3 ;; Copyright (C) 1987, 1993, 1994, 1996, 1997 Free Software Foundation, Inc.
   4
   5 ;; Authors: Daniel Pfeiffer, Markus Heritsch, Rolf Ebert <ebert@waporo.muc.de>
   6 ;; Maintainer: Rolf Ebert <ebert@waporo.muc.de>
   7 ;; Keywords: languages, ada
   8 ;; Rolf Ebert's version: 2.26
   9
  10 ;;; Commentary:
  11
  12 ;;
  13 ;; put the following statement in your .emacs:
  14 ;; (require 'ada-stmt)
  15 ;;
  16
  17 ;;; History:
  18
  19 ;; Created May 1987.
  20 ;; Original version from V. Bowman as in ada.el of Emacs-18
  21 ;; (borrowed heavily from Mick Jordan's Modula-2 package for GNU,
  22 ;; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.)
  23 ;;
  24 ;; Sep 1993. Daniel Pfeiffer <pfeiffer@cict.fr> (DP)
  25 ;; Introduced statement.el for smaller code and user configurability.
  26 ;;
  27 ;; Nov 1993. Rolf Ebert <ebert@enpc.fr> (RE) Moved the
  28 ;; skeleton generation into this separate file. The code still is
  29 ;; essentially written by DP
  30 ;;
  31 ;; Adapted Jun 1994. Markus Heritsch
  32 ;; <Markus.Heritsch@studbox.uni-stuttgart.de> (MH)
  33 ;; added menu bar support for templates
  34 ;;
  35 ;; 1994/12/02  Christian Egli <cegli@hcsd.hac.com>
  36 ;; General cleanup and bug fixes.
  37 ;;
  38 ;; 1995/12/20  John Hutchison <hutchiso@epi.syr.ge.com>
  39 ;; made it work with skeleton.el from emacs-19.30. Several
  40 ;; enhancements and bug fixes.
  41
  42 ;; BUGS:
  43 ;;;> I have the following suggestions for the function template: 1) I
  44 ;;;> don't want it automatically assigning it a name for the return variable. I
  45 ;;;> never want it to be called "Result" because that is nondescriptive. If you
  46 ;;;> must define a variable, give me the ability to specify its name.
  47 ;;;>
  48 ;;;> 2) You do not provide a type for variable 'Result'. Its type is the same
  49 ;;;> as the function's return type, which the template knows, so why force me
  50 ;;;> to type it in?
  51 ;;;>
  52
  53 ;;;It would be nice if one could configure such layout details separately
  54 ;;;without patching the LISP code. Maybe the metalanguage used in ada-stmt.el
  55 ;;;could be taken even further, providing the user with some nice syntax
  56 ;;;for describing layout. Then my own hacks would survive the next
  57 ;;;update of the package :-)
  58
  59 \f
  60 ;;; Code:
  61
  62 (require 'ada-mode)
  63 (load "skeleton") ;; bug in 19.28 through 19.30 skeleton.el, not provided.
  64 (require 'easymenu)
  65
  66 (defvar ada-stmt-use-debug t
  67   "*Toggle to insert ada debug code parts.")
  68
  69
  70 (defvar ada-debug-call-str "pragma Debug (%s);"
  71   "*Debug call code to insert.")
  72
  73
  74 (defvar ada-debug-exception-str "pragma Debug (%s);"
  75   "*Debug exception code to insert." )
  76
  77
  78 \f
  79 (defun ada-func-or-proc-name ()
  80   ;; Get the name of the current function or procedure."
  81   (save-excursion
  82     (let ((case-fold-search t))
  83       (if (re-search-backward ada-procedure-start-regexp nil t)
  84           (buffer-substring (match-beginning 2) (match-end 2))
  85         "NAME?"))))
  86
  87
  88 (defun ada-toggle-debugging ()
  89   "Toggles behaviour of `ada-debug-info-insertion'."
  90   (interactive)
  91   (setq ada-stmt-use-debug (not ada-stmt-use-debug))
  92   (if ada-stmt-use-debug
  93       (message "Debugging enabled")
  94     (message "Debugging disabled")))
  95
  96
  97 (defvar ada-template-map nil
  98   "Keymap used in Ada mode for smart template operations.")
  99
 100
 101 (let ((ada-mp (make-sparse-keymap)))
 102   (define-key ada-mp "h" 'ada-header)
 103 ;  (define-key ada-mp "p" 'ada-toggle-prompt-pseudo)
 104   (define-key ada-mp "(" 'insert-parentheses)
 105   (define-key ada-mp "\C-a" 'ada-array)
 106   (define-key ada-mp "b" 'ada-exception-block)
 107   (define-key ada-mp "d" 'ada-declare-block)
 108   (define-key ada-mp "c" 'ada-case)
 109   (define-key ada-mp "\C-e" 'ada-elsif)
 110   (define-key ada-mp "e" 'ada-else)
 111   (define-key ada-mp "\C-k" 'ada-package-spec)
 112   (define-key ada-mp "k" 'ada-package-body)
 113   (define-key ada-mp "\C-p" 'ada-procedure-spec)
 114   (define-key ada-mp "\C-f" 'ada-function-spec)
 115   (define-key ada-mp "p" 'ada-subprogram-body)
 116   (define-key ada-mp "f" 'ada-for-loop)
 117   (define-key ada-mp "i" 'ada-if)
 118   (define-key ada-mp "l" 'ada-loop)
 119   (define-key ada-mp "\C-r" 'ada-record)
 120   (define-key ada-mp "\C-s" 'ada-subtype)
 121   (define-key ada-mp "S" 'ada-tabsize)
 122   (define-key ada-mp "\C-t" 'ada-task-spec)
 123   (define-key ada-mp "t" 'ada-task-body)
 124   (define-key ada-mp "\C-y" 'ada-type)
 125   (define-key ada-mp "\C-v" 'ada-private)
 126   (define-key ada-mp "u" 'ada-use)
 127   (define-key ada-mp "\C-u" 'ada-with)
 128   (define-key ada-mp "\C-w" 'ada-when)
 129   (define-key ada-mp "w" 'ada-while-loop)
 130   (define-key ada-mp "\C-x" 'ada-exception)
 131   (define-key ada-mp "x" 'ada-exit)
 132   (setq ada-template-map ada-mp))
 133
 134 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 135 ;; Place the templates into Ada Mode.  They may be inserted under any key.
 136 ;; C-c C-t will be the default.  If you use templates alot, you
 137 ;; may want to consider moving the binding to another key in your .emacs
 138 ;; file.  Be sure to (require 'ada-stmt) first.
 139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 140 ;(define-key ada-mode-map "\C-ct" ada-template-map)
 141 (define-key ada-mode-map "\C-c\C-t" ada-template-map)
 142
 143 ;;; ---- statement skeletons ------------------------------------------
 144
 145 (define-skeleton ada-array
 146   "Insert array type definition.  Uses the minibuffer to prompt
 147 for component type and index subtypes."
 148   ()
 149   "array (" ("index definition: " str ", " ) -2 ") of " _ ?\;)
 150
 151
 152 (define-skeleton ada-case
 153   "Build skeleton case statement, prompting for the selector expression.
 154 Also builds the first when clause."
 155   "[selector expression]: "
 156   "case " str " is" \n
 157   > "when " ("discrete choice: " str " | ") -3 " =>" \n
 158   > _ \n
 159   < < "end case;")
 160
 161
 162 (define-skeleton ada-when
 163   "Start a case statement alternative with a when clause."
 164   ()
 165   < "when " ("discrete choice: " str " | ") -3 " =>" \n
 166   >)
 167
 168
 169 (define-skeleton ada-declare-block
 170   "Insert a block with a declare part.
 171 Indent for the first declaration."
 172   "[block name]: "
 173   < str & ?: & \n
 174   > "declare" \n
 175   > _ \n
 176   < "begin" \n
 177   > \n
 178   < "end " str | -1 ?\;)
 179
 180
 181 (define-skeleton ada-exception-block
 182   "Insert a block with an exception part.
 183 Indent for the first line of code."
 184   "[block name]: "
 185   < str & ?: & \n
 186   > "begin" \n
 187   > _ \n
 188   < "exception" \n
 189   > \n
 190   < "end " str | -1 ?\;)
 191
 192
 193 (define-skeleton ada-exception
 194   "Insert an indented exception part into a block."
 195   ()
 196   < "exception" \n
 197   >)
 198
 199
 200 (define-skeleton ada-exit-1
 201   "Insert then exit condition of the exit statement, prompting for condition."
 202   "[exit condition]: "
 203   "when " str | -5)
 204
 205
 206 (define-skeleton ada-exit
 207   "Insert an exit statement, prompting for loop name and condition."
 208   "[name of loop to exit]: "
 209   "exit " str & ?\
 210   (ada-exit-1)
 211   | -1 ?\;)
 212
 213
 214 (defun ada-header ()
 215   "Insert a descriptive header at the top of the file."
 216   (interactive "*")
 217   (save-excursion
 218     (goto-char (point-min))
 219     (if (fboundp 'make-header)
 220         (make-header)
 221       (ada-header-tmpl))))
 222
 223
 224 (define-skeleton ada-header-tmpl
 225   "Insert a comment block containing the module title, author, etc."
 226   "[Description]: "
 227   "--                              -*- Mode: Ada -*-"
 228   "\n-- Filename        : " (buffer-name)
 229   "\n-- Description     : " str
 230   "\n-- Author          : " (user-full-name)
 231   "\n-- Created On      : " (current-time-string)
 232   "\n-- Last Modified By: ."
 233   "\n-- Last Modified On: ."
 234   "\n-- Update Count    : 0"
 235   "\n-- Status          : Unknown, Use with caution!"
 236   "\n")
 237
 238
 239 (define-skeleton ada-display-comment
 240   "Inserts three comment lines, making a display comment."
 241   ()
 242   "--\n-- " _ "\n--")
 243
 244
 245 (define-skeleton ada-if
 246   "Insert skeleton if statement, prompting for a boolean-expression."
 247   "[condition]: "
 248   "if " str " then" \n
 249   > _ \n
 250   < "end if;")
 251
 252
 253 (define-skeleton ada-elsif
 254   "Add an elsif clause to an if statement,
 255 prompting for the boolean-expression."
 256   "[condition]: "
 257   < "elsif " str " then" \n
 258   >)
 259
 260
 261 (define-skeleton ada-else
 262   "Add an else clause inside an if-then-end-if clause."
 263   ()
 264   < "else" \n
 265   >)
 266
 267
 268 (define-skeleton ada-loop
 269   "Insert a skeleton loop statement.  The exit statement is added by hand."
 270   "[loop name]: "
 271   < str & ?: & \n
 272   > "loop" \n
 273   > _ \n
 274   < "end loop " str | -1 ?\;)
 275
 276
 277 (define-skeleton ada-for-loop-prompt-variable
 278   "Prompt for the loop variable."
 279   "[loop variable]: "
 280   str)
 281
 282
 283 (define-skeleton ada-for-loop-prompt-range
 284   "Prompt for the loop range."
 285   "[loop range]: "
 286   str)
 287
 288
 289 (define-skeleton ada-for-loop
 290   "Build a skeleton for-loop statement, prompting for the loop parameters."
 291   "[loop name]: "
 292   < str & ?: & \n
 293   > "for "
 294   (ada-for-loop-prompt-variable)
 295   " in "
 296   (ada-for-loop-prompt-range)
 297   " loop" \n
 298   > _ \n
 299   < "end loop " str | -1 ?\;)
 300
 301
 302 (define-skeleton ada-while-loop-prompt-entry-condition
 303   "Prompt for the loop entry condition."
 304   "[entry condition]: "
 305   str)
 306
 307
 308 (define-skeleton ada-while-loop
 309   "Insert a skeleton while loop statement."
 310   "[loop name]: "
 311   < str & ?: & \n
 312   > "while "
 313   (ada-while-loop-prompt-entry-condition)
 314   " loop" \n
 315   > _ \n
 316   < "end loop " str | -1 ?\;)
 317
 318
 319 (define-skeleton ada-package-spec
 320   "Insert a skeleton package specification."
 321   "[package name]: "
 322   "package " str  " is" \n
 323   > _ \n
 324   < "end " str ?\;)
 325
 326
 327 (define-skeleton ada-package-body
 328   "Insert a skeleton package body --  includes a begin statement."
 329   "[package name]: "
 330   "package body " str " is" \n
 331   > _ \n
 332 ;  < "begin" \n
 333   < "end " str ?\;)
 334
 335
 336 (define-skeleton ada-private
 337   "Undent and start a private section of a package spec. Reindent."
 338   ()
 339   < "private" \n
 340   >)
 341
 342
 343 (define-skeleton ada-function-spec-prompt-return
 344   "Prompts for function result type."
 345   "[result type]: "
 346   str)
 347
 348
 349 (define-skeleton ada-function-spec
 350   "Insert a function specification.  Prompts for name and arguments."
 351   "[function name]: "
 352   "function " str
 353   " (" ("[parameter_specification]: " str "; " ) -2 ")"
 354   " return "
 355   (ada-function-spec-prompt-return)
 356   ";" \n )
 357
 358
 359 (define-skeleton ada-procedure-spec
 360   "Insert a procedure specification, prompting for its name and arguments."
 361   "[procedure name]: "
 362   "procedure " str
 363   " (" ("[parameter_specification]: " str "; " ) -2 ")"
 364   ";" \n )
 365
 366
 367 (define-skeleton ada-subprogram-body
 368   "Insert frame for subprogram body.
 369 Invoke right after `ada-function-spec' or `ada-procedure-spec'."
 370   ()
 371   ;; Remove `;' from subprogram decl
 372   (save-excursion
 373     (ada-search-ignore-string-comment ada-subprog-start-re t nil)
 374     (ada-search-ignore-string-comment "(" nil nil t)
 375     (backward-char 1)
 376     (forward-sexp 1)
 377     (if (looking-at ";")
 378         (delete-char 1)))
 379   < "is" \n
 380   > _ \n
 381   < "begin" \n
 382   > (if ada-stmt-use-debug
 383         (format ada-debug-call-str (ada-func-or-proc-name))) \n
 384   > \n
 385   < (if ada-stmt-use-debug
 386       "exception") & \n
 387   > (if ada-stmt-use-debug
 388       "when others =>") & \n
 389   > (if ada-stmt-use-debug
 390       (format ada-debug-exception-str (ada-func-or-proc-name))) \n
 391   < < "end "
 392   (ada-func-or-proc-name)
 393   ?\;)
 394
 395
 396 (define-skeleton ada-separate
 397   "Finish a body stub with `separate'."
 398   ()
 399   > "separate;" \n
 400   <)
 401
 402
 403 ;(define-skeleton ada-with
 404 ;  "Inserts a with clause, prompting for the list of units depended upon."
 405 ;  "[list of units depended upon]: "
 406 ;  "with " str ?\;)
 407
 408 ;(define-skeleton ada-use
 409 ;  "Inserts a use clause, prompting for the list of packages used."
 410 ;  "[list of packages used]: "
 411 ;  "use " str ?\;)
 412
 413
 414 (define-skeleton ada-record
 415   "Insert a skeleton record type declaration."
 416   ()
 417   "record" \n
 418   > _ \n
 419   < "end record;")
 420
 421
 422 (define-skeleton ada-subtype
 423   "Start insertion of a subtype declaration, prompting for the subtype name."
 424   "[subtype name]: "
 425   "subtype " str " is " _ ?\;
 426   (not (message "insert subtype indication.")))
 427
 428
 429 (define-skeleton ada-type
 430   "Start insertion of a type declaration, prompting for the type name."
 431   "[type name]: "
 432   "type " str ?\(
 433   ("[discriminant specs]: " str " ")
 434   | (backward-delete-char 1) | ?\)
 435   " is "
 436   (not (message "insert type definition.")))
 437
 438
 439 (define-skeleton ada-task-body
 440   "Insert a task body, prompting for the task name."
 441   "[task name]: "
 442   "task body " str " is\n"
 443   "begin\n"
 444   > _ \n
 445   < "end " str ";" )
 446
 447
 448 (define-skeleton ada-task-spec
 449   "Insert a task specification, prompting for the task name."
 450   "[task name]: "
 451   "task " str
 452   " (" ("[discriminant]: " str "; ") ") is\n"
 453   > "entry " _ \n
 454   <"end " str ";" )
 455
 456
 457 (define-skeleton ada-get-param1
 458   "Prompt for arguments and if any enclose them in brackets."
 459   ()
 460   ("[parameter_specification]: " str "; " ) & -2 & ")"
 461   )
 462
 463
 464 (define-skeleton ada-get-param
 465   "Prompt for arguments and if any enclose them in brackets."
 466   ()
 467   " ("
 468   (ada-get-param1) | -2
 469   )
 470
 471
 472 (define-skeleton ada-entry
 473   "Insert a task entry, prompting for the entry name."
 474   "[entry name]: "
 475   "entry " str
 476   (ada-get-param)
 477   ";" \n
 478 ;  (ada-indent-current)
 479 )
 480
 481
 482 (define-skeleton ada-entry-family-prompt-discriminant
 483   "Insert a entry specification, prompting for the entry name."
 484   "[discriminant name]: "
 485   str)
 486
 487
 488 (define-skeleton ada-entry-family
 489   "Insert a entry specification, prompting for the entry name."
 490   "[entry name]: "
 491   "entry " str
 492   " (" (ada-entry-family-prompt-discriminant) ")"
 493   (ada-get-param)
 494   ";" \n
 495   ;(ada-indent-current)
 496 )
 497
 498
 499 (define-skeleton ada-select
 500   "Insert a select block."
 501   ()
 502   "select\n"
 503   > _ \n
 504   < "end select;")
 505
 506
 507 (define-skeleton ada-accept-1
 508   "Insert a condition statement, prompting for the condition name."
 509   "[condition]: "
 510   "when " str | -5 )
 511
 512
 513 (define-skeleton ada-accept-2
 514   "Insert an accept statement, prompting for the name and arguments."
 515   "[accept name]: "
 516   > "accept " str
 517   (ada-get-param)
 518 ;  " (" ("[parameter_specification]: " str "; ") -2 ")"
 519   " do" \n
 520   > _ \n
 521   < "end " str ";" )
 522
 523
 524 (define-skeleton ada-accept
 525   "Insert an accept statement (prompt for condition, name and arguments)."
 526   ()
 527   > (ada-accept-1) & " =>\n"
 528   (ada-accept-2)
 529 )
 530
 531
 532 (define-skeleton ada-or-accept
 533   "Insert a or statement, prompting for the condition name."
 534   ()
 535   < "or\n"
 536   (ada-accept)
 537 )
 538
 539
 540 (define-skeleton ada-or-delay
 541   "Insert a delay statement, prompting for the delay value."
 542   "[delay value]: "
 543   < "or\n"
 544   > "delay " str ";")
 545
 546
 547 (define-skeleton ada-or-terminate
 548   "Insert a terminate statement."
 549   ()
 550   < "or\n"
 551   > "terminate;")
 552
 553
 554 ;; ----
 555 (defun ada-adjust-case-skeleton ()
 556   "Adjusts the case of the text inserted by a skeleton."
 557   (save-excursion
 558     (let ((aa-end (point)))
 559       (ada-adjust-case-region
 560        (progn (goto-char beg) (forward-word -1) (point))
 561        (goto-char aa-end))
 562       )))
 563
 564
 565 ;; ---- add menu 'Statements' in Ada mode (MH)
 566 (defun ada-add-statement-menu ()
 567   "Adds the menu 'Statements' to the menu bar in Ada mode."
 568   (easy-menu-define ada-stmt-menu ada-mode-map
 569                     "Menu for statement templates in Ada."
 570                     '("Statements"
 571 ;                     ["Toggle Prompt/Pseudo Code" toggle-skeleton-no-prompt t]
 572                       ["Toggle: Debugging" ada-toggle-debugging t]
 573 ;                     ["-------" nil nil]
 574                       ["Header" (ada-header) t]
 575                       ["-------" nil nil]
 576                       ["package Body" (ada-package-body) t]
 577                       ["package Spec" (ada-package-spec) t]
 578                       ["function Spec" (ada-function-spec) t]
 579                       ["procedure Spec" (ada-procedure-spec) t]
 580                       ["proc/func Body" (ada-subprogram-body) t]
 581                       ["task Body" (ada-task-body) t]
 582                       ["task Spec" (ada-task-spec) t]
 583                       ["declare Block" (ada-declare-block) t]
 584                       ["exception Block" (ada-exception-block) t]
 585                       ["------" nil nil]
 586                       ["entry" (ada-entry) t]
 587                       ["entry family" (ada-entry-family) t]
 588                       ["select" (ada-select) t]
 589                       ["accept" (ada-accept) t]
 590                       ["or accept" (ada-or-accept) t]
 591                       ["or delay" (ada-or-delay) t]
 592                       ["or terminate" (ada-or-terminate) t]
 593                       ["-----" nil nil]
 594                       ["type" (ada-type) t]
 595                       ["private" (ada-private) t]
 596                       ["subtype" (ada-subtype) t]
 597                       ["record" (ada-record) t]
 598                       ["array" (ada-array) t]
 599                       ["------" nil nil]
 600                       ["if" (ada-if) t]
 601                       ["else" (ada-else) t]
 602                       ["elsif" (ada-elsif) t]
 603                       ["case" (ada-case) t]
 604                       ["-----" nil nil]
 605                       ["while Loop" (ada-while-loop) t]
 606                       ["for Loop" (ada-for-loop) t]
 607                       ["loop" (ada-loop) t]
 608                       ["---" nil nil]
 609                       ["exception" (ada-exception) t]
 610                       ["exit" (ada-exit) t]
 611                       ["when" (ada-when) t]
 612                       ))
 613     (if (ada-xemacs)
 614         (progn
 615           (easy-menu-add ada-stmt-menu)
 616           (setq mode-popup-menu (cons "Ada Mode" ada-stmt-menu)))))
 617
 618
 619
 620 (add-hook 'ada-mode-hook 'ada-add-statement-menu)
 621 (add-hook 'ada-mode-hook '(lambda ()
 622                             (setq skeleton-further-elements
 623                                   '((< '(backward-delete-char-untabify
 624                                          (min ada-indent (current-column))))))
 625                             (add-hook 'skeleton-end-hook
 626                                       'ada-adjust-case-skeleton)))
 627
 628 (provide 'ada-stmt)
 629
 630 ;;; ada-stmt.el ends here