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  -*- lexical-binding:t -*-
   2 ;; Ada projects without 'make' or similar tool
   3 ;;
   4 ;; Copyright (C) 1994, 1995, 1997 - 2015  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 (require 'ada-mode-compat-24.2)
  38
  39 (require 'ada-mode)
  40
  41 ;;;; User customization
  42
  43 (defgroup ada-build nil
  44   "Major mode for compiling and running Ada projects in Emacs."
  45   :group 'ada)
  46
  47 (defcustom ada-build-prompt-prj 'default
  48   "Policy for finding a project file when none is currently selected."
  49   :type '(choice (const default)
  50                  (const prompt-default)
  51                  (const prompt-exist)
  52                  (const error))
  53   :safe  #'symbolp)
  54
  55 (defcustom ada-build-confirm-command nil
  56   "If non-nil, prompt for confirmation/edit of each command before it is run."
  57   :type  'boolean
  58   :safe  #'booleanp)
  59
  60 (defcustom ada-build-check-cmd
  61   (concat "${cross_prefix}gnatmake -u -c -gnatc ${gnatmake_opt} ${full_current} -cargs -I${src_dir} ${comp_opt}")
  62   "Default command to syntax check a single file.
  63 Overridden by project variable `check_cmd'."
  64   :type 'string)
  65
  66 (defcustom ada-build-make-cmd
  67   (concat "${cross_prefix}gnatmake -P${gpr_file} -o ${main} ${main} ${gnatmake_opt} "
  68           "-cargs -I${src_dir} ${comp_opt} -bargs ${bind_opt} -largs ${link_opt}")
  69   "Default command to compile the application.
  70 Overridden by project variable `make_cmd'."
  71   :type 'string)
  72
  73 ;; FIXME: make this more intelligent to work on Windows cmd shell?
  74 ;; either detect Windows and drop "./", or expand to full path at
  75 ;; runtime.
  76 (defcustom ada-build-run-cmd "./${main}"
  77   "Default command to run the application, in a spawned shell.
  78 Overridden by project variable `run_cmd'."
  79   :type 'string)
  80
  81 ;;;; code
  82
  83 (defun ada-build-replace-vars (cmd-string)
  84   "Recursively expand variable references in CMD-STRING.
  85 ${var} is a project variable or environment variable, $var an
  86 environment variable.
  87
  88 A prefix may be specified with the format `-<prefix>${var}'; then
  89 the value is expanded with the prefix prepended. If the value is
  90 a list, the prefix is prepended to each list element. For
  91 example, if src_dir contains `dir_1 dir_2', `-I${src_dir}'
  92 expands to `-Idir_1 -Idir_2'.
  93
  94 As a special case, ${full_current} is replaced by the current
  95 buffer file name including the directory and extension."
  96
  97   (while (string-match "\\(-[^-$ ]+\\)?\\${\\([^}]+\\)}" cmd-string)
  98     (let ((prefix (match-string 1 cmd-string))
  99           (name (match-string 2 cmd-string))
 100           value)
 101
 102       (when (string= name "full_current")
 103         (setq value (buffer-file-name)))
 104
 105       (when (null value)
 106         (setq value (ada-prj-get (intern name))))
 107
 108       (when (null value)
 109         (setq value (getenv name)))
 110
 111       (cond
 112        ((null value)
 113         (setq cmd-string (replace-match "" t t cmd-string)))
 114
 115        ((stringp value)
 116         (setq cmd-string (replace-match (concat prefix value) t t cmd-string)))
 117
 118        ((listp value)
 119         (setq cmd-string (replace-match
 120                           (mapconcat (lambda (x) (concat prefix x)) value " ")
 121                             t t cmd-string)))
 122        )))
 123
 124   (substitute-in-file-name cmd-string))
 125
 126 (defun ada-build-default-prj (project)
 127   "Add to PROJECT the default properties list for Ada project variables used by ada-build."
 128   (append
 129    project
 130    (list
 131     'check_cmd       ada-build-check-cmd
 132     'main            (when (buffer-file-name)
 133                        (file-name-nondirectory
 134                         (file-name-sans-extension (buffer-file-name))))
 135     'make_cmd        ada-build-make-cmd
 136     'run_cmd         ada-build-run-cmd
 137     )))
 138
 139 (defun ada-build-select-default-prj ()
 140   "Create and select a new default project."
 141   (let ((prj-file (expand-file-name "default.adp"))
 142         project)
 143
 144     (when (null (assoc prj-file ada-prj-alist))
 145       (setq project (ada-prj-default)) ;; ada-build-default-prj included via ada-prj-default-compiler-alist
 146
 147       (add-to-list 'ada-prj-alist (cons prj-file project))
 148       )
 149
 150     (ada-select-prj-file prj-file)
 151   ))
 152
 153 (defun ada-build-find-select-prj-file ()
 154   "Search for a project file in the current directory, parse and select it.
 155 The file must have the same basename as the project variable
 156 `main' or the current buffer if `main' is nil, and extension from
 157 `ada-prj-file-extensions'.  Returns non-nil if a file is
 158 selected, nil otherwise."
 159   (let* ((base-file-name (file-name-base
 160                           (or (ada-prj-get 'main)
 161                               (file-name-nondirectory (file-name-sans-extension (buffer-file-name))))))
 162          (filename
 163           (or
 164            (file-name-completion base-file-name
 165                                  ""
 166                                  (lambda (name) (member (file-name-extension name) ada-prj-file-extensions)))
 167
 168            (file-name-completion base-file-name
 169                                  ""
 170                                  (lambda (name) (member (file-name-extension name) ada-prj-file-ext-extra)))))
 171         )
 172     (when filename
 173       (ada-parse-prj-file filename)
 174       (ada-select-prj-file filename))
 175     ))
 176
 177 (defun ada-build-prompt-select-prj-file ()
 178   "Search for a project file, parse and select it.
 179 The file must have an extension from `ada-prj-file-extensions'.
 180 Returns non-nil if a file is selected, nil otherwise."
 181   (interactive)
 182   (let ((ext (append ada-prj-file-extensions ada-prj-file-ext-extra))
 183         filename)
 184     (condition-case nil
 185         (setq filename
 186               (read-file-name
 187                "Project file: " ; prompt
 188                nil ; dir
 189                "" ; default-filename
 190                t   ; mustmatch
 191                nil; initial
 192                (lambda (name)
 193                  ;; this allows directories, which enables navigating
 194                  ;; to the desired file. We just assume the user won't
 195                  ;; return a directory.
 196                  (or (file-accessible-directory-p name)
 197                      (member (file-name-extension name) ext)))))
 198       (error
 199        (setq filename nil))
 200       )
 201
 202     (when (not (equal "" filename))
 203       (ada-parse-prj-file filename)
 204       (ada-select-prj-file filename)
 205       t)
 206     ))
 207
 208 (defun ada-build-require-project-file ()
 209   "Ensure that a project file is selected.
 210 Action when no project file is currently selected is determined
 211 by `ada-build-prompt-prj':
 212
 213 default - Search for a project file in the current directory with
 214 the same name as the main file. If not found, use a default
 215 project; no gpr file, current directory only, current file as
 216 main.
 217
 218 default-prompt - Search for a project file in the current
 219 directory with the same name as the main file. If not found,
 220 prompt for a project file; error result does not change current
 221 project.
 222
 223 prompt - Prompt for a project file; error result does not
 224 change current project.
 225
 226 error - Throw an error (no prompt, no default project)."
 227   (unless ada-prj-current-file
 228     (cl-ecase ada-build-prompt-prj
 229       (default
 230         (or (ada-build-find-select-prj-file)
 231             (ada-build-select-default-prj)))
 232
 233       (default-prompt
 234         (or (ada-build-find-select-prj-file)
 235             (ada-build-prompt-select-prj-file)))
 236
 237       (prompt
 238        (ada-build-prompt-select-prj-file))
 239
 240       (error
 241        (error "no project file selected"))
 242       )))
 243
 244 ;;;; user functions
 245
 246 (defun ada-build-run-cmd (prj-field confirm prompt)
 247   "Run the command in the PRJ-FIELD project variable.
 248 If CONFIRM or `ada-build-confirm-command' are non-nil, ask for
 249 user confirmation of the command, using PROMPT."
 250   (ada-build-require-project-file)
 251   (let ((cmd (ada-prj-get prj-field))
 252         (process-environment (ada-prj-get 'proc_env)))
 253
 254     (unless cmd
 255       (setq cmd '("")
 256             confirm t))
 257
 258     (when (or ada-build-confirm-command confirm)
 259       (setq cmd (read-from-minibuffer (concat prompt ": ") cmd)))
 260
 261     (compile (ada-build-replace-vars cmd))))
 262
 263 (defun ada-build-check (&optional confirm)
 264   "Run the check_cmd project variable.
 265 By default, this checks the current file for syntax errors.
 266 If CONFIRM is non-nil, prompt for user confirmation of the command."
 267   (interactive "P")
 268   (ada-build-run-cmd 'check_cmd confirm "check command"))
 269
 270 (defun ada-build-make (&optional confirm)
 271   "Run the make_cmd project variable.
 272 By default, this compiles and links the main program.
 273 If CONFIRM is non-nil, prompt for user confirmation of the command."
 274   (interactive "P")
 275   (ada-build-run-cmd 'make_cmd confirm "make command"))
 276
 277 (defun ada-build-set-make (&optional confirm)
 278   "Set the main project variable to the current file, then run the make_cmd project variable.
 279 By default, this compiles and links the new main program.
 280 If CONFIRM is non-nil, prompt for user confirmation of the command."
 281   (interactive "P")
 282   (ada-prj-put 'main (file-name-nondirectory (file-name-sans-extension (buffer-file-name))))
 283   (ada-build-run-cmd 'make_cmd confirm "make command"))
 284
 285 (defun ada-build-run (&optional confirm)
 286   "Run the run_cmd project variable.
 287 By default, this runs the main program.
 288 If CONFIRM is non-nil, prompt for user confirmation of the command."
 289   (interactive "P")
 290   (ada-build-run-cmd 'run_cmd confirm "run command"))
 291
 292 (defun ada-build-show-main ()
 293   "Show current project main program filename."
 294   (interactive)
 295   (message "Ada mode main: %s"(ada-prj-get 'main)))
 296
 297 ;;; setup
 298 (add-to-list 'ada-prj-default-list 'ada-build-default-prj)
 299
 300 (provide 'ada-build)
 301 ;; end of file