⟦854fe14af⟧

TextFile

;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Emacs-Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ada-etempl.el --- Ada 'smart' template editing support.
;;                   Is distributed ada.el integrated into the bigger support
;; Author          : Vincent Broman
;; Created On      : Wed Jul 20 07:35:07 1988
;; Last Modified By: Lynn Slater
;; Last Modified On: Tue Oct 18 07:03:13 1988
;; Update Count    : 28
;; Status          : General Public Release 1.05
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This file is part of GNU Emacs.
;; Copyright (C) 1988 Lynn Randolph Slater, Jr.
;; Copyright (C) 1988 Free Software Foundation, Inc.
;;
;; This file is distributed in the hope that it will be useful,
;; but without any warranty.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.
;;
;; Everyone is granted permission to copy, modify and redistribute
;; this file, but only under the conditions described in the
;; document "GNU Emacs copying permission notice".   An exact copy
;; of the document is supposed to have been given to you along with
;; this file so that you can know how you may redistribute it all.
;; It should be in a file named COPYING.  Among other things, the
;; copyright notice and this notice must be preserved on all copies.

;; Make this a file called ada-etempl.el in your path
;; You should byte-compile it.

; Obtained by editing the following:
;;; Ada editing support package in GNU Emacs Elisp.  v2.4
;;; Author: Vincent Broman <broman@nosc.mil>  March 1988.
;;;
;;; (borrows from Mick Jordan's modula-2-mode for Emacs,
;;; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.)
;;;
;;; Tries hard to do all the indenting automatically.
;;; Emphasizes correct insertion of new code using smart templates.
;;;
;;; To do:   semiautomatic variable declaration.
;;;          stubbing
;;;          interface with abbrev-mode and/or outline-mode
;;;
; 'Smart' templates are those that have procedural logic rather than a
; blind adhesion to a BNF.

;; History 		
;; 12-Oct-1988		Lynn Slater	
;;    Added ada-box command
;; 11-Oct-1988		Lynn Slater	
;;    Moved point-on-blank-line and ada-go-to-this-indent to elec-ada.el
;;    cause they are very useful 
;; 26-Sep-1988		Lynn Slater	
;;    Incorperated, in full, latest changes from Vincent Broman. These
;;    essentually replace in full the previous releases of ada-etempl.el

(provide 'ada-etempl)
(require 'elec-ada)

(defvar ada-template-map nil
  "Keymap used in Ada mode for smart template operations.")

(let ((ada-mp (make-sparse-keymap)))
  (define-key ada-mp "\C-m" 'ada-openline)
  (define-key ada-mp "h" 'ada-header)
  (define-key ada-mp "(" 'insert-parentheses)
  (define-key ada-mp "-" 'ada-comment)
  (define-key ada-mp "=" 'ada-show-subprogram-name)
  (define-key ada-mp "<" 'ada-backward-to-less-indent)
  (define-key ada-mp ">" 'ada-forward-to-same-indent)
  (define-key ada-mp "\C-a" 'ada-array)
  (define-key ada-mp "a" 'ada-accept)
  (define-key ada-mp "b" 'ada-exception-block)
  (define-key ada-mp "d" 'ada-declare-block)
  (define-key ada-mp "c" 'ada-case)
  (define-key ada-mp "\C-e" 'ada-elsif)
  (define-key ada-mp "e" 'ada-else)
  (define-key ada-mp "\C-k" 'ada-package-spec)
  (define-key ada-mp "k" 'ada-package-body)
  (define-key ada-mp "\C-n" 'ada-entry)
  (define-key ada-mp "\C-p" 'ada-procedure-spec)
  (define-key ada-mp "p" 'ada-subprogram-body)
  (define-key ada-mp "\C-f" 'ada-function-spec)
  (define-key ada-mp "f" 'ada-for-loop)
  (define-key ada-mp "i" 'ada-if)
  (define-key ada-mp "l" 'ada-loop)
  (define-key ada-mp "o" 'ada-or)
  (define-key ada-mp "\C-r" 'ada-record)
  (define-key ada-mp "\C-s" 'ada-subtype)
  (define-key ada-mp "s" 'ada-select)
;;;  (define-key ada-mp "S" 'ada-separate)
  (define-key ada-mp "S" 'ada-tabsize)
  (define-key ada-mp "\C-t" 'ada-task-spec)
  (define-key ada-mp "t" 'ada-task-body)
  (define-key ada-mp "\C-y" 'ada-type)
  (define-key ada-mp "\C-u" 'ada-with-use)
  (define-key ada-mp "\C-v" 'ada-private)
  (define-key ada-mp "\C-w" 'ada-when)
  (define-key ada-mp "w" 'ada-while-loop)
  (define-key ada-mp "\C-x" 'ada-exception)
  (define-key ada-mp "x" 'ada-exit)
  (setq ada-template-map ada-mp))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Place the templates into ada mode.  They may be inserted under any key.
;; C-c t and C-c C-t will be the defaults.  If you use templates alot, you
;; may want to consider moving the binding to another key in your .emacs
;; file.  be sure to (require 'ada-etempl) first.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-key ada-mode-map "\C-ct" ada-template-map)
(define-key ada-mode-map "\C-c\C-t" ada-template-map)

(defvar ada-edit-prefix "Last Mod:    "
  "*String prefixed to the timestamp from the last ada-mode edit of this file.")

(defvar ada-openparen-style " ("
  "*The string inserted for open parens.  Spaces may precede or follow.")

(defvar ada-closeparen-style ")"
  "*The string inserted for close parens.  Spaces may precede or follow.")


(defun ada-indent-after-heading ()
  "Returns the amount of indentation desired
on the line just after a subprogram heading with no body."
  (cdr (ada-get-subprogram-name)))

(defun ada-newline ()
  "Start new line and indent to current tab stop."
  (interactive)
  (let ((ada-cc (current-indentation)))
    (newline)
    (indent-to ada-cc)))

(defun ada-openline ()
  "Start new line ahead of this line and indent to current tab stop."
  (interactive)
  (let ((ada-cc (current-indentation)))
    (beginning-of-line)
    (open-line 1)
    (indent-to ada-cc)))

(defun ada-indent-more ()
  "Indent to next tab stop."
  (interactive)
  (indent-to (* (1+ (/ (current-indentation) indent-change)) indent-change)))

(defun ada-indent-less ()
  "Delete backwards from current indentation to previous tab stop."
  (interactive)
  (let ((ada-cc (current-indentation)))
    (if (> ada-cc 0)
	(progn
	  (back-to-indentation)
	  (backward-delete-char-untabify
	    (1+ (mod (1- ada-cc) indent-change)) nil)))))

(defun ada-two-lines-one-indented ()
  "Insert two newlines, the first indented again, the second not."
  (ada-newline)
  (ada-indent-more)
  (ada-newline)
  (ada-indent-less))

(defun ada-comment-and-temp-indent ()
  "Insert three newlines, the first before a comment line,
the second temporarily indented again, the third not."
  (let ((ada-indentation (current-indentation)))
    (insert "\n" comment-start "\n")
    (indent-to ada-indentation))
  (ada-indent-more)
  (ada-newline)
  (ada-indent-less))
    
;; Moved fcn below to elec-ada because it was so useful.
;;(defun ada-go-to-this-indent (step indent-level) 
;;  "Move point repeatedly by <step> lines till the current line
;;has given indent-level or less, or the start/end of the buffer is hit.
;;Ignore blank lines, statement labels, block/loop names."
;;  (while (and
;;	  (zerop (forward-line step))
;;	  (or (looking-at
;;"^[ \t\f]*$\\|^[ \t\f]*--\\|^<<[A-Za-z0-9_]+>>\\|^[A-Za-z0-9_]+:")
;;	      (> (current-indentation) indent-level)))
;;    nil))

(defun ada-backward-to-same-indent ()
  "Move point backwards to nearest line with same indentation or less.
If not found, point is left at top of buffer."
  (interactive)
  (ada-go-to-this-indent -1 (current-indentation))
  (back-to-indentation))

(defun ada-forward-to-same-indent ()
  "Move point forwards to nearest line with same indentation or less.
If not found, point is left at start of last line in buffer."
  (interactive)
  (ada-go-to-this-indent 1 (current-indentation))
  (back-to-indentation))

(defun ada-backward-to-less-indent ()
  "Move point backwards to nearest line with less indentation.
If not found, point is left at top of buffer."
  (interactive)
  (ada-go-to-this-indent -1 (1- (current-indentation)))
  (back-to-indentation))

(defun ada-forward-to-less-indent ()
  "Move point forwards to nearest line with less indentation.
If not found, point is left at start of last line in buffer."
  (interactive)
  (ada-go-to-this-indent 1 (1- (current-indentation)))
  (back-to-indentation))


(defun ada-start-insert-here ()
  "Remember that point is the start of a long construct being inserted.
This makes an undo after the insertion retreat to this point."
  (undo-boundary))

(defun ada-end-insert-here ()
  "Remember point as the end of a long construct being inserted.
Also, make this point and the following line visible on screen if it is not.
This function might be called repeatedly during any one insertion,
because of all the opportunities for keyboard interrupts during read-string."
  (save-excursion
    (end-of-line 2)
    (if (not (pos-visible-in-window-p))
	(recenter -1))))

(defun ada-end-insert-at (ada-line-offset)
  "Remember the point at the end of ada-line-offset lines following
the current line as being the end of a long construct being inserted."
  (save-excursion
    (end-of-line (1+ ada-line-offset))
    (ada-end-insert-here)))


(defun ada-array ()
  "Add an array type definition,
prompting for the component type and the index subtypes."
  (interactive)
  (ada-start-insert-here)
  (insert "array" ada-openparen-style ada-closeparen-style)
  (ada-end-insert-here)
  (backward-char (length ada-closeparen-style))
  (insert (read-string "index subtype(s): "))
  (end-of-line)
  (insert " of ;")
  (ada-end-insert-here)
  (backward-char)
  (insert (read-string "component type: "))
  (end-of-line)
  (ada-end-insert-here))

(defun ada-accept (ada-bodiless)
  "Insert an accept statement, prompting for its entry name and arguments.
If a prefix argument is supplied, the accept statement has no do-end body."
  (interactive "P")
  (ada-start-insert-here)
  (insert "accept ")
  (ada-end-insert-here)
  (let ((ada-orig-indent (current-indentation))
	(ada-entry-name (read-string "entry name: "))
	(ada-entry-index nil))
    (insert ada-entry-name)
    (ada-end-insert-here)
    (setq ada-entry-index (read-string "[entry index]: "))
    (if (not (string-equal ada-entry-index ""))
	(insert ada-openparen-style ada-entry-index ada-closeparen-style))
    (ada-get-arg-list)
    (if (not ada-bodiless)
	(progn
	  (insert " do")
	  (newline)
	  (indent-to ada-orig-indent)
	  (ada-indent-more)
	  (ada-newline)
	  (ada-indent-less)
	  (insert "end " ada-entry-name))))
  (insert ";")
  (ada-end-insert-here)
  (if (not ada-bodiless)
      (end-of-line 0)))

(defun ada-case ()
  "Build skeleton case statement, prompting for the selector expression."
  (interactive)
  (ada-start-insert-here)
  (insert "case ")
  (ada-end-insert-here)
  (insert (read-string "selector expression: ") " is")
  (ada-two-lines-one-indented)
  (insert "end case;")
  (ada-end-insert-here)
  (end-of-line 0))

(defun ada-declare-block ()
  "Insert a block with a declare part and indent for the 1st declaration."
  (interactive)
  (ada-start-insert-here)
  (insert "declare")
  (ada-end-insert-here)
  (let ((ada-block-name (read-string "[block name]: ")))
    (if (not (string-equal ada-block-name ""))
	(progn
	  (beginning-of-line)
	  (open-line 1)
	  (insert ada-block-name ":")
	  (end-of-line 2)))
    (ada-two-lines-one-indented)
    (insert "begin")
    (ada-two-lines-one-indented)
    (if (string-equal ada-block-name "")
	(insert "end;")
      (insert "end " ada-block-name ";")))
  (ada-end-insert-here)
  (end-of-line -2))

(defun ada-exception-block ()
  "Insert a block with an exception part and indent for the 1st line of code."
  (interactive)
  (ada-start-insert-here)
  (insert "begin")
  (ada-end-insert-here)
  (let ((ada-block-name (read-string "[block name]: ")))
    (if (not (string-equal ada-block-name ""))
	(progn
	  (beginning-of-line)
	  (open-line 1)
	  (insert ada-block-name ":")
	  (end-of-line 2)))
    (ada-two-lines-one-indented)
    (insert "exception")
    (ada-two-lines-one-indented)
    (if (string-equal ada-block-name "")
	(insert "end;")
      (insert "end " ada-block-name ";")))
  (ada-end-insert-here)
  (end-of-line -2))

(defun ada-exception ()
  "Undent and insert an exception part into a block.  Reindent."
  (interactive)
  (ada-start-insert-here)
  (ada-indent-less)
  (insert "exception")
  (ada-newline)
  (ada-indent-more)
  (ada-end-insert-here))

(defun ada-last-key-when ()
  "Predicate checks whether the nearest preceding code line with less
indentation starts with the keyword WHEN."
  (save-excursion
    (end-of-line 0)
    (ada-backward-to-less-indent)
    (let ((case-fold-search t))
      (looking-at "when\\>"))))

(defun ada-else ()
  "Add an else clause inside an if-then-end-if or select clause."
  (interactive)
  (ada-start-insert-here)
  (ada-indent-less)
  (if (ada-last-key-when)
      (ada-indent-less))
  (insert "else")
  (ada-newline)
  (ada-indent-more)
  (ada-end-insert-here))

(defun ada-insert-guard-condition ()
  "On newline, prompt for and insert an optional guard condition, and indent."
  (ada-newline)
  (ada-indent-more)
  (insert "when  =>")
  (ada-end-insert-here)
  (backward-char 3)
  (let ((ada-guard-condition (read-string "[guard condition]: ")))
    (if (string-equal ada-guard-condition "")
	(progn
	  (end-of-line)
	  (delete-backward-char 8))	; length of when  =>
	(progn
	  (insert ada-guard-condition)
	  (end-of-line)
	  (ada-newline)
	  (ada-indent-more)))))

(defun ada-or ()
  "Add an or clause inside a select clause."
  (interactive)
  (ada-start-insert-here)
  (ada-indent-less)
  (if (ada-last-key-when)
      (ada-indent-less))
  (insert "or")
  (ada-insert-guard-condition)
  (ada-end-insert-here))

(defun ada-select ()
  "Add a skeleton select clause, prompting for an optional guard condition."
  (interactive)
  (ada-start-insert-here)
  (insert "select")
  (let ((ada-old-indent (current-indentation)))
    (ada-insert-guard-condition)
    (newline)
    (indent-to ada-old-indent))
    (insert "end select;")
  (ada-end-insert-here)
  (end-of-line 0))

(defun ada-when ()
  "Start a case statement alternative or exception handler with a when clause.
When clauses in exit and select statements
are prompted for during the creation of those statements."
  (interactive)
  (end-of-line)
  (ada-start-insert-here)
  (if (=
	(current-indentation)
	(save-excursion
	  (end-of-line 0)
	  (current-indentation)))
      (ada-indent-less))			; not already undented by hand
  (insert "when  =>")
  (ada-end-insert-here)
  (backward-char 3)
  (insert (read-string "list of choice| choice| choice...: "))
  (end-of-line)
  (ada-newline)
  (ada-indent-more)
  (ada-end-insert-here))

(defun ada-exit ()
  "Insert an exit statement, prompting for loop name and condition."
  (interactive)
  (ada-start-insert-here)
  (insert "exit")
  (ada-end-insert-here)
  (let ((ada-loop-name (read-string "[name of loop to exit]: ")))
    (if (not (string-equal ada-loop-name ""))
	(insert " " ada-loop-name)))
  (insert " when ")
  (ada-end-insert-here)
  (let ((ada-exit-condition (read-string "[exit condition]: ")))
    (if (string-equal ada-exit-condition "")
	(delete-backward-char 6)
      (insert ada-exit-condition)))
  (insert ";")
  (ada-end-insert-here))

(defun ada-for-loop ()
  "Build a skeleton for-loop statement, prompting for the loop parameters."
  (interactive)
  (ada-start-insert-here)
  (insert "for ")
  (ada-end-insert-here)
  (let* ((ada-loop-name (read-string "[loop name]: "))
	 (ada-loop-is-named (not (string-equal ada-loop-name ""))))
    (if ada-loop-is-named
	(progn
	  (beginning-of-line)
	  (open-line 1)
	  (insert ada-loop-name ":")
	  (next-line 1)
	  (end-of-line 1)))
    (ada-end-insert-here)
    (insert (read-string "loop variable: ") " in ")
    (ada-end-insert-here)
    (insert (read-string "range: ") " loop")
    (ada-two-lines-one-indented)
    (insert "end loop")
    (if ada-loop-is-named (insert " " ada-loop-name))
    (insert ";"))
  (ada-end-insert-here)
  (end-of-line 0))

(defun ada-if ()
  "Insert skeleton if statement, prompting for the boolean-expression."
  (interactive)
  (ada-start-insert-here)
  (insert "if ")
  (ada-end-insert-here)
  (insert (read-string "condition: ") " then")
  (ada-two-lines-one-indented)
  (insert "end if;")
  (ada-end-insert-here)
  (end-of-line 0))

(defun ada-elsif ()
  "Add an elsif clause to an if statement, prompting for the boolean-expression."
  (interactive)
  (ada-start-insert-here)
  (ada-indent-less)
  (insert "elsif ")
  (ada-end-insert-here)
  (insert (read-string "condition: ") " then")
  (ada-newline)
  (ada-indent-more)
  (ada-end-insert-here))

(defun ada-loop ()
  "Insert a skeleton loop statement.  exit statement added by hand."
  (interactive)
  (ada-end-insert-here)
  (insert "loop ")
  (ada-end-insert-here)
  (let* ((ada-loop-name (read-string "[loop name]: "))
	 (ada-loop-is-named (not (string-equal ada-loop-name ""))))
    (if ada-loop-is-named
	(progn
	  (beginning-of-line)
	  (open-line 1)
	  (insert ada-loop-name ":")
	  (forward-line 1)
	  (end-of-line 1)))
    (ada-two-lines-one-indented)
    (insert "end loop")
    (if ada-loop-is-named (insert " " ada-loop-name))
    (insert ";"))
  (ada-end-insert-here)
  (end-of-line 0))

(defun ada-package-spec (ada-instantiate)
  "Insert a skeleton package specification.
If a prefix arg is given, make it a generic instantiation."
  (interactive "P")
  (ada-start-insert-here)
  (insert "package ")
  (ada-end-insert-here)
  (let ((ada-package-name (read-string "package name: " )))
    (insert ada-package-name " is")
    (if ada-instantiate
	(progn
	  (insert " new ")
	  (insert (get-generic-expr "package") ";"))
      (progn
	(ada-comment-and-temp-indent)
	(insert "end " ada-package-name ";"))))
  (ada-end-insert-here)
  (if (not ada-instantiate)
      (end-of-line 0)))

(defun ada-package-body (ada-is-separate)
  "Insert a skeleton package body --  includes a begin statement.
If a prefix arg is given, make it an is-separate stub."
  (interactive "P")
  (ada-start-insert-here)
  (insert "package body ")
  (ada-end-insert-here)
  (let ((ada-package-name (read-string "package name: " )))
    (insert ada-package-name " is")
    (if ada-is-separate
	(insert " separate;")
      (progn
	(ada-comment-and-temp-indent)
	(insert "begin")
	(ada-two-lines-one-indented)
	(insert "end " ada-package-name ";")))
    (ada-end-insert-here)
    (if (not ada-is-separate)
	(end-of-line -2))))

(defun ada-private ()
  "Undent and start a private section of a package spec. Reindent."
  (interactive)
  (end-of-line)
  (ada-start-insert-here)
  (ada-indent-less)
  (insert "private")
  (ada-newline)
  (ada-indent-more)
  (ada-end-insert-here))

(defun ada-task-spec ()
  "Insert a skeleton task specification."
  (interactive)
  (ada-start-insert-here)
  (insert "task ")
  (ada-end-insert-here)
  (let ((ada-task-name (read-string "task_name or type task_type_name: " )))
    (insert ada-task-name " is")
    (ada-comment-and-temp-indent)
    (insert "end " ada-task-name ";")
    (ada-end-insert-here)
    (end-of-line 0)))

(defun ada-task-body (ada-is-separate)
  "Insert a skeleton task body.
If a prefix arg is given, make it an is-separate stub."
  (interactive "P")
  (ada-start-insert-here)
  (insert "task body ")
  (ada-end-insert-here)
  (let ((ada-task-name (read-string "task_name: " )))
    (insert ada-task-name " is")
    (if ada-is-separate
	(insert " separate;")
      (progn
	(ada-comment-and-temp-indent)
	(insert "begin")
	(ada-two-lines-one-indented)
	(insert "end " ada-task-name ";")))
    (ada-end-insert-here)
    (if (not ada-is-separate)
	(end-of-line -2))))

(defun ada-insert-with-semi (ada-arg)
  "Insert string and append semicolon if not present at end thereof."
  (insert ada-arg)
  (if (not (string-match ";$" ada-arg))
      (insert ";")))

(defun ada-get-arg-list ()
  "Read from user a procedure or function argument list.
Add parens if one or more arguments are supplied, and insert into buffer.
Individual argument specs are stacked vertically if entered one-at-a-time.
The argument list is terminated when a CR is given instead of an argument."
  (insert ada-openparen-style)
  (ada-end-insert-here)
  (let ((ada-arg-indent (current-column))
	(ada-arg (read-string "[argument and type]: ")))
    (if (string-equal ada-arg "")
	(backward-delete-char (length ada-openparen-style))
      (progn
	(while (not (string-equal "" ada-arg))
	  (ada-insert-with-semi ada-arg)
	  (newline)
	  (indent-to ada-arg-indent)
          (ada-end-insert-here)
	  (setq ada-arg (read-string "[next argument and type]: ")))
	(delete-horizontal-space)
	(backward-delete-char 2)	; NewLine and SemiColon
	(insert ada-closeparen-style))))
  (ada-end-insert-here))

(defun get-generic-expr (ada-gen-type)
  "Solicit the name and actual parameters of a generic for instantiation."
  (ada-end-insert-here)
  (read-string (concat "generic " ada-gen-type " name [and parameters]: ")))

(defun ada-function-spec (ada-instantiate)
  "Insert a function specification.  Prompts for name and arguments.
If a prefix arg is given, make it a generic instantiation, instead."
  (interactive "P")
  (ada-start-insert-here)
  (insert "function ")
  (ada-end-insert-here)
  (insert (read-string "function name: "))
  (if ada-instantiate
      (progn
	(insert " is new ")
	(insert (get-generic-expr "function") ";"))
    (progn
      (ada-get-arg-list)
      (insert " return ")
      (ada-end-insert-here)
      (insert (read-string "result type: "))))
  (ada-end-insert-here))

(defun ada-procedure-spec (ada-instantiate)
  "Insert a procedure specification, prompting for its name and arguments.
If a prefix arg is given, make it a generic instantiation, instead."
  (interactive "P")
  (ada-start-insert-here)
  (insert "procedure ")
  (ada-end-insert-here)
  (insert (read-string "procedure name: " ))
  (if ada-instantiate
      (progn
	(insert " is new ")
	(insert (get-generic-expr "procedure") ";"))
    (ada-get-arg-list))
  (ada-end-insert-here))

(defun ada-entry ()
  "Insert an entry specification, prompting for its name and arguments."
  (interactive)
  (ada-start-insert-here)
  (insert "entry ")
  (ada-end-insert-here)
  (insert (read-string "entry name: " ))
  (ada-end-insert-here)
  (let ((ada-entry-index-range (read-string "[entry index range]: ")))
    (if (not (string-equal ada-entry-index-range ""))
	(insert ada-openparen-style
		ada-entry-index-range
		ada-closeparen-style)))
  (ada-get-arg-list)
  (insert ";")
  (ada-end-insert-here))

(defun ada-am-in-comment ()
  "Predicate indicates whether point is in a comment,
i.e. past the beginning of the comment introducer."
  (let ((ada-opoint (point))
	(ada-eol (save-excursion (end-of-line) (point))))
    (save-excursion
      (beginning-of-line)
      (and
       (re-search-forward comment-start-skip ada-eol 'keep-going)
       (> ada-opoint (match-beginning 0))))))

(defun ada-get-subprogram-name ()
  "Return (without moving point or mark) a pair whose CAR is
the name associated with the function, procedure,
accept, or entry statement which immediately precedes point,
and whose CDR is the column number at which the
accept/entry/function/procedure keyword was found."
  (save-excursion
    (let ((ada-proc-indent 0)
	  (case-fold-search t))		; note dynamic binding
      (if (re-search-backward
	    "^[ \t\f]*\\(procedure\\|function\\|entry\\|accept\\)\\>" nil t)
	  (progn
	    (setq ada-proc-indent (current-indentation))
	    (forward-sexp 2)
	    (let ((p2 (point)))
	      (forward-sexp -1)
	      (cons (buffer-substring (point) p2) ada-proc-indent)))
	(cons "NAME?" ada-proc-indent)))))

(defun ada-subprogram-body (ada-is-separate)
  "Insert frame for subprogram body.
Invoke right after ada-function-spec or ada-procedure-spec at end of line.
If a prefix arg is given, make it an is-separate stub."
  (interactive "P")
  (ada-start-insert-here)
  (insert " is")
  (let ((ada-subprogram-name-col (ada-get-subprogram-name)))
    (if ada-is-separate
	(progn
	  (insert " separate;")
	  (newline)
	  (indent-to (cdr ada-subprogram-name-col)))
      (progn
	(newline)
	(insert comment-start)
	(newline)
	(indent-to (cdr ada-subprogram-name-col))
	(ada-indent-more)
	(ada-newline)
	(ada-indent-less)
	(insert "begin")
	(ada-two-lines-one-indented)
	(insert "end " (car ada-subprogram-name-col) ";"))))
  (ada-end-insert-here)
  (if (not ada-is-separate)
      (end-of-line -2)))

(defun ada-show-subprogram-name ()
  "Display in the echo area the name of the subprogram
in the closest procedure or function header found before point.
Simple minded."
  (interactive)
  (let ((ada-sub-name (ada-get-subprogram-name)))
    (message (concat "subprogram name is " (car ada-sub-name) "."))))

(defun ada-separate ()
  "Mention the parent of a subunit in a 'separate' clause."
  (interactive)
  (ada-start-insert-here)
  (insert "separate" ada-openparen-style ada-closeparen-style)
  (ada-end-insert-here)
  (backward-char (length ada-closeparen-style))
  (insert (read-string "name of parent unit: "))
  (end-of-line)
  (ada-end-insert-here))


(defun ada-type-name-twice (ada-pkg-name)
  "Enter the package name in both the use and with clauses being constructed."
  (end-of-line 1)
  (search-backward ";")
  (insert ada-pkg-name)
  (search-backward ";")
  (insert ada-pkg-name)
  (end-of-line 1))

(defun ada-with-use ()
  "Inserts with and use clauses, prompting for the packages named in both."
  (interactive)
  (ada-start-insert-here)
  (insert "with ;  use ;")
  (ada-end-insert-here)
  (let ((ada-pkg-name (read-string "package name: ")))
    (search-backward ";")
    (insert ada-pkg-name)
    (search-backward ";")
    (insert ada-pkg-name)
    (end-of-line 1)
    (ada-end-insert-here)
    (setq ada-pkg-name (read-string "[next package name]: "))
    (while (not (string-equal ada-pkg-name ""))
      (ada-newline)
      (insert "with " ada-pkg-name ";  use " ada-pkg-name ";")
      (ada-end-insert-here)
      (setq ada-pkg-name (read-string "[next package name]: ")))))

(defun ada-record ()
  "Insert a skeleton record type declaration."
  (interactive)
  (ada-start-insert-here)
  (if (not (point-on-blank-line))
      (progn
	(end-of-line)
	(ada-newline)
	(ada-indent-more)))
  (insert "record")
  (ada-two-lines-one-indented)
  (insert "end record;")
  (ada-end-insert-here)
  (end-of-line 0))

(defun ada-subtype ()
  "Start insertion of a subtype declaration, prompting for the subtype name."
  (interactive)
  (ada-start-insert-here)
  (insert "subtype ")
  (ada-end-insert-here)
  (insert (read-string "subtype name: ") " is ;")
  (ada-end-insert-here)
  (backward-char)
  (message "insert subtype indication."))

(defun ada-type ()
  "Start insertion of a type declaration, prompting for the type name."
  (interactive)
  (ada-start-insert-here)
  (insert "type ")
  (ada-end-insert-here)
  (insert (read-string "type name: "))
  (ada-end-insert-here)
  (let ((ada-disc-part (read-string "[discriminant specs]: ")))
    (if (not (string-equal ada-disc-part ""))
	(insert ada-openparen-style
		ada-disc-part
		ada-closeparen-style)))
  (insert " is ")
  (ada-end-insert-here)
  (message "insert type definition."))

(defun ada-while-loop ()
  (interactive)
  (ada-start-insert-here)
  (insert "while ")
  (ada-end-insert-here)
  (let* ((ada-loop-name (read-string "[loop name]: "))
	 (ada-loop-is-named (not (string-equal ada-loop-name ""))))
    (if ada-loop-is-named
	(progn
	  (beginning-of-line)
	  (open-line 1)
	  (insert ada-loop-name ":")
	  (next-line 1)
	  (end-of-line 1)))
    (ada-end-insert-here)
    (insert (read-string "entry condition: ") " loop")
    (ada-two-lines-one-indented)
    (insert "end loop")
    (if ada-loop-is-named (insert " " ada-loop-name))
    (insert ";"))
  (ada-end-insert-here)
  (end-of-line 0))

(defun ada-update-timestamp ()
  "Update the Last Mod: timestamp if found near the start of the buffer."
  (if (not buffer-read-only)
      (save-excursion
	(let ((ada-buf-was-mod (buffer-modified-p))
	      (ada-last-edit-marker (concat "--.*" ada-edit-prefix)))
	  (goto-char (point-min))
	  (if (re-search-forward ada-last-edit-marker (+ 2000 (point-min)) t)
	      (progn
		(delete-char (- (save-excursion (end-of-line) (point))
				(point)))
		(insert (current-time-string))
		(set-buffer-modified-p ada-buf-was-mod)))))))

(defun ada-box ()
  "Builds a box comment"
  (interactive)
  (insert comment-start (make-string (- fill-column (current-column)) ?-))
  (indent-new-comment-line)
  (save-excursion
    (indent-new-comment-line)
    (insert (make-string (+ 2 (- fill-column (current-column))) ?-))))

(defvar ada-procedure-start-regexp
  "[ \t\n]*\\(procedure\\|function\\)[ \t\n]+\\([a-zA-Z0-9_]*\\)[ \(\t\n;]+"
  "Regexp used to find ada headers")

(defun ada-header (ada-note-copyright)
  "Insert a comment block containing the module title, author, etc.
If given a prefix arg, make a copyright notice instead of an Author: entry."
  (interactive "P")
  (ada-start-insert-here)
  (let* ((start-col (current-column))
	 (fname
	  (if (looking-at ada-procedure-start-regexp)	       
	      (progn
		(goto-char (match-beginning 1))
		(setq start-col (current-column))
		(buffer-substring (match-beginning 2) (match-end 2)))
	    (read-string "Title: ")))
	 new-point)
    (beginning-of-line)
    (indent-to start-col)
    (insert "--  "
	    (make-string (- (- fill-column start-col) 4) ?\-)
	    "\n")
    (indent-to start-col) (insert "--  Title:       " fname "\n")
    (indent-to start-col) (insert "--  Last Mod:    " (current-time-string) "\n")
    (indent-to start-col) (insert (if ada-note-copyright
				      (concat "--  Copyright "
					      (substring (current-time-string)
							 -4)
					      " ")
				    "--  Author:      ")
				  (user-full-name)
				  " <" (user-login-name) "@" (system-name)
				  ">\n")
    (indent-to start-col) (insert "--  Visibility:  \n")
    (setq new-point (1- (point)))
    (indent-to start-col) (insert "--  Description: \n")
    (indent-to start-col) (insert "--  Exceptions:  \n")
    (indent-to start-col) 
    (insert "--  "
	    (make-string (- (- fill-column start-col) 4) ?\-)
	    "\n")
    (goto-char new-point)
    (ada-end-insert-here)))

;;(defun point-on-blank-line () ;; --> moved to elec-ada.el lrs 10/11/88
;;  "Tell whether point is on a blank line or not."
;;  (save-excursion
;;    (beginning-of-line)
;;    (looking-at "^[ \t\f]*$")))

(defun ada-comment (ada-display-comment)
  "Insert a comment at end of this line, unless a prefix argument is given,
in which case a display comment following this line is created.
Inline comments start to at comment-column,
unless already past comment-column, in which case we add a newline first."
  (interactive "P")
  (end-of-line)
  (ada-start-insert-here)
  (if ada-display-comment
      (progn
	(if (point-on-blank-line)
	    (progn
	      (delete-horizontal-space))
	  (progn
	    (end-of-line)
	    (newline)))
	(insert "--\n-- \n--"))
    (progn
      (if (> (current-column) comment-column) (newline))
      (indent-for-comment)))
  (ada-end-insert-here)
  (if ada-display-comment
      (end-of-line 0)))

(defun ada-comment-indent ()
  "Compute indent column for comment here."
  (if (and
	(= (current-column) 0)
	(or
	  (looking-at "--")
	  (= comment-column 0)))
      0
    (save-excursion
      (skip-chars-backward " \t\f")
      (max comment-column
	   (1+ (current-column))))))

(defun resize-indent-one-line (otab newtab)
  "Reindent the current line, subservient to resize-indent-whole-buffer."
  (back-to-indentation)
  (let ((curindent (current-indentation)))
    (delete-backward-char
      (- (point)
	 (save-excursion (beginning-of-line) (point))))
    (indent-to
       (+
	 (* newtab (/ curindent otab))	; whole tabs
	 (min newtab (mod curindent otab)) ; partial tabs
	 ))))

(defun resize-indent-whole-buffer (old-tab-size new-tab-size)
  "Change the indentation of all lines, using a user-supplied
old tab-spacing and a new tab-spacing.
Odd leading spaces are preserved so far as they are smaller
than the new tab spacing."
  (interactive "nold tab-size: \nnnew tab-size: ")
  (if (< old-tab-size 1)
      (message "old tab-size must be positive")
    (if (< new-tab-size 0)
	(message "new tab-size must be nonnegative")
      (progn
	(goto-char (point-min))
	(resize-indent-one-line old-tab-size new-tab-size)
	(while (= (forward-line 1) 0)
	  (resize-indent-one-line old-tab-size new-tab-size))))))


(defun ada-prev-code-line ()
  "Move back to start of nearest preceding line containing code,
i.e. is not whitespace, a label, nor a block name.
Return nil if no such line found before beginning-of-buffer,
otherwise returns point from beginning of that line."
  (let ((ada-no-code t))
    (while (and
	     (zerop (forward-line -1))
	     (setq ada-no-code (looking-at
"^[ \t\f]*$\\|^[ \t\f]*--\\|^<<[A-Za-z0-9_]+>>\\|^[A-Za-z0-9_]+:")))
      nil)
    (if ada-no-code nil (point))))

(defun ada-goto-end-of-code ()
  "Move point on same line to end of code,
preceding any trailing whitespace or comment on the line.
Assumes point is on the beginning-of-line already."
  (let ((ada-eol-point (save-excursion (end-of-line) (point))))
    (if (re-search-forward comment-start-skip ada-eol-point 'keep-going)
	(goto-char (match-beginning))))
  (skip-chars-backward " \t\f"))

(defun string-match-list (sm-list-of-regex sm-list-candidate)
  (if sm-list-of-regex
      (if (string-match (car sm-list-of-regex) sm-list-candidate)
	  t
	(string-match-list (cdr sm-list-of-regex sm-list-candidate)))
    nil))
		   

(defun ada-prev-line-continued-at ()
  "Returns a column for code continuing a previous line to begin on,
or else nil, in case the previous line is complete or nonexistent."
  (save-excursion
    (if (ada-prev-code-line)
	(let ((ada-bol-point (point)))
	  (ada-goto-end-of-code)
	  (if (string-match-list ada-line-enders
				 (buffer-substring ada-bol-point (point)))
	      nil			; line is complete
	    (+ (current-indentation) 1 (/ (1- indent-change) 2))))
      nil)))				; there is no prev code line

;;;
;;; unfinished, just confirms current indent for hard cases.
;;; 
(defun ada-related-indent (ada-nxt-pt ada-nxt-key ada-prev-pt ada-prev-key)
  (save-excursion
    (goto-char ada-nxt-pt)
    (current-indentation)))

(defun ada-get-starter ()
  (buffer-substring (point)
		    (save-excursion
		      (skip-chars-forward "A-Za-z0-9_"))))

(defun ada-compute-indentation ()
  "Return column nbr appropriate for this line of ada code.
Assumes point is at the current indentation."
  (save-excursion
    (let ((case-fold-search t)
	  (ada-opoint (point)))
      (cond
	((looking-at comment-start-skip)
	 (ada-comment-indent))
	((or (looking-at "<<")
	     (looking-at "[a-z0-9_]+:[ \t\f]*$"))
	 0)
	((ada-prev-line-continued-at))
	(t
	  (let (ada-prev-point ada-prev-key)
	    (save-excursion
	      (setq ada-prev-point (ada-prev-code-line))
	      (if ada-prev-point (setq ada-prev-key (ada-get-starter))))
	    (if ada-prev-point
		(ada-related-indent (point) (ada-get-starter)
				    ada-prev-point ada-prev-key)
	      0)))))))

(defun ada-indent-line ()
  "Reindent current line to column appropriate for the code.
Mainly checks the near left context."
  (interactive)
  (let* ((ada-beyond-indent (max 0 (- (point)
				      (progn (back-to-indentation) (point)))))
	 (ada-computed-indentation (ada-compute-indentation)))
    (delete-backward-char
      (- (point)
	 (save-excursion (beginning-of-line) (point))))
    (indent-to (ada-computed-indentation))
    (forward-char ada-beyond-indent)))

;;;       for future use of a dumb parser.
;;; beginners of lines
;;; "\\<declare\\>", "\\<begin\\>", "\\<case\\>", "\\<if\\>",
;;;   "\\<loop\\>", "\\<for\\>", "\\<while\\>", "\\<record\\>", "\\<task\\>"
;;; "\\<procedure\\>", "\\<function\\>", "\\<accept\\>", "\\<entry\\>"
;;; "\\<exception\\>", "\\<elsif\\>", "\\<private\\>"
;;; "\\<package\\>"
;;; "\\<generic\\>"
;;; "\\<end\\>"
;;; "\\<or\\>", "\\<else\\>"
;;; "\\<when
;;; "\\<[a-zA-Z0-9_]+\\>"
;;;

(defvar ada-line-enders
  '(
  "^.*;" "^.*=>" "^.*:" "^.*>>"
  "^.*\\<separate[ \t\f]*([ \t\f]*[a-zA-Z0-9_]+[ \t\f]*)"
  "^[ \t\f]*or" "^[ \t\f]*else"
  "^.*\\<declare\\>" "^.*\\<begin\\>" "^.*\\<exception\\>" "^.*\\<then\\>"
  "^.*\\<is\\>" "^.*\\<loop\\>" "^.*\\<record\\>"
  "^.*\\<private\\>" "^.*\\<generic\\>"
  "^.*\\<do\\>" "^.*\\<select\\>" "^.*\\<use\\>"
  )
  "List of regexps which match code which can belong on the end of a line,
Even if infinite room were available for long lines.")
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦854fe14af⟧ TextFile

Derivation

TextFile
