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