;;; -*- Mode:LISP; Package:ZWEI; Fonts:(CPTFONT); Base:10 -*-
;;; $Header: /ct/editor/adamode.l,v 1.9 85/03/06 17:35:15 alfred Exp $
(putprop 'adamode "$Revision: 1.9 $" 'rcs_revision)
;;; NOTE: Removed Patch-File: T -- DRM

;;; ****************************************************************
;;;
;;;  John L. Shelton, Mark L. Miller, Alfred Correira, Bob Laddaga
;;;
;;;  Ada-Mode
;;;
;;;  This file supports ada-mode for ZMACS on the lisp machine.
;;;
;;;
;;;                                                                  
;;; This file is part of a proprietary software project.  Source     
;;; code and documentation describing implementation details are     
;;; available on a confidential, non-disclosure basis only.  These
;;; materials, including this file in particular, are trade secrets  
;;; of Computer * Thought Corporation.                               
;;;                                                                  
;;; (c) Copyright 1984,  Computer * Thought Corporation.    
;;;     All Rights Reserved.                                         

;;;   This is a kludged version of ADAMODE, designed for temporary shipment
;;;   as a product.
;;;
;;;   The major change is that this version is for the 3600, and includes
;;;  not one, but TWO menus off to the side.
;;;

;;; Ensure presence of needed files. 
(eval-when (compile load eval) (user:ct_load 'user:bufship))  ;Buffer interface stuff.
(user:ct_load 'user:menufix)			;Make fonted menus BOX correctly
(eval-when (compile load eval) (user:ct_load 'user:multline)) ;Multi-line menu item support.


;;;  ****************************************************************
;;;  COMPATIBILITY STUFF
;;;  ****************************************************************

#+Symbolics
(deff typep* #'typep)

#+LMI
(defmacro typep* (&rest args)
  `(dont-optimize (typep . ,args)))

;;;  ****************************************************************
;;;  CONSTANTS, GLOBALS, DECLARED STUFF.
;;;  ****************************************************************

;;;  Release string for bldsys
(defconst *adamode-release* "1.0")

(defconst *reserved-font-choices*
	  '(("CptFontB" . fonts:cptfontb)
	    ("HL10" . fonts:hl10)
	    ("HL10B" . fonts:HL10B)
	    ("HL12" . fonts:hl12)
	    ("HL12B" . fonts:hl12b)
	    ("TR10" . fonts:tr10)
	    ("TR10B" . fonts:tr10b)
	    ("TR12B" . fonts:tr12b))
  "Fonts that can be selected in parameter menu.")

(defconst *comment-font-choices*
	  '(("TR10I" . fonts:tr10i)
	    ("HL10" . fonts:hl10)
	    ("HL12" . fonts:hl12)
	    ("HL12BI" . fonts:hl12bi)
	    ("HL12I" . fonts:hl12i)
	    ("TR10" . fonts:tr10)
	    ("TR10BI" . fonts:tr10bi)
	    ("TR12I" . fonts:tr12i))
  "Fonts that can be selected in parameter menu.")

(defconst *normal-font-choices*
	  '(("CptFont" . fonts:cptfont)
	    ("CptFontB" . fonts:cptfontb)
	    ("HL10" . fonts:hl10)
	    ("HL12" . fonts:hl12)
	    ("HL12B" . fonts:hl12b)
	    ("TR10" . fonts:tr10)
	    ("TR10B" . fonts:tr10b)
	    ("TR12B" . fonts:tr12b))
  "Fonts that can be selected in parameter menu.")


(defconst *editor-menu-description*
          '(("Ada Parameters" :eval (com-set-ada-parameters) :font fonts:tr12
             :documentation "Select parameters affecting Ada Mode editing")
            ("" :no-select t)
	    ("Font Region" :eval (progn (com-ada-font-words-region)
					(must-redisplay *window* dis-text))
	     :font fonts:tr12b :documentation "Put whole region in correct fonts")
	    ("Font Buffer" :eval (progn (com-ada-font-words-buffer)
					(must-redisplay *window* dis-text))
	     :font fonts:tr12 :documentation "Put the whole buffer in correct fonts")
            ("Indent Region" :eval (progn (com-ada-indent-region)
					  (must-redisplay *window* dis-text))
	     :font fonts:tr12b :documentation "Indent every line in the region")
	    ("Indent Buffer" :eval (progn (com-ada-indent-buffer)
					  (must-redisplay *window* dis-text))
	     :font fonts:tr12 :documentation "Indent every line in the buffer.")
            
            )
  "The menu contents for the editor command menu that appears in the top
 right corner of the editor.")

;;;  When nil, and we go into ada-mode, turn on the editor menu feature.
;;; If T, it must already be on.
(defvar *ada-mode-of-editor-menu-loaded* nil)

(defvar *ada-reserved-words*
	'(abort abs accept access all and array at begin body case
		constant declare delay delta digits do else elsif
		end entry exception exit for function generic goto
		if in is limited loop mod new not null of or others
		out package pragma private procedure raise range
		record rem rename return reverse select separate subtype
                task terminate then type use when while with xor)
        "All known ada reserved words.")

;;;  The fonts used in ada source code. 
;;;  The numbers are the positions in the font map.
(defvar *ada-reserved-word-font* 2)
(defvar *ada-comment-font* 1)
(defvar *ada-normal-font* 0)

;;;  What to do with non-reserved words.  Normally it is
;;; ':UPPER, but could be ':LOWER or nil.  Nil means
;;; to leave the word as the user typed it.
(defvar *ada-non-reserved-word-action* ':UPPER)   


;;;  What to do with reserved words.  Normally ':LOWER.
(defvar *ada-reserved-word-action* ':LOWER)


;;;  This is the amount by which to indent (or de-indent) a line.
;;; A line to be indented more than the previous line will be
;;; indented by this much more.
(defvar *ada-indent-delta* 2.)


;;;  The list of fonts that most buffers will get set to in ADA mode.
;;;  This will probably want to get changed in the future.  The ordering
;;; is normal, comment, reserved.
(defconst *ada-mode-default-font-list*
	  '(fonts:cptfont fonts:hl12i fonts:cptfontb))


;;;  List of additional characters to expand words on
(defconst *ada-expand-command-chars*
	  '(#\meta-p #\meta-n #\tab #/;
	    #\mouse-1-1 #\mouse-2-1 #\mouse-1-2 mouse-2-2))

;;; List of characters  to NOT expand words on.  These chars may be
;;; in the middle of words, and we don't want the words expanding
;;; as they are half-typed.
(defconst *ada-dont-expand-command-chars*
	  '(#/_))

;;;  True when in ada-mode
(defvariable *ada-mode-p* nil :boolean "Whether or not in Ada mode.")
(setq *ada-mode-p* nil)				;defvariable doesn't init.

;;;  Disable stupid error query from zwei when Ada font parameters are changed
(setq zwei:*set-attribute-updates-list* t)

;;;  If you want to be able to use a variable in a major mode, it
;;; must have a mode-settable-p property of T.
(defprop *ada-mode-p* t mode-settable-p)
(defprop *region-marking-mode* t mode-settable-p)
(defprop *region-right-margin-mode* t mode-settable-p)
(defprop *indent-with-tabs* t mode-settable-p)


;;; Don't fool with this.
(defvar *editor-command-menu-width* 0)

(defvar *setting-up-right-menus* nil)


;;;  Returns T if word is in column 1 of the string.  Ignores case.
(defmacro firstword (string word &aux (len (string-length word)))
  `(and (>= (string-length ,string) ,len)
	(string-equal ,word
		      (string-upcase ,string)
		      0 0 ,len ,len)))


;;;  To allow the command menu (for templates) to have multiple
;;; line menu items.
(defflavor tv:multiline-command-menu-pane
	()
	(tv:multiline-item-mixin tv:command-menu-pane))

(eval-when (eval compile load)
(defmacro let-variable-values (bindings &body body)
  (let ((holding-variables (loop repeat (length bindings) collect (gensym)))
	(variables (loop for binding in bindings
			 collecting (if (atom binding) binding (first binding))))
	(values (loop for binding in bindings
		      collecting (if (atom binding) nil (second binding)))))
    `(let ,(loop for hold in holding-variables and variable in variables
		 collecting `(,hold ,variable))
       (unwind-protect
	 (progn ,@(loop for variable in variables and value in values collecting
			`(setf ,variable ,value))
		. ,body)
	 . ,(loop for hold in holding-variables and variable in variables collecting
		  `(setf ,variable ,hold)))))))


;;;  ****************************************************************
;;;  Auto INDENTING INTERESTING generation
;;;  ****************************************************************

;;;  It would be nice to generate the list of indent-interesting keywords
;;; automatically, based on the other tables defined.


;;;  This takes a table of patterns, and generates the list of keywords
;;; used.  Probably want to use on *ada-patterns*.
(defun pattern-keywords (pattern-lists)
  (loop for pattern in pattern-lists
	nconc (loop for word in pattern
		    collect word)))


;;;  Takes a table of actions, and generates a list of keywords.
(defun action-keywords (alists)
  (loop for alist in alists
	nconc (list (car alist))
	nconc (loop for thing in (cdr alist)
		    collect (car thing))))




;;;  ****************************************************************
;;;  INDENTING VARIABLES
;;;  ****************************************************************


;;;  This is the list of reserved words that indicate the NEXT line
;;; should be indented even more.
(defvar *ada-indent-words*
	'(accept begin declare else elsif for if loop  ;; case
		 package procedure function private function generic is
		 record select exception         type subtype
		 |=>| when task then while))


;;;  The list of replacements to do on the stack.  Each list contained
;;; herein is a pattern.  If the pattern appears on the stack, it is
;;; removed.
(defvar *ada-patterns*
      '((function is begin end)
	(function is separate)
	(procedure is begin end)
	(procedure is separate)
	(package body is begin end)
	(package body is separate)
	(package is private end)
	(package is end)
	(private end)
        (type is record end record)
	(type is new)
        (type is private)
	(type is array of)
	(type is)
	(record end record)
	(array of)
	(for use)
	(record end record)
	(if then else end if)
	(elsif then)
	(if then end if)
	(if end if)
	(accept end)
	(select end select)
	(task body is begin end)
	(task body is separate)
	(task is end)
	(case end case)
	(case when others |=>| end case)
	(|=>| when)
	(while loop exit when end loop)
	(for loop exit when end loop)
	(loop exit when end loop)
	(while loop end loop)
	(for loop end loop)
	(loop end loop)
	(record end record)
	(declare begin end)
	(begin end)
	))

;;;  These words indicate possible program stubs.
(defconst *ada-stub-words* '(procedure function))

;;; Used for the current indentation action function.  This is
;;; an alist of alists.  The indicator for the first alist
;;; is the word on the current line.  The indicator for the 
;;; inner alist is the word found on the stack.  Read the first
;;; entry like:
;;;  "If the word on this line is 'begin, and the last word
;;;   on the stack is 'function, then indent by -delta."
;;;
(defconst *current-indent-action*
	  '((end . ((case . (- (* 2 *ada-indent-delta*)))
		    (|=>| . (- (* 2 *ada-indent-delta*)))
		    (when . (- (* 2 *ada-indent-delta*)))
		    (*match-any* . (- *ada-indent-delta*))))
	    (begin . (
		     ; (function . (- *ada-indent-delta*))
		      (is . (- *ada-indent-delta*)) ;;;replaced procedure
		      (declare . (- *ada-indent-delta*))
		     ; (package . (- *ada-indent-delta*))
		     ; (task . (- *ada-indent-delta*))
		      ))
	    (exception . ((begin . (- *ada-indent-delta*))))
	    (private . ((is . (- *ada-indent-delta*)))) ;;;replaced package
	    (elsif . ((then . (- *ada-indent-delta*))))
	    (else . ((then . (- *ada-indent-delta*))
		     (when . (- *ada-indent-delta*))
		     (or . (- *ada-indent-delta*))))
	    (|=>| . ((when . *ada-indent-delta*)))
	    (when . ((|=>| . (- *ada-indent-delta*))
                     (case . *ada-indent-delta*)
		     (select . *ada-indent-delta*)))
	    (or . ((select . (- *ada-indent-delta*))))
	    (of . ((is . *ada-indent-delta*)))
	    (array . ((is . *ada-indent-delta*)))
	    (record . ((*match-any* . *ada-indent-delta*)))))


;;;  The list of words interesting to the indenter.  These
;;;  are the words appearing in the short-indent-stack.
;;;  This is automatically generated from the preceding four
;;;  lists.
(defconst *ada-indent-interesting-keywords*
	  (union (pattern-keywords *ada-patterns*)
		 (action-keywords *current-indent-action*)
		 *ada-stub-words*
		 *ada-indent-words*))



;;;  We need a simple readtable that doesn't do silly things like
;;; packages.
(defconst *ada-simple-readtable*
	  (copy-readtable si:initial-readtable))

;;;  This readtable is used when doing a read-from-string.
;;; We should consider making a semicolon a self-delimiting token,;;
;;; so that we can parse it.  ++  John.
#+Symbolics
(defun setup-ada-simple-readtable ()
  (set-syntax-from-char #/;  #\space *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #/:  #/A     *ada-simple-readtable* si:initial-readtable)
;;;  (set-syntax-from-char #//  #/A     *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #//  #/+     *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #/|  #/A     *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #/(  #\space *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #/)  #\space *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #/,  #/A     *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #/`  #/A     *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #/'  #/A     *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #/.  #/A     *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #/#  #/A     *ada-simple-readtable* si:initial-readtable)
  (set-syntax-from-char #/_  #/A     *ada-simple-readtable* si:initial-readtable)
  )

(defun setup-ada-simple-readtable ()
  (copy-syntax #/;  #\space *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #/:  #/A     *ada-simple-readtable* si:initial-readtable)
;;;  (copy-syntax #//  #/A     *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #//  #/+     *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #/|  #/A     *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #/(  #\space *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #/)  #\space *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #/,  #/A     *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #/`  #/A     *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #/'  #/A     *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #/.  #/A     *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #/#  #/A     *ada-simple-readtable* si:initial-readtable)
  (copy-syntax #/_  #/A     *ada-simple-readtable* si:initial-readtable))

(setup-ada-simple-readtable)			;go ahead with standard defs.




;;;  ****************************************************************
;;;  CHANGING PARAMETERS
;;;  ****************************************************************


(defcom com-set-ada-parameters "Change Ada parameters.
 A choose-variable-values menu will be used to select various ada-mode
 parameters for the editor.  Does not affect the interpreter."
	()
  (let* ((arwa  *ada-reserved-word-action*)
	 (anrwa *ada-non-reserved-word-action*)
	 (aind  *ada-indent-delta*)
	 (zrmm *region-marking-mode*)
	 (zrrmm *region-right-margin-mode*)
	 (font-map (send (window-sheet *window*) ':font-map))
	 (font0 (font-name (aref font-map 0)))
	 (font1 (font-name (aref font-map 1)))
	 (font2 (font-name (aref font-map 2))))
    (declare (special arwa anrwa aind zrmm zrrmm font0 font1 font2))
    (let ((value 
	    (*catch 'abort
	      (tv:choose-variable-values
		`("Treatment of words"
		  (arwa "Reserved words" :menu-alist
			(("Lower Case" :value :lower :documentation
			  "Put reserved words in lower case.")
			 ("Leave alone" :value nil :documentation
			  "Don't change case of reserved words.")
			 ("Upper Case" :value :upper :documentation
			  "Put reserved words in upper case.")))
		  (anrwa "Non-Reserved words" :menu-alist
			 (("Upper Case" :value :upper :documentation
			   "Put non-reserved words in upper case.")
			  ("Leave alone" :value nil :documentation
			   "Don't change case of non-reserved words.")
			  ("Lower Case" :value :lower :documentation
			   "Put non-reserved words in lower case.")))
		  " "						;blank line
		  "Indentation"
		  (aind "Amount to indent by" :documentation
			"Number of spaces used to increment indentation."
			:choose (0 1 2 3 4 5))
		  " "
		  "Fonts to use:"
		  (font0 "Normal font" :documentation
			 "Font to use for most Ada text."
			 :assoc ,*normal-font-choices*)
		  (font1 "Comment font" :documentation
			 "Font to use for Ada Comments."
			 :assoc ,*comment-font-choices*)
		  (font2 "Reserved font" :documentation
			 "Font to use for Reserved Words."
			 :assoc ,*reserved-font-choices*)
		  
		  " "						;blank line
		  "Region Marking"
		  (zrmm "Way to mark regions" :documentation
			"The method used to mark regions in the editor."
			:choose (:underline :reverse-video))
		  (zrrmm "Mark to right margin" :documentation
			 "Show marked regions all the way to the right margin."
			 :boolean)
		  
		  )
		':label '(:string "Choose values to affect Ada Mode in the editor. "
			  :font fonts:tr12b)
		':margin-choices '(("ABORT" (progn (beep)(*throw 'abort 'abort))) "OK")))))
      (cond
	((not (eq value 'abort))
	 ;; If any of the fonts have been changed, do the right updating, which
	 ;; will ask the user whether or not to change the file attributes line.
	 ;; Obviously, if the user doesn't change the attribute line, we shouldn't
	 ;; ask.
	 (unless (and (eq font0 (font-name (aref font-map 0)))
		      (eq font1 (font-name (aref font-map 1)))
		      (eq font2 (font-name (aref font-map 2))))
	   (let ((tem (list (cons (get-pname font0) (symeval font0))
			    (cons (get-pname font1) (symeval font1))
			    (cons (get-pname font2) (symeval font2)))))
	     #+Symbolics
	     (progn
	       (redefine-fonts *window* tem)
	       (WHEN (SEND *INTERVAL* ':OPERATION-HANDLED-P ':PUTPROP)
		 (SEND *INTERVAL* ':PUTPROP TEM ':FONT-ALIST)
		 (AND (SEND *INTERVAL* ':OPERATION-HANDLED-P ':EDITING-FILE-P)
		      (SET-ATTRIBUTE-INTERNAL ':FONTS "Fonts"
					      (AND TEM (FORMAT NIL "~{~A~^,~}"
							       (MAPCAR 'CAR TEM)))
					      (MAKE-FONT-ALIST-ATTRIBUTE TEM)))))
	     #+LMI
	     (setup-ada-fonts (mapcar #'car tem) t t)))
	 
	 (setq *ada-reserved-word-action*     arwa
	       *ada-non-reserved-word-action* anrwa
	       *ada-indent-delta*             aind)
	 (setf *region-marking-mode*          zrmm)
	 (setf *region-right-margin-mode*     zrrmm)))))
  dis-none)




;;;  ****************************************************************
;;;  ADA MODE 
;;;  ****************************************************************

;;;  There are, in zwei, special variables *COMMENT-START* and *COMMENT-BEGIN*.
;;;  *comment-start* is a string or function that is used to RECOGNIZE a comment.
;;; Several things in Zwei count on *comment-start*.  We want it to be just "--",
;;; since that is the minimal string necessary to delimit the comment.
;;;
;;;  *comment-begin* is a string that is used to generate all comments.  Functions
;;; such as META-SEMI use this string.
;;;
;;;  There is a problem, that the functions that update the attribute line do
;;; NOT use *comment-begin* to generate the comment, but instead use *comment-start*
;;; if it is a string.  We kludge around this by binding *comment-start* to "-- "
;;; when we update the attribute line.


;;;  Defmajor is particular about its args.  Most importantly, the BODY
;;; of the defmajor may consist only of certain undoable things.  See the
;;; documentation in [zwei; modes lisp] for more information.
(defmajor com-ada-mode ada-mode "Ada"
	  "Puts ZMACS in Ada Mode, for editing Ada source text.
 Displays source text in three fonts: normal, bold, and italics.
 Sets up keys for proper indentation."
	  ()
	  (set-comtab *mode-comtab*
		      '(#\tab com-indent-for-ada
			#\meta-tab com-less-indent-for-ada
			#\end com-complete-ada-reserved-word
			#\line com-indent-new-line-for-ada
			#\super-p com-set-ada-parameters
			#\hand-up com-up-real-line
			#\hand-down com-down-real-line
			#\hand-left com-backward
			#\hand-right com-forward
			;; The 160. here is #\DELETE, which was removed from Release 5
			;; (even on the LM-2 !!!!).  This line can be expunged, or
			;; (send si:xr-character-name-hash-table ':put-hash "Delete" 160.)
			;; can be done to define #\Delete.  Remember that though #\Delete
			;; is 160. in Release 5, it is 139. in Release 4.  Blech.
			;; -- Richard Soley
			#+CADR 160. #+CADR com-delete-forward
			#\control-D com-delete-forward
			)
		      (make-command-alist
			'(com-ada-indent-region
			   com-ada-indent-buffer
			   com-ada-font-words-region
			   com-ada-font-words-buffer)))
	  (set-char-syntax word-alphabetic	;Make following chars be parts of
			   *mode-word-syntax-table* #/_)	;words:  UNDERSCORE
	  (set-char-syntax word-alphabetic
			   *mode-word-syntax-table* #/')	;        APOSTROPHE
	  (setq *ada-mode-p* t)			;Tell world we are here.
	  (setq *comment-begin* "-- ")		;comments start "--"
	  (setq *comment-start* "--")
	  (command-hook 'ada-expand-abbrev-hook
			*command-hook*)		;abbrevs
          (command-hook 'ada-fix-comment-starters-hook *command-hook*)
	  (setq *last-expansion-bp* nil)
	  (setq *last-expanded* nil)
	  (setq *last-expansion* nil)
	  (setq *region-marking-mode* ':reverse-video)
	  (setq *region-right-margin-mode* t)
	  (setq *word-abbrev-prefix-mark* nil)
	  (setq *indent-with-tabs* nil)		;use spaces instead.
	  (progn				; Hook for non-undoable stuff.
	    (do-some-more-ada-init)))


;;; This variable gives us a handle on the ada window object defined by defmajor
(defvar *ada-mode-handle* nil)

;;;  This function does other initialization in ada-mode.  The things
;;; done here are NOT undo-able, but shouldn't matter.
;;;
;;;  1.  First, look to see if this is a new buffer.  Remember this for
;;;      later.
;;; 
;;;  2.  Make sure the fonts list is correct, and generate a attribute line.
;;;
;;;  4.  Next, do attribute line correctly, including ADA mode.
;;;
;;;  Note that *COMMENT-START* is bound to "-- " for the duration of this
;;; function.  This is done so that new mode lines are started with a 
;;; space.  See notes above.
(defun do-some-more-ada-init (&aux re-font-buffer)
  (cond ((zerop *editor-command-menu-width*)
	 (com-make-top-command-menu)))
  ;; Get a handle on the newly-created ada-mode flavor instance
  (setq *ada-mode-handle* #+Symbolics (car *modes*) #+LMI 'ada-mode)
  ;; Now, if it is a new buffer (only one line) AND if it is NOT read-only (or has
  ;; no mode line), we diddle with (or create) the attribute line.
  (if (and (not (eq (send *interval* ':tick) ':read-only))
	   (or
	     (< (count-lines *interval*) 2)
	     (and (send *interval* :pathname)
                  (= (length  ;; file has no attribute line -> '(mode ada) set at this point
		       (fs:read-attribute-list
			 (send (send *interval* :pathname) :generic-pathname)
			 (interval-stream *interval* nil t t)))
		     2)
		  (setq re-font-buffer t))))
      (let-variable-values ((*comment-start* "-- "))

	#+Symbolics
        (let ((tem (mapcar #'(lambda (fon) (cons (get-pname fon) (symeval fon)))
                           *ada-mode-default-font-list*))
              (*set-attribute-updates-list* t)
              (current-fonts  (progn (reparse-attribute-list-internal
                                       *interval* (interval-stream *interval* nil t t))
                                     (send *interval* ':get ':font-alist))))
          ;;  Now, merge existing fonts in window with our defaults.  This
          ;; means that the user can supply one, two, or all three fonts
          ;; in his attribute list, and we will supply any missing ones.
          (setq tem (append current-fonts (nthcdr (length current-fonts) tem)))
	
          (redefine-fonts *window* tem)
          (when (send *interval* ':operation-handled-p ':putprop)
            (send *interval* ':putprop tem ':font-alist)
            (and (send *interval* ':operation-handled-p ':editing-file-p)
                 (set-attribute-internal ':fonts "fonts"
                                         (and tem (format nil "~{~a~^,~}" (mapcar 'car tem)))
                                         (make-font-alist-attribute tem))))
          (update-font-name)
          (update-attribute-list-internal *interval*))

	#+LMI
	(setup-ada-fonts *ada-mode-default-font-list*)

	(com-goto-end)                          ;Goto end of new buffer, and
	(com-insert-crs)                        ;insert a <return>. 
	))
  (and re-font-buffer (com-ada-font-words-buffer))
  (must-redisplay *window* dis-text))

#+LMI
(DEFUN setup-ada-fonts (FONTS &optional (query? nil) (forget-old? nil))
  "Make sure that all the fonts in the list FONTS are available in the current buffer."
  (PKG-BIND "FONTS"
    (SETQ FONTS
	  (LOOP FOR FONT IN FONTS
		COLLECT
		(FONT-NAME (SEND (TV:SHEET-GET-SCREEN (WINDOW-SHEET *WINDOW*))
				 ':PARSE-FONT-DESCRIPTOR
				 (READ-FROM-STRING (STRING FONT)))))))
  (LET ((OLD-LIST (WINDOW-FONT-ALIST *WINDOW*)))
    (AND ( (LENGTH OLD-LIST) 26.) (BARF "The maximum number of fonts is 26."))
    (OR OLD-LIST (SETQ OLD-LIST (LET ((FONT0 (CURRENT-FONT *WINDOW* 0)))
				  (LIST (CONS (GET-PNAME (FONT-NAME FONT0)) FONT0)))))
    (when forget-old? (setq old-list nil))
    (SETQ old-list (SUBSET-NOT #'(LAMBDA (FONT) (mem #'string-equal (car FONT) fonts))
                               old-list))
    (SEND *INTERVAL* ':SET-ATTRIBUTE ':FONTS
	  (NCONC FONTS (MAPCAR  #'(LAMBDA (AELT) (FONT-NAME (CDR AELT))) OLD-LIST))
	  (if query? :query t))
    (REDEFINE-FONTS *WINDOW* (APPEND (MAPCAR #'(LAMBDA (FONT)
						 (CONS (GET-PNAME FONT) (SYMEVAL FONT)))
					     FONTS)
				     OLD-LIST))
    FONTS))

;;;  Make sure we have the correct word abbreviations.
(eval-when (load eval)
  (cond ((not (user:status_feature 'user:adaqwabl))
	 (with-open-file (qwabl-stream (user:ct_load_get 'user:adaqwabl) ':IN)
	   (load-qwabl qwabl-stream))))
  (user:sstatus_feature 'user:adaqwabl))

;;;  This makes extensions .ada and .a turn on ada mode.
(push '("ada" . :ada) fs:*file-type-mode-alist*)
(push '("a" . :ada) fs:*file-type-mode-alist*)


;;; Now, make ADA MODE a M-X command.
(set-comtab *standard-comtab* () (make-command-alist '(com-ada-mode)))

;;; GROSS HACK to enable/disable Ada-mode when entering/exiting an ada buffer
;;; Turn off the mode.  If it is not on, do nothing.
#+Symbolics
(DEFUN TURN-OFF-MODE (MODE)
  (WHEN (SYMBOLP MODE)
    (SETQ MODE (MODE-OF-FLAVOR MODE)))
  (LET ((MODE-ELEMENT (ASSQ MODE *MODE-LIST*)))
    (UNLESS (NULL MODE-ELEMENT)
      ;; We must first turn off all more-recently added modes,
      ;; then turn off this mode, and then turn the more-recently added
      ;; modes on in reverse order.  To accomplish the last, backward step
      ;; more elegantly, we use a recursive subfunction.
      (TURN-OFF-MODE-UNDERSCORE *MODE-LIST* MODE-ELEMENT)))
  (if (equal mode *ada-mode-handle*) (com-remove-top-command-menu))
  (SETQ *MODE-NAME-LIST* (DELQ MODE *MODE-NAME-LIST*)))

#+LMI
(DEFUN TURN-OFF-MODE (MODE-SYMBOL)
  "Turn off mode MODE-SYMBOL.  Mode symbol is, for example, LISP-MODE.
Does nothing if the mode is not on."
  (LET ((MODE-ELEMENT (ASSQ MODE-SYMBOL *MODE-LIST*)))
    (COND ((NOT (NULL MODE-ELEMENT))
	   ;; We must first turn off all more-recently added modes,
	   ;; then turn off this mode, and then turn the more-recently added
	   ;; modes on in reverse order.  To accomplish the last, backward step
	   ;; more elegantly, we use a recursive subfunction.
	   (TURN-OFF-MODE-UNDERSCORE *MODE-LIST* MODE-ELEMENT))))
  (when (eq mode-symbol *ada-mode-handle*) (com-remove-top-command-menu))
  (SETQ *MODE-NAME-LIST* (DELQ MODE-SYMBOL *MODE-NAME-LIST*)))

;;; Turn off all modes.  For ZMACS.
#+Symbolics
(DEFUN UN-SET-MODES ()
  (DOLIST (L *MODE-LIST*)
    (MAPC #'EVAL (SECOND L)))
  (SETQ *MODE-NAME-LIST* NIL
	*MODE-LIST* NIL)
  (com-remove-top-command-menu))

;;; Turn off all modes.  For ZMACS.
#+LMI
(DEFUN UN-SET-MODES ()
  "Turns off all modes that are on."
  (DOLIST (V *LOCAL-BOUND-VARIABLES*)
    (EH:DELETE-BINDING-FROM-CLOSURE *EDITOR* V))
  (DOLIST (V *LOCAL-VARIABLES*)
    (UNLESS (MEMQ V *LOCAL-BOUND-VARIABLES*)
      (SET V (SI:SYMEVAL-GLOBALLY V))))
  (DOLIST (L *MODE-LIST*)
    (MAPC #'EVAL (SECOND L)))
  (SETQ *MODE-NAME-LIST* NIL
	*MODE-LIST* NIL)
  (SETQ *LOCAL-VARIABLES* NIL)
  (SETQ *LOCAL-BOUND-VARIABLES* NIL)
  (com-remove-top-command-menu))

;;; Turn on a saved set of modes.  For ZMACS.
#+Symbolics
(DEFUN SET-MODES (MODE-LIST MAJOR-MODE)
  (SET-MODES-UNDERSCORE MODE-LIST)
  (SETQ *MAJOR-MODE* MAJOR-MODE)
  (TURN-ON-MODE *MAJOR-MODE*)
  (if (equal major-mode *ada-mode-handle*) (com-expose-top-command-menu)))

;;; Turn on a saved set of modes.  For ZMACS.
#+LMI
(DEFUN SET-MODES (MODE-LIST MAJOR-MODE &OPTIONAL LOCAL-VARIABLES)
  "Turn on the modes in MODE-LIST, and major mode MAJOR-MODE.
MAJOR-MODE, and the elements of MODE-LIST, are mode symbols, like LISP-MODE."
  (SET-MODES-UNDERSCORE MODE-LIST)
  (SETQ *MAJOR-MODE* MAJOR-MODE)
  (TURN-ON-MODE *MAJOR-MODE*)
  (DOLIST (V LOCAL-VARIABLES)
    (MAKE-LOCAL-VARIABLE (CAR V) NIL (CDR V))
    (SET (CAR V) (CADR V)))
  (when (eq major-mode *ada-mode-handle*) (com-expose-top-command-menu)))

;;;  ****************************************************************
;;;  COMMENTS
;;;  ****************************************************************


;;;  To support comments, it is also necessary to, when starting ada mode,
;;; set zwei:*comment-begin* to "--".  This atom is the string inserted
;;; when the comment-generating commands (M-;, C-;, M-P, M-N) are typed.


;;;  This function is stolen from [zwei;lparse lisp], and modified.  
;;;  The modification allows us to recognize a comment as two hyphens
;;; next to each other.  This modification only works in *ada-mode-p*;
;;; otherwise, the function behaves the same as always.
;;;
;; Describe the syntactic context of a spot identified by BP.
;; The first value is non-NIL if that spot is in a string.
;; The second is non-NIL if that spot is slashified.
;; The third is non-NIL if that spot is in a comment.
#+Symbolics
(defun ada-bp-syntactic-context
       (bp &optional (start-bp (beg-line bp)));;;(forward-definition bp -1 t)))
  (declare (return-list in-string slashified in-comment))
  (do ((i (cond ((eq (bp-line bp) (bp-line start-bp))
		 (bp-index start-bp)) (t 0))
	  (1+ i))
       (line (bp-line bp))
       (end-idx (bp-index bp))
       ;; start of line is not slashified, and may be in a string.
       (slash nil)
       (in-string (lisp-parse-from-definition (bp-line bp) start-bp))
       (ch))
      (( i end-idx)
       (return in-string slash nil))
    ;; now scan through the line parsing till we reach the spot.
    (setq ch (ldb %%ch-char (aref line i)))
    (cond ((and slash (not zwei:*ada-mode-p*))
	   (setq slash nil))
	  (t
	   (cond
	     ((and (not zwei:*ada-mode-p*)
		   (eq (list-syntax ch) list-slash))
	      (setq slash t))
	     ((and zwei:*ada-mode-p*		;if in ada mode
		   (> i 0)			;not the first char on line
		   (eq ch #/-)
		   (eq (ldb %%ch-char (aref line (1- i))) #/-)
		   (not in-string))
	      (return nil nil t))
	     ((and (not zwei:*ada-mode-p*)	; if not in ada mode
		   (not in-string)		; do what we otherwise
		   (eq (list-syntax ch) list-comment))	; would have done.
	      (return nil nil t))
	     ((eq (list-syntax ch) list-double-quote)
	      (cond ((not in-string)
		     (setq in-string ch))
		    ((= ch in-string)
		     (setq in-string nil)))))))))

#+LMI
(DEFUN ada-BP-SYNTACTIC-CONTEXT 
       (BP &OPTIONAL (START-BP (beg-line bp)));;;(FORWARD-DEFUN BP -1 T)))
  "Describe the syntactic context of a spot identified by BP.
The first value is non-NIL if that spot is in a string.
The second is non-NIL if that spot is slashified.
The third is non-NIL if that spot is in a comment.
START-BP is where to parse from to compute these
 (default is start of containing defun)."
  (DECLARE (RETURN-LIST IN-STRING SLASHIFIED IN-COMMENT))
  (DO ((I (COND ((EQ (BP-LINE BP) (BP-LINE START-BP)) (BP-INDEX START-BP)) (T 0))
	  (1+ I))
       (LINE (BP-LINE BP))
       (END-IDX (BP-INDEX BP))
       ;; Start of line is not slashified, and may be in a string.
       (SLASH NIL)
       (IN-STRING (LISP-PARSE-FROM-DEFUN (BP-LINE BP) START-BP))
       (CH))
      (( I END-IDX)
       (RETURN IN-STRING SLASH NIL))
    ;; Now scan through the line parsing till we reach the spot.
    (SETQ CH (LDB %%CH-CHAR (AREF LINE I)))
    (COND ((and SLASH (not *ada-mode-p*))
	   (SETQ SLASH NIL))
	  (T
	   (let ((syntax (list-syntax-open-coded ch)))
	     (cond ((and (not *ada-mode-p*)
			 (eq syntax list-slash))
		    (setq slash t))
		   ;; Once we reach the start of a comment, we know the answer, so exit.
		   ((and *ada-mode-p*
			 (> i 0)		;not the first char on line
			 (eq ch #/-)
			 (eq (ldb %%ch-char (aref line (1- i))) #/-)
			 (not in-string))
		    (return nil nil t))
		   ((and (not *ada-mode-p*)
			 (not in-string)
			 (eq syntax list-comment))
		    (RETURN NIL NIL T))
		   ((eq syntax LIST-DOUBLE-QUOTE)
		    (COND ((NOT IN-STRING)
			   (SETQ IN-STRING CH))
			  ((= CH IN-STRING)
			   (SETQ IN-STRING NIL))))))))))

;;;  ****************************************************************
;;;  FONTS for RESERVED WORDS
;;;  ****************************************************************

#|

Steve had the right approach here, but it wasn't completely successful.
The idea is to have abbrev-expand check to see if the word just typed
was not in a comment or a string.  If not, and it is a reserved word,
"expand" it by changing its font to bold.

The critical thing here is to recognize being in comments and inside strings.
We have been guaranteed that no strings will extend across a line boundary,
so we can write fairly simple functions that determine whether or not
a point is in a comment.

|#



;;;  the word-abbrev hook for ada.
(defprop ada-expand-abbrev-hook 10 command-hook-priority)
(defun ada-expand-abbrev-hook (keystroke)
  (if (not (= keystroke #\tab))			; don't abbrev if only indenting is needed
      (and (ada-expand-p *last-command-char*)
	   (not *numeric-arg-p*)
	   (ada-expand-abbrev)
	   (must-redisplay *window* dis-text))))



;;;  Our ada-expand-p allows some other characters to do word
;;; abbreviation.  The standard definition [zwei;modes lisp] is
;;; a bit puritanical.
(defun ada-expand-p (char)
  (and (not (memq char *ada-dont-expand-command-chars*))
       (or (memq char *ada-expand-command-chars*)
	   (expand-p char))))


;;;  This function is called by the word-abbrev hook.  (It should be
;;; called each time a word is terminated.)  It will check to see if the
;;; word is an ada reserved word and that we are not in a comment or
;;; a string.  If not, the font will be changed to bold.
;;;
;;;  Reserved words are required to be abbreviations that expand to
;;; themselves.  Thus, when a user types "begin ", it expands to "begin ",
;;; but then the word-abbrev-hook allows us to change the font.
;;;
;;;  This function is largely rewritten from [zwei; modes lisp].
(defun ada-expand-abbrev (&aux bp original-bp string sym tem prop imark ipoint)
  (and (= (word-syntax (bp-char-before (point))) word-alphabetic)
       (multiple-value (string bp)
         (bound-word (point))))

  #+LMI
  ;;; Problem: Above sometimes returns an ART-FAT-STRING.  Must skinny it up a bit.
  (when (and string (arrayp string) (eq (array-type string) 'art-fat-string))
    (loop with new-string = (make-array (string-length string) :type 'art-string)
          for char being the array-elements of string using (index i) do
          (setf (aref new-string i) char)
          finally (setq string new-string)))
        
  (setq original-bp bp)
  (let ((ch (bp-char (point)))
	(savebp (point)))
    (cond ((= (word-syntax ch) word-alphabetic)
;;; if you are in or at the end of a word, a key click should ensure that the
;;; whole word is properly fonted prior to moving to the next location; otherwise
;;; you should simply process the input in place.
	   (prog2 (and (not (< *last-command-char* 256.)) (com-forward-word))
		  (multiple-value (string bp) (bound-word (point)))
		  (move-bp (point) savebp)))))
  (cond (original-bp
	 (multiple-value-bind (instr nil incomment)
	     (ada-bp-syntactic-context bp)
	   (cond ((not (or instr incomment
			   (inside-mini-buffer)))
		  (selectq *ada-non-reserved-word-action*
		    (:upper (upcase-interval bp (point) t))
		    (:lower (downcase-interval bp (point) t))
		    (:capital (upcase-interval bp (point) t))   ;; Not working.
		    (t nil))		  
		  (change-font-interval bp (point) t *ada-normal-font*)
		  (must-redisplay *window* dis-text))
		 ((and incomment  (not (inside-attribute-line))(not (inside-mini-buffer)))
		  (change-font-interval bp (point) t *ada-comment-font* )
		  (must-redisplay *window* dis-text))))))
  (cond ((and string
	      (not (inside-mini-buffer))
              (setq sym (intern-soft (string-upcase string) *utility-package*))
              (setq tem (or (get sym (setq prop (get-abbrev-mode-name)))
                            (get sym (setq prop '*-abbrev)))))
	 (cond (*last-expansion-bp*
		(move-bp *last-expansion-bp* bp))
               (t
                (setf *last-expansion-bp* (copy-bp bp ':normal))))
	 (cond ((and (char-equal (bp-char-before bp) #/-)
		     (bp-= (move-bp bp (forward-char bp -1))
			   *word-abbrev-prefix-mark*))
		(setq string (string-append "-" string))
		(delete-interval bp (forward-char bp) t))
	       (t
		(setq string (string-append string))))
	 (setf *last-expanded* string)
	 (setf *last-expansion* tem)
	 (setf *last-expansion-symbol* sym)
	 (setf *last-expansion-usage-prop* (get-abbrev-usage-name prop))
	 (let ((v (get sym *last-expansion-usage-prop*)))
	   (putprop sym (if v (1+ v) 1) *last-expansion-usage-prop*))
	 (setq imark *last-expansion-bp*
	       ipoint (move-bp (point) (case-replace *last-expansion-bp* (point) tem)))
	 ;;  Here we check whether or not to font.  First, the abbrev expansion
	 ;; must be an ada reserved word.  Secondly, we check the mark to see
	 ;; it's syntactic context.  If in a comment or string, don't do anything.
	 (if (and (mem #'string-equal *last-expansion* *ada-reserved-words*)
		  (multiple-value-bind (instr nil incomment)
		      (ada-bp-syntactic-context imark)
		    (not (or instr incomment))))
	     (progn
	       (selectq *ada-reserved-word-action*
		 (:upper (upcase-interval imark ipoint t))
		 (:lower (downcase-interval imark ipoint t))
		 (:capital (downcase-interval imark ipoint t))	;not working yet.
		 (t nil))
	       (change-font-interval imark ipoint t *ada-reserved-word-font*))))))

(defprop ada-fix-comment-starters-hook 10 command-hook-priority)
(defun ada-fix-comment-starters-hook (ignore)
  (if (= *last-command-char* #\space)
      (font-comment-starters))
  (must-redisplay *window* dis-text))

(defun font-comment-starters ()
  (let ((orig (copy-bp (point))))
    (loop until (not (= (bp-char-before (point)) #/-))
          do (com-backward))
    (if (comment-starter (string-interval (create-interval (point) orig)))
        (change-font-interval (point) orig t *ada-normal-font*))
    (move-bp (point) orig)))




;;;  ****************************************************************
;;;  Re-fonting Region, Buffer
;;;  ****************************************************************

;;;  Someone may decide it a good idea to re-font the region (or buffer.)
;;;  Perhaps an unfonted file has just been read in.

(defcom com-ada-font-words-region "Font words in region correctly for Ada."
	(nm)
  (pkg-bind 'zwei
    (let ((bp1 (point))  (bp2 (mark)) (readtable *ada-simple-readtable*))
      (cond  ((bp-= bp1 bp2) dis-none)		;if pt = mark, do nothing
	     ((bp-< bp1 bp2)			;do the real work.
	      (loop until (bp-< bp2 (point))
		    for next-bp = (forward-word  (point))
		    while next-bp
		    do  (move-bp (point) next-bp)
		    do  (ada-expand-abbrev))
	      dis-all)
	     (t (com-swap-point-and-mark)	;if pt > mark, swap, and recurse.
		(com-ada-font-words-region))))))


(defcom com-ada-font-words-buffer "Font all words in buffer correctly for Ada."
	()
  (move-bp (point) (interval-first-bp *interval*))	;Go to beginning of buffer
  (down-real-line 1)				;then down a line
  (point-pdl-push (point) *window* nil)		;set mark
  (move-bp (mark) (point))			;set mark
  (setf (window-mark-p *window*) t)		;set mark
  (MOVE-BP (POINT) (INTERVAL-LAST-BP *INTERVAL*))	;goto end of buffer.
  (com-ada-font-words-region))




;;;  ****************************************************************
;;;  INDENTATION
;;;  ****************************************************************


;;;  This function is modified from [zwei;pl1mod lisp].
;;;  It is the actual command to indent a line.
;;;  Currently only works at the beginning of line.
;;;  Runs MUCH TOO SLOWLY.
(defcom com-indent-for-ada "Indent sufficiently for the Ada statement
 or statement fragment that I am about to type." ()
  (let ((old-point (copy-bp (point) ':normal))
	(begin-p (beg-line-p (point))))
    (move-bp (point) (beg-line (point) 0 t))	;goto beginning of line.
    (delete-around *blanks* (point))		;i think this deletes blanks.
    (whitespace-to-hpos (point)
			(new-ada-indent-amount (buffer-string)
					   (line-string)))
    (unless begin-p (swap-bps (point) old-point)))
  dis-text)

(defun internal-indent-for-ada (stack line-string)
    (delete-around *blanks* (point))		;i think this deletes blanks.
    (whitespace-to-hpos (point)
			(stack-ada-indent-amount stack ;;;(buffer-string)
					   line-string))
    )

;;;  This command should be used when the user knows he will be typing
;;; a reserved word that should be de-indented compared with the previous
;;; line.
(defcom com-less-indent-for-ada "Indent less than would otherwise be
 required." ()
  (delete-around *blanks* (point))
  (whitespace-to-hpos (point)
		      (max 0 (- (new-ada-indent-amount (buffer-string))
				*ada-indent-delta*)))
  dis-text)


(defcom com-indent-new-line-for-ada "Indent new line.
 Indents the current line, inserts a return, and indentation on the
 new line." ()
  (com-indent-for-ada)
  (com-indent-new-line))

;;;  Inserts a semi-colon and tabs the current line.  Normally, this
;;; is NOT bound to a key because of the expense of indentation.
(defcom com-insert-semi-and-indent "Inserts semicolon and indents current line."
	()
  (funcall *standard-command*)			;standard insert the char.
  (com-indent-for-ada))				;indent the current line.



(defcom com-ada-indent-buffer "Indents all the lines in the buffer"
        ()
  (interval-lines ((interval-first-bp *interval*) (interval-last-bp *interval*))
                  (start-line stop-line)
    (DO ((last-line nil line)
	 (LINE START-LINE (LINE-NEXT LINE))
         (stack nil (make-stack line stack))
         (POINT (POINT))
  ;       (OLD-POINT (COPY-BP (POINT)))
	 )
        ((EQ LINE STOP-LINE)
         (MOVE-BP (POINT) (INTERVAL-FIRST-BP *INTERVAL*)))	;goto beginning
      (MOVE-BP POINT LINE 0)
      (internal-indent-for-ada stack (string line));;; (com-indent-for-ada)
      ))
  dis-text)


(defcom com-ada-indent-region "Indents all the lines in the region"
	()
  (region-lines (first last)
    (do ((line first (line-next line))
	 (stack (short-indent-stack
		  (string-append "" (cheap-string-interval
				      (interval-first-bp *interval*)
				      (if (bp-< (mark) (point)) (mark) (point)))))
		(make-stack line stack))
	 (point (point))
	 (old-point (copy-bp (point))))
	((eq line last)
	 (move-bp (point) old-point))
      (move-bp point line 0)
      (internal-indent-for-ada stack (string line))))
  dis-text)

;;;  Returns T if a string is not a comment only.
(defun line-not-comment (string)
  (setq string (string-left-trim '(#\space) string))
  (cond ((< (string-length string) 2) t)
	(t (not (string-equal (substring string 0 2)
			      "--")))))

;;;  Returns T if a string is not blank.
(defun line-not-blank (string)
  (not (string-equal (string-trim '(#\space) string) "")))

;;;  Returns T if the string is all hyphens except for the spaces
;;; at either end.
(defun comment-starter (string)
  (setq string (string-trim '(#\space) string))
  (loop for i from 0 to (1- (string-length string))
        initially (if (< (string-length string) 2.) (return nil))
        do (if (not (= (aref string i) #/-))
               (return nil))
        finally (return t)))

;;;  Returns the first word in a line, interned as a symbol.  (We upper case
;;; it)
(defun first-word-in-line (string)
  (setq string (string-left-trim '(#\space) string))
  (intern (string-upcase (substring string 0
				    (string-search-set '(#\tab #\space
							 #/; )
						       string)))
	  'zwei))


;;;  Returns the amount of indentation of a line.  This is the number of spaces
;;; at the beginning of the line.
(defun indentation (string)
;   (or (string-search-not-char #\space string) 0))
  (- (string-length string)
     (string-length (string-left-trim '(#\space) string))))



;;;  We have to redefine this function (from [zwei; comb lisp]) to
;;; make indentation work correctly with comments.  Problem is that
;;; unmodified, this function deletes indentation when setting
;;; up a comment.
(defun indent-for-comment (bp &optional (times 1) create-p move-to-next-p beg-line-not-special
			      &aux (up-p 1))
  (setq bp (copy-bp bp ':moves))
  (and (minusp times)
       (setq up-p -1 times (minus times)))
  (do ((i 0 (1+ i))
       (line)
       (len)
       (ch)
       (start-start-index)		;index in line of start of existing comment starter.
       (start-end-index))		;index in line of end of ...
      (( i times))
    (setq line (bp-line bp)
	  len (line-length line))
    (multiple-value (start-start-index start-end-index)
      (find-comment-start line t))
    (cond (start-start-index
	   ;; a comment already exists.  move bp to it.
	   (move-bp bp line start-start-index)
	   ;; distinguish between ";", ";;" and ";;;" type comments.
	   (cond ((and (zerop start-start-index)	;at the beginning of the line stays
		       (not beg-line-not-special)))
		 ((and (> len (1+ start-start-index))
		       (char-equal (aref line (1+ start-start-index))
				   (setq ch (aref line start-start-index))))
		  (cond ((or ( len (+ start-start-index 2))	; ";;;" doesn't move
			     (not (char-equal ch (aref line (+ start-start-index 2)))))
			 ;; it is a double semicolon, indent as code.
			 ;; patch here for ada mode.
			 (if (not *ada-mode-p*)
			     (indent-line bp (indent-for-lisp bp)))
			 )))
		 (t
		  (delete-backward-over *blanks* bp)
		  (indent-to-comment-column bp)))
	   ;; now that indentation is adjusted, move over the comment starter.
	   (move-bp bp (forward-char bp (- start-end-index start-start-index))))
	  (create-p
	   ;; no existing comment, and no numeric arg, means make a comment.
	   (move-bp bp line len)		; move to end of line
	   (delete-backward-over *blanks* bp)
	   (indent-to-comment-column bp)
	   (insert bp *comment-begin*)))
    (and move-to-next-p				; move to next line
	 (move-bp bp (or (beg-line bp up-p) (return nil)))))
  bp)

;;;  The string from beginning of buffer to point.
(defun buffer-string ()
  (cheap-string-interval (interval-first-bp *interval*)
		   (point)))

(defun full-buffer-string ()
  (cheap-string-interval (interval-first-bp *interval*)
		   (interval-last-bp  *interval*)))

(defun region-string ()
  (cheap-string-interval (point) (mark)))

;;;  The string of this line.
(defun line-string ()
  (cheap-string-interval (beg-line (point)) (end-line (point))))


;;;  Returns T if we are operating in the mini-buffer
(defun inside-mini-buffer ()
  (typep* (window-sheet *window*) 'zwei-mini-buffer))

;;;  Returns T if we are in the attribute line of the file.
;;; This means:  1. on first line of file
;;;              2. line contains -*-
(defun inside-attribute-line ()
  (and (string-search "-*-" (line-string))
       (bp-= (beg-line (point)) (interval-first-bp *interval*))))

;;;  My own version.  taken from (sys:zwei;insert).  This should be
;;; cheaper, since it always uses and returns 8-bit strings.  (Normally,
;;; the real function STRING-INTERVAL would return 16-bit strings, since
;;; the ada buffer is probably fonted.
(DEFUN cheap-STRING-INTERVAL (FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (LET ((FROM-LINE (BP-LINE FROM-BP))
	(FROM-INDEX (BP-INDEX FROM-BP))
	(TO-LINE (BP-LINE TO-BP))
	(TO-INDEX (BP-INDEX TO-BP))
	STRING)
    (SETQ STRING (MAKE-ARRAY (COUNT-CHARS FROM-BP TO-BP) ':TYPE 'art-string))
    (COND ((EQ FROM-LINE TO-LINE)
	   ;; Within a line.  Copy the characters.
	   (DO ((LF FROM-INDEX (1+ LF))
		(ST 0 (1+ ST)))
	       (( LF TO-INDEX))
	     (ASET (AREF FROM-LINE LF) STRING ST)))
	  (T
	   (LET ((ST 0))
	     ;; Copy from the first line.
	     (DO ((FLF FROM-INDEX (1+ FLF))
		  (LEN (LINE-LENGTH FROM-LINE)))
		 (( FLF LEN))
	       (ASET (AREF FROM-LINE FLF) STRING ST)
	       (SETQ ST (1+ ST)))
	     (ASET #\CR STRING ST)
	     (SETQ ST (1+ ST))
	     ;; Copy from intermediate lines.
	     (DO ((LINE (LINE-NEXT FROM-LINE) (LINE-NEXT LINE)))
		 ((EQ LINE TO-LINE))
	       (DO ((LF 0 (1+ LF))
		    (LEN (LINE-LENGTH LINE)))
		   (( LF LEN))
		 (ASET (AREF LINE LF) STRING ST)
		 (SETQ ST (1+ ST)))
	       (ASET #\CR STRING ST)
	       (SETQ ST (1+ ST)))
	     ;; Copy from the last line.
	     (DO ((TLF 0 (1+ TLF)))
		 (( TLF TO-INDEX))
	       (ASET (AREF TO-LINE TLF) STRING ST)
	       (SETQ ST (1+ ST))))))
    STRING))



;;;  ****************************************************************
;;;  NEW INDENT
;;;  ****************************************************************


;;;  The simple indentation algorithm, that looks at only one prvious
;;; line, is wrong.  This section of code introduces an improved
;;; indentation algorithm.

;;;  The INDENTATION STACK is a list of reserved words seen at the
;;; beginnings of lines before the point.  This stack only goes back
;;; as far as a PROCEDURE, TASK, FUNCTION, or PACKAGE found at the
;;; beginning of a line, or to the beginning of the buffer otherwise.

;;;  Each reserved word has an indentation behavior, both for itself
;;; and for lines below.  Many reserved words will be indented the same
;;; as the line above.  Many will indent the next line MORE than itself.
;;; Lines without a reserved word at the beginning will indented
;;; according to the previous line: the same as most lines, but more than
;;; some lines.

;;;  Indentation behavior for each keyword is table driven.



;;;  The amount of indentation needed for the current line.  This is calculated
;;; from the indentation of the last real code line of any kind, and
;;; some special functions that look at what reserved words are before the
;;; current point in the buffer.
;;;
;;; ++ We may find we don't always need the stack, which is one of the more
;;; expensive operations here.  (Not TOO expensive, but....)  If truly not
;;; needed much of the time, then don't always compute it.  (Further improvement.)
;;;  +++
;;;
(defun new-ada-indent-amount (buffer-string &optional (line ""))
  (let ((stack (short-indent-stack (string-append "" buffer-string))))
    ;; For debugging, display indentation quanta in typein area.
    (if (status feature debugging)
	( typein-line "Curr ind:~d  Prev. actn:~d"   ;;;taken out
		     (current-indentation-action (first-word-in-line line) stack)
		     (previous-indentation-action stack)))
    (+ (current-indentation-action (first-word-in-line line) stack)
       (previous-indentation-action stack))))

(defun stack-ada-indent-amount (stack &optional (line ""))
  (setq stack (collapse *ada-patterns* (copylist stack)))
  ;; For debugging, display indentation quanta in typein area.
  (if (status feature debugging)
      ( typein-line "Curr ind:~d  Prev. actn:~d"   ;;;taken out
       (current-indentation-action (first-word-in-line line) stack)
       (previous-indentation-action stack)))
  (+ (current-indentation-action (first-word-in-line line) stack)
     (previous-indentation-action stack)))

;;;  Returns an amount of indentation based on what is on the stack,
;;; and what kind of token is on the stack.  I think most of the time
;;; we won't need this info.
;;;
;;;  THIS HAS BEEN CHANGED TO BE TABLE DRIVEN.
;;;  Basically, we find that all we check is the current word, and
;;; the last word on the stack.
;;;
(defun current-indentation-action (word stack
				   &aux (last (caar (last stack))))
  (if (status feature debugging) (typein-line "~A" stack))  ;;taken out
  (or (eval (cdr (or (assq last (cdr (assq word *current-indent-action*)))
		     ;; check for special case of match-any.
		     (assq '*match-any* (cdr (assq word *current-indent-action*))))))
      0))





;;;  Returns an amount of indentation based on the last real line
;;; before us.  For example, if it began with "BEGIN", then we
;;; would want to indent some.
;;;
;;;  The stack contains keywords, an indentation (a fixnum) and
;;; a semi-indicator.  The semi-indicator tells if the line 
;;; containing the keyword ended in a semi-colon.  This value is
;;; T or nil.
;;;  The indentation qty is the indentation of the line containing
;;; the keyword.
(defun previous-indentation-action (stack)
  (let ((last-word (caar (last stack)))
	(last-ind (or (cadar (last stack)) 0))
	(last-semi (cddar (last stack))))
    (cond ((memq last-word *ada-stub-words*)
	   (if last-semi last-ind (+ last-ind *ada-indent-delta*)))
	  ((memq last-word *ada-indent-words*)
	   (+ last-ind *ada-indent-delta*))
	  (t last-ind))))




;;; Returns T if a semicolon at the end of the line, ignoring comments.
;;;  This is a very simple parser, but it cannot be fooled!  (I hope.)
(defun semi-at-end-of-line (string)
  (loop for i from 0 to (1- (string-length string))
	with semi = nil
	with comment = nil
	with str = nil
	with str2 = nil
	do (selectq (aref string i)
	     (#/; (setq semi (not str)))	;Seen a semi, remember for 1 cycle
	     (#/" (setq str (not str)))		;Toggle whether in " string
	     (#/' (setq str2 (not str2)))	;Toggle whether in ' string
	     (#/- (cond ((or str str2))		;Possible start of comment.
			((null comment) (setq comment t))
			(t (return semi))))	;If second "-", definite comment.
	     (#\space (setq comment nil))	;Space doesn't affect fact we
						;have seen a semi.
	     (t (setq comment nil		;Any other char flushes semi
		      semi nil)))		;and comment.
	finally (return semi)))



;;;  This function returns the current indentation stack, as a list of
;;; conses of symbols and the indentation on that line.
;;;  This function seems to run pretty slowly.  We need to speed it 
;;; up.
(defun indent-stack (&optional (buff (buffer-string)) &aux list)
  (loop with ptr1 = (string-reverse-search-char #\return buff)
	with ptr2 = (string-length buff)
	for str = (substring buff (if ptr1 (1+ ptr1) 0) ptr2)
	for ind = (indentation str)
	for semi = (semi-at-end-of-line str)
	do (if (and (line-not-comment str) (line-not-blank str))
	       (setq list (append
			    (indent-interesting-keywords str ind semi)
			    list)))
	until (null ptr1)
	do (setq ptr2 ptr1
		 ptr1 (string-reverse-search-char #\return buff ptr1))
	until (or (firstword str "PROCEDURE")
		  (firstword str "PACKAGE")
		  (firstword str "TASK")
		  (firstword str "FUNCTION")))
  list)

;;;  New function to create a stack the easy way.  (har, har.)
;;; This uses ZWEI buffer lines.
(defun make-stack (zwei-line stack)
  (let ((string (string-append "" zwei-line)))
    (append stack (indent-interesting-keywords string
					       (indentation string)
					       (semi-at-end-of-line string)))))

;;;  Returns a list of interesting (for indentation) keywords found
;;;in a string, or nil.  
(defun indent-interesting-keywords (string ind semi)
  (loop for word in (ada-words-in-string string)
	collect (cons word (cons ind semi))))


;;; Make sure we don't confuse compiler in funtion below.
(declare (special readtable))

;;;  Returns a list of all words on a line, except those in strings
;;; or comments.   This was recoded to avoid string consing.  Before, this
;;; appended  and  (top-T and top-Y) characters to the beginning and end
;;; of the string so we could read it all at once.  Now, we don't bother
;;; making a new string, and instead do multiple reads.  This also should
;;; simplify the read table.
(defun ada-words-in-string (string)
  (pkg-bind 'zwei
    (let ((readtable *ada-simple-readtable*))
      (loop with len = (string-length string)
	    with ptr = 0
	    with token = nil
	    do (multiple-value (token ptr)
		 (read-from-string string ':ct-eof-while-reading ptr))
	    until (eq token ':ct-eof-while-reading)
	    until (and (symbolp token)
		       (string-equal "--" token 0 0 2 2))
	    ;; Don't collect strings.
	    unless (stringp token)
	    ;; collect only interesting keywords for indenting
	    when (memq token *ada-indent-interesting-keywords*)
	    collect token
	    until ( ptr len)))))


;;;  Returns condensed indentation-stack.
(defun short-indent-stack (buffer-string)
  (let ((stack (indent-stack buffer-string)))
    (collapse *ada-patterns* stack)))


;;;  Accepts a list of patterns and a list of symbols.  Removes
;;; all occurances of patterns from the list, even when removing
;;; one instance of some pattern creates an instance of some
;;; (same or other) pattern.
(defun collapse (patlst lst)
  ;;; keep applying the splicing out specified by patlst until nothing changes
  (prog (prevlen ans)
	(setq ans lst)
     loop 
	(setq prevlen (length ans))
	(setq ans (collapse-by-pats1 patlst ans))
	(cond ((= (length ans) prevlen) (return ans))
	      (t (go loop)))))

;;; New, improved version.  Applies each pattern, in order.  If a successful
;;; collapse is done, we start the list of patterns over, rather than continuing.
;;; If we ever get through all the patterns, we are done.
(defun collapse-by-pats1 (patlst lst)
  (loop with patterns = patlst
	do (let ((len (length lst)))
	     (setq lst (splice-out (car patterns) lst))
	     (if (= (length lst) len)
		 (setq patterns (cdr patterns))
		 (setq patterns patlst)))
	until (null patterns))
  lst)

;;;  Splice-out attempts to remove pattern from list as many times as possible.
;;; We still have to do this N times, but need only look at the end of the list.
(defun splice-out (pat lst)
  (prog (prevlen)
     loop 
	(setq prevlen (length lst))
	(setq lst (splice-out1 pat lst))
	(cond ((= (length lst) prevlen) (return lst))
	      (t (go loop)))))

(defun splice-out1 (pat tail)
  ;;; Destructively splices out all occurrences of the token-sequence pat in tail.
  (prog (tl cdrtl len)
	(setq len (length pat))
	;;; The initial case is tougher for splicing ...
	(cond ((first-equal pat tail)
	       (return (splice-out pat (nthcdr len tail)))))
	(setq tl    tail
	      cdrtl (cdr tl))
   loop (cond ((null cdrtl) (return tail)))
	(cond
	  ((first-equal pat cdrtl) (rplacd tl (nthcdr len cdrtl))
				   (setq cdrtl (cdr tl))
				   (go loop))
	  (t (setq tl    cdrtl
		   cdrtl (cdr cdrtl))
	     (go loop)))))

;;;  This checks to see if two lists are equal in a funny way;  The check
;;; is made element by element, for only the number of elements in PAT.
;;; If there are extra elements in tail, it doesn't matter.  Also,
;;; an elementin PAT is matched with the CAR of elements in tail.
;; Non-tail-recursive version.  Should be quicker.
(defun first-equal (pat tail)
  "Checks whether the first part of tail is item-by-item eq to all of pat."
  (unless (< (length tail) (length pat))
    (loop for pat-item in pat
	  for tail-item in tail
	  if (neq pat-item (car tail-item))
	  return nil
	  finally (return t))))







;;;  &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
;;;  &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
;;;  &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
;;;
;;;  NEW Support for lozenged characters.
;;;
;;;  The following code is MUCH less kludgey than what we had in the
;;; past.  Before, we actually installed a 25th font in the font-map
;;; that was the temploz font.  This required special care to make sure
;;; it was always installed. 
;;;
;;;  NOW, we merely define new characters in the lisp machine character
;;; set.  It turns out that characters bigger than #o200 are independent
;;; of font, and are (other than return/lf) printed as lozenged chars.
;;;  SO, all we need to do is define our lozenges as new characters.
;;;  That's what this section is all about.
;;;
;;;  &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
;;;  &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
;;;  &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

;;;
;;;  THIS WHOLE SECTION is wrapped in an EVAL-WHEN to make sure we
;;; define these characters at compile time, too.
;;;
;;;  Installs a new character in the character set, or complains.
;;;  You must supply at least one name for the character, and you
;;; may optionally supply others.  If the number is already in use,
;;; or any of the names are in use, this will barf, and return nil.
(eval-when (compile load eval)
#+Symbolics
(defun install-new-character (char-number best-name &rest char-names &aux value)
  (cond
    ((> char-number #o400)
     (format t "~%You can't install ~D. as a character; it's too big." char-number))
    ((setq value (aref si:xr-character-name-array char-number))
     (unless (string-equal value best-name)
       (format t "~%You can't install ~D. as a character; it's already ~C"
	       char-number char-number))
     nil)
    ((send si:xr-character-name-hash-table ':get-hash best-name)
     (format t "~%You can't install ~A as a character-name; it's already ~D."
	     best-name (send si:xr-character-name-hash-table ':get-hash best-name)))
    (t
     ;; The number is OK, and so is the best name.  If any of the other names
     ;; are already used, we'll notify the user, but not die.
     (aset best-name si:xr-character-name-array char-number)
     (send si:xr-character-name-hash-table ':put-hash best-name char-number)
     (loop for name in char-names
	   do (if (send si:xr-character-name-hash-table ':get-hash name)
		  (format t "~%Not installing ~A as a name for ~D."
			  name char-number)
		  (send si:xr-character-name-hash-table ':put-hash name char-number)))
     t)))

;;; Problem with LMI is that there is only one list (SI:XR-CHARACTER-NAME-ARRAY)
;;; used to map from name to char-number and char-number to lozenged name.  So,
;;; must push entries onto the list such that the last thing pushed maps the
;;; best-name into the char-number.  Also, names want to be keywords because
;;; lookup is done by ASSQ and RASSQ.
(defun make-keyword (string)
  (intern (string-upcase string) :keyword))

#+LMI
(defun install-new-character (char-number best-name &rest char-names &aux value)
  (setq best-name (make-keyword best-name))
  (cond
    ((> char-number #o400)
     (format t "~%You can't install ~D. as a character; it's too big." char-number))
    ((setq value (car (rassq char-number si:xr-special-character-names)))
     (unless (string-equal value best-name)
       (format t "~%You can't install ~D. as a character; it's already ~C"
	       char-number char-number))
     nil)
    ((setq value (cdr (assq best-name si:xr-special-character-names)))
     (unless (eq value char-number)
       (format t "~%You can't install ~A as a character-name; it's already ~D."
	       best-name value)))
    (t
     ;; The number is OK, and so is the best name.  If any of the other names
     ;; are already used, we'll notify the user, but not die.
     (loop for name in char-names do
	   (setq name (make-keyword name))
	   (if (car (setq value (assq name si:xr-special-character-names)))
	       (unless (eq (cdr value) char-number)
		 (format t "~%Not installing ~A as a name for ~D."
			 name char-number))
	     (push `(,name . ,char-number) si:xr-special-character-names)))
     (push `(,best-name . ,char-number) si:xr-special-character-names)
     t)))

;;;  ****************
;;;  Here are all the characters needed as lozenges in the
;;;  ADA-MODE editor.  Feel free to add more; the maximum is 255.
;;;  ****************

(install-new-character 200. "identifier")
(install-new-character 201. "statements" "statement" "code")
(install-new-character 202. "condition")
(install-new-character 203. "declarations" "declaration")
(install-new-character 204. "parameters" "parameter")
(install-new-character 205. "range")
(install-new-character 206. "value")
(install-new-character 207. "components" "component_list")
(install-new-character 208. "name")
(install-new-character 209. "literal" "literals")
(install-new-character 210. "type name" "type-name")
(install-new-character 211. "discrete range" "discrete-range")
(install-new-character 212. "component")
(install-new-character 213. "initial value" "initial-value")
(install-new-character 214. "discriminant")
(install-new-character 215. "default")
(install-new-character 216. "choice")
(install-new-character 217. "constraint")
(install-new-character 218. "component-name")
(install-new-character 219. "index")
(install-new-character 220. "expression")
(install-new-character 221. "block name" "block-name")
(install-new-character 222. "exception" "exceptions")
(install-new-character 223. "entry name" "entry-name")
(install-new-character 224. "mode")
(install-new-character 225. "variable")
(install-new-character 226. "accept statement" "accept-statement" "accept-statements")
(install-new-character 227. "generic function name" "generic-function-name")
(install-new-character 228. "generic procedure name" "generic-procedure-name")
(install-new-character 229. "generic package name" "generic-package-name")
(install-new-character 230. "type" "types")
)						;End of EVAL-WHEN




;;;  ****************************************************************
;;;  TEMPLATES
;;;  ****************************************************************


#|

We want to offer some aids to the user.  Templates are one such way.
This section allows a user to select templates from a menu, and insert
them into his code.

The actual template is inserted into the text with correct indentation.
A template insert acts as if the user had typed in the words of the template
himself.

|#


;;; A template is a list of components that describe what things will
;;; be placed in the
;;; buffer.  Each component contains a string and a font number.
;;;  The first element of the template is a list of a documentation string
;;; and a character with which to associate the template.
;;; (Historically, this character was the one in which the template was
;;;  displayed in TEMPLADA font.)
;;;
;;;  A very crude example is:
;;; '(("Doc." #/A) ("begin" 2) ("<return>" 0) ("B" 25.) ("<return>" 0) ("end;" 2))
;;;
;;;  In order to simplify typing in templates, components do not have
;;; to specify a font number; zero is the default.  Thus, ("foo" 0)
;;; is the same as just "foo".
;;;  Also, since carriage return is such a common thing to insert,
;;; the null string "" can be used instead of carriage return. 
;;;
;;;  Also, a component can be a list of a symbol,string & font.  The
;;; symbol allows the system to ask the user to supply something to
;;; insert for this component.  The string is used to query the user.
;;; If this symbol recurs, the first queried value will be used for
;;; the additional occurances.  In this example, the editor will ask
;;; the user for the name of the procedure, then use it in two places.
;;;
;;;  (NEW)  A component may be just a number, in which case it is
;;; an amount of indentation to indent.  (should be used only at
;;; the beginning of a line).  This indents over N times the indent-delta
;;; more than the first line was indented.
;;;  (NEWER) If the number is greater than 20, then it is assumed to be a
;;; single character, and is inserted, instead.
;;;
;;;  (NEW)  A component may be just T.  If so, this is where the cursor
;;; is left after the template is inserted.  If no component is T, then
;;; the cursor is left after the inserted template.
;;;
;;;  (NEW)  There are now characters installed in the lisp machine
;;; character set that are printed as lozenges no matter what the font.
;;;  These are used for template dummies.  You can get them with the
;;; usual #\name reader syntax.  Example:  #\DECLARATIONS gets you a character
;;; whose lozenge is <DECLARATIONS>.
;;;




;;;  This function inserts a template into the buffer at the current
;;; point.  You may not want to have the user call this directly, since
;;; the effects when in the middle of the line may be somewhat undesirable.
;;;
(defun insert-template (template) 
  (let (#+LMI (*undo-save-small-changes* nil))
    (loop for component in (cdr (second template))      ;+++jrm, 6/11/83
          ;; We loop down cdr of template, since car is docn and display char.
          with plist = (cons nil nil)           ;disembodied prop list
          with ptr = nil
          
          ;; Find indentation on first line
          with indent = (indentation (line-string))
          
          do (cond
               ;; If T, remember cursor location
               ((eq component t)
                (setq ptr (copy-bp (point))))
               
               ;; If just a CR component, indent this line & insert CR
               ((and (stringp component)
                     (string-equal component ""))
                (insert-moving (point)  (format nil #+Symbolics "~%~vX" #+LMI "~%~VT" indent)))
               
               ;; If a number, must be some amount to indent.  Better be
               ;; positive or zero!  If the number is large, it is a char,
               ;; and we insert the character instead.
               ((numberp component)
                (if ( component 20.)
                    ;; If sufficiently small, just insert some spaces.
                    (insert-moving (point) (format nil #+Symbolics "~vX" #+LMI "~vT"
                                                   (* component *ada-indent-delta*)))
		  ;; Otherwise, insert the special character
		  (insert-moving (point) (string component))))
               
               ;; Simple string, insert in font 0.
               ((stringp component)
                (insert-string-in-buffer component 0))
               
               ;; Fonted string, insert in its own font.
               ((and (listp component)
                     (stringp (first component)))
                (insert-string-in-buffer (first component)
                                         (or (second component) 0)))
               
               ;; Symbol for user input, possibly get new value
               ;; definitely insert the value.
               ((and (listp component)
                     (symbolp (first component)))
                (let ((value (get plist (first component))))
                  (if value
                      (insert-string-in-buffer value
                                               (or (third component) 0))
		    (setq value (get-string-from-minibuffer
				  (second component)))
		    (putprop plist value (first component))
		    (insert-string-in-buffer value
					     (or (third component) 0)))))
               (t (break #+Symbolics bad-component-in-template #+LMI "Bad component in template")))
          finally (if ptr (swap-bps (point) ptr)) )))


;;;  This inserts a string into the buffer in a given font.
;;;  The font is numeric, and will likely be in the range 0  n  2.
(defun insert-string-in-buffer (string font)
  (let (#+LMI (*batch-undo-save* t))
    (let ((old-point (copy-bp (point))))
      (insert-moving (point) string)
      (change-font-interval old-point (point) t font)
      (selectq font
        (0 (selectq *ada-non-reserved-word-action*
             (:upper (upcase-interval old-point (point)))
             (:lower (downcase-interval old-point (point)))))
        (2 (selectq *ada-reserved-word-action*
             (:upper (upcase-interval old-point (point)))
             (:lower (downcase-interval old-point (point)))))))))


(defun get-string-from-minibuffer (prompt)
  (prog (string)
     loop
	(setq string  (multiple-value-bind (nil nil interval)
			  (edit-in-mini-buffer
			    *mini-buffer-comtab* nil nil
			    (list prompt '(:right-flush " (Type return when done.)")))
			(string-interval interval)))
	(if (memq (intern (string-upcase (string-trim '(#\space) string)) 'zwei)
		  *ada-reserved-words*)
	    (progn (beep) (go loop))
	    (return string))))



(defun get-string-from-pop-up-minibuffer (prompt)
  (USING-RESOURCE (EDITOR EDITOR-FOR-TEMPORARY-MINI-BUFFER-RESOURCE)
    (FUNCALL EDITOR ':CALL-MINI-BUFFER-NEAR-WINDOW ':mouse
	     #'READ-string PROMPT)))


(defun read-string (prompt)
  (MULTIPLE-VALUE-BIND (NIL NIL INTERVAL)
	(EDIT-IN-MINI-BUFFER *mini-buffer-COMTAB* NIL NIL
			     (LIST PROMPT '(:RIGHT-FLUSH " ")))
      (string-interval interval)))


;;;  Here are the templates.
;;;This is now an a-list of (template_name template_defn).  TEMPLATE_NAME
;;;keys into *TEMPLATE_CONCEPT_ASSOCIATIONS*.
;;;JRM, 6/11/83 +++
  
(defconst *ada-templates*
	  '(
	    (foo
	      (("" 1)
	       ("type " 2) #\name t (" is ( " 2) #\literal (", " 2) #\literal (" );" 2)))
	    (foo
	      (("" 2)
	       ("type " 2) #\name t (" is array ( " 2) #\type-name (" range <> )" 2) ""
	       1 ("of " 2) #\type-name (";" 2)))
	    (foo
	      (("" 3)
	       ("type " 2) #\name t (" is array ( " 2) #\discrete-range (", " 2) #\discrete-range
	       (" )" 2) ""
	       1 ("of " 2) #\type-name (";" 2)))
	    (foo
	      (("" 4.)
	       ("type " 2) #\name t (" is record" 2) ""
	       1 #\component (" : " 2) #\type-name (" := " 2) #\initial-value (";" 2) ""
	       1 #\component (" : " 2) #\type-name (";" 2) ""
	       ("end record;" 2)))
	    (foo
	      (("" 5.)
	       ("type " 2) #\name t (" ( " 2) #\discriminant (" : " 2) #\type-name (" := " 2)
	       #\default (" ) is record" 2) ""
	       1 #\component (" : " 2) #\type-name (" := " 2) #\initial-value (";" 2) ""
	       1 #\component (" : " 2) #\type-name (";" 2) ""
	       ("end record;" 2)))
	    (foo
	      (("" 6.)
	       ("type " 2) #\name t (" ( " 2) #\discriminant (" : " 2) #\type-name (" := " 2)
	       #\default (" ) is record" 2) ""
	       1 #\component (" : " 2) #\type-name (" := " 2) #\initial-value (";" 2) ""
	       1 #\component (" : " 2) #\type-name (";" 2) ""
	       1 ("case " 2) #\discriminant (" is" 2) ""
	       2 ("when " 2) #\choice ("|" 2) #\choice (" => " 2) #\component (" : " 2) #\type-name (";" 2) ""
	       2 ("when others => " 2) #\components (" : " 2) #\type-name (";" 2) ""
	       1 ("end case;" 2) ""
	       ("end record;" 2)))
	    (foo
	      (("" 7.)
	       ("type " 2) #\name t (" is new " 2) #\type-name " " #\constraint (";" 2) ""))
	    (foo
	      (("" 8.)
	       ("type " 2) #\name t (" is subtype " 2) #\type-name " " #\constraint (";" 2) ""))
	    (foo
	      (("" 9.)
	       ("type " 2) #\name t (" is private;" 2) ""))
	    (foo
	      (("" 10.)
	       ("type " 2) #\name t (" is limited private;" 2) ""))
	    (foo
	      (("" 11.)
	       ("( " 2) #\component-name  (" => " 2) #\value ("," 2) ""
	       1    #\component-name (" => " 2) #\value (" );" 2) ""))
	    (foo
	      (("" 12.)
	       ("( " 2) #\index t (" => " 2) #\value (", " 2) #\index (" => " 2) #\value ("," 2) ""
	       1 ("others => " 2) #\value (" );" 2) ""))
	    (foo
	      (( "" 13.)
	       #\name t ("'address" 2)))
	    (foo
	      (( "" 14.)
	       #\name t ("'base" 2)))
	    (foo
	      (( "" 15.)
	       #\name t ("'first" 2)))
	    (foo
	      (( "" 16.)
	       #\name t ("'image" 2)))
	    (foo
	      (( "" 17.)
	       #\name t ("'last" 2)))
	    (foo
	      (( "" 18.)
	       #\name t ("'length" 2)))
	    (foo
	      (( "" 19.)
	       #\name t ("'range" 2)))
	    (foo
	      (( "" 20.)
	       #\name t ("'size" 2)))
	    (foo
	      (( "" 21.)
	       #\name t ("'succ" 2)))
	    (foo
	      (( "" 22.)
	       #\name t ("'val" 2)))
	    (foo
	      (( "" 23.)
	       #\name t ("'value" 2)))
	    (foo
	      (( "" 24.)
	       #\name t ("'width" 2)))
	    (foo
	      (("" 25.)
	       ("if " 2) #\condition t (" then" 2) ""
	       1 #\statements ""
	       ("end if;" 2)))
	    (foo
	      (("" 26.)
	       ("if " 2) #\condition t (" then" 2) ""
	       1 #\statements ""
	       ("elsif " 2) #\condition (" then" 2) ""
	       1 #\statements ""
	       ("else" 2) ""
	       1 #\statements ""
	       ("end if;" 2)))
	    (if-then-else
	      (("If Then Else End If" 27.)
	       ("if " 2) #\condition t (" then" 2) "" ;;If <condition> <cursor> then
	       1  #\code ""		                ;  -- <code>
	       ("else" 2) ""		                ;else
	       1  #\code ""		                ;  -- <code>
	       ("end if;" 2)))		                ;end;
	    (case
	      (("" 28.)
	       ("case " 2) #\expression t (" is" 2) ""
	       1 ("when " 2) #\choice (" => " 2) ""
	       2 #\statements ""
	       1 ("when " 2) #\choice ("|" 2) #\choice (" => " 2) ""
	       2 #\statements ""
	       1 ("when others =>" 2) ""
	       2 #\statements ""
	       ("end case;" 2)))
	    (while-loop
	      (("while loop end loop" 29.)
	       ("while " 2) #\condition t (" loop" 2) ""
	       1 #\statements ""
	       ("end loop;" 2)))
	    (for-loop
	      (("" 30.)
	       ("for " 2) #\variable t (" in " 2) #\range (" loop" 2) ""
	       1 #\statements ""
	       ("end loop;" 2)))
	    (for-loop
	      (("" 31.)
	       ("for " 2) #\variable t (" in reverse " 2) #\range (" loop" 2) ""
	       1 #\statements ""
	       ("end loop;" 2)))
	    (loop
	      (("" 32.)
	       ("loop" 2) ""
	       1 #\statements t ""
	       1 ("exit when " 2) #\condition (";" 2) ""
	       1 #\statements ""
	       ("end loop;" 2)))
	    (begin-end
	      (("Begin end" 33.)
	       ("begin" 2) ""		  ;begin
	       1 #\statements t ""	  ;  <code>  --leave cursor
	       ("end;" 2)))	          ;end if
	    (declare-begin-end
	      (("Declare Begin end" 34.)
	       ("declare" 2) ""
	       1 #\declarations t ""
	       ("begin" 2) ""
	       1 #\statements ""
	       ("end;" 2)))
	    (labeled-declare-begin-end
	      (("Labelled Declare Begin end" 35.)
	       (block-name "Block Name: ") t (":" 2) ""
	       ("declare" 2) ""
	       1 #\declarations ""
	       ("begin" 2) ""
	       1 #\statements ""
	       ("end " 2) (block-name "garbage.") (";" 2)))
	    (begin-exception-end
	      (("Begin Exception End" 36.)
	       ("begin" 2) ""
	       1 #\statements t ""
	       ("exception" 2) ""
	       1 ("when " 2) #\exception (" =>" 2) ""
	       2 #\statements ""
	       ("end;" 2)))
	    (declare-begin-exception-end
	      (("Declare Begin Exception End" 37.)
	       ("declare" 2) ""
	       1 #\declarations t ""
	       ("begin" 2) ""
	       1 #\statements ""
	       ("exception" 2) ""
	       1 ("when " 2) #\exception (" =>" 2) ""
	       2 #\statements ""
	       ("end;" 2)))
	    (labeled-declare-begin-exception-end
	      (("Labelled Declare Begin Exception End" 38.)
	       (block-name "Block Name: ") t ":" ""
	       ("declare" 2) ""
	       1 #\declarations t ""
	       ("begin" 2) ""
	       1 #\statements ""
	       ("exception" 2) ""
	       1 ("when " 2) #\exception (" =>" 2) ""
	       2 #\statements ""
	       ("end " 2) (block-name "garbage.") (";" 2)))
	    (foo
	      (("" 39.)
	       ("function " 2) #\name t ""
	       1 ("( " 2) #\parameter (" : " 2) #\type-name (";" 2) ""
	       2      #\parameter (" : " 2) #\type-name (" ) return " 2) #\type-name (";" 2) ""))
	    (foo
	      (("" 40.)
	       ("function " 2) #\name t ""
	       1 ("( " 2) #\parameter (" : " 2) #\type-name (";" 2) ""
	       2      #\parameter (" : " 2) #\type-name (" ) return " 2) #\type-name ""
	       1 ("is separate;" 2)))
	    (function
	      (("Function begin end" 41.)
	       ("function " 2) (func-name "Name of function: ")
	       1 ("( " 2) #\parameter t (" : " 2) #\type-name (";" 2) ""
	       2      #\parameter (" : " 2) #\type-name (" ) return " 2) #\type-name (" is" 2) ""
	       1 #\declarations t ""
	       ("begin" 2) ""
	       1 #\code ""
	       ("end " 2) (func-name "garbage.") (";" 2)))
	    (foo
	      (("" 42.)
	       ("generic" 2) ""
	       1 #\parameter t (" : " 2) #\type-name #\constraint (";" 2) ""
	       ("function " 2) #\name ""
	       1 ("( " 2) #\parameter (" : " 2) #\type-name (";" 2) ""
	       2      #\parameter (" : " 2) #\type-name (" ) return " 2) #\type-name (";" 2) ""))
	    (function
	      (("Function begin end" 43.)
	       ("generic" 2) ""
	       1 #\parameter t (" : " 2) #\type-name #\constraint (";" 2) ""
	       ("function " 2) (func-name "Name of function: ")
	       1 ("( " 2) #\parameter (" : " 2) #\type-name (";" 2) ""
	       2      #\parameter (" : " 2) #\type-name (" ) return " 2) #\type-name (" is" 2) ""
	       1 #\declarations t ""
	       ("begin" 2) ""
	       1 #\code ""
	       ("end " 2) (func-name "") (";" 2)))
	    (procedure-specification
	      (("" 44.)
	       ("procedure " 2) #\name t
	       1 ("( " 2) #\parameter (" : " 2) #\mode " " #\type-name (";" 2) ""
	       2      #\parameter (" : " 2) #\mode " " #\type-name (" );" 2) ""))
	    (procedure-body-stub
	      (("" 45.)
	       ("procedure " 2) #\name t
	       1 ("( "2)  #\parameter (" : " 2) #\mode " " #\type-name (";" 2) ""
	       2      #\parameter (" : " 2) #\mode " " #\type-name (" )" 2) ""
	       1 ("is separate;" 2)))
	    (procedure-spec-and-body
	      (("" 46.)
	       ("procedure " 2) (procedure-name "Name of procedure: ")
	       1 ("( " 2) #\parameter t (" : " 2) #\mode " " #\type-name (";" 2) ""
	       2      #\parameter (" : " 2) #\mode " " #\type-name (" ) is" 2) ""
	       ("begin" 2) ""
	       1 #\statements ""
	       ("end " 2) (procedure-name "") (";" 2)))
	    (generic-procedure-specification
	      (("" 47.)
	       ("generic" 2) ""
	       1 #\parameter t (" : " 2) #\type-name " " #\constraint (";" 2) ""
	       ("procedure " 2) #\name
	       1 ("( " 2) #\parameter (" : " 2) #\mode " " #\type-name (";" 2) ""
	       2      #\parameter (" : " 2) #\mode " " #\type-name (" );" 2) ""))
	    (generic-procedure-spec-and-body
	      (("" 48.)
	       ("generic" 2) ""
	       1 #\parameter t (" : " 2) #\type-name " " #\constraint (";" 2) ""
	       ("procedure " 2) #\name t
	       1 ("( " 2) #\parameter (" : " 2) #\mode " " #\type-name (";" 2) ""
	       2      #\parameter (" : " 2) #\mode " " #\type-name (" ) is" 2) ""
	       ("begin" 2) ""
	       1 #\statements ""
	       ("end;" 2)))
	    
	    (package-specification
	      (("" 49.)
	       ("package " 2) (package-name "Name of package: ")
	       (" is" 2) ""		          ;package FOO is
	       1 #\declarations t ""	          ;  <declarations> -- leave cursor
	       ("private" 2)
	       1 #\declarations ""
	       ("end " 2) (package-name "") (";" 2))) ;end FOO;
	    
	    (package-body
	      (("" 50.)
	       ("package body " 2) (package-name "Name of package: ")
	       (" is" 2) ""			   ;package body FOO is
	       1 #\declarations t ""		   ;  <declarations>  -- leave cursor
	       ("begin" 2) ""			   ;begin
	       1 #\code ""			   ;  <code>
	       ("exception" 2) ""
	       1 ("when " 2) #\condition (" =>" 2) ""
	       2 #\code ""
	       ("end " 2) (package-name "") (";" 2)))  ;end FOO
							  
	    (package-spec-and-body
	      (("" 51.)
	       ("package " 2) (package-name "Name of package: ")
	       (" is" 2) ""		              ;package FOO is
	       1 #\declarations t ""	              ;  <declarations> -- leave cursor
	       ("private" 2)
	       1 #\declarations ""
	       ("end " 2) (package-name "") (";" 2)   ;end FOO;
	       ""				      ;blank line
	       ("package body " 2) (package-name "")
	       (" is" 2) ""			      ;package body FOO is
	       1 #\declarations t ""		      ;  <declarations>  -- leave cursor
	       ("begin" 2) ""			      ;begin
	       1 #\code ""			      ;  <code>
	       ("exception" 2) ""
	       1 ("when " 2) #\condition (" =>" 2) ""
	       2 #\code ""
	       ("end " 2) (package-name "") (";" 2))) ;end FOO;
	    (package-body-stub
	      (("" 52.)
	       ("package " 2) #\name t (" is separate;" 2)))
	    (generic-package-spec
	      (("" 53.)
	       ("package " 2) (package-name "Name of package: ")
	       (" is" 2) ""		              ;package FOO is
	       1 #\declarations t ""	              ;  <declarations> -- leave cursor
	       ("private" 2)
	       1 #\declarations ""
	       ("end " 2) (package-name "") (";" 2)   ;end FOO;
	       ""				      ;blank line
	       ("package body " 2) (package-name "")
	       (" is" 2) ""			      ;package body FOO is
	       1 #\declarations t ""		      ;  <declarations>  -- leave cursor
	       ("begin" 2) ""			      ;begin
	       1 #\code ""			      ;  <code>
	       ("end " 2) (package-name "") (";" 2))) ;end FOO;
	    (generic-package-spec-and-body
	      (("" 54.)
	       ("generic" 2) ""
	       1 #\parameter t (" : " 2) #\type-name (";" 2) ""
	       ("package " 2) (package-name "Name of package: ")
	       (" is" 2) ""		  ;package FOO is
	       1 #\declarations t ""	  ;  <declarations> -- leave cursor
	       ("private" 2)
	       1 #\declarations ""
	       ("end " 2) (package-name "") (";" 2) ;end FOO;
	       ""				;blank line
	       ("package body " 2) (package-name "")
	       (" is" 2) ""			;package body FOO is
	       1 #\declarations t ""		;  <declarations>  -- leave cursor
	       ("begin" 2) ""			;begin
	       1 #\code ""			;  <code>
	       ("exception" 2) ""
	       1 ("when " 2) #\condition (" =>" 2) ""
	       2 #\code ""
	       ("end " 2) (package-name "") (";" 2)))

	    (task-specification 
	      (("" 55.)
	       ("task " 2) (task-name "Name of Task: ") (" is" 2) ""
	       1 ("entry ( " 2) #\parameter t (" : " 2) #\type ("; " 2)
	       #\parameter (" : " 2) #\type (" );" 2) ""
	       1 #\declaration ""
	       ("end " 2) (task-name "") (";" 2)))
	    (task-body
	      (("" 56.)
	       ("task body " 2) (task-name "Name of Task: ") (" is" 2) ""
	       1 #\declarations t ""		;  <declarations>  -- leave cursor
	       ("begin" 2) ""			;begin
	       1 #\code ""			;  <code>
	       ("end " 2) (task-name "") (";" 2)))
	    (task-spec-and-body
	      (("" 57.)
	       ("task " 2) (task-name "Name of Task: ") (" is" 2) ""
	       1 ("entry ( " 2) #\parameter t (" : " 2) #\type ("; " 2)
	       #\parameter (" : " 2) #\type (" );" 2) ""
	       1 #\declaration ""
	       ("end " 2) (task-name "") (";" 2) ""
	       ("task body " 2) (task-name "") (" is" 2) ""
	       1 #\declarations t ""		;  <declarations>  -- leave cursor
	       ("begin" 2) ""			;begin
	       1 #\code ""			;  <code>
	       ("end " 2) (task-name "") (";" 2)))
	    (generic-task-spec
	      (("" 58.)
	       ("generic" 2) ""
	       1 #\parameter t (" : " 2) #\type (";" 2) ""
	       ("task " 2) (task-name "Name of Task: ") (" is" 2) ""
	       1 ("entry ( " 2) #\parameter t (" : " 2) #\type ("; " 2)
	       #\parameter (" : " 2) #\type (" );" 2) ""
	       1 #\declaration ""
	       ("end " 2) (task-name "") (";" 2)))
	    (generic-task-spec-and-body
	      (("" 59.)
	       ("generic" 2) ""
	       1 #\parameter t (" : " 2) #\type (";" 2) ""
	       ("task " 2) (task-name "Name of Task: ") (" is" 2) ""
	       1 ("entry ( " 2) #\parameter t (" : " 2) #\type ("; " 2)
	       #\parameter (" : " 2) #\type (" );" 2) ""
	       1 #\declaration ""
	       ("end " 2) (task-name "") (";" 2) ""
	       ("task body " 2) (task-name "") (" is" 2) ""
	       1 #\declarations t ""		;  <declarations>  -- leave cursor
	       ("begin" 2) ""			;begin
	       1 #\code ""			;  <code>
	       ("end " 2) (task-name "") (";" 2)))   
	    (task-body-stub
	      (("" 60.)
	       ("task body " 2) #\name t (" is separate;" 2)))
	    (accept-statement
	      (("" 61.)
	       ("accept " 2) (entry-name "Name of entry: ")
	       (" ( " 2) #\parameter t (" : " 2) #\type (";" 2) ""
	       2 #\parameter (" : " 2) #\type (" ) do" 2) ""
	       1 #\code ""
	       ("end " 2) (entry-name "") (";" 2)))
	    (select-statement
	      (("" 62.)
	       ("select" 2) ""
	       1 ("when " 2) #\condition t (" => " 2) #\accept-statement ""
	       ("or" 2) ""
	       1 ("when " 2) #\condition (" => " 2) #\accept-statement ""
	       ("end select;" 2)))
	    (select-statement-else
	      (("" 63.)
	       ("select" 2) ""
	       1 ("when " 2) #\condition t (" => " 2) #\accept-statement ""
	       ("or" 2) ""
	       1 ("when " 2) #\condition (" => " 2) #\accept-statement ""
	       ("else" 2) ""
	       1 #\code ""
	       ("end select;" 2)))
	    (exception
	      (("" 64.)
	       ("exception" 2) ""
	       1 ("when " 2) #\condition t (" =>" 2) ""
	       2 #\code (";" 2)))
	    (exception-with-others
	      (("" 65.)
	       ("exception" 2) ""
	       1 ("when " 2) #\condition t (" =>" 2) ""
	       2 #\code ""
	       1 ("when others =>" 2) ""
	       2 #\code (";" 2)))
	    (propagated-exception
	      (("" 66.)
	       ("exception" 2) ""
	       1 ("when " 2) #\condition t (" =>" 2) ""
	       2 ("raise " 2) #\exception (";" 2)))
	    (propagated-exception-with-others
	      (("" 67.)
	       ("exception" 2) ""
	       1 ("when " 2) #\condition t (" =>" 2) ""
	       2 #\code ""
	       1 ("when others =>" 2) ""
	       2 ("raise " 2) #\exception (";" 2)))

	    (generic-function-instantiation
	      (("" 68.)
	       ("function " 2) #\name t (" is new " 2) #\generic-function-name ""
	       2 ("( " 2) #\parameter (" : " 2) #\value (" );" 2)))
	    (generic-procedure-instantiation
	      (("" 69.)
	       ("procedure " 2) #\name t (" is new " 2) #\generic-procedure-name ""
	       2 ("( " 2) #\parameter (" : " 2) #\value (" );" 2)))
	    (generic-package-instantiation
	      (("" 70.)
	       ("package " 2) #\name t (" is new " 2) #\generic-package-name ""
	       2 ("( " 2) #\parameter (" : " 2) #\value (" );" 2)))
	    (generic-parameter-declaration
	      (("" 71.)
	       ("generic" 2) ""
	       1 #\parameter t (" : " 2) #\type (";" 2)))

;;; old templates reinserted here

	    (simple-package-specification
	      (("" 72.)
	       ("package " 2) (package-name "Name of package: ") ; package FOO is
               (" is" 2) ""                                      ;  <declarations>
	       1 #\declarations t ""                             ; end FOO;
	       ("end " 2) (package-name "") (";" 2)))
	    (simple-package-body
	      (("" 73.)
	       ("package body " 2) (package-name "Name of package: ")
	       (" is" 2) ""			   ;package body FOO is
	       1 #\declarations t ""		   ;  <declarations>  -- leave cursor
	       ("begin" 2) ""			   ;begin
	       1 #\code ""			   ;  <code>
	       ("end " 2) (package-name "") (";" 2)))  ;end FOO
	    
	    ))

;;;  This function returns the string that closely resembles what a template
;;; will look like.  It ignores lozenges; primarily, it includes only
;;; keywords.
(defun string-of-template (char)
  (string-append 
    (apply #'string-append 
	   (loop for construct in (cdadr (get-template-from-char char *ada-templates*))
		 if (and (listp construct)
			 (stringp (first construct)))
		 collect (first construct) into result
		 if (and (listp construct)
			 (not (stringp (first construct))))
		 collect "NAME?" into result
		 if (and (stringp construct)
			 (string-equal construct "")
			 (not (eq (car (last result)) #\return)))
		 collect #\return into result
		 if (and (stringp construct)
			 (not (string-equal construct "")))
		 collect construct into result
		 if (and (numberp construct) (< construct 20.))
		 collect (format nil "~v@T" construct) into result
		 if (and (numberp construct) (> construct 199.))
		 collect construct into result
		 finally (return result)))
    #\return))

;;;  Here is the list of things to put in the template command menu pane.
(defconst *editor-template-commands*
	  `(("Type Declarations" :eval (select-template-and-insert 1 2 3 4 5 6 7 8. 9. 10.)
             :font ,fonts:tr12b)
	    ("Expressions" :eval (select-template-and-insert 11. 12. 13. 14. 15. 16.
							     17. 18. 19. 20. 21. 22.
							     23. 24.)
	     :font ,fonts:tr12b)
	    ("Conditionals & Cases" :eval (select-template-and-insert 25. 26. 27. 28.)
	     :font ,fonts:tr12b)
	    ("Loop Constructs" :eval (select-template-and-insert 29. 30. 31. 32.)
	     :font ,fonts:tr12b)
	    ("Block Constructs" :eval (select-template-and-insert 33. 34. 35. 36. 37. 38.)
	     :font ,fonts:tr12b)
	    ("Function" :eval (select-template-and-insert 39. 40. 41. 42. 43.)
	     :font ,fonts:tr12b)
	    ("Procedure" :eval (select-template-and-insert 44. 45. 46. 47. 48.)
	     :font ,fonts:tr12b)
	    ("Packages" :eval (select-template-and-insert 72. 49. 73. 50. 51. 52. 53. 54.)
	     :font ,fonts:tr12b)
	    ("Tasks" :eval (select-template-and-insert 55. 56. 57. 58. 59. 60. 61. 62. 63.)
	     :font ,fonts:tr12b)
	    ("Exceptions" :eval (select-template-and-insert 64. 65. 66. 67.)
	     :font ,fonts:tr12b)
	    ("Generics" :eval (select-template-and-insert 68. 69. 70. 71. 58. 42. 47. 54.)
	     :font ,fonts:tr12b)
	    ))

;;;  gets the current list of template characters from *ada-templates*
;;;+++JRM fix for the named template list
(defun get-template-char-list (template-list)
  (loop for templ in template-list
	collect (cadar (second templ))))

;;;  Selects a template based on a character.
;;;+++JRM fix for the named template list
(defun get-template-from-char (char template-list)
  (loop for templ in template-list
	if (eq char (cadar (second templ)))
	return templ))

(defvar *template-menu*
	(tv:make-window 'tv:momentary-left-multiline-menu))

(defun select-template-and-insert
       (&rest template-chars)
  (send *template-menu* ':set-item-list
	(loop for char in template-chars
	      collect `(,(string-of-template char)
			:value ,char :font ,fonts:tr10b)))
  (let ((char (send *template-menu* ':choose)))
    (if char (insert-template-and-redisplay char))))


(defun insert-template-and-redisplay
       (template-char)
  (insert-template (get-template-from-char template-char *ada-templates*))
  (must-redisplay *window* dis-text))




;;;  ****************************************************************
;;;  Ada EXECUTE stuff
;;;  ****************************************************************


;;;  ****************  Commands  ****************


(defcom com-ada-quick-execute-buffer "Send the buffer to the interpreter"
	()
  (with-input-from-string (buffer-stream (fix-string (full-buffer-string)))
    (ada-execute-stream buffer-stream
			(Format nil "Current buffer: ~A" (current-buffer-name)))))

(defcom com-ada-quick-execute-region "Send the region to the interpreter"
	()
  (with-input-from-string (region-stream (fix-string (region-string)))
    (ada-execute-stream
      region-stream
      (format nil "Selected region from buffer: ~A" (current-buffer-name))))
  (must-redisplay *window* dis-all))

(defcom com-ada-quick-execute-file "Send a file to the interpreter"
	()
  (let ((filename (get-string-from-minibuffer "File Name for Ada Program to Run?")))
    (with-open-file (file-stream filename)
      (ada-execute-stream file-stream (format nil "File: ~A" filename)))))

;;;  Allows the user to select a buffer from a list of ada-mode buffers.
;;; There is no way to select for execution a non-ada-mode buffer.  If the
;;; user is really bent on doing this, he should go to that buffer first.
(defcom com-ada-quick-execute-any-buffer "Send any buffer to the interpreter"
	()
  (let ((buffer (tv:menu-choose (loop for buff in *zmacs-buffer-list*
				      if (eq (caar (send buff ':saved-mode-list))
					     'zwei:ada-mode)
				      collect buff)
				"Select an Ada-Mode buffer:")))
    (if buffer
	(with-input-from-string
	  (buffer-stream (fix-string (string-interval (send buffer ':first-bp)
					  (send buffer ':last-bp))))
	  (ada-execute-stream
	    buffer-stream
	    (format nil "Menu selected buffer: ~A" (send buffer ':name)))))))

;;;  ****************  Main Execute Routine  ****************

;;;  The internal function for all quick-execution.  If the interpreter
;;; is not loaded, we offer to load it.  If the user does not want to load
;;; interp (which might take several minutes), exit quickly without
;;; errors.
;;;
;;;  Source is an optional string that tells the location of the
;;; stream.
(defun ada-execute-stream (stream &optional (source nil))
  (cond
    ((status feature interp)
     (let* ((old-map (send terminal-io ':font-map))
	    (list-buf (user:get-zmacs-buffer "Ada Listing"))
	    (list-buf-stream (user:buffer-stream list-buf))
	    (err-buf (user:get-zmacs-buffer "Ada Error"))
	    (err-buf-stream (user:buffer-stream err-buf))
	    (broadcast (make-broadcast-stream err-buf-stream terminal-io)))
       (unwind-protect
	 (progn
	   (send terminal-io ':set-font-map (list fonts:cptfontb))
	   (if source (format list-buf-stream "~&Executing from ~A.~2%" source))
	   (if source (format broadcast "~&Executing from ~A.~2%" source))
	   
	   (format t "~& Listing being sent to editor buffer Ada Listing.
 Error output being sent to editor buffer Ada Error.~2%")
	   (pkg-bind 'user
	     (user:ada_int stream         list-buf-stream
			   terminal-io    broadcast
			   terminal-io    terminal-io))
	   (send terminal-io ':set-font-map (list fonts:cptfontb))

	   (if source (format list-buf-stream "~2&Finished executing from ~A.~2%" source))
	   (if source (format broadcast "~2&Finished executing from ~A.~2%" source))
						;
	   (send terminal-io ':set-font-map (list fonts:tr12b))
	   (format t "~2&Type a space to resume editing.~%"))
	 (send terminal-io ':set-font-map old-map))))
    (t (beep)
       (typein-line "~A" "Interpreter not loaded now.")
       (cond ((fquery '(:select t) "Ct_Load INTERP now? (May take 5 minutes.)")
	      (typein-line "~%... Please wait while interpreter is loaded.")
	      (user:ct_load 'user:interp)
	      (ada-execute-stream stream))
	     (t (typein-line "Interpreter loading deferred."))))))




;;;  ****************************************************************
;;; Misc Useful stuff
;;;  ****************************************************************


;;;  Deletes a begin-end block.
;;;  DEFCOM option NM means NO MARK; in other words, get rid of the 
;;; marked region after executing this command.
;;;
;;;  THIS IS A CROCK, and doesn't work.  (The algorithm is losing.)
;;;
;(defcom com-kill-begin-end-block "Deletes from the the BEGIN closest to
; and before the cursor to the first END following it." (nm)
;  (when (search-move-point-reverse "begin")
;    (com-set-pop-mark)				;
;    (when (and (search-move-point "end") (search-move-point ";"))
;      (com-kill-region)
;      dis-all)))


;;;  Select the buffer named "Ada Listing", if there is one.
(defcom com-find-ada-listing-buffer "Find Ada Listing Buffer
 Locate the buffer for ada interpreter output."
	()
  (make-buffer-current (user:get-zmacs-buffer "Ada Listing"))
  dis-all)


(defcom com-find-ada-errors-buffer "Find Ada Errors Buffer
 Locate the buffer for Ada Interpreter Error output."
	()
  (make-buffer-current (user:get-zmacs-buffer "Ada Errors"))
  dis-all)


;;;  Removes font information from 16-bit strings.
(defun fix-string (string)
  ;; actually modifies string.
  (unless (typep* string 'art-string)
    (loop for i from 0 to (1- (string-length string))
	  do (aset (ldb %%ch-char (aref string i)) string i)))
  string)

#+Symbolics
(defun current-buffer-name ()
  "Returns the name of the current buffer."
  (send (car *zmacs-buffer-history*) ':name))

#+LMI
(defun current-buffer-name ()
  "Returns the name of the current buffer."
  (send *interval* ':name))

#+Symbolics
(defun search-move-point (string)
  (let ((search-result (search (point) string)))
    (cond
      (search-result (move-bp (point) search-result) t)
      (t (beep) nil))))

#+LMI
(defun search-move-point (string)
  (let ((search-result (zwei-search (point) string)))
    (cond
      (search-result (move-bp (point) search-result) t)
      (t (beep) nil))))

#+Symbolics
(defun search-move-point-reverse (string)
  (let ((search-result (search (point) string t)))
    (cond
      (search-result (move-bp (point) search-result) t)
      (t (beep) nil))))

#+LMI
(defun search-move-point-reverse (string)
  (let ((search-result (zwei-search (point) string t)))
    (cond
      (search-result (move-bp (point) search-result) t)
      (t (beep) nil))))


;;;  Send this to THE zmacs frame; it will install the top menu for you.
;;;  Creates the command menu, and makes it an inferior of the zmacs frame.
;;; The input buffers are made to be the same.  After menu creation, updates
;;; the editor-command-menu-width.  Deletes any previous command menu
;;; inferiors of this zmacs frame.  
;;;
;;;  Space-wise, this changes the size of the frame, WITHOUT changing the size
;;; of any of the inferiors.  Then, special menus are inserted on the right.
;;;
;;;  Note the peculiar use of numbers near 200.  They are required to get the 
;;; command menu to be 200 pixels high.  Foo.
(defmethod (zmacs-frame :install-top-menu)
	   ()
  (multiple-value-bind (screen-width screen-height)
      (send tv:main-screen ':inside-size)
    #+LMI (send self :set-size (- screen-width 200.) screen-height)
    (let* ((old-width (prog1 (send self ':size)
			     (let ((*setting-up-right-menus* t))
			       (send self ':set-size screen-width screen-height))))
	   (menu-width (- screen-width old-width 5.))
	   (cmd-menu (tv:make-window
		       'tv:command-menu-pane
		       ':label '(:string "Ada Commands" :font fonts:tr12b)
		       ':item-list *editor-menu-description*
		       ':superior self
		       ':geometry `(nil nil ,menu-width ,(- 196. 17.)
					,(- menu-width 4) 200.)
		       ':left (- old-width 1)
		       ':top 1
		       ':io-buffer tv:io-buffer 
		       ':expose-p t))
	   (tem-menu (tv:make-window
		       'tv:multiline-command-menu-pane
		       ':label '(:string "Ada Templates" :font fonts:tr12b)
		       ':item-list *editor-template-commands*
		       ':superior self
		       ':geometry `(nil nil ,menu-WIDTH
                                        ,(- screen-height 206. 17. #+LMI 2.)
					,(- menu-width 4) ,(- screen-height 202.))
		       ':left (- old-width 1)
		       ':top (+ 201. #+LMI 1)
		       ':io-buffer tv:io-buffer
		       ':expose-p t)))
      ;; Now, we need to globally remember the width of these new menus,
      ;; so that if we change a zmacs-buffer-window, we know how much
      ;; smaller to make it.
      (setq *editor-command-menu-width* (send cmd-menu ':size))
      
      ;; We were getting LOTS of command menus hanging around.  This will
      ;; clean them up.
      (loop for inf in tv:inferiors
	    do (if (typep* inf 'tv:command-menu-pane)
		   (setq tv:inferiors (delq inf tv:inferiors))))
      (setq tv:inferiors (cons cmd-menu (cons tem-menu tv:inferiors)))	;add menus as inferior
      ;; Now, set the size of the editor frame iteself.
      
      )))


;;;  The only things we need to do to remove the menus are:
;;;  1.  Kill off the command menus.
;;;  2.  Resize the frame.
;;;  3.  Change the width of the editor-command-menu global variable.
(defmethod (zmacs-frame :remove-top-menu)
	   ()
  (loop for window in (send self ':inferiors)	;Loop through all inferiors
	if (typep* window 'tv:command-menu-pane)	;If it is a command pane,
	do (send window ':bury))		;delete it.
  ;; Now, find current height.  Set the new INSIDE-size to the width of
  ;; any of the inferiors, and the present inside height.  
  (multiple-value-bind (nil cur-hei)
      (send self ':inside-size)
    ;; Don't bother readjusting all the inferiors, since they
    ;; should be OK already.
    (let ((*setting-up-right-menus* t))
      (send self ':set-inside-size
	    (send (loop for inf in tv:inferiors
			if (typep* inf 'zmacs-window-pane)
			return inf) ':size)
	    cur-hei)))
  ;; Update this.
  (setq *editor-command-menu-width* 0))

(defmethod (zmacs-frame :expose-top-menu) ()
  (loop for window in (send self ':inferiors)	;Loop through all inferiors
	if (typep* window 'tv:command-menu-pane)	;If it is a command pane,
	do (send window ':expose))		;delete it.
)

;;; Flag set by several split screen zwei functions when they are called
(defvar *in-split-screen-mode* nil
  "flag to test for screen splitting*")

;;;  This command actually INSTALLS the menu at the top of the editor screen.
(defcom com-make-top-command-menu "Install command menu at top of screen.
 This command installs a command menu at the top of the screen.  It may
 contain as many items as desired.  It is displayed from the value of 
 *editor-menu-description*.  If you change this value, you will need to
 run this command again." ()
  (if (not *in-split-screen-mode*)
      (let ((cur-win (window-sheet *window*)))
	(send (send (window-sheet *window*) ':superior) ':install-top-menu)
	(send cur-win ':select)))
  dis-all)

(defcom com-expose-top-command-menu "Expose command menu at top of screen.
 This command exposes a command menu at the top of the screen.  It may
 contain as many items as desired.  It is displayed from the value of 
 *editor-menu-description*.  If you change this value, you will need to
 run this command again." ()
  (if (not *in-split-screen-mode*)
      (let ((cur-win (window-sheet *window*)))
	(send (send (window-sheet *window*) ':superior) ':expose-top-menu)
	(send cur-win ':select)))
  dis-all)

;;; Removes any top command menu. 
(defcom com-remove-top-command-menu "Removes top command menu." ()
  (if (not *in-split-screen-mode*)
      (let ((cur-win (window-sheet *window*)))
	(send (send (window-sheet *window*) ':superior) ':remove-top-menu)
	(send cur-win ':select)))
  dis-all)

;;;  A redefined function.  This computes the size of editor windows.  The
;;; quantity is designed to interface well with the size of the menu.
;;;  We subtract the width of the editor-command-menus from the right edge
;;; to make all editor buffer panes the right size, even though the frame
;;; may be bigger.
(defmethod (zwei-frame :inside-edges-without-mode-line-window) ()
  (values (tv:sheet-inside-left)
	  (tv:sheet-inside-top)
	  (- (tv:sheet-inside-right) *editor-command-menu-width*)
	  (- (tv:sheet-inside-bottom) (tv:sheet-height mode-line-window))))

;;; These next two functions stolen from [zwei:]sectio.lisp and hacked to add
;;; a flag to prevent circular removal of the command menus during split screen
;;; activities.

#+Symbolics
(DEFUN SWITCH-WINDOWS (&OPTIONAL CHANGE-INTERVAL (ONE-TO-SELECT 2)
		       &AUX TOP-WINDOW BOTTOM-WINDOW)
  (unwind-protect
    (progn
      (setq *in-split-screen-mode* t)
      (MULTIPLE-VALUE (TOP-WINDOW BOTTOM-WINDOW)
	(FUNCALL (WINDOW-FRAME *WINDOW*) ':TWO-EDITOR-WINDOWS))
      (COND (CHANGE-INTERVAL
	     (SET-WINDOW-INTERVAL BOTTOM-WINDOW *INTERVAL*)
	     (MOVE-BP (WINDOW-POINT BOTTOM-WINDOW) (POINT))
	     (MUST-REDISPLAY BOTTOM-WINDOW DIS-TEXT)))
      (COND ((AND (WINDOW-EXPOSED-P TOP-WINDOW) (WINDOW-EXPOSED-P BOTTOM-WINDOW))
	     (COM-OTHER-WINDOW))
	    (T
	     (TWO-WINDOWS TOP-WINDOW BOTTOM-WINDOW)
	     (LET ((WINDOW (IF (= ONE-TO-SELECT 1) TOP-WINDOW BOTTOM-WINDOW)))
	       (IF (EQ WINDOW *WINDOW*) (SELECT-WINDOW WINDOW)
		   (MAKE-WINDOW-CURRENT WINDOW))))))
    (setq *in-split-screen-mode* nil)))

#+LMI
(DEFUN SWITCH-WINDOWS (&OPTIONAL CHANGE-INTERVAL (ONE-TO-SELECT 2))
  (setq *in-split-screen-mode* nil)
  (let-globally ((*in-split-screen-mode* t))
    (MULTIPLE-VALUE-bind (TOP-WINDOW BOTTOM-WINDOW) (SEND (WINDOW-FRAME *WINDOW*) ':TWO-EDITOR-WINDOWS)
      (when CHANGE-INTERVAL
	(SEND BOTTOM-WINDOW ':SET-INTERVAL *INTERVAL*)
	(MOVE-BP (WINDOW-POINT BOTTOM-WINDOW) (POINT)))
      (LET ((FEW (FRAME-EXPOSED-WINDOWS)))
	(COND ((AND (MEMQ TOP-WINDOW FEW) (MEMQ BOTTOM-WINDOW FEW))
	       (COM-OTHER-WINDOW))
	      (T
	       (TWO-WINDOWS TOP-WINDOW BOTTOM-WINDOW)
	       (let ((haec top-window)		; Latin demonstrative feminine singular nominative
		     (illa bottom-window))	; pronouns (fenestra)
		 (when (= one-to-select 2) (swapf haec illa))
		 (if (eq haec *window*) (select-window haec)
		   (make-window-current haec))
		 (send illa :redisplay :point nil nil t))))))))

#+Symbolics
(DEFCOM COM-SPLIT-SCREEN "Makes several windows split among the buffers as specified." ()
  (unwind-protect
    (progn
      (setq *in-split-screen-mode* t)
      (LET* ((FRAME (WINDOW-FRAME *WINDOW*))
	     (BUFFER-LIST (SPLIT-SCREEN-AMONG-BUFFERS-VIA-MENUS FRAME
								*ZMACS-BUFFER-NAME-ALIST*))
	     WINDOW-LIST)
	(COND (BUFFER-LIST
	       (SETQ WINDOW-LIST (SPLIT-SCREEN-AMONG-BUFFERS-DO-IT FRAME BUFFER-LIST))
	       ;; Arrange for the current buffer to stay current if possible
	       (LET ((N (FIND-POSITION-IN-LIST *INTERVAL* BUFFER-LIST)))
		 (UNLESS (OR (NULL N) (= N 0))
		   (SWAPF (NTH N BUFFER-LIST) (CAR BUFFER-LIST))
		   (SWAPF (NTH N WINDOW-LIST) (CAR WINDOW-LIST))))
	       (DO ((BL BUFFER-LIST (CDR BL)))
		   ((NULL BL))
		 (AND (TYPEP* (CAR BL) 'FS:PATHNAME)
		      (MULTIPLE-VALUE-BIND (NIL BUF)
			  (FIND-FILE (CAR BL) NIL)
			(SETF (CAR BL) BUF))))
	       (MAKE-WINDOW-CURRENT (CAR WINDOW-LIST))
	       (MAKE-BUFFER-CURRENT (CAR BUFFER-LIST))
	       (DO ((BL BUFFER-LIST (CDR BL))
		    (WL WINDOW-LIST (CDR WL)))
		   ((NULL BL))
		 (SET-WINDOW-BUFFER (CAR WL) (CAR BL)))))))
    (setq *in-split-screen-mode* nil))
  DIS-TEXT)

#+LMI
(DEFCOM COM-SPLIT-SCREEN "Make several windows split among the buffers as specified." ()
  (setq *in-split-screen-mode* nil)
  (let-globally ((*in-split-screen-mode* t))
    (LET* ((FRAME (WINDOW-FRAME *WINDOW*))
	   (BUFFER-LIST (SPLIT-SCREEN-AMONG-BUFFERS-VIA-MENUS FRAME
							      *ZMACS-BUFFER-NAME-ALIST*))
	   WINDOW-LIST)
      (COND (BUFFER-LIST
	     (TV:PRESERVE-SUBSTITUTE-STATUS FRAME
	       (SETQ WINDOW-LIST (SPLIT-SCREEN-AMONG-BUFFERS-DO-IT FRAME BUFFER-LIST))
	       (DO ((BL BUFFER-LIST (CDR BL)))
		   ((NULL BL))
		 (AND (TYPEP (CAR BL) 'FS:PATHNAME)
		      (SETF (CAR BL) (FIND-FILE (CAR BL) NIL))))
	       (MAKE-WINDOW-CURRENT (CAR WINDOW-LIST)))
	     (MAPC 'FUNCALL WINDOW-LIST (CIRCULAR-LIST ':SET-INTERVAL) BUFFER-LIST))))
    DIS-TEXT))

;;;  This function redefined from zmacs sources.  It is used by the top level
;;; loop to process characters.  We had to modify it to accept (:menu ....)
;;; blips.
#+Symbolics
(defselect (process-special-command unknown-special-command)
  (redisplay ()
    ;the window is presumably on our list of windows and will get redisplayed
    ;in the normal course of events when buffered input had been processed.
    nil)
  (must-redisplay (&rest args)
    (apply #'must-redisplay args)
    nil)
  (must-redisplay-interval (interval &rest args)
    (lexpr-funcall #'must-redisplay-other-windows interval nil args)
    nil)
  (select-window (window)
    (prog1 (neq window *window*)
	   (make-window-current window)))
  (configuration-changed ()
   (and (not (window-exposed-p *window*))
	(dolist (w *window-list*)
	  (and (window-exposed-p w)
	       (make-window-current w nil))))
   nil)
  (scroll (window nlines type)
    (if (eq type ':relative)
	(recenter-window-relative window nlines)
	(recenter-window window ':start
			 (forward-line (interval-first-bp (window-interval window))
				       nlines t)))
    t)
  ;; Our addition to handle menu blips.  Note that this assumes the third item
  ;; in the menu item is the thing to eval.  Since WE defined the menu, this is ok.
  (:menu (&rest ch)
   (eval (cadr (memq ':eval (first ch))))
   t)
  
  (:mouse (window ch *mouse-x* *mouse-y*)
    (decf *mouse-x* (tv:sheet-inside-left (window-sheet window)))
    (decf *mouse-y* (tv:sheet-inside-top (window-sheet window)))
    (and (memq ':record (funcall standard-input ':which-operations))
	 (funcall standard-input ':record ch))
    (if (and (neq window *window*) ( ch #\mouse-3-1))	;given in another window,
	(let ((*comtab* (if (eq *window* *mini-buffer-window*) *standard-comtab* *comtab*))
	      (*last-command-type* nil)	;dont confuse mouse mark thing, and
	      *current-command-type*
	      (*window* window)
	      (*interval* (window-interval window)))	;temporarily act there (mini-buffer)
	  (process-command-char ch))
	(process-command-char ch))
    t)
  ((:typeout-execute :execute) (function &rest args)
   (not (apply function args))))

#+LMI
(DEFSELECT (PROCESS-SPECIAL-COMMAND UNKNOWN-SPECIAL-COMMAND)
  (REDISPLAY ()
    ;The window is presumably on our list of windows and will get redisplayed
    ;in the normal course of events when buffered input had been processed.
    NIL)
  (SELECT-WINDOW (WINDOW)
    (PROG1 (NEQ WINDOW *WINDOW*)
	   (MAKE-WINDOW-CURRENT WINDOW)))
  (CONFIGURATION-CHANGED ()
    (LET ((FEW (FRAME-EXPOSED-WINDOWS)))
      (UNLESS (MEMQ *WINDOW* FEW)
	(MAKE-WINDOW-CURRENT (CAR FEW))))
    NIL)
  (SCROLL (WINDOW NLINES TYPE)
    (IF (EQ TYPE ':RELATIVE)
	(RECENTER-WINDOW-RELATIVE WINDOW NLINES)
	(RECENTER-WINDOW WINDOW ':START
			 (FORWARD-LINE (INTERVAL-FIRST-BP (WINDOW-INTERVAL WINDOW))
				       NLINES T)))
    (UNLESS (EQ WINDOW *WINDOW*)
      ;; Scrolling nonselected window => flush typeout on it
      ;; because the main loop won't do it except for the selected window.
      (PREPARE-WINDOW-FOR-REDISPLAY WINDOW))
    T)

  ;; Our addition to handle menu blips.  Note that this assumes the third item
  ;; in the menu item is the thing to eval.  Since WE defined the menu, this is ok.
  (:menu (&rest ch)
   (eval (cadr (memq ':eval (first ch))))
   t)

  (:MOUSE-BUTTON (CH WINDOW *MOUSE-X* *MOUSE-Y*)
    (IF (NOT (TYPEP WINDOW 'ZWEI))
	(WHEN (CHAR= CH #/MOUSE-R)
	  (TV:MOUSE-CALL-SYSTEM-MENU))
      (DECF *MOUSE-X* (TV:SHEET-INSIDE-LEFT (WINDOW-SHEET WINDOW)))
      (DECF *MOUSE-Y* (TV:SHEET-INSIDE-TOP (WINDOW-SHEET WINDOW)))
      (AND (MEMQ ':RECORD (SEND *STANDARD-INPUT* ':WHICH-OPERATIONS))
	   (SEND *STANDARD-INPUT* ':RECORD CH))
      (IF *MOUSE-HOOK*
	  (FUNCALL *MOUSE-HOOK* WINDOW CH *MOUSE-X* *MOUSE-Y*)
	(IF (NEQ WINDOW *WINDOW*)		;Given in another window,
	    (LET ((*COMTAB* (IF (EQ *WINDOW* *MINI-BUFFER-WINDOW*) *STANDARD-COMTAB* *COMTAB*))
		  (*LAST-COMMAND-TYPE* NIL)	;dont confuse mouse mark thing, and
		  *CURRENT-COMMAND-TYPE*
		  (*WINDOW* WINDOW)
		  (*INTERVAL* (WINDOW-INTERVAL WINDOW)))	;temporarily act there (mini-buffer)
	      (PROCESS-COMMAND-CHAR CH))
	  (PROCESS-COMMAND-CHAR CH)))
      T))
  ((:TYPEOUT-EXECUTE :EXECUTE) (FUNCTION &REST ARGS)
   (LET ((*MINI-BUFFER-DONT-RECORD* T))
     ;; We would not be able to repeat the command anyway.
     (NOT (APPLY FUNCTION ARGS)))))

;;;  This function had to be redefined to know about the command menu, and to
;;; not do anything nasty to it.
#+Symbolics
(defmethod (zmacs-frame :update-labels) ()
  (if ( (length tv:exposed-inferiors) 3)
      (dolist (w tv:exposed-inferiors)
	(or (eq w mode-line-window)
	    (typep* w 'tv:command-menu-pane)
	    (funcall w ':delayed-set-label
		     (funcall (window-interval (funcall w ':zwei-window)) ':name))))
      (dolist (w tv:exposed-inferiors)
	(or (eq w mode-line-window)
	    (typep* w 'tv:command-menu-pane)
	    (funcall w ':set-label nil)))))

#+LMI
(DEFMETHOD (ZMACS-FRAME :UPDATE-LABELS) ()
  (IF ( (LENGTH TV:EXPOSED-INFERIORS) 3)
      (DOLIST (W TV:EXPOSED-INFERIORS)
	(OR (EQ W MODE-LINE-WINDOW)
	    (typep* w 'tv:command-menu-pane)
	    (SEND W ':DELAYED-SET-LABEL (BUFFER-NAME (WINDOW-INTERVAL W)))))
    (DOLIST (W TV:EXPOSED-INFERIORS)
      (OR (EQ W MODE-LINE-WINDOW)
	  (typep* w 'tv:command-menu-pane)
	  (SEND W ':SET-LABEL NIL)))))

;;;  This had to be redefined to know about the command-menu, and not
;;; do anything nasty to it.
#+Symbolics
(defmethod (zmacs-frame :n-editor-windows) (n &aux list)
  (do ((l tv:inferiors (cdr l))
       (i 0 (1+ i)))
      ((or (null l) ( i n)))
    (or (eq (car l) mode-line-window)
	(typep* (car l) 'tv:command-menu-pane)
	(push (funcall (car l) ':zwei-window) list)))
  (dotimes (i (- n (length list)))
    (push (funcall-self ':create-window 'zmacs-window-pane) list))
  list)

#+LMI
(DEFMETHOD (ZMACS-FRAME :N-EDITOR-WINDOWS) (N &AUX LIST)
  (DO ((L TV:INFERIORS (CDR L))
       (I 0 (1+ I)))
      ((OR (NULL L) ( I N)))
    (OR (EQ (CAR L) MODE-LINE-WINDOW)
	(typep* (car l) 'tv:command-menu-pane)
	(PUSH (SEND (CAR L) ':ZWEI-WINDOW) LIST)))
  (DOTIMES (I (- N (LENGTH LIST)))
    (PUSH (SEND SELF ':CREATE-WINDOW 'ZMACS-WINDOW-PANE) LIST))
  LIST)

;;;  this function had to be redefined.
#+Symbolics
(defmethod (zmacs-frame :two-editor-windows) (&optional pref &aux ws)
  (setq ws (sort (copylist tv:inferiors)	;make sure get two contiguous
		 #'(lambda (w-1 w-2)
		     (< (if (tv:sheet-exposed-p w-1) (tv:sheet-y-offset w-1) 177777)
			(if (tv:sheet-exposed-p w-2) (tv:sheet-y-offset w-2) 177777)))))
  (loop for window in ws			;splice out the command
	if (typep* window 'tv:command-menu-pane)	;menu, if there is one.
	do (setq ws (delq window ws)))
  (and pref
       (let ((l (memq pref ws)))
	 (if (loop for w in (cdr l) thereis (and (tv:sheet-exposed-p w)
						 (neq w mode-line-window)))
	     (setq ws l)
	     (setq ws (loop for l on ws
			    when (eq (cadr l) pref) return l
			    finally (return ws))))))
  (do ((l ws (cdr l))
       (window)
       (top-window) (bottom-window))
      ((null l)
       (values (funcall top-window ':zwei-window)
	       (funcall-self ':create-window 'zmacs-window-pane)))
    (cond ((eq (setq window (car l)) mode-line-window))
	  ((null top-window)
	   (setq top-window window))
	  (t
	   (setq bottom-window window)
	   (and (tv:sheet-exposed-p bottom-window)
		(< (tv:sheet-y-offset bottom-window) (tv:sheet-y-offset top-window))
		(psetq top-window bottom-window bottom-window top-window))
	   (return (funcall top-window ':zwei-window)
		   (funcall bottom-window ':zwei-window))))))

#+LMI
(DEFMETHOD (ZMACS-FRAME :TWO-EDITOR-WINDOWS) ()
  (DO ((L TV:INFERIORS (CDR L))
       (WINDOW)
       (TOP-WINDOW) (BOTTOM-WINDOW))
      ((NULL L)
       (VALUES TOP-WINDOW
	       (SEND SELF ':CREATE-WINDOW 'ZMACS-WINDOW-PANE
		     ':INTERVAL (OR (PREVIOUS-BUFFER)
				    'ZMACS-BUFFER))))
    (COND ((typep* (car l) 'tv:command-menu-pane))
	  ((EQ (SETQ WINDOW (CAR L)) MODE-LINE-WINDOW))
	  ((NULL TOP-WINDOW)
	   (SETQ TOP-WINDOW WINDOW))
	  (T
	   (SETQ BOTTOM-WINDOW WINDOW)
	   (AND (TV:SHEET-EXPOSED-P BOTTOM-WINDOW)
		(< (TV:SHEET-Y-OFFSET BOTTOM-WINDOW) (TV:SHEET-Y-OFFSET TOP-WINDOW))
		(PSETQ TOP-WINDOW BOTTOM-WINDOW BOTTOM-WINDOW TOP-WINDOW))
	   (RETURN TOP-WINDOW BOTTOM-WINDOW)))))

;;; Now, install this command permanently as a M-X command.
(set-comtab *standard-comtab* () (make-command-alist '(com-make-top-command-menu)))
(set-comtab *standard-comtab* () (make-command-alist '(com-remove-top-command-menu)))
(set-comtab *standard-comtab* () (make-command-alist '(com-expose-top-command-menu)))

;;;  I don't know what is going on here, but this is somehow telling some windows
;;; to set their edges out of bounds.  I inserted a MAX in here to try to fix it.
;;;  GROSS GROSS KLUDGE!!
;;;  Code from sys:zwei;screen lisp >
;;;
#+Symbolics
(DEFMETHOD (ZWEI-FRAME :AFTER :CHANGE-OF-SIZE-OR-MARGINS)
	   (&REST IGNORE &AUX OLD-INSIDE-WIDTH OLD-INSIDE-HEIGHT
		  NEW-INSIDE-LEFT NEW-INSIDE-TOP
		  NEW-INSIDE-RIGHT NEW-INSIDE-BOTTOM
		  NEW-INSIDE-WIDTH NEW-INSIDE-HEIGHT)
  (DECLARE (SPECIAL OLD-EXPOSED-INFERIORS
		    OLD-INSIDE-LEFT OLD-INSIDE-TOP
		    OLD-INSIDE-RIGHT OLD-INSIDE-BOTTOM))
  (SETQ OLD-INSIDE-WIDTH (- OLD-INSIDE-RIGHT OLD-INSIDE-LEFT)
	OLD-INSIDE-HEIGHT (- OLD-INSIDE-BOTTOM OLD-INSIDE-TOP))
  (MULTIPLE-VALUE (NEW-INSIDE-LEFT NEW-INSIDE-TOP NEW-INSIDE-RIGHT NEW-INSIDE-BOTTOM)
    (FUNCALL-SELF ':INSIDE-EDGES-WITHOUT-MODE-LINE-WINDOW))
  (SETQ NEW-INSIDE-WIDTH (- NEW-INSIDE-RIGHT NEW-INSIDE-LEFT)
	NEW-INSIDE-HEIGHT (- NEW-INSIDE-BOTTOM NEW-INSIDE-TOP))
  ;; Prevent this code from doing anything drastic when we are setting
  ;; up the menus on the right.
  (unless *setting-up-right-menus*
    (TV:WITH-SHEET-DEEXPOSED (SELF)
      (DO ((WL (COPYLIST TV:INFERIORS) (CDR WL))
	   (WINDOW)
	   (OLD-LEFT) (OLD-TOP) (OLD-RIGHT) (OLD-BOTTOM)
	   (NEW-LEFT) (NEW-TOP) (NEW-RIGHT) (NEW-BOTTOM))
	  ((NULL WL))
	(SETQ WINDOW (CAR WL))
	(MULTIPLE-VALUE (OLD-LEFT OLD-TOP OLD-RIGHT OLD-BOTTOM)
	  (FUNCALL WINDOW ':EDGES))
	(IF (EQ WINDOW MODE-LINE-WINDOW)
	    (SETQ NEW-LEFT NEW-INSIDE-LEFT
		  NEW-TOP NEW-INSIDE-BOTTOM
		  NEW-RIGHT NEW-INSIDE-RIGHT
		  NEW-BOTTOM (+ NEW-INSIDE-BOTTOM (- OLD-BOTTOM OLD-TOP)))
	    (SETQ NEW-LEFT (IF (= OLD-LEFT OLD-INSIDE-LEFT) NEW-INSIDE-LEFT
			       (// (* OLD-LEFT NEW-INSIDE-WIDTH) OLD-INSIDE-WIDTH))
		  NEW-TOP (max 1 (IF (= OLD-TOP OLD-INSIDE-TOP) NEW-INSIDE-TOP
				     (// (* OLD-TOP NEW-INSIDE-HEIGHT) OLD-INSIDE-HEIGHT)))
		  NEW-RIGHT (IF (= OLD-RIGHT OLD-INSIDE-RIGHT) NEW-INSIDE-RIGHT
				(// (* OLD-RIGHT NEW-INSIDE-WIDTH) OLD-INSIDE-WIDTH))
		  NEW-BOTTOM (IF (= OLD-BOTTOM OLD-INSIDE-BOTTOM) NEW-INSIDE-BOTTOM
				 (// (* OLD-BOTTOM NEW-INSIDE-HEIGHT) OLD-INSIDE-HEIGHT))))
	(FUNCALL WINDOW ':SET-EDGES NEW-LEFT NEW-TOP NEW-RIGHT NEW-BOTTOM)
	(AND (MEMQ WINDOW OLD-EXPOSED-INFERIORS)
	     (FUNCALL WINDOW ':EXPOSE))))))

#+LMI
(DEFMETHOD (ZWEI-FRAME :AFTER :CHANGE-OF-SIZE-OR-MARGINS)
	   (&REST IGNORE &AUX OLD-INSIDE-WIDTH OLD-INSIDE-HEIGHT
			      NEW-INSIDE-LEFT NEW-INSIDE-TOP
			      NEW-INSIDE-RIGHT NEW-INSIDE-BOTTOM
			      NEW-INSIDE-WIDTH NEW-INSIDE-HEIGHT)
  (DECLARE (SPECIAL OLD-EXPOSED-INFERIORS
		    OLD-INSIDE-LEFT OLD-INSIDE-TOP
		    OLD-INSIDE-RIGHT OLD-INSIDE-BOTTOM))
  (SETQ OLD-INSIDE-WIDTH (- OLD-INSIDE-RIGHT OLD-INSIDE-LEFT)
	OLD-INSIDE-HEIGHT (- OLD-INSIDE-BOTTOM OLD-INSIDE-TOP))
  (MULTIPLE-VALUE (NEW-INSIDE-LEFT NEW-INSIDE-TOP NEW-INSIDE-RIGHT NEW-INSIDE-BOTTOM)
    (SEND SELF ':INSIDE-EDGES-WITHOUT-MODE-LINE-WINDOW))
  (SETQ NEW-INSIDE-WIDTH (- NEW-INSIDE-RIGHT NEW-INSIDE-LEFT)
	NEW-INSIDE-HEIGHT (- NEW-INSIDE-BOTTOM NEW-INSIDE-TOP))
  ;; Prevent this code from doing anything drastic when we are setting
  ;; up the menus on the right.
  (unless *setting-up-right-menus*
    (TV:WITH-SHEET-DEEXPOSED (SELF)
      (DO ((WL (COPY-LIST TV:INFERIORS) (CDR WL))
           (WINDOW)
           (OLD-LEFT) (OLD-TOP) (OLD-RIGHT) (OLD-BOTTOM)
           (NEW-LEFT) (NEW-TOP) (NEW-RIGHT) (NEW-BOTTOM))
          ((NULL WL))
        (SETQ WINDOW (CAR WL))
        (MULTIPLE-VALUE (OLD-LEFT OLD-TOP OLD-RIGHT OLD-BOTTOM)
          (SEND WINDOW ':EDGES))
        (IF (EQ WINDOW MODE-LINE-WINDOW)
            (SETQ NEW-LEFT NEW-INSIDE-LEFT
                  NEW-TOP NEW-INSIDE-BOTTOM
                  NEW-RIGHT NEW-INSIDE-RIGHT
                  NEW-BOTTOM (+ NEW-INSIDE-BOTTOM (- OLD-BOTTOM OLD-TOP)))
          (SETQ NEW-LEFT (IF (= OLD-LEFT OLD-INSIDE-LEFT) NEW-INSIDE-LEFT
                           (TRUNCATE (* OLD-LEFT NEW-INSIDE-WIDTH) OLD-INSIDE-WIDTH))
                NEW-TOP (IF (= OLD-TOP OLD-INSIDE-TOP) NEW-INSIDE-TOP
                          (TRUNCATE (* OLD-TOP NEW-INSIDE-HEIGHT) OLD-INSIDE-HEIGHT))
                NEW-RIGHT (IF (= OLD-RIGHT OLD-INSIDE-RIGHT) NEW-INSIDE-RIGHT
                            (TRUNCATE (* OLD-RIGHT NEW-INSIDE-WIDTH) OLD-INSIDE-WIDTH))
                NEW-BOTTOM (IF (= OLD-BOTTOM OLD-INSIDE-BOTTOM) NEW-INSIDE-BOTTOM
                             (TRUNCATE (* OLD-BOTTOM NEW-INSIDE-HEIGHT)
                                       OLD-INSIDE-HEIGHT))))
        (SEND WINDOW ':SET-EDGES NEW-LEFT NEW-TOP NEW-RIGHT NEW-BOTTOM)
        (AND (MEMQ WINDOW OLD-EXPOSED-INFERIORS)
             (SEND WINDOW ':EXPOSE))))))

;;; Our menus are never ready for redisplay since they don't handle the
;;; :READY-FOR-DISPLAY-P message.
#+LMI
(DEFUN WINDOW-READY-P (WINDOW &OPTIONAL (CURRENT-WINDOW-SPECIAL T))
  "T if WINDOW is ready for redisplay now.
The value does not depend on whether WINDOW needs redisplay.
Unless CURRENT-WINDOW-SPECIAL is NIL, the current window is always considered ready."
  (and (send window :operation-handled-p :ready-for-redisplay-p)
       (SEND WINDOW ':READY-FOR-REDISPLAY-P CURRENT-WINDOW-SPECIAL)))