(require 'cus-edit)
(defvar ada-prj-current-values nil
"Hold the current value of the fields, This is a property list.")
(make-variable-buffer-local 'ada-prj-current-values)
(defvar ada-prj-default-values nil
"Hold the default value for the fields, This is a property list.")
(make-variable-buffer-local 'ada-prj-default-values)
(defvar ada-prj-ada-buffer nil
"Indicates what Ada source file was being edited.")
(defun ada-prj-new ()
"Open a new project file"
(interactive)
(let* ((prj
(if (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer))
ada-prj-prj-file
"default.adp"))
(filename (read-file-name "Project file: "
(if prj "" nil)
nil
nil
prj)))
(if (not (string= (file-name-extension filename t) ".adp"))
(error "File name extension for project files must be .adp"))
(ada-customize nil filename)))
(defun ada-prj-edit ()
"Editing the project file associated with the current Ada buffer.
If there is none, opens a new project file"
(interactive)
(let ((file (ada-prj-find-prj-file)))
(if file
(progn
(ada-reread-prj-file file)
(ada-customize))
(ada-prj-new))))
(defun ada-prj-add-ada-menu ()
"Add a new submenu to the Ada menu.
The items are added to the menu NAME in map MAP. NAME should be the same
name as was passed to `ada-create-menu'."
(if ada-xemacs
(progn
(funcall (symbol-function 'add-menu-button)
'("Ada" "Project")
["Edit" ada-prj-edit t] "Associate")
(funcall (symbol-function 'add-menu-button)
'("Ada" "Project")
["New..." ada-prj-new t] "Associate"))
(define-key (lookup-key ada-mode-map [menu-bar Ada Project])
[Edit] '("Edit current" . ada-prj-edit))
(define-key (lookup-key ada-mode-map [menu-bar Ada Project])
[New] '("New" . ada-prj-new))))
(defun ada-prj-add-keymap ()
"Add new keybindings for ada-prj."
(define-key ada-mode-map "\C-cu" 'ada-prj-edit))
(defun ada-prj-initialize-values (symbol ada-buffer &optional filename)
"Set SYMBOL to the property list of the project file FILENAME.
If FILENAME is null, read the file associated with ADA-BUFFER. If no
project file is found, returns the default values."
(let ((prj filename))
(if filename
(if (file-exists-p filename)
(ada-reread-prj-file))
(save-excursion
(set-buffer ada-buffer)
(set 'prj ada-prj-prj-file)))
(if (and prj
(not (string= prj ""))
(assoc prj ada-xref-project-files))
(set symbol (copy-sequence (cdr (assoc prj ada-xref-project-files))))
(ada-xref-set-default-prj-values symbol ada-buffer)
(if (and prj (not (string= prj "")))
(set symbol (plist-put (eval symbol) 'filename prj)))
)))
(defun ada-prj-save-specific-option (field)
"Returns the string to print in the project file to save FIELD.
If the current value of FIELD is the default value, returns an empty string."
(if (string= (plist-get ada-prj-current-values field)
(plist-get ada-prj-default-values field))
""
(concat (symbol-name field)
"=" (plist-get ada-prj-current-values field) "\n")))
(defun ada-prj-save ()
"Save the edited project file."
(interactive)
(let ((file-name (plist-get ada-prj-current-values 'filename))
output)
(set 'output
(concat
(ada-prj-save-specific-option 'comp_opt)
(ada-prj-save-specific-option 'bind_opt)
(ada-prj-save-specific-option 'link_opt)
(ada-prj-save-specific-option 'gnatmake_opt)
(ada-prj-save-specific-option 'cross_prefix)
(ada-prj-save-specific-option 'remote_machine)
(ada-prj-save-specific-option 'comp_cmd)
(ada-prj-save-specific-option 'check_cmd)
(ada-prj-save-specific-option 'make_cmd)
(ada-prj-save-specific-option 'run_cmd)
(ada-prj-save-specific-option 'debug_cmd)
(concat "main=" (plist-get ada-prj-current-values 'main) "\n")
(concat "main_unit=" (plist-get ada-prj-current-values 'main_unit) "\n")
(concat "build_dir=" (plist-get ada-prj-current-values 'build_dir) "\n")
(ada-prj-set-list "casing"
(plist-get ada-prj-current-values 'casing)) "\n"
(ada-prj-set-list "src_dir"
(plist-get ada-prj-current-values 'src_dir)) "\n"
(ada-prj-set-list "obj_dir"
(plist-get ada-prj-current-values 'obj_dir)) "\n"
))
(find-file file-name)
(erase-buffer)
(insert output)
(save-buffer)
(kill-buffer nil)
(kill-buffer "*Customize Ada Mode*")
(set (make-local-variable 'ada-prj-prj-file) file-name)
(ada-reread-prj-file file-name)
)
)
(defun ada-prj-load-from-file (symbol)
"Load SYMBOL value from file. One item per line should be found in the file."
(save-excursion
(let ((file (read-file-name "File name: " nil nil t))
(buffer (current-buffer))
line
list)
(find-file file)
(widen)
(goto-char (point-min))
(while (not (eobp))
(set 'line (buffer-substring-no-properties
(point) (save-excursion (end-of-line) (point))))
(add-to-list 'list line)
(forward-line 1)
)
(kill-buffer nil)
(set-buffer buffer)
(set 'ada-prj-current-values
(plist-put ada-prj-current-values
symbol
(append (plist-get ada-prj-current-values symbol)
(reverse list))))
)
(ada-prj-display-page 2)
))
(defun ada-prj-subdirs-of (dir)
"Returns a list of all the subdirectories of dir, recursively."
(let ((subdirs (directory-files dir t "^[^.].*"))
(dirlist (list dir)))
(while subdirs
(if (file-directory-p (car subdirs))
(let ((sub (ada-prj-subdirs-of (car subdirs))))
(if sub
(set 'dirlist (append sub dirlist)))))
(set 'subdirs (cdr subdirs)))
dirlist))
(defun ada-prj-load-directory (field &optional file-name)
"Append the content of FILE-NAME to FIELD in the current project file.
If FILE-NAME is nil, ask the user for the name."
(unless file-name
(set 'file-name (read-file-name "Root directory: " nil nil t)))
(set 'ada-prj-current-values
(plist-put ada-prj-current-values
field
(append (plist-get ada-prj-current-values field)
(reverse (ada-prj-subdirs-of
(expand-file-name file-name))))))
(ada-prj-display-page 2))
(defun ada-prj-display-page (tab-num)
"Display one of the pages available in the notebook. TAB-NUM should have
a value between 1 and the maximum number of pages.
The current buffer must be the project editing buffer."
(let ((inhibit-read-only t))
(erase-buffer))
(widget-insert "\n Project and Editor configuration.\n
___________ ____________ ____________ ____________\n / ")
(widget-create 'push-button :notify
(lambda (&rest dummy) (ada-prj-display-page 1)) "General")
(widget-insert " \\ / ")
(widget-create 'push-button :notify
(lambda (&rest dummy) (ada-prj-display-page 2)) "Paths")
(widget-insert " \\ / ")
(widget-create 'push-button :notify
(lambda (&rest dummy) (ada-prj-display-page 3)) "Switches")
(widget-insert " \\ / ")
(widget-create 'push-button :notify
(lambda (&rest dummy) (ada-prj-display-page 4)) "Ada Menu")
(widget-insert " \\\n")
(cond
((= tab-num 1)
(widget-insert "_/ \\/______________\\/______________\\/______________\\_____\n\n")
(widget-insert "Project file name:\n")
(widget-insert (plist-get ada-prj-current-values 'filename))
(widget-insert "\n\n")
(ada-prj-field 'main "Executable file name"
"Name of the executable generated when you
compile your application. This should include
the full directory name, using ${build_dir} if
you wish.")
(ada-prj-field 'main_unit "File name of the main unit"
"Name of the file to pass to the gnatmake command,
and that will create the executable.
This should not include any directory specification.")
(ada-prj-field 'build_dir "Build directory"
"Reference directory for relative paths in
src_dir and obj_dir below. This is also the directory
where the compilation is done.")
(ada-prj-field 'remote_machine "Name of the remote machine (if any)"
"If you want to remotely compile, debug and
run your application, specify the name of a
remote machine here. This capability requires
the 'rsh' protocol on the remote machine.")
(ada-prj-field 'cross_prefix "Prefix used in for the cross tool chain"
"When working on multiple cross targets, it is
most convenient to specify the prefix of the
tool chain here. For instance, on PowerPc
vxworks, you would enter 'powerpc-wrs-vxworks-'.
To use JGNAT, enter 'j'.")
)
((= tab-num 2)
(widget-insert "_/_____________\\/ \\/______________\\/______________\\_____\n\n")
(ada-prj-field 'src_dir "Source directories"
"Enter the list of directories where your Ada
sources can be found. These directories will be
used for the cross-references and for the default
compilation commands.
Note that src_dir includes both the build directory
and the standard runtime."
t t
(mapconcat (lambda(x)
(concat " " x))
ada-xref-runtime-library-specs-path
"\n")
)
(widget-insert "\n\n")
(ada-prj-field 'obj_dir "Object directories"
"Enter the list of directories where the GNAT
library files (ALI files) can be found. These
files are used for cross-references and by the
gnatmake command.
Note that obj_dir includes both the build directory
and the standard runtime."
t t
(mapconcat (lambda(x)
(concat " " x))
ada-xref-runtime-library-ali-path
"\n")
)
(widget-insert "\n\n")
)
((= tab-num 3)
(widget-insert "_/_____________\\/______________\\/ \\/______________\\_____\n\n")
(ada-prj-field 'comp_opt "Switches for the compiler"
"These switches are used in the default
compilation commands, both for compiling a
single file and rebuilding the whole project")
(ada-prj-field 'bind_opt "Switches for the binder"
"These switches are used in the default build
command and are passed to the binder")
(ada-prj-field 'link_opt "Switches for the linker"
"These switches are used in the default build
command and are passed to the linker")
(ada-prj-field 'gnatmake_opt "Switches for gnatmake"
"These switches are used in the default gnatmake
command.")
)
((= tab-num 4)
(widget-insert "_/_____________\\/______________\\/______________\\/ \\_____\n\n")
(widget-insert "All the fields below can use variable substitution\n")
(widget-insert "The syntax is ${name}, where name is the name that\n")
(widget-insert "appears after the Help buttons in this buffer.\n")
(widget-insert "As a special case, ${current} is replaced with the name\n")
(widget-insert "of the file currently edited, with directory name but\n")
(widget-insert "no extension.\n\n")
(widget-insert
"The environment variables ADA_INCLUDE_PATH and ADA_OBJECTS_PATH\n")
(widget-insert
"are set to ${src_dir} and ${obj_dir} before running the compilation\n")
(widget-insert
"commands, so that you don't need to specify the -aI and -aO\n")
(widget-insert
"switches on the command line\n\n")
(ada-prj-field 'check_cmd
"Check syntax of a single file (menu Ada->Check File)"
"This command is run to check the syntax and semantics of a file.
The file name is added at the end of this command.")
(ada-prj-field 'comp_cmd
"Compiling a single file (menu Ada->Compile File)"
"This command is run when the recompilation
of a single file is needed. The file name is
added at the end of this command.")
(ada-prj-field 'make_cmd "Rebuilding the whole project (menu Ada->Build)"
"This command is run when you want to rebuild
your whole application. It is never issues
automatically and you will need to ask for it.
If remote_machine has been set, this command
will be executed on the remote machine.")
(ada-prj-field 'run_cmd "Running the application (menu Ada->Run)"
"This command specifies how to run the
application, including any switch you need to
specify. If remote_machine has been set, this
command will be executed on the remote host.")
(ada-prj-field 'debug_cmd "Debugging the application"
"Specifies how to debug the application, possibly
remotely if remote_machine has been set. We
recommend the following debuggers:
> gdb
> gdbtk
> ddd --tty -fullname -toolbar")
)
)
(widget-insert "______________________________________________________________________\n\n ")
(widget-create 'push-button
:notify (lambda (&rest ignore)
(ada-xref-set-default-prj-values
'ada-prj-current-values ada-prj-ada-buffer)
(ada-prj-display-page 1))
"Reset to Default Values")
(widget-insert " ")
(widget-create 'push-button :notify (lambda (&rest ignore) (kill-buffer nil))
"Cancel")
(widget-insert " ")
(widget-create 'push-button :notify (lambda (&rest ignore) (ada-prj-save))
"Save")
(widget-insert "\n\n")
(widget-setup)
(beginning-of-buffer)
)
(defun ada-customize (&optional new-file filename)
"Edit the project file associated with the current buffer.
If there is none or NEW-FILE is non-nil, make a new one.
If FILENAME is given, edit that file."
(interactive)
(let ((ada-buffer (current-buffer))
(inhibit-read-only t))
(ada-require-project-file)
(switch-to-buffer "*Customize Ada Mode*")
(kill-all-local-variables)
(ada-xref-set-default-prj-values 'ada-prj-default-values ada-buffer)
(ada-prj-initialize-values 'ada-prj-current-values ada-buffer filename)
(set (make-local-variable 'ada-prj-ada-buffer) ada-buffer)
(use-local-map (copy-keymap custom-mode-map))
(local-set-key "\C-x\C-s" 'ada-prj-save)
(make-local-variable 'widget-keymap)
(define-key widget-keymap "\C-x\C-s" 'ada-prj-save)
(ada-prj-display-page 1)
))
(defun ada-prj-set-list (string ada-dir-list)
"Join the strings in ADA-DIR-LIST into a single string. Each name is put
on a separate line that begins with STRING."
(mapconcat (lambda (x) (concat string "=" (file-name-as-directory x)))
ada-dir-list "\n"))
(defun ada-prj-get-prj-dir (&optional ada-file)
"Returns the directory/name of the project file for ADA-FILE.
If ADA-FILE is nil, returns the project file for the current buffer."
(unless ada-file
(setq ada-file (buffer-file-name)))
(save-excursion
(set-buffer (get-file-buffer ada-file))
(let ((prj-file (ada-prj-find-prj-file t)))
(if (or (not prj-file)
(not (file-exists-p prj-file))
)
(setq prj-file
(concat (file-name-sans-extension ada-file)
ada-project-file-extension)))
prj-file)
))
(defun ada-prj-field-modified (widget &rest dummy)
"Callback called each time the value of WIDGET is modified. Save the
change in ada-prj-current-values so that selecting another page and coming
back keeps the new value."
(set 'ada-prj-current-values
(plist-put ada-prj-current-values
(widget-get widget 'prj-field)
(widget-value widget))))
(defun ada-prj-display-help (widget widget-modified event)
"An help button in WIDGET was clicked on. The parameters are so that
this function can be used as :notify for the widget."
(let ((text (widget-get widget 'prj-help)))
(if event
(widget-choose "Help"
(mapcar (lambda (a) (cons a t))
(split-string text "\n"))
event)
(momentary-string-display
(concat "*****Help*****\n" text "\n**************\n")
(save-excursion (forward-line) (beginning-of-line) (point)))
)))
(defun ada-prj-show-value (widget widget-modified event)
(let ((value (plist-get ada-prj-current-values
(widget-get widget 'prj-field)))
(inhibit-read-only t))
(if (widget-get widget 'prj-other-widget)
(progn
(widget-delete (widget-get widget 'prj-other-widget))
(widget-put widget 'prj-other-widget nil)
(widget-default-value-set widget "Show Value")
)
(save-excursion
(mouse-set-point event)
(forward-line 1)
(beginning-of-line)
(widget-put widget 'prj-other-widget
(widget-create 'editable-list
:entry-format "%i%d %v"
:notify 'ada-prj-field-modified
:help-echo (widget-get widget 'prj-help)
:value value
(list 'editable-field
:keymap widget-keymap)))
(widget-default-value-set widget "Hide Value")
)
)
(widget-setup)
))
(defun ada-prj-field (field text help-text &optional is-list is-paths after-text)
"Create a widget to edit FIELD in the current buffer.
TEXT is a short explanation of what the field means, whereas HELP-TEXT
is the text displayed when the user pressed the help button.
If IS-LIST is non-nil, the field contains a list. Otherwise, it contains
a single string.
if IS-PATHS is true, some special buttons are added to load paths,...
AFTER-TEXT is inserted just after the widget."
(let ((value (plist-get ada-prj-current-values field))
(inhibit-read-only t)
widget)
(unless value
(set 'value
(if is-list '() "")))
(widget-insert text)
(widget-insert ":")
(move-to-column 54 t)
(widget-put (widget-create 'push-button
:notify 'ada-prj-display-help
"Help")
'prj-help
help-text)
(widget-insert (concat " (" (symbol-name field) ")\n"))
(if is-paths
(progn
(widget-create 'push-button
:notify
(list 'lambda '(&rest dummy) '(interactive)
(list 'ada-prj-load-from-file
(list 'quote field)))
"Load From File")
(widget-insert " ")
(widget-create 'push-button
:notify
(list 'lambda '(&rest dummy) '(interactive)
(list 'ada-prj-load-directory
(list 'quote field)))
"Load Recursive Directory")
(widget-insert "\n ${build_dir}\n")))
(set 'widget
(if is-list
(if (< (length value) 15)
(widget-create 'editable-list
:entry-format "%i%d %v"
:notify 'ada-prj-field-modified
:help-echo help-text
:value value
(list 'editable-field :keymap widget-keymap))
(let ((w (widget-create 'push-button
:notify 'ada-prj-show-value
"Show value")))
(widget-insert "\n")
(widget-put w 'prj-field field)
(widget-put w 'prj-help help-text)
(widget-put w 'prj-other-widget nil)
w)
)
(widget-create 'editable-field
:format "%v"
:notify 'ada-prj-field-modified
:help-echo help-text
:keymap widget-keymap
value)))
(widget-put widget 'prj-field field)
(if after-text
(widget-insert after-text))
(widget-insert "\n")
))
(ada-prj-add-keymap)
(ada-prj-add-ada-menu)
(provide 'ada-prj)