code.delx.au - gnu-emacs-elpa/blob - packages/ada-mode/ada-build.el

   1 ;;; ada-build.el --- extensions to ada-mode for compiling and running
   2 ;;; Ada projects without 'make' or similar tool
   3 ;;
   4 ;;; Copyright (C) 1994, 1995, 1997 - 2014  Free Software Foundation, Inc.
   5 ;;
   6 ;; Author: Stephen Leake <stephen_leake@member.fsf.org>
   7 ;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
   8 ;;
   9 ;; This file is part of GNU Emacs.
  10 ;;
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15 ;;
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Design:
  25 ;;
  26 ;; Separate from ada-mode.el because sophisticated users don't need
  27 ;; this (they use 'make' or similar tool), so it would just get in the
  28 ;; way, particularly for fixing bugs in the core capabilities of
  29 ;; ada-mode.
  30
  31 ;;; History:
  32 ;;
  33 ;; see ada-mode.el; the current code is a complete rewrite of the
  34 ;; compiling and running capabilities in Ada mode 4.01, done in 2013 by
  35 ;; Stephen Leake <stephen_leake@stephe-leake.org>.
  36
  37 (when (and (= emacs-major-version 24)
  38            (= emacs-minor-version 2))
  39   (require 'ada-mode-compat-24.2))
  40
  41 (require 'ada-mode)
  42
  43 ;;;; User customization
  44
  45 (defgroup ada-build nil
  46   "Major mode for compiling and running Ada projects in Emacs."
  47   :group 'ada)
  48
  49 (defcustom ada-build-prompt-prj 'default
  50   "Policy for finding a project file when none is currently selected."
  51   :type '(choice (const default)
  52                  (const prompt-default)
  53                  (const prompt-exist)
  54                  (const error))
  55   :group 'ada-build
  56   :safe  'symbolp)
  57
  58 (defcustom ada-build-confirm-command nil
  59   "If non-nil, prompt for confirmation/edit of each command before it is run."
  60   :type  'boolean
  61   :group 'ada-build
  62   :safe  'booleanp)
  63
  64 (defcustom ada-build-check-cmd
  65   (concat "${cross_prefix}gnatmake -u -c -gnatc ${gnatmake_opt} ${full_current} -cargs -I${src_dir} ${comp_opt}")
  66   "Default command to syntax check a single file.
  67 Overridden by project variable 'check_cmd'."
  68   :type 'string
  69   :group 'ada-build)
  70
  71 (defcustom ada-build-make-cmd
  72   (concat "${cross_prefix}gnatmake -P${gpr_file} -o ${main} ${main} ${gnatmake_opt} "
  73           "-cargs -I${src_dir} ${comp_opt} -bargs ${bind_opt} -largs ${link_opt}")
  74   "Default command to compile the application.
  75 Overridden by project variable 'make_cmd'."
  76   :type 'string
  77   :group 'ada-build)
  78
  79 (defcustom ada-build-run-cmd "./${main}"
  80   "Default command to run the application, in a spawned shell.
  81 Overridden by project variable 'run_cmd'."
  82   :type 'string
  83   :group 'ada-build)
  84
  85 ;;;; code
  86
  87 (defun ada-build-replace-vars (cmd-string)
  88   "Recursively expand variable references in CMD-STRING.
  89 ${var} is a project variable or environment variable, $var an
  90 environment variable.
  91
  92 A prefix may be specified with the format '-<prefix>${var}'; then
  93 the value is expanded with the prefix prepended. If the value is
  94 a list, the prefix is prepended to each list element. For
  95 example, if src_dir contains 'dir_1 dir_2', '-I${src_dir}'
  96 expands to '-Idir_1 -Idir_2'.
  97
  98 As a special case, ${full_current} is replaced by the name
  99 including the directory and extension."
 100
 101   (while (string-match "\\(-[^-$ ]+\\)?\\${\\([^}]+\\)}" cmd-string)
 102     (let ((prefix (match-string 1 cmd-string))
 103           (name (match-string 2 cmd-string))
 104           value)
 105
 106       (when (string= name "full_current")
 107         (setq value (buffer-file-name)))
 108
 109       (when (null value)
 110         (setq value (ada-prj-get (intern name))))
 111
 112       (when (null value)
 113         (setq value (getenv name)))
 114
 115       (cond
 116        ((null value)
 117         (setq cmd-string (replace-match "" t t cmd-string)))
 118
 119        ((stringp value)
 120         (setq cmd-string (replace-match (concat prefix value) t t cmd-string)))
 121
 122        ((listp value)
 123         (setq cmd-string (replace-match
 124                           (mapconcat (lambda (x) (concat prefix x)) value " ")
 125                             t t cmd-string)))
 126        )))
 127
 128   (substitute-in-file-name cmd-string))
 129
 130 (defun ada-build-default-prj (project)
 131   "Add to PROJECT the default properties list for Ada project variables used by ada-build."
 132   (append
 133    project
 134    (list
 135     'check_cmd       ada-build-check-cmd
 136     'main            (when (buffer-file-name)
 137                        (file-name-nondirectory
 138                         (file-name-sans-extension (buffer-file-name))))
 139     'make_cmd        ada-build-make-cmd
 140     'run_cmd         ada-build-run-cmd
 141     )))
 142
 143 (defun ada-build-select-default-prj ()
 144   "Create and select a new default project."
 145   (let ((prj-file (expand-file-name "default.adp"))
 146         project)
 147
 148     (when (null (assoc prj-file ada-prj-alist))
 149       (setq project (ada-prj-default)) ;; ada-build-default-prj included via ada-prj-default-compiler-alist
 150
 151       (add-to-list 'ada-prj-alist (cons prj-file project))
 152       )
 153
 154     (ada-select-prj-file prj-file)
 155   ))
 156
 157 (defun ada-build-find-select-prj-file ()
 158   "Search for a project file in the current directory, parse and select it.
 159 The file must have the same basename as the project variable
 160 'main' or the current buffer if 'main' is nil, and extension from
 161 `ada-prj-file-extensions'.  Returns non-nil if a file is
 162 selected, nil otherwise."
 163   (let* ((base-file-name (file-name-base
 164                           (or (ada-prj-get 'main)
 165                               (file-name-nondirectory (file-name-sans-extension (buffer-file-name))))))
 166          (filename
 167           (or
 168            (file-name-completion base-file-name
 169                                  ""
 170                                  (lambda (name) (member (file-name-extension name) ada-prj-file-extensions)))
 171
 172            (file-name-completion base-file-name
 173                                  ""
 174                                  (lambda (name) (member (file-name-extension name) ada-prj-file-ext-extra)))))
 175         )
 176     (when filename
 177       (ada-parse-prj-file filename)
 178       (ada-select-prj-file filename))
 179     ))
 180
 181 (defun ada-build-prompt-select-prj-file ()
 182   "Search for a project file, parse and select it.
 183 The file must have an extension from `ada-prj-file-extensions'.
 184 Returns non-nil if a file is selected, nil otherwise."
 185   (interactive)
 186   (let ((ext (append ada-prj-file-extensions ada-prj-file-ext-extra))
 187         filename)
 188     (condition-case nil
 189         (setq filename
 190               (read-file-name
 191                "Project file: " ; prompt
 192                nil ; dir
 193                "" ; default-filename
 194                t   ; mustmatch
 195                nil; initial
 196                (lambda (name)
 197                  ;; this allows directories, which enables navigating
 198                  ;; to the desired file. We just assume the user won't
 199                  ;; return a directory.
 200                  (or (file-accessible-directory-p name)
 201                      (member (file-name-extension name) ext)))))
 202       (error
 203        (setq filename nil))
 204       )
 205
 206     (when (not (equal "" filename))
 207       (ada-parse-prj-file filename)
 208       (ada-select-prj-file filename)
 209       t)
 210     ))
 211
 212 (defun ada-build-require-project-file ()
 213   "Ensure that a project file is selected.
 214 Action when no project file is currently selected is determined
 215 by `ada-build-prompt-prj':
 216
 217 default - Search for a project file in the current directory with
 218 the same name as the main file. If not found, use a default
 219 project; no gpr file, current directory only, current file as
 220 main.
 221
 222 default-prompt - Search for a project file in the current
 223 directory with the same name as the main file. If not found,
 224 prompt for a project file; error result does not change current
 225 project.
 226
 227 prompt - Prompt for a project file; error result does not
 228 change current project.
 229
 230 error - Throw an error (no prompt, no default project)."
 231   (unless ada-prj-current-file
 232     (cl-ecase ada-build-prompt-prj
 233       (default
 234         (or (ada-build-find-select-prj-file)
 235             (ada-build-select-default-prj)))
 236
 237       (default-prompt
 238         (or (ada-build-find-select-prj-file)
 239             (ada-build-prompt-select-prj-file)))
 240
 241       (prompt
 242        (ada-build-prompt-select-prj-file))
 243
 244       (error
 245        (error "no project file selected"))
 246       )))
 247
 248 ;;;; user functions
 249
 250 (defun ada-build-run-cmd (prj-field confirm prompt)
 251   "Run the command in the PRJ-FIELD project variable.
 252 If CONFIRM or `ada-build-confirm-command' are non-nil, ask for
 253 user confirmation of the command, using PROMPT."
 254   (ada-build-require-project-file)
 255   (let ((cmd (ada-prj-get prj-field))
 256         (process-environment (ada-prj-get 'proc_env)))
 257
 258     (unless cmd
 259       (setq cmd '("")
 260             confirm t))
 261
 262     (when (or ada-build-confirm-command confirm)
 263       (setq cmd (read-from-minibuffer (concat prompt ": ") cmd)))
 264
 265     (compile (ada-build-replace-vars cmd))))
 266
 267 (defun ada-build-check (&optional confirm)
 268   "Run the check_cmd project variable.
 269 By default, this checks the current file for syntax errors.
 270 If CONFIRM is non-nil, prompt for user confirmation of the command."
 271   (interactive "P")
 272   (ada-build-run-cmd 'check_cmd confirm "check command"))
 273
 274 (defun ada-build-make (&optional confirm)
 275   "Run the make_cmd project variable.
 276 By default, this compiles and links the main program.
 277 If CONFIRM is non-nil, prompt for user confirmation of the command."
 278   (interactive "P")
 279   (ada-build-run-cmd 'make_cmd confirm "make command"))
 280
 281 (defun ada-build-set-make (&optional confirm)
 282   "Set the main project variable to the current file, then run the make_cmd project variable.
 283 By default, this compiles and links the new main program.
 284 If CONFIRM is non-nil, prompt for user confirmation of the command."
 285   (interactive "P")
 286   (ada-prj-put 'main (file-name-nondirectory (file-name-sans-extension (buffer-file-name))))
 287   (ada-build-run-cmd 'make_cmd confirm "make command"))
 288
 289 (defun ada-build-run (&optional confirm)
 290   "Run the run_cmd project variable.
 291 By default, this runs the main program.
 292 If CONFIRM is non-nil, prompt for user confirmation of the command."
 293   (interactive "P")
 294   (ada-build-run-cmd 'run_cmd confirm "run command"))
 295
 296 (defun ada-build-show-main ()
 297   "Show current project main program filename."
 298   (interactive)
 299   (message "Ada mode main: %s"(ada-prj-get 'main)))
 300
 301 ;;; setup
 302 (add-to-list 'ada-prj-default-list 'ada-build-default-prj)
 303
 304 (provide 'ada-build)
 305 ;; end of file