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