-
-
Notifications
You must be signed in to change notification settings - Fork 39
/
ada-xref.el
2282 lines (1928 loc) · 78.8 KB
/
ada-xref.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;; ada-xref.el --- for lookup and completion in Ada mode
;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
;; 2004, 2005, 2006 Free Software Foundation, Inc.
;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
;; Rolf Ebert <ebert@inf.enst.fr>
;; Emmanuel Briot <briot@gnat.com>
;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
;; Keywords: languages ada xref
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; This Package provides a set of functions to use the output of the
;;; cross reference capabilities of the GNAT Ada compiler
;;; for lookup and completion in Ada mode.
;;;
;;; If a file *.`adp' exists in the ada-file directory, then it is
;;; read for configuration informations. It is read only the first
;;; time a cross-reference is asked for, and is not read later.
;;; You need Emacs >= 20.2 to run this package
;;; History:
;;
;;; Code:
;; ----- Requirements -----------------------------------------------------
(require 'compile)
(require 'comint)
(require 'find-file)
(require 'ada-mode)
;; ------ User variables
(defcustom ada-xref-other-buffer t
"*If nil, always display the cross-references in the same buffer.
Otherwise create either a new buffer or a new frame."
:type 'boolean :group 'ada)
(defcustom ada-xref-create-ali nil
"*If non-nil, run gcc whenever the cross-references are not up-to-date.
If nil, the cross-reference mode never runs gcc."
:type 'boolean :group 'ada)
(defcustom ada-xref-confirm-compile nil
"*Non-nil means ask for confirmation before compiling or running the application."
:type 'boolean :group 'ada)
(defcustom ada-krunch-args "0"
"*Maximum number of characters for filenames created by `gnatkr'.
Set to 0, if you don't use crunched filenames. This should be a string."
:type 'string :group 'ada)
(defcustom ada-gnatls-args '("-v")
"*Arguments to pass to `gnatfind' to find location of the runtime.
Typical use is to pass `--RTS=soft-floats' on some systems that support it.
You can also add `-I-' if you do not want the current directory to be included.
Otherwise, going from specs to bodies and back will first look for files in the
current directory. This only has an impact if you are not using project files,
but only ADA_INCLUDE_PATH."
:type '(repeat string) :group 'ada)
(defcustom ada-prj-default-comp-opt "-gnatq -gnatQ"
"Default compilation options."
:type 'string :group 'ada)
(defcustom ada-prj-default-bind-opt ""
"Default binder options."
:type 'string :group 'ada)
(defcustom ada-prj-default-link-opt ""
"Default linker options."
:type 'string :group 'ada)
(defcustom ada-prj-default-gnatmake-opt "-g"
"Default options for `gnatmake'."
:type 'string :group 'ada)
(defcustom ada-prj-gnatfind-switches "-rf"
"Default switches to use for `gnatfind'.
You should modify this variable, for instance to add `-a', if you are working
in an environment where most ALI files are write-protected.
The command `gnatfind' is used every time you choose the menu
\"Show all references\"."
:type 'string :group 'ada)
(defcustom ada-prj-default-check-cmd
(concat "${cross_prefix}gnatmake -u -c -gnatc ${gnatmake_opt} ${full_current}"
" -cargs ${comp_opt}")
"*Default command to be used to compile a single file.
Emacs will substitute the current filename for ${full_current}, or add
the filename at the end. This is the same syntax as in the project file."
:type 'string :group 'ada)
(defcustom ada-prj-default-comp-cmd
(concat "${cross_prefix}gnatmake -u -c ${gnatmake_opt} ${full_current} -cargs"
" ${comp_opt}")
"*Default command to be used to compile a single file.
Emacs will substitute the current filename for ${full_current}, or add
the filename at the end. This is the same syntax as in the project file."
:type 'string :group 'ada)
(defcustom ada-prj-default-debugger "${cross_prefix}gdb"
"*Default name of the debugger."
:type 'string :group 'ada)
(defcustom ada-prj-default-make-cmd
(concat "${cross_prefix}gnatmake -o ${main} ${main_unit} ${gnatmake_opt} "
"-cargs ${comp_opt} -bargs ${bind_opt} -largs ${link_opt}")
"*Default command to be used to compile the application.
This is the same syntax as in the project file."
:type 'string :group 'ada)
(defcustom ada-prj-default-project-file ""
"*Name of the current project file.
Emacs will not try to use the search algorithm to find the project file if
this string is not empty. It is set whenever a project file is found."
:type '(file :must-match t) :group 'ada)
(defcustom ada-gnatstub-opts "-q -I${src_dir}"
"*List of the options to pass to `gnatsub' to generate the body of a package.
This has the same syntax as in the project file (with variable substitution)."
:type 'string :group 'ada)
(defcustom ada-always-ask-project nil
"*If nil, use default values when no project file was found.
Otherwise, ask the user for the name of the project file to use."
:type 'boolean :group 'ada)
(defconst is-windows (memq system-type (quote (windows-nt)))
"True if we are running on Windows NT or Windows 95.")
(defcustom ada-tight-gvd-integration nil
"*If non-nil, a new Emacs frame will be swallowed in GVD when debugging.
If GVD is not the debugger used, nothing happens."
:type 'boolean :group 'ada)
(defcustom ada-xref-search-with-egrep t
"*If non-nil, use egrep to find the possible declarations for an entity.
This alternate method is used when the exact location was not found in the
information provided by GNAT. However, it might be expensive if you have a lot
of sources, since it will search in all the files in your project."
:type 'boolean :group 'ada)
(defvar ada-load-project-hook nil
"Hook that is run when loading a project file.
Each function in this hook takes one argument FILENAME, that is the name of
the project file to load.
This hook should be used to support new formats for the project files.
If the function can load the file with the given filename, it should create a
buffer that contains a conversion of the file to the standard format of the
project files, and return that buffer. (The usual \"src_dir=\" or \"obj_dir=\"
lines.) It should return nil if it doesn't know how to convert that project
file.")
;; ------- Nothing to be modified by the user below this
(defvar ada-last-prj-file ""
"Name of the last project file entered by the user.")
(defconst ada-prj-file-extension ".adp"
"The extension used for project files.")
(defvar ada-xref-runtime-library-specs-path '()
"Directories where the specs for the standard library is found.
This is used for cross-references.")
(defvar ada-xref-runtime-library-ali-path '()
"Directories where the ali for the standard library is found.
This is used for cross-references.")
(defvar ada-xref-pos-ring '()
"List of positions selected by the cross-references functions.
Used to go back to these positions.")
(defvar ada-cd-command
(if (string-match "cmdproxy.exe" shell-file-name)
"cd /d"
"cd")
"Command to use to change to a specific directory.
On Windows systems using `cmdproxy.exe' as the shell,
we need to use `/d' or the drive is never changed.")
(defvar ada-command-separator (if is-windows " && " "\n")
"Separator to use between multiple commands to `compile' or `start-process'.
`cmdproxy.exe' doesn't recognize multiple-line commands, so we have to use
\"&&\" for now.")
(defconst ada-xref-pos-ring-max 16
"Number of positions kept in the list ada-xref-pos-ring.")
(defvar ada-operator-re
"\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>"
"Regexp to match for operators.")
(defvar ada-xref-project-files '()
"Associative list of project files with properties.
It has the format: (project project ...)
A project has the format: (project-file . project-plist)
\(See 'apropos plist' for operations on property lists). See
ada-xref-set-default-prj-values for the list of valid properties. The
current project is retrieved with ada-xref-current-project. Properties
are retrieved with ada-xref-get-project-field, set with
ada-xref-set-project-field. If project properties are accessed with no
project file, a (nil . default-properties) entry is created.")
;; ----- Identlist manipulation -------------------------------------------
;; An identlist is a vector that is used internally to reference an identifier
;; To facilitate its use, we provide the following macros
(defmacro ada-make-identlist () (make-vector 8 nil))
(defmacro ada-name-of (identlist) (list 'aref identlist 0))
(defmacro ada-line-of (identlist) (list 'aref identlist 1))
(defmacro ada-column-of (identlist) (list 'aref identlist 2))
(defmacro ada-file-of (identlist) (list 'aref identlist 3))
(defmacro ada-ali-index-of (identlist) (list 'aref identlist 4))
(defmacro ada-declare-file-of (identlist) (list 'aref identlist 5))
(defmacro ada-references-of (identlist) (list 'aref identlist 6))
(defmacro ada-on-declaration (identlist) (list 'aref identlist 7))
(defmacro ada-set-name (identlist name) (list 'aset identlist 0 name))
(defmacro ada-set-line (identlist line) (list 'aset identlist 1 line))
(defmacro ada-set-column (identlist col) (list 'aset identlist 2 col))
(defmacro ada-set-file (identlist file) (list 'aset identlist 3 file))
(defmacro ada-set-ali-index (identlist index) (list 'aset identlist 4 index))
(defmacro ada-set-declare-file (identlist file) (list 'aset identlist 5 file))
(defmacro ada-set-references (identlist ref) (list 'aset identlist 6 ref))
(defmacro ada-set-on-declaration (ident value) (list 'aset ident 7 value))
(defsubst ada-get-ali-buffer (file)
"Read the ali file FILE into a new buffer, and return the buffer's name."
(find-file-noselect (ada-get-ali-file-name file)))
;; -----------------------------------------------------------------------
(defun ada-quote-cmd (cmd)
"Duplicate all \\ characters in CMD so that it can be passed to `compile'."
(mapconcat 'identity (split-string cmd "\\\\") "\\\\"))
(defun ada-find-executable (exec-name)
"Find the full path to the executable file EXEC-NAME.
On Windows systems, this will properly handle .exe extension as well"
(or (ada-find-file-in-dir exec-name exec-path)
(ada-find-file-in-dir (concat exec-name ".exe") exec-path)
exec-name))
(defun ada-initialize-runtime-library (cross-prefix)
"Initialize the variables for the runtime library location.
CROSS-PREFIX is the prefix to use for the `gnatls' command."
(save-excursion
(setq ada-xref-runtime-library-specs-path '()
ada-xref-runtime-library-ali-path '())
(set-buffer (get-buffer-create "*gnatls*"))
(widen)
(erase-buffer)
;; Catch any error in the following form (i.e gnatls was not found)
(condition-case nil
;; Even if we get an error, delete the *gnatls* buffer
(unwind-protect
(progn
(let ((gnatls
(ada-find-executable (concat cross-prefix "gnatls"))))
(apply 'call-process gnatls (append '(nil t nil) ada-gnatls-args)))
(goto-char (point-min))
;; Source path
(search-forward "Source Search Path:")
(forward-line 1)
(while (not (looking-at "^$"))
(back-to-indentation)
(if (looking-at "<Current_Directory>")
(add-to-list 'ada-xref-runtime-library-specs-path ".")
(add-to-list 'ada-xref-runtime-library-specs-path
(buffer-substring-no-properties
(point)
(save-excursion (end-of-line) (point)))))
(forward-line 1))
;; Object path
(search-forward "Object Search Path:")
(forward-line 1)
(while (not (looking-at "^$"))
(back-to-indentation)
(if (looking-at "<Current_Directory>")
(add-to-list 'ada-xref-runtime-library-ali-path ".")
(add-to-list 'ada-xref-runtime-library-ali-path
(buffer-substring-no-properties
(point)
(save-excursion (end-of-line) (point)))))
(forward-line 1))
)
(kill-buffer nil))
(error nil))
(set 'ada-xref-runtime-library-specs-path
(reverse ada-xref-runtime-library-specs-path))
(set 'ada-xref-runtime-library-ali-path
(reverse ada-xref-runtime-library-ali-path))
))
(defun ada-treat-cmd-string (cmd-string)
"Replace meta-sequences like ${...} in CMD-STRING with the appropriate value.
Assumes project exists.
As a special case, ${current} is replaced with the name of the current
file, minus extension but with directory, and ${full_current} is
replaced by the name including the extension."
(while (string-match "\\(-[^-\$IO]*[IO]\\)?\${\\([^}]+\\)}" cmd-string)
(let (value
(name (match-string 2 cmd-string)))
(cond
((string= name "current")
(setq value (file-name-sans-extension (buffer-file-name))))
((string= name "full_current")
(setq value (buffer-file-name)))
(t
(save-match-data
(setq value (ada-xref-get-project-field (intern name))))))
;; Check if there is an environment variable with the same name
(if (null value)
(if (not (setq value (getenv name)))
(message "%s" (concat "No environment variable " name " found"))))
(cond
((null value)
(setq cmd-string (replace-match "" t t cmd-string)))
((stringp value)
(setq cmd-string (replace-match value t t cmd-string)))
((listp value)
(let ((prefix (match-string 1 cmd-string)))
(setq cmd-string (replace-match
(mapconcat (lambda(x) (concat prefix x)) value " ")
t t cmd-string)))))
))
cmd-string)
(defun ada-xref-set-default-prj-values (symbol ada-buffer)
"Reset the properties in SYMBOL to the default values for ADA-BUFFER."
(let ((file (buffer-file-name ada-buffer))
plist)
(save-excursion
(set-buffer ada-buffer)
(set 'plist
;; Try hard to find a project file, even if the current
;; buffer is not an Ada file or not associated with a file
(list 'filename (expand-file-name
(cond
(ada-prj-default-project-file
ada-prj-default-project-file)
(file (ada-prj-find-prj-file file t))
(t
(message (concat "Not editing an Ada file,"
"and no default project "
"file specified!"))
"")))
'build_dir (file-name-as-directory (expand-file-name "."))
'src_dir (list ".")
'obj_dir (list ".")
'casing (if (listp ada-case-exception-file)
ada-case-exception-file
(list ada-case-exception-file))
'comp_opt ada-prj-default-comp-opt
'bind_opt ada-prj-default-bind-opt
'link_opt ada-prj-default-link-opt
'gnatmake_opt ada-prj-default-gnatmake-opt
'gnatfind_opt ada-prj-gnatfind-switches
'main (if file
(file-name-nondirectory
(file-name-sans-extension file))
"")
'main_unit (if file
(file-name-nondirectory
(file-name-sans-extension file))
"")
'cross_prefix ""
'remote_machine ""
'comp_cmd (list ada-prj-default-comp-cmd)
'check_cmd (list ada-prj-default-check-cmd)
'make_cmd (list ada-prj-default-make-cmd)
'run_cmd (list (concat "./${main}" (if is-windows ".exe")))
'debug_pre_cmd (list (concat ada-cd-command " ${build_dir}"))
'debug_cmd (concat ada-prj-default-debugger
" ${main}" (if is-windows ".exe"))
'debug_post_cmd (list nil)))
)
(set symbol plist)))
(defun ada-xref-get-project-field (field)
"Extract the value of FIELD from the current project file.
Project variables are substituted.
Note that for src_dir and obj_dir, you should rather use
`ada-xref-get-src-dir-field' or `ada-xref-get-obj-dir-field' which will in
addition return the default paths."
(let ((file-name ada-prj-default-project-file)
file value)
;; Get the project file (either the current one, or a default one)
(setq file (or (assoc file-name ada-xref-project-files)
(assoc nil ada-xref-project-files)))
;; If the file was not found, use the default values
(if file
;; Get the value from the file
(set 'value (plist-get (cdr file) field))
;; Create a default nil file that contains the default values
(ada-xref-set-default-prj-values 'value (current-buffer))
(add-to-list 'ada-xref-project-files (cons nil value))
(ada-xref-update-project-menu)
(set 'value (plist-get value field))
)
;; Substitute the ${...} constructs in all the strings, including
;; inside lists
(cond
((stringp value)
(ada-treat-cmd-string value))
((null value)
nil)
((listp value)
(mapcar (lambda(x) (if x (ada-treat-cmd-string x) x)) value))
(t
value)
)
))
(defun ada-xref-get-src-dir-field ()
"Return the full value for src_dir, including the default directories.
All the directories are returned as absolute directories."
(let ((build-dir (ada-xref-get-project-field 'build_dir)))
(append
;; Add ${build_dir} in front of the path
(list build-dir)
(ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir)
build-dir)
;; Add the standard runtime at the end
ada-xref-runtime-library-specs-path)))
(defun ada-xref-get-obj-dir-field ()
"Return the full value for obj_dir, including the default directories.
All the directories are returned as absolute directories."
(let ((build-dir (ada-xref-get-project-field 'build_dir)))
(append
;; Add ${build_dir} in front of the path
(list build-dir)
(ada-get-absolute-dir-list (ada-xref-get-project-field 'obj_dir)
build-dir)
;; Add the standard runtime at the end
ada-xref-runtime-library-ali-path)))
(defun ada-xref-update-project-menu ()
"Update the menu Ada->Project, with the list of available project files."
;; Create the standard items.
(let ((submenu
`("Project"
["Load..." ada-set-default-project-file t]
["New..." ada-prj-new t]
["Edit..." ada-prj-edit t]
"---"
;; Add the new items
,@(mapcar
(lambda (x)
(let ((name (or (car x) "<default>"))
(command `(lambda ()
"Change the active project file."
(interactive)
(ada-parse-prj-file ,(car x))
(set 'ada-prj-default-project-file ,(car x))
(ada-xref-update-project-menu))))
(vector
(if (string= (file-name-extension name)
ada-prj-file-extension)
(file-name-sans-extension
(file-name-nondirectory name))
(file-name-nondirectory name))
command
:button (cons
:toggle
(equal ada-prj-default-project-file
(car x))
))))
;; Parses all the known project files, and insert at
;; least the default one (in case
;; ada-xref-project-files is nil)
(or ada-xref-project-files '(nil))))))
(easy-menu-add-item ada-mode-menu '() submenu)))
;;-------------------------------------------------------------
;;-- Searching a file anywhere on the source path.
;;--
;;-- The following functions provide support for finding a file anywhere
;;-- on the source path, without providing an explicit directory.
;;-- They also provide file name completion in the minibuffer.
;;--
;;-- Public subprograms: ada-find-file
;;--
;;-------------------------------------------------------------
(defun ada-do-file-completion (string predicate flag)
"Completion function when reading a file from the minibuffer.
Completion is attempted in all the directories in the source path, as
defined in the project file."
;; FIXME: doc arguments
(let (list
(dirs (ada-xref-get-src-dir-field)))
(while dirs
(if (file-directory-p (car dirs))
(set 'list (append list (file-name-all-completions string (car dirs)))))
(set 'dirs (cdr dirs)))
(cond ((equal flag 'lambda)
(assoc string list))
(flag
list)
(t
(try-completion string
(mapcar (lambda (x) (cons x 1)) list)
predicate)))))
;;;###autoload
(defun ada-find-file (filename)
"Open FILENAME, from anywhere in the source path.
Completion is available."
(interactive
(list (completing-read "File: " 'ada-do-file-completion)))
(let ((file (ada-find-src-file-in-dir filename)))
(if file
(find-file file)
(error (concat filename " not found in src_dir")))))
;; ----- Utilities -------------------------------------------------
(defun ada-require-project-file ()
"If no project file is currently active, load a default one."
(if (or (not ada-prj-default-project-file)
(not ada-xref-project-files)
(string= ada-prj-default-project-file ""))
(ada-reread-prj-file)))
(defun ada-xref-push-pos (filename position)
"Push (FILENAME, POSITION) on the position ring for cross-references."
(setq ada-xref-pos-ring (cons (list position filename) ada-xref-pos-ring))
(if (> (length ada-xref-pos-ring) ada-xref-pos-ring-max)
(setcdr (nthcdr (1- ada-xref-pos-ring-max) ada-xref-pos-ring) nil)))
(defun ada-xref-goto-previous-reference ()
"Go to the previous cross-reference we were on."
(interactive)
(if ada-xref-pos-ring
(let ((pos (car ada-xref-pos-ring)))
(setq ada-xref-pos-ring (cdr ada-xref-pos-ring))
(find-file (car (cdr pos)))
(goto-char (car pos)))))
(defun ada-convert-file-name (name)
"Convert from NAME to a name that can be used by the compilation commands.
This is overriden on VMS to convert from VMS filenames to Unix filenames."
name)
;; FIXME: use convert-standard-filename instead
(defun ada-set-default-project-file (name &optional keep-existing)
"Set the file whose name is NAME as the default project file.
If KEEP-EXISTING is true and a project file has already been loaded, nothing
is done. This is meant to be used from `ada-mode-hook', for instance, to force
a project file unless the user has already loaded one."
(interactive "fProject file:")
(if (or (not keep-existing)
(not ada-prj-default-project-file)
(equal ada-prj-default-project-file ""))
(progn
(setq ada-prj-default-project-file name)
(ada-reread-prj-file name))))
;; ------ Handling the project file -----------------------------
(defun ada-prj-find-prj-file (&optional file no-user-question)
"Find the prj file associated with FILE (or the current buffer if nil).
If NO-USER-QUESTION is non-nil, use a default file if not project file was
found, and do not ask the user.
If the buffer is not an Ada buffer, associate it with the default project
file. If none is set, return nil."
(let (selected)
;; Use the active project file if there is one.
;; This is also valid if we don't currently have an Ada buffer, or if
;; the current buffer is not a real file (for instance an emerge buffer)
(if (or (not (string= mode-name "Ada"))
(not (buffer-file-name)))
(if (and ada-prj-default-project-file
(not (string= ada-prj-default-project-file "")))
(setq selected ada-prj-default-project-file)
(setq selected nil))
;; other cases: use a more complex algorithm
(let* ((current-file (or file (buffer-file-name)))
(first-choice (concat
(file-name-sans-extension current-file)
ada-prj-file-extension))
(dir (file-name-directory current-file))
;; on Emacs 20.2, directory-files does not work if
;; parse-sexp-lookup-properties is set
(parse-sexp-lookup-properties nil)
(prj-files (directory-files
dir t
(concat ".*" (regexp-quote
ada-prj-file-extension) "$")))
(choice nil))
(cond
;; Else if there is a project file with the same name as the Ada
;; file, but not the same extension.
((file-exists-p first-choice)
(set 'selected first-choice))
;; Else if only one project file was found in the current directory
((= (length prj-files) 1)
(set 'selected (car prj-files)))
;; Else if there are multiple files, ask the user
((and (> (length prj-files) 1) (not no-user-question))
(save-window-excursion
(with-output-to-temp-buffer "*choice list*"
(princ "There are more than one possible project file.\n")
(princ "Which one should we use ?\n\n")
(princ " no. file name \n")
(princ " --- ------------------------\n")
(let ((counter 1))
(while (<= counter (length prj-files))
(princ (format " %2d) %s\n"
counter
(nth (1- counter) prj-files)))
(setq counter (1+ counter))
))) ; end of with-output-to ...
(setq choice nil)
(while (or
(not choice)
(not (integerp choice))
(< choice 1)
(> choice (length prj-files)))
(setq choice (string-to-number
(read-from-minibuffer "Enter No. of your choice: "))))
(set 'selected (nth (1- choice) prj-files))))
;; Else if no project file was found in the directory, ask a name
;; to the user, using as a default value the last one entered by
;; the user
((= (length prj-files) 0)
(unless (or no-user-question (not ada-always-ask-project))
(setq ada-last-prj-file
(read-file-name
(concat "project file [" ada-last-prj-file "]:")
nil ada-last-prj-file))
(unless (string= ada-last-prj-file "")
(set 'selected ada-last-prj-file))))
)))
(or selected "default.adp")
))
(defun ada-parse-prj-file (prj-file)
"Read PRJ-FILE, set it as the active project."
;; FIXME: doc nil, search, etc.
(if prj-file
(let (project src_dir obj_dir make_cmd comp_cmd check_cmd casing
run_cmd debug_pre_cmd debug_post_cmd
(ada-buffer (current-buffer)))
(setq prj-file (expand-file-name prj-file))
;; Set the project file as the active one.
(setq ada-prj-default-project-file prj-file)
;; Initialize the project with the default values
(ada-xref-set-default-prj-values 'project (current-buffer))
;; Do not use find-file below, since we don't want to show this
;; buffer. If the file is open through speedbar, we can't use
;; find-file anyway, since the speedbar frame is special and does not
;; allow the selection of a file in it.
(if (file-exists-p prj-file)
(progn
(let* ((buffer (run-hook-with-args-until-success
'ada-load-project-hook prj-file)))
(unless buffer
(setq buffer (find-file-noselect prj-file nil)))
(set-buffer buffer))
(widen)
(goto-char (point-min))
;; Now overrides these values with the project file
(while (not (eobp))
(if (looking-at "^\\([^=]+\\)=\\(.*\\)")
(cond
;; fields that are lists or paths require special processing
;; FIXME: strip trailing spaces
((string= (match-string 1) "src_dir")
(add-to-list 'src_dir
(file-name-as-directory (match-string 2))))
((string= (match-string 1) "obj_dir")
(add-to-list 'obj_dir
(file-name-as-directory (match-string 2))))
((string= (match-string 1) "casing")
(set 'casing (cons (match-string 2) casing)))
((string= (match-string 1) "build_dir")
(set 'project
(plist-put project 'build_dir
(file-name-as-directory (match-string 2)))))
((string= (match-string 1) "make_cmd")
(add-to-list 'make_cmd (match-string 2)))
((string= (match-string 1) "comp_cmd")
(add-to-list 'comp_cmd (match-string 2)))
((string= (match-string 1) "check_cmd")
(add-to-list 'check_cmd (match-string 2)))
((string= (match-string 1) "run_cmd")
(add-to-list 'run_cmd (match-string 2)))
((string= (match-string 1) "debug_pre_cmd")
(add-to-list 'debug_pre_cmd (match-string 2)))
((string= (match-string 1) "debug_post_cmd")
(add-to-list 'debug_post_cmd (match-string 2)))
(t
;; any other field in the file is just copied
(set 'project (plist-put project (intern (match-string 1))
(match-string 2))))))
(forward-line 1))
(if src_dir (set 'project (plist-put project 'src_dir
(reverse src_dir))))
(if obj_dir (set 'project (plist-put project 'obj_dir
(reverse obj_dir))))
(if casing (set 'project (plist-put project 'casing
(reverse casing))))
(if make_cmd (set 'project (plist-put project 'make_cmd
(reverse make_cmd))))
(if comp_cmd (set 'project (plist-put project 'comp_cmd
(reverse comp_cmd))))
(if check_cmd (set 'project (plist-put project 'check_cmd
(reverse check_cmd))))
(if run_cmd (set 'project (plist-put project 'run_cmd
(reverse run_cmd))))
(if debug_post_cmd (set 'project (plist-put project 'debug_post_cmd
(reverse debug_post_cmd))))
(if debug_pre_cmd (set 'project (plist-put project 'debug_pre_cmd
(reverse debug_pre_cmd))))
;; Kill the project buffer
(kill-buffer nil)
(set-buffer ada-buffer)
)
;; Else the file wasn't readable (probably the default project).
;; We initialize it with the current environment variables.
;; We need to add the startup directory in front so that
;; files locally redefined are properly found. We cannot
;; add ".", which varies too much depending on what the
;; current buffer is.
(set 'project
(plist-put project 'src_dir
(append
(list command-line-default-directory)
(split-string (or (getenv "ADA_INCLUDE_PATH") "") ":")
(list "." default-directory))))
(set 'project
(plist-put project 'obj_dir
(append
(list command-line-default-directory)
(split-string (or (getenv "ADA_OBJECTS_PATH") "") ":")
(list "." default-directory))))
)
;; Delete the default project file from the list, if it is there.
;; Note that in that case, this default project is the only one in
;; the list
(if (assoc nil ada-xref-project-files)
(setq ada-xref-project-files nil))
;; Memorize the newly read project file
(if (assoc prj-file ada-xref-project-files)
(setcdr (assoc prj-file ada-xref-project-files) project)
(add-to-list 'ada-xref-project-files (cons prj-file project)))
;; Sets up the compilation-search-path so that Emacs is able to
;; go to the source of the errors in a compilation buffer
(setq compilation-search-path (ada-xref-get-src-dir-field))
;; Set the casing exceptions file list
(if casing
(progn
(setq ada-case-exception-file (reverse casing))
(ada-case-read-exceptions)))
;; Add the directories to the search path for ff-find-other-file
;; Do not add the '/' or '\' at the end
(setq ada-search-directories-internal
(append (mapcar 'directory-file-name compilation-search-path)
ada-search-directories))
(ada-xref-update-project-menu)
)
;; No prj file ? => Setup default values
;; Note that nil means that all compilation modes will first look in the
;; current directory, and only then in the current file's directory. This
;; current file is assumed at this point to be in the common source
;; directory.
(setq compilation-search-path (list nil default-directory))
))
(defun ada-find-references (&optional pos arg local-only)
"Find all references to the entity under POS.
Calls gnatfind to find the references.
If ARG is t, the contents of the old *gnatfind* buffer is preserved.
If LOCAL-ONLY is t, only the declarations in the current file are returned."
(interactive "d\nP")
(ada-require-project-file)
(let* ((identlist (ada-read-identifier pos))
(alifile (ada-get-ali-file-name (ada-file-of identlist)))
(process-environment (ada-set-environment)))
(set-buffer (get-file-buffer (ada-file-of identlist)))
;; if the file is more recent than the executable
(if (or (buffer-modified-p (current-buffer))
(file-newer-than-file-p (ada-file-of identlist) alifile))
(ada-find-any-references (ada-name-of identlist)
(ada-file-of identlist)
nil nil local-only arg)
(ada-find-any-references (ada-name-of identlist)
(ada-file-of identlist)
(ada-line-of identlist)
(ada-column-of identlist) local-only arg)))
)
(defun ada-find-local-references (&optional pos arg)
"Find all references to the entity under POS.
Calls `gnatfind' to find the references.
If ARG is t, the contents of the old *gnatfind* buffer is preserved."
(interactive "d\nP")
(ada-find-references pos arg t))
(defun ada-find-any-references
(entity &optional file line column local-only append)
"Search for references to any entity whose name is ENTITY.
ENTITY was first found the location given by FILE, LINE and COLUMN.
If LOCAL-ONLY is t, then list only the references in FILE, which
is much faster.
If APPEND is t, then append the output of the command to the existing
buffer `*gnatfind*', if there is one."
(interactive "sEntity name: ")
(ada-require-project-file)
;; Prepare the gnatfind command. Note that we must protect the quotes
;; around operators, so that they are correctly handled and can be
;; processed (gnatfind \"+\":...).
(let* ((quote-entity
(if (= (aref entity 0) ?\")
(if is-windows
(concat "\\\"" (substring entity 1 -1) "\\\"")
(concat "'\"" (substring entity 1 -1) "\"'"))
entity))
(switches (ada-xref-get-project-field 'gnatfind_opt))
(command (concat "gnat find " switches " "
quote-entity
(if file (concat ":" (file-name-nondirectory file)))
(if line (concat ":" line))
(if column (concat ":" column))
(if local-only (concat " " (file-name-nondirectory file)))
))
old-contents)
;; If a project file is defined, use it
(if (and ada-prj-default-project-file
(not (string= ada-prj-default-project-file "")))
(if (string-equal (file-name-extension ada-prj-default-project-file)
"gpr")
(setq command (concat command " -P" ada-prj-default-project-file))
(setq command (concat command " -p" ada-prj-default-project-file))))
(if (and append (get-buffer "*gnatfind*"))
(save-excursion
(set-buffer "*gnatfind*")
(setq old-contents (buffer-string))))
(let ((compilation-error "reference"))
(compilation-start command))
;; Hide the "Compilation" menu
(save-excursion
(set-buffer "*gnatfind*")
(local-unset-key [menu-bar compilation-menu])
(if old-contents
(progn
(goto-char 1)
(insert old-contents)
(goto-char (point-max)))))
)
)
(defalias 'ada-change-prj (symbol-function 'ada-set-default-project-file))
;; ----- Identifier Completion --------------------------------------------
(defun ada-complete-identifier (pos)
"Try to complete the identifier around POS, using compiler cross-reference information."
(interactive "d")
(ada-require-project-file)
;; Initialize function-local variables and jump to the .ali buffer
;; Note that for regexp search is case insensitive too
(let* ((curbuf (current-buffer))
(identlist (ada-read-identifier pos))
(sofar (concat "^[0-9]+[a-zA-Z][0-9]+[ *]\\("
(regexp-quote (ada-name-of identlist))
"[a-zA-Z0-9_]*\\)"))
(completed nil)
(symalist nil))
;; Open the .ali file
(set-buffer (ada-get-ali-buffer (buffer-file-name)))
(goto-char (point-max))
;; build an alist of possible completions
(while (re-search-backward sofar nil t)
(setq symalist (cons (cons (match-string 1) nil) symalist)))
(setq completed (try-completion "" symalist))
;; kills .ali buffer
(kill-buffer nil)
;; deletes the incomplete identifier in the buffer
(set-buffer curbuf)
(looking-at "[a-zA-Z0-9_]+")
(replace-match "")
;; inserts the completed symbol
(insert completed)
))
;; ----- Cross-referencing ----------------------------------------
(defun ada-point-and-xref ()
"Jump to the declaration of the entity below the cursor."
(interactive)
(mouse-set-point last-input-event)
(ada-goto-declaration (point)))
(defun ada-point-and-xref-body ()
"Jump to the body of the entity under the cursor."
(interactive)