; ----------------------------------------------------------------------------
; ada.ml - Ada mode for Emacs
; ----------------------------------------------------------------------------
;  
;                         Ada Mode for Gosling Emacs
;  
;                              Steven M. Rosen
;  
;                  Siemens Corporate Research and Support, Inc.
;                     Research and Technology Laboratories
;                             Princeton, NJ 08540
;                                (609) 734-6538
;  
;                                 rosen@siemens
; 
; ----------------------------------------------------------------------------
; 
; 	This code is public domain and may be used or modified at your site
; 	in any fashion that you choose.  No support or capabilities are
; 	implied or guaranteed by the release of this code.  This disclaimer
;	must be maintained in conjunction with the code.
; 
; ----------------------------------------------------------------------------
;
; $Header: ada.ml,v 4.1 85/04/15 08:33:06 rosen Exp $
; 
; Created 12-18-84
; Updated 04-15-85
; 
; Bindings:
; 
; 	indent-change = size of indentation (default to 2)
; 
; 	Indent from (dot) to (mark)			  ^X->
; 	De-dent from (dot) to (mark)			  ^X-<
; 	Tab over to indent of most recent line of code	  <TAB>,<ESC><TAB>
; 	Decrease indent level and start newline		  <ESC>-<CR>
; 	Enter Ada comment mode				  "--"
; 
; Features:
; 
;   o	Automatically performs indentation while editing Ada code.
; 
;   o	Automatically performs justification of Ada comments which
; 	begin on a blank line.
; 
;   o	Automatically matches parentheses.
; 


(defun
    (ada-mode
	(declare-buffer-specific in-comment-edit)
	(setq-default indent-change 2)
	(setq tab-size 8)
	(setq in-comment-edit 0)
	(setq mode-string "Ada")
	(use-syntax-table "Ada")
	(setq abbrev-mode 1)
	(local-bind-to-key "begin-ada-comment" "-")
	(local-bind-to-key "indent-region" "\^X>")
	(local-bind-to-key "dedent-region" "\^X<")
	(local-bind-to-key "tab-ada" "\t")
	(local-bind-to-key "tab-ada" "\e\t")
	(local-bind-to-key "indent-ada" "\^M")
	(local-bind-to-key "de-dent-ada" "\e\^M")
	(local-bind-to-key "show-matching-paren" ")")
; 
; The following two lines can be include to suit local naming 
; conventions:
; 
;	(modify-syntax-entry "w    _")
;	(modify-syntax-entry "w    .")
; 
;
	(modify-syntax-entry "()   (")
	(modify-syntax-entry ")(   )")
	(modify-syntax-entry "\"    \"")
	(modify-syntax-entry "  { --")
	(modify-syntax-entry "   } \n")
	(error-occurred (ada-mode-hook))
	(novalue)
    )
)    

(defun 
    (cond n running
	  (setq n 1)
	  (setq running 1)
	  (while (& running (< n (nargs)))
		 (if (arg n)
		     (setq running 0)
		     (setq n (+ n 2))))
	  (arg (+ n 1))))
    
(defun 
    (show-matching-paren
	(insert-character (last-key-struck))
	(save-excursion 
	    (backward-paren)
	    (if (dot-is-visible)
		(sit-for 5)
		(progn 
		       (beginning-of-line)
		       (set-mark)
		       (end-of-line)
		       (message (region-to-string)))))))
    
(defun 
    (leave-and-show
	(setq abbrev-mode 1)
	(show-matching-paren)))
    
(defun 
    (change-indentation colno	; indent by arg for region
	(save-excursion 
	    (if (< (mark) (dot))
		(progn 
		       (end-of-line)
		       (exchange-dot-and-mark)
		       (beginning-of-line))
		(progn 
		       (beginning-of-line)
		       (exchange-dot-and-mark)
		       (end-of-line)))
	    (narrow-region)
	    (end-of-file)
	    (beginning-of-line)
	    (setq colno (+ (current-indent) (arg 1)))
	    (delete-white-space)
	    (if (> colno 1)
		(to-col colno))
	    (beginning-of-line)
	    (while (! (bobp))
		   (previous-line)
		   (setq colno (+ (current-indent) (arg 1)))
		   (delete-white-space)
		   (if (> colno 1)
		       (to-col colno))
		   (beginning-of-line))
	    (widen-region))))
    
(defun 
    (dedent-region 		; dedents region
	(change-indentation (- 0 indent-change))))
    
(defun 
    (indent-region colno	; indents region
	(change-indentation indent-change)))
    
    
(defun 
    (tab-ada dotab colno
	(if 
	    (& (eobp) (eolp))
	    (progn 
		   (insert-character '\n')
		   (backward-character))
	)
	(if 
	    (| (& (bolp) (looking-at "[ \t]*\n"))
	       (< (current-column) (current-indent)))
	    (progn 
		   (save-excursion 
		       (while 
			      (& (| (looking-at "[ \t]*\n") 
				    (looking-at "[ \t]*--"))
				 (! (bobp)))
			      (progn 
				     (previous-line)
				     (beginning-of-line)))
		       (setq colno (current-indent)))
		   (delete-white-space)
		   (to-col colno))
	    1
	    (insert-character '\t'))))
    
(defun 
    (de-dent-ada colno
	(setq colno (- (current-indent) indent-change))
	(beginning-of-line)
	(if 
		(! (looking-at "[ \t]*\n"))
			(progn 
				(end-of-line)
				(newline)))
	(delete-white-space)
	(to-col colno)))

(defun 
    (indent-ada colno
	(cond
	     (bolp)
	     (newline)
	     (! (eolp))
	     (newline-and-indent)
	     1
	     (progn
		   (save-excursion
		       (end-of-line)
		       (if (eobp)
			   (newline)))
		   (setq colno (current-indent))
		   (beginning-of-line)
		   (setq case-fold-search 1)
		   (cond
			(& (= in-comment-edit 1)
			   (looking-at "[ \t]*-- \n"))
			(progn 
			       (setq in-comment-edit 0)
			       (beginning-of-line)
			       (kill-to-end-of-line)
			       (kill-to-end-of-line)
			       (if 
				   (looking-at "[ \t]*\n")
				   (tab-ada)
				   1
				   (beginning-of-line))
			       (setq right-margin 1000)
			       (setq left-margin 1)
			       (setq prefix-string "")
			       (local-bind-to-key "begin-ada-comment" "-")
			       (local-bind-to-key "tab-ada" "\t")
			       (message "Finished editing ada comment"))
			(& (= in-comment-edit 1)
			   (! (looking-at "[ \t]*--[ \t]*..")))
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col comment-column)
			       (insert-string "-- "))
			(& (= in-comment-edit 1)
			   (looking-at "[ \t]*--[ \t]*.."))
			(progn 
			       (end-of-line)
			       (newline-and-indent)
			       (insert-string "-- "))
			(looking-at "[ \t]*--.*\n")
			(progn 
			       (end-of-line)
			       (newline)
			       (tab-ada))
			(looking-at "[ \t]*begin\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*end\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (- colno indent-change)))
			(looking-at "[ \t]*when\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*generic\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*declare\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*loop\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*if\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*elsif\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*else\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*while\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*case\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*for\\b")
			(progn 
			       (end-of-line)
			       (if (= (preceding-char) ';')
				   (newline-and-indent)
				   (progn 
					  (newline)
					  (to-col (+ colno indent-change)))))
			(looking-at "[ \t]*loop\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*or\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*exception\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*record\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*private\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(| (looking-at "[ \t]*type\\b")
			   (looking-at "[ \t]*subtype\\b"))
			(progn 
			       (end-of-line)
			       (backward-word)
			       (if 
				   (looking-at "record\\b")
				   (progn 
					  (setq colno (current-column))
					  (end-of-line)
					  (newline)
					  (to-col (+ colno indent-change)))
				   (looking-at "is\\b")
				   (progn 
					  (end-of-line)
					  (newline)
					  (to-col (+ colno indent-change)))
				   1
				   (progn 
					  (end-of-line)
					  (newline-and-indent))))
			(looking-at "[ \t]*select\\b")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*accept\\b")
			(progn 
			       (end-of-line)
			       (backward-word)
			       (if (looking-at "do\\b")
				   (progn 
					  (end-of-line)
					  (newline)
					  (to-col (+ colno indent-change)))
				   (progn 
					  (end-of-line)
					  (newline-and-indent))))
			(looking-at "[ \t]*task\\b")
			(progn 
			       (end-of-line)
			       (backward-word)
			       (if (looking-at "is\\b")
				   (progn 
					  (end-of-line)
					  (newline)
					  (to-col (+ colno indent-change)))
				   (progn 
					  (end-of-line)
					  (newline-and-indent))))
			(| (looking-at "[ \t]*procedure\\b")
			   (looking-at "[ \t]*function\\b"))
			(progn 
			       (end-of-line)
			       (backward-word)
			       (if (looking-at "is\\b")
				   (progn 
					  (end-of-line)
					  (newline)
					  (to-col (+ colno indent-change)))
				   (progn 
					  (end-of-line)
					  (newline-and-indent))))
			(looking-at "[ \t]*package\\b")
			(progn 
			       (end-of-line)
			       (backward-word)
			       (if (looking-at "is\\b")
				   (progn 
					  (end-of-line)
					  (newline)
					  (to-col (+ colno indent-change)))
				   (progn 
					  (end-of-line)
					  (newline-and-indent))))
			(|  (looking-at "[ \t]*.*:[^=].*[^;]\n")
			    (looking-at "[ \t]*.*:[ \t]*\n"))
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			(looking-at "[ \t]*<<.*>>")
			(progn 
			       (end-of-line)
			       (newline)
			       (to-col (+ colno indent-change)))
			1
			(progn
			      (setq colno (current-indent))
			      (if (looking-at "[ \t][ \t]*\n")
				  (kill-to-end-of-line))
			      (end-of-line)
			      (newline)
			      (to-col colno)))
		   (setq case-fold-search 0)))))

(defun
    (begin-ada-comment c
	(insert-character (last-key-struck))
	(remove-local-binding "-")
	(remove-local-binding "\t")
	(setq c (get-tty-character))
	(insert-character c)
	(if 
	    (&
	      (= c 45)
	      (looking-at "[ \t]*\n"))
	    (progn 
		   (setq in-comment-edit 1)
		   (setq comment-column (- (current-column) 2))
		   (move-to-comment-column)
		   (setq left-margin comment-column)
		   (setq right-margin 76)
		   (setq prefix-string "-- ")
		   (cond 
			 (looking-at "[ \t]*--")
			 (progn 
				(end-of-line)
				(newline)
				(to-col comment-column)
				(insert-string "-- "))
			 1
			 (end-of-line))
		   (message "Editing ada comment")
	    )
	    1
	    (progn 
		   (local-bind-to-key "begin-ada-comment" "-")
		   (local-bind-to-key "tab-ada" "\t")
	    ))
    )
)

(defun
	(end-ada-comment
		(setq in-comment-edit 0)
		(setq right-margin 1000)
		(if (!= (preceding-char) ' ') (insert-string " "))
		(to-col comment-column)
		(insert-string "--")
		(newline)
		(local-bind-to-key "tab-ada" "\t")
		(message "Finished editing ada comment")
	)
)
; ----------------------------------------------------------------------------