1 ;;; ada-prj.el --- GUI editing of project files for the ada-mode
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
4 ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Emmanuel Briot <briot@gnat.com>
7 ;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
8 ;; Keywords: languages, ada, project file
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;;; This package provides a set of functions to easily edit the project
29 ;;; files used by the ada-mode.
30 ;;; The only function publicly available here is `ada-customize'.
31 ;;; See the documentation of the Ada mode for more information on the project
33 ;;; Internally, a project file is represented as a property list, with each
34 ;;; field of the project file matching one property of the list.
43 ;; ----- Requirements -----------------------------------------------------
51 ;; ----- Buffer local variables -------------------------------------------
53 (defvar ada-prj-current-values nil
54 "Hold the current value of the fields, This is a property list.")
55 (make-variable-buffer-local 'ada-prj-current-values
)
57 (defvar ada-prj-default-values nil
58 "Hold the default value for the fields, This is a property list.")
59 (make-variable-buffer-local 'ada-prj-default-values
)
61 (defvar ada-prj-ada-buffer nil
62 "Indicates what Ada source file was being edited.")
64 (defvar ada-old-cross-prefix nil
65 "The cross-prefix associated with the currently loaded runtime library.")
68 ;; ----- Functions --------------------------------------------------------
71 "Open a new project file."
74 (if (and ada-prj-default-project-file
75 (not (string= ada-prj-default-project-file
"")))
76 ada-prj-default-project-file
78 (filename (read-file-name "Project file: "
83 (if (not (string= (file-name-extension filename t
) ".adp"))
84 (error "File name extension for project files must be .adp"))
86 (ada-customize nil filename
)))
88 (defun ada-prj-edit ()
89 "Editing the project file associated with the current Ada buffer.
90 If there is none, opens a new project file."
92 (if ada-prj-default-project-file
96 (defun ada-prj-initialize-values (symbol ada-buffer filename
)
97 "Set SYMBOL to the property list of the project file FILENAME.
98 If FILENAME is null, read the file associated with ADA-BUFFER.
99 If no project file is found, return the default values."
100 ;; FIXME: rationalize arguments; make ada-buffer optional?
102 (not (string= filename
""))
103 (assoc filename ada-xref-project-files
))
104 (set symbol
(copy-sequence (cdr (assoc filename ada-xref-project-files
))))
106 ;; Set default values (except for the file name if this was given
108 (set symbol
(ada-default-prj-properties))
109 (if (and filename
(not (string= filename
"")))
110 (set symbol
(plist-put (eval symbol
) 'filename filename
)))
114 (defun ada-prj-save-specific-option (field)
115 "Return the string to print in the project file to save FIELD.
116 If the current value of FIELD is the default value, return an empty string."
117 (if (string= (plist-get ada-prj-current-values field
)
118 (plist-get ada-prj-default-values field
))
120 (concat (symbol-name field
)
121 "=" (plist-get ada-prj-current-values field
) "\n")))
123 (defun ada-prj-save ()
124 "Save the edited project file."
126 (let ((file-name (or (plist-get ada-prj-current-values
'filename
)
127 (read-file-name "Save project as: ")))
132 ;; Save the fields that do not depend on the current buffer
133 ;; only if they are different from the default value
135 (ada-prj-save-specific-option 'comp_opt
)
136 (ada-prj-save-specific-option 'bind_opt
)
137 (ada-prj-save-specific-option 'link_opt
)
138 (ada-prj-save-specific-option 'gnatmake_opt
)
139 (ada-prj-save-specific-option 'gnatfind_opt
)
140 (ada-prj-save-specific-option 'cross_prefix
)
141 (ada-prj-save-specific-option 'remote_machine
)
142 (ada-prj-save-specific-option 'debug_cmd
)
144 ;; Always save the fields that depend on the current buffer
145 "main=" (plist-get ada-prj-current-values
'main
) "\n"
146 "build_dir=" (plist-get ada-prj-current-values
'build_dir
) "\n"
147 (ada-prj-set-list "check_cmd"
148 (plist-get ada-prj-current-values
'check_cmd
)) "\n"
149 (ada-prj-set-list "make_cmd"
150 (plist-get ada-prj-current-values
'make_cmd
)) "\n"
151 (ada-prj-set-list "comp_cmd"
152 (plist-get ada-prj-current-values
'comp_cmd
)) "\n"
153 (ada-prj-set-list "run_cmd"
154 (plist-get ada-prj-current-values
'run_cmd
)) "\n"
155 (ada-prj-set-list "src_dir"
156 (plist-get ada-prj-current-values
'src_dir
)
158 (ada-prj-set-list "obj_dir"
159 (plist-get ada-prj-current-values
'obj_dir
)
161 (ada-prj-set-list "debug_pre_cmd"
162 (plist-get ada-prj-current-values
'debug_pre_cmd
))
164 (ada-prj-set-list "debug_post_cmd"
165 (plist-get ada-prj-current-values
'debug_post_cmd
))
169 (find-file file-name
)
173 ;; kill the project buffer
176 ;; kill the editor buffer
177 (kill-buffer "*Edit Ada Mode Project*")
179 ;; automatically set the new project file as the active one
180 (set 'ada-prj-default-project-file file-name
)
182 ;; force Emacs to reread the project files
183 (ada-reread-prj-file file-name
)
187 (defun ada-prj-load-from-file (symbol)
188 "Load SYMBOL value from file.
189 One item per line should be found in the file."
191 (let ((file (read-file-name "File name: " nil nil t
))
192 (buffer (current-buffer))
197 (goto-char (point-min))
199 (set 'line
(buffer-substring-no-properties
200 (point) (save-excursion (end-of-line) (point))))
201 (add-to-list 'list line
)
206 (set 'ada-prj-current-values
207 (plist-put ada-prj-current-values
209 (append (plist-get ada-prj-current-values symbol
)
212 (ada-prj-display-page 2)
215 (defun ada-prj-subdirs-of (dir)
216 "Return a list of all the subdirectories of DIR, recursively."
217 (let ((subdirs (directory-files dir t
"^[^.].*"))
218 (dirlist (list dir
)))
220 (if (file-directory-p (car subdirs
))
221 (let ((sub (ada-prj-subdirs-of (car subdirs
))))
223 (set 'dirlist
(append sub dirlist
)))))
224 (set 'subdirs
(cdr subdirs
)))
227 (defun ada-prj-load-directory (field &optional file-name
)
228 "Append to FIELD in the current project the subdirectories of FILE-NAME.
229 If FILE-NAME is nil, ask the user for the name."
231 ;; Do not use an external dialog for this, since it wouldn't allow
232 ;; the user to select a directory
233 (let ((use-dialog-box nil
))
235 (set 'file-name
(read-file-name "Root directory: " nil nil t
))))
237 (set 'ada-prj-current-values
238 (plist-put ada-prj-current-values
240 (append (plist-get ada-prj-current-values field
)
241 (reverse (ada-prj-subdirs-of
242 (expand-file-name file-name
))))))
243 (ada-prj-display-page 2))
245 (defun ada-prj-display-page (tab-num)
246 "Display page TAB-NUM in the notebook.
247 The current buffer must be the project editing buffer."
249 (let ((inhibit-read-only t
))
252 ;; Widget support in Emacs 21 requires that we clear the buffer first
253 (if (and (not (featurep 'xemacs
)) (>= emacs-major-version
21))
255 (setq widget-field-new nil
256 widget-field-list nil
)
257 (mapc (lambda (x) (delete-overlay x
)) (car (overlay-lists)))
258 (mapc (lambda (x) (delete-overlay x
)) (cdr (overlay-lists)))))
262 (widget-insert "\n Project configuration.\n
263 ___________ ____________ ____________ ____________ ____________\n / ")
264 (widget-create 'push-button
:notify
265 (lambda (&rest dummy
) (ada-prj-display-page 1)) "General")
266 (widget-insert " \\ / ")
267 (widget-create 'push-button
:notify
268 (lambda (&rest dummy
) (ada-prj-display-page 2)) "Paths")
269 (widget-insert " \\ / ")
270 (widget-create 'push-button
:notify
271 (lambda (&rest dummy
) (ada-prj-display-page 3)) "Switches")
272 (widget-insert " \\ / ")
273 (widget-create 'push-button
:notify
274 (lambda (&rest dummy
) (ada-prj-display-page 4)) "Ada Menu")
275 (widget-insert " \\ / ")
276 (widget-create 'push-button
:notify
277 (lambda (&rest dummy
) (ada-prj-display-page 5)) "Debugger")
278 (widget-insert " \\\n")
280 ;; Display the currently selected page
285 ;; First page (General)
288 (widget-insert "/ \\/______________\\/______________\\/______________\\/______________\\\n")
290 (widget-insert "Project file name:\n")
291 (widget-insert (plist-get ada-prj-current-values
'filename
))
292 (widget-insert "\n\n")
293 (ada-prj-field 'casing
"Casing Exceptions"
294 "List of files that contain casing exception
295 dictionaries. All these files contain one
296 identifier per line, with a special casing.
297 The first file has the highest priority."
299 (mapconcat (lambda(x)
301 (ada-xref-get-project-field 'casing
)
304 (ada-prj-field 'main
"Executable file name"
305 "Name of the executable generated when you
306 compile your application. This should include
307 the full directory name, using ${build_dir} if
309 (ada-prj-field 'build_dir
"Build directory"
310 "Reference directory for relative paths in
311 src_dir and obj_dir below. This is also the directory
312 where the compilation is done.")
313 (ada-prj-field 'remote_machine
"Name of the remote machine (if any)"
314 "If you want to remotely compile, debug and
315 run your application, specify the name of a
316 remote machine here. This capability requires
317 the 'rsh' protocol on the remote machine.")
318 (ada-prj-field 'cross_prefix
"Prefix used in for the cross tool chain"
319 "When working on multiple cross targets, it is
320 most convenient to specify the prefix of the
321 tool chain here. For instance, on PowerPc
322 vxworks, you would enter 'powerpc-wrs-vxworks-'.
323 To use JGNAT, enter 'j'.")
328 ;; Second page (Paths)
331 (if (not (equal (plist-get ada-prj-current-values
'cross_prefix
)
332 ada-old-cross-prefix
))
334 (setq ada-old-cross-prefix
335 (plist-get ada-prj-current-values
'cross_prefix
))
336 (ada-initialize-runtime-library ada-old-cross-prefix
)))
339 (widget-insert "/_____________\\/ \\/______________\\/______________\\/______________\\\n")
340 (ada-prj-field 'src_dir
"Source directories"
341 "Enter the list of directories where your Ada
342 sources can be found. These directories will be
343 used for the cross-references and for the default
344 compilation commands.
345 Note that src_dir includes both the build directory
346 and the standard runtime."
348 (mapconcat (lambda(x)
350 ada-xref-runtime-library-specs-path
353 (widget-insert "\n\n")
355 (ada-prj-field 'obj_dir
"Object directories"
356 "Enter the list of directories where the GNAT
357 library files (ALI files) can be found. These
358 files are used for cross-references and by the
360 Note that obj_dir includes both the build directory
361 and the standard runtime."
363 (mapconcat (lambda(x)
365 ada-xref-runtime-library-ali-path
368 (widget-insert "\n\n")
372 ;; Third page (Switches)
375 (widget-insert "/_____________\\/______________\\/ \\/______________\\/______________\\\n")
376 (ada-prj-field 'comp_opt
"Switches for the compiler"
377 "These switches are used in the default
378 compilation commands, both for compiling a
379 single file and rebuilding the whole project")
380 (ada-prj-field 'bind_opt
"Switches for the binder"
381 "These switches are used in the default build
382 command and are passed to the binder")
383 (ada-prj-field 'link_opt
"Switches for the linker"
384 "These switches are used in the default build
385 command and are passed to the linker")
386 (ada-prj-field 'gnatmake_opt
"Switches for gnatmake"
387 "These switches are used in the default gnatmake
389 (ada-prj-field 'gnatfind_opt
"Switches for gnatfind"
390 "The command gnatfind is run every time the Ada/Goto/List_References menu.
391 You should for instance add -a if you are working in an environment
392 where most ALI files are write-protected, since otherwise they get
393 ignored by gnatfind and you don't see the references within.")
400 (widget-insert "/_____________\\/______________\\/______________\\/ \\/______________\\\n")
402 "All the fields below can use variable substitution. The syntax is ${name},
403 where name is the name that appears after the Help buttons in this buffer. As
404 a special case, ${current} is replaced with the name of the file currently
405 edited, with directory name but no extension, whereas ${full_current} is
406 replaced with the name of the current file with directory name and
409 "The environment variables ADA_INCLUDE_PATH and ADA_OBJECTS_PATH are set to
410 ${src_dir} and ${obj_dir} before running the compilation commands, so that you
411 don't need to specify the -aI and -aO switches on the command line\n")
413 "You can reference any environment variable using the same ${...} syntax as
414 above, and put the name of the variable between the quotes.\n\n")
415 (ada-prj-field 'check_cmd
416 "Check syntax of a single file (menu Ada->Check File)"
417 "This command is run to check the syntax and semantics of a file.
418 The file name is added at the end of this command." t
)
419 (ada-prj-field 'comp_cmd
420 "Compiling a single file (menu Ada->Compile File)"
421 "This command is run when the recompilation
422 of a single file is needed. The file name is
423 added at the end of this command." t
)
424 (ada-prj-field 'make_cmd
"Rebuilding the whole project (menu Ada->Build)"
425 "This command is run when you want to rebuild
426 your whole application. It is never issues
427 automatically and you will need to ask for it.
428 If remote_machine has been set, this command
429 will be executed on the remote machine." t
)
430 (ada-prj-field 'run_cmd
"Running the application (menu Ada->Run)"
431 "This command specifies how to run the
432 application, including any switch you need to
433 specify. If remote_machine has been set, this
434 command will be executed on the remote host." t
)
441 (widget-insert "/_____________\\/______________\\/______________\\/______________\\/ \\\n")
442 (ada-prj-field 'debug_pre_cmd
"Commands to execute before launching the
444 "The following commands are executed one after the other before starting
445 the debugger. These can be used to set up your environment." t
)
447 (ada-prj-field 'debug_cmd
"Debugging the application"
448 "Specifies how to debug the application, possibly
449 remotely if remote_machine has been set. We
450 recommend the following debuggers:
453 > ddd --tty -fullname -toolbar")
455 (ada-prj-field 'debug_post_cmd
"Commands to execute in the debugger"
456 "The following commands are executed one in the debugger once it has been
457 started. These can be used to initialize the debugger, for instance to
458 connect to the target when working with cross-environments" t
)
464 (widget-insert "______________________________________________________________________\n\n ")
465 (widget-create 'push-button
466 :notify
(lambda (&rest ignore
)
467 (setq ada-prj-current-values
(ada-default-prj-properties))
468 (ada-prj-display-page 1))
469 "Reset to Default Values")
471 (widget-create 'push-button
:notify
(lambda (&rest ignore
) (kill-buffer nil
))
474 (widget-create 'push-button
:notify
(lambda (&rest ignore
) (ada-prj-save))
476 (widget-insert "\n\n")
480 (beginning-of-buffer))
484 (defun ada-customize (&optional new-file filename
)
485 "Edit the project file associated with the current buffer.
486 If there is none or NEW-FILE is non-nil, make a new one.
487 If FILENAME is given, edit that file."
490 (let ((ada-buffer (current-buffer))
491 (inhibit-read-only t
))
493 ;; We can only edit interactively the standard ada-mode project files. If
494 ;; the user is using other formats for the project file (through hooks in
495 ;; `ada-load-project-hook', we simply edit the file
497 (if (and (not new-file
)
498 (or ada-prj-default-project-file filename
)
499 (string= (file-name-extension
500 (or filename ada-prj-default-project-file
))
503 (find-file ada-prj-default-project-file
)
504 (add-hook 'after-save-hook
'ada-reread-prj-file t t
)
508 (ada-reread-prj-file filename
)
509 (if (not (string= ada-prj-default-project-file
""))
510 (ada-reread-prj-file ada-prj-default-project-file
)
511 (ada-reread-prj-file)))
513 (switch-to-buffer "*Edit Ada Mode Project*")
515 (ada-prj-initialize-values 'ada-prj-current-values
517 ada-prj-default-project-file
)
519 (set (make-local-variable 'ada-prj-ada-buffer
) ada-buffer
)
521 (use-local-map (copy-keymap custom-mode-map
))
522 (local-set-key "\C-x\C-s" 'ada-prj-save
)
524 (make-local-variable 'widget-keymap
)
525 (define-key widget-keymap
"\C-x\C-s" 'ada-prj-save
)
527 (set (make-local-variable 'ada-old-cross-prefix
)
528 (ada-xref-get-project-field 'cross-prefix
))
530 (ada-prj-display-page 1)
533 ;; ---------------- Utilities --------------------------------
535 (defun ada-prj-set-list (string ada-list
&optional is-directory
)
536 "Prepend STRING to strings in ADA-LIST, return new-line separated string.
537 If IS-DIRECTORY is non-nil, each element of ADA-LIST is explicitly
538 converted to a directory name."
540 (mapconcat (lambda (x) (concat string
"="
542 (file-name-as-directory x
)
547 (defun ada-prj-field-modified (widget &rest dummy
)
548 "Callback for modification of WIDGET.
549 Remaining args DUMMY are ignored.
550 Save the change in `ada-prj-current-values' so that selecting
551 another page and coming back keeps the new value."
552 (set 'ada-prj-current-values
553 (plist-put ada-prj-current-values
554 (widget-get widget
':prj-field
)
555 (widget-value widget
))))
557 (defun ada-prj-display-help (widget widget-modified event
)
558 "Callback for help button in WIDGET.
559 Parameters WIDGET-MODIFIED, EVENT match :notify for the widget."
560 (let ((text (widget-get widget
'prj-help
)))
562 ;; If we have a mouse-event, popup a menu
563 (widget-choose "Help"
564 (mapcar (lambda (a) (cons a t
))
565 (split-string text
"\n"))
567 ;; Else display the help string just before the next group of
569 (momentary-string-display
570 (concat "*****Help*****\n" text
"\n**************\n")
571 (save-excursion (forward-line) (beginning-of-line) (point)))
574 (defun ada-prj-show-value (widget widget-modified event
)
575 "Show the current field value in WIDGET.
576 Parameters WIDGET-MODIFIED, EVENT match :notify for the widget."
577 (let* ((field (widget-get widget
':prj-field
))
578 (value (plist-get ada-prj-current-values field
))
579 (inhibit-read-only t
)
582 ;; If the other widget is already visible, delete it
583 (if (widget-get widget
'prj-other-widget
)
585 (widget-delete (widget-get widget
'prj-other-widget
))
586 (widget-put widget
'prj-other-widget nil
)
587 (widget-put widget
':prj-field field
)
588 (widget-default-value-set widget
"Show Value")
593 (mouse-set-point event
)
596 (setq w
(widget-create 'editable-list
597 :entry-format
"%i%d %v"
598 :notify
'ada-prj-field-modified
599 :help-echo
(widget-get widget
'prj-help
)
601 (list 'editable-field
:keymap widget-keymap
)))
602 (widget-put widget
'prj-other-widget w
)
603 (widget-put w
':prj-field field
)
604 (widget-put widget
':prj-field field
)
605 (widget-default-value-set widget
"Hide Value")
611 (defun ada-prj-field (field text help-text
&optional is-list is-paths after-text
)
612 "Create a widget to edit FIELD in the current buffer.
613 TEXT is a short explanation of what the field means, whereas HELP-TEXT
614 is the text displayed when the user pressed the help button.
615 If IS-LIST is non-nil, the field contains a list. Otherwise, it contains
617 If IS-PATHS is true, some special buttons are added to load paths,...
618 AFTER-TEXT is inserted just after the widget."
619 (let ((value (plist-get ada-prj-current-values field
))
620 (inhibit-read-only t
)
624 (if is-list
'() "")))
627 (move-to-column 54 t
)
628 (widget-put (widget-create 'push-button
629 :notify
'ada-prj-display-help
633 (widget-insert (concat " (" (symbol-name field
) ")\n"))
636 (widget-create 'push-button
638 (list 'lambda
'(&rest dummy
) '(interactive)
639 (list 'ada-prj-load-from-file
640 (list 'quote field
)))
643 (widget-create 'push-button
645 (list 'lambda
'(&rest dummy
) '(interactive)
646 (list 'ada-prj-load-directory
647 (list 'quote field
)))
648 "Load Recursive Directory")
649 (widget-insert "\n ${build_dir}\n")))
653 (if (< (length value
) 15)
654 (widget-create 'editable-list
655 :entry-format
"%i%d %v"
656 :notify
'ada-prj-field-modified
659 (list 'editable-field
:keymap widget-keymap
))
661 (let ((w (widget-create 'push-button
662 :notify
'ada-prj-show-value
665 (widget-put w
'prj-help help-text
)
666 (widget-put w
'prj-other-widget nil
)
669 (widget-create 'editable-field
671 :notify
'ada-prj-field-modified
673 :keymap widget-keymap
675 (widget-put widget
':prj-field field
)
677 (widget-insert after-text
))
684 ;; arch-tag: 65978c77-816e-49c6-896e-6905605d1b4c
685 ;;; ada-prj.el ends here