re PR fortran/36325 (specific or generic INTERFACE implies the EXTERNAL attribute)
[gcc.git] / gcc / fortran / symbol.c
1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
21
22
23 #include "config.h"
24 #include "system.h"
25 #include "flags.h"
26 #include "gfortran.h"
27 #include "parse.h"
28
29
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
32 modules. */
33
34 const mstring flavors[] =
35 {
36 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
38 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
39 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
40 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
41 minit (NULL, -1)
42 };
43
44 const mstring procedures[] =
45 {
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
47 minit ("MODULE-PROC", PROC_MODULE),
48 minit ("INTERNAL-PROC", PROC_INTERNAL),
49 minit ("DUMMY-PROC", PROC_DUMMY),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
53 minit (NULL, -1)
54 };
55
56 const mstring intents[] =
57 {
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
59 minit ("IN", INTENT_IN),
60 minit ("OUT", INTENT_OUT),
61 minit ("INOUT", INTENT_INOUT),
62 minit (NULL, -1)
63 };
64
65 const mstring access_types[] =
66 {
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
68 minit ("PUBLIC", ACCESS_PUBLIC),
69 minit ("PRIVATE", ACCESS_PRIVATE),
70 minit (NULL, -1)
71 };
72
73 const mstring ifsrc_types[] =
74 {
75 minit ("UNKNOWN", IFSRC_UNKNOWN),
76 minit ("DECL", IFSRC_DECL),
77 minit ("BODY", IFSRC_IFBODY),
78 minit ("USAGE", IFSRC_USAGE)
79 };
80
81 const mstring save_status[] =
82 {
83 minit ("UNKNOWN", SAVE_NONE),
84 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
85 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
86 };
87
88 /* This is to make sure the backend generates setup code in the correct
89 order. */
90
91 static int next_dummy_order = 1;
92
93
94 gfc_namespace *gfc_current_ns;
95
96 gfc_gsymbol *gfc_gsym_root = NULL;
97
98 static gfc_symbol *changed_syms = NULL;
99
100 gfc_dt_list *gfc_derived_types;
101
102
103 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
104
105 /* The following static variable indicates whether a particular element has
106 been explicitly set or not. */
107
108 static int new_flag[GFC_LETTERS];
109
110
111 /* Handle a correctly parsed IMPLICIT NONE. */
112
113 void
114 gfc_set_implicit_none (void)
115 {
116 int i;
117
118 if (gfc_current_ns->seen_implicit_none)
119 {
120 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
121 return;
122 }
123
124 gfc_current_ns->seen_implicit_none = 1;
125
126 for (i = 0; i < GFC_LETTERS; i++)
127 {
128 gfc_clear_ts (&gfc_current_ns->default_type[i]);
129 gfc_current_ns->set_flag[i] = 1;
130 }
131 }
132
133
134 /* Reset the implicit range flags. */
135
136 void
137 gfc_clear_new_implicit (void)
138 {
139 int i;
140
141 for (i = 0; i < GFC_LETTERS; i++)
142 new_flag[i] = 0;
143 }
144
145
146 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
147
148 try
149 gfc_add_new_implicit_range (int c1, int c2)
150 {
151 int i;
152
153 c1 -= 'a';
154 c2 -= 'a';
155
156 for (i = c1; i <= c2; i++)
157 {
158 if (new_flag[i])
159 {
160 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
161 i + 'A');
162 return FAILURE;
163 }
164
165 new_flag[i] = 1;
166 }
167
168 return SUCCESS;
169 }
170
171
172 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
173 the new implicit types back into the existing types will work. */
174
175 try
176 gfc_merge_new_implicit (gfc_typespec *ts)
177 {
178 int i;
179
180 if (gfc_current_ns->seen_implicit_none)
181 {
182 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
183 return FAILURE;
184 }
185
186 for (i = 0; i < GFC_LETTERS; i++)
187 {
188 if (new_flag[i])
189 {
190
191 if (gfc_current_ns->set_flag[i])
192 {
193 gfc_error ("Letter %c already has an IMPLICIT type at %C",
194 i + 'A');
195 return FAILURE;
196 }
197 gfc_current_ns->default_type[i] = *ts;
198 gfc_current_ns->set_flag[i] = 1;
199 }
200 }
201 return SUCCESS;
202 }
203
204
205 /* Given a symbol, return a pointer to the typespec for its default type. */
206
207 gfc_typespec *
208 gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
209 {
210 char letter;
211
212 letter = sym->name[0];
213
214 if (gfc_option.flag_allow_leading_underscore && letter == '_')
215 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
216 "gfortran developers, and should not be used for "
217 "implicitly typed variables");
218
219 if (letter < 'a' || letter > 'z')
220 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
221
222 if (ns == NULL)
223 ns = gfc_current_ns;
224
225 return &ns->default_type[letter - 'a'];
226 }
227
228
229 /* Given a pointer to a symbol, set its type according to the first
230 letter of its name. Fails if the letter in question has no default
231 type. */
232
233 try
234 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
235 {
236 gfc_typespec *ts;
237
238 if (sym->ts.type != BT_UNKNOWN)
239 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
240
241 ts = gfc_get_default_type (sym, ns);
242
243 if (ts->type == BT_UNKNOWN)
244 {
245 if (error_flag && !sym->attr.untyped)
246 {
247 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
248 sym->name, &sym->declared_at);
249 sym->attr.untyped = 1; /* Ensure we only give an error once. */
250 }
251
252 return FAILURE;
253 }
254
255 sym->ts = *ts;
256 sym->attr.implicit_type = 1;
257
258 if (sym->attr.is_bind_c == 1)
259 {
260 /* BIND(C) variables should not be implicitly declared. */
261 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
262 "not be C interoperable", sym->name, &sym->declared_at);
263 sym->ts.f90_type = sym->ts.type;
264 }
265
266 if (sym->attr.dummy != 0)
267 {
268 if (sym->ns->proc_name != NULL
269 && (sym->ns->proc_name->attr.subroutine != 0
270 || sym->ns->proc_name->attr.function != 0)
271 && sym->ns->proc_name->attr.is_bind_c != 0)
272 {
273 /* Dummy args to a BIND(C) routine may not be interoperable if
274 they are implicitly typed. */
275 gfc_warning_now ("Implicity declared variable '%s' at %L may not "
276 "be C interoperable but it is a dummy argument to "
277 "the BIND(C) procedure '%s' at %L", sym->name,
278 &(sym->declared_at), sym->ns->proc_name->name,
279 &(sym->ns->proc_name->declared_at));
280 sym->ts.f90_type = sym->ts.type;
281 }
282 }
283
284 return SUCCESS;
285 }
286
287
288 /* This function is called from parse.c(parse_progunit) to check the
289 type of the function is not implicitly typed in the host namespace
290 and to implicitly type the function result, if necessary. */
291
292 void
293 gfc_check_function_type (gfc_namespace *ns)
294 {
295 gfc_symbol *proc = ns->proc_name;
296
297 if (!proc->attr.contained || proc->result->attr.implicit_type)
298 return;
299
300 if (proc->result->ts.type == BT_UNKNOWN)
301 {
302 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
303 == SUCCESS)
304 {
305 if (proc->result != proc)
306 {
307 proc->ts = proc->result->ts;
308 proc->as = gfc_copy_array_spec (proc->result->as);
309 proc->attr.dimension = proc->result->attr.dimension;
310 proc->attr.pointer = proc->result->attr.pointer;
311 proc->attr.allocatable = proc->result->attr.allocatable;
312 }
313 }
314 else
315 {
316 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
317 proc->result->name, &proc->result->declared_at);
318 proc->result->attr.untyped = 1;
319 }
320 }
321 }
322
323
324 /******************** Symbol attribute stuff *********************/
325
326 /* This is a generic conflict-checker. We do this to avoid having a
327 single conflict in two places. */
328
329 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
330 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
331 #define conf_std(a, b, std) if (attr->a && attr->b)\
332 {\
333 a1 = a;\
334 a2 = b;\
335 standard = std;\
336 goto conflict_std;\
337 }
338
339 static try
340 check_conflict (symbol_attribute *attr, const char *name, locus *where)
341 {
342 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
343 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
344 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
345 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
346 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
347 *private = "PRIVATE", *recursive = "RECURSIVE",
348 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
349 *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
350 *function = "FUNCTION", *subroutine = "SUBROUTINE",
351 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
352 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
353 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
354 *volatile_ = "VOLATILE", *protected = "PROTECTED",
355 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
356 static const char *threadprivate = "THREADPRIVATE";
357
358 const char *a1, *a2;
359 int standard;
360
361 if (where == NULL)
362 where = &gfc_current_locus;
363
364 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
365 {
366 a1 = pointer;
367 a2 = intent;
368 standard = GFC_STD_F2003;
369 goto conflict_std;
370 }
371
372 /* Check for attributes not allowed in a BLOCK DATA. */
373 if (gfc_current_state () == COMP_BLOCK_DATA)
374 {
375 a1 = NULL;
376
377 if (attr->in_namelist)
378 a1 = in_namelist;
379 if (attr->allocatable)
380 a1 = allocatable;
381 if (attr->external)
382 a1 = external;
383 if (attr->optional)
384 a1 = optional;
385 if (attr->access == ACCESS_PRIVATE)
386 a1 = private;
387 if (attr->access == ACCESS_PUBLIC)
388 a1 = public;
389 if (attr->intent != INTENT_UNKNOWN)
390 a1 = intent;
391
392 if (a1 != NULL)
393 {
394 gfc_error
395 ("%s attribute not allowed in BLOCK DATA program unit at %L",
396 a1, where);
397 return FAILURE;
398 }
399 }
400
401 if (attr->save == SAVE_EXPLICIT)
402 {
403 conf (dummy, save);
404 conf (in_common, save);
405 conf (result, save);
406
407 switch (attr->flavor)
408 {
409 case FL_PROGRAM:
410 case FL_BLOCK_DATA:
411 case FL_MODULE:
412 case FL_LABEL:
413 case FL_PROCEDURE:
414 case FL_DERIVED:
415 case FL_PARAMETER:
416 a1 = gfc_code2string (flavors, attr->flavor);
417 a2 = save;
418 goto conflict;
419
420 case FL_VARIABLE:
421 case FL_NAMELIST:
422 default:
423 break;
424 }
425 }
426
427 conf (dummy, entry);
428 conf (dummy, intrinsic);
429 conf (dummy, threadprivate);
430 conf (pointer, target);
431 conf (pointer, intrinsic);
432 conf (pointer, elemental);
433 conf (allocatable, elemental);
434
435 conf (target, external);
436 conf (target, intrinsic);
437
438 if (!attr->if_source)
439 conf (external, dimension); /* See Fortran 95's R504. */
440
441 conf (external, intrinsic);
442 conf (entry, intrinsic);
443
444 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
445 {
446 conf (external, subroutine);
447 conf (external, function);
448 }
449
450 conf (allocatable, pointer);
451 conf_std (allocatable, dummy, GFC_STD_F2003);
452 conf_std (allocatable, function, GFC_STD_F2003);
453 conf_std (allocatable, result, GFC_STD_F2003);
454 conf (elemental, recursive);
455
456 conf (in_common, dummy);
457 conf (in_common, allocatable);
458 conf (in_common, result);
459
460 conf (dummy, result);
461
462 conf (in_equivalence, use_assoc);
463 conf (in_equivalence, dummy);
464 conf (in_equivalence, target);
465 conf (in_equivalence, pointer);
466 conf (in_equivalence, function);
467 conf (in_equivalence, result);
468 conf (in_equivalence, entry);
469 conf (in_equivalence, allocatable);
470 conf (in_equivalence, threadprivate);
471
472 conf (in_namelist, pointer);
473 conf (in_namelist, allocatable);
474
475 conf (entry, result);
476
477 conf (function, subroutine);
478
479 if (!function && !subroutine)
480 conf (is_bind_c, dummy);
481
482 conf (is_bind_c, cray_pointer);
483 conf (is_bind_c, cray_pointee);
484 conf (is_bind_c, allocatable);
485 conf (is_bind_c, elemental);
486
487 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
488 Parameter conflict caught below. Also, value cannot be specified
489 for a dummy procedure. */
490
491 /* Cray pointer/pointee conflicts. */
492 conf (cray_pointer, cray_pointee);
493 conf (cray_pointer, dimension);
494 conf (cray_pointer, pointer);
495 conf (cray_pointer, target);
496 conf (cray_pointer, allocatable);
497 conf (cray_pointer, external);
498 conf (cray_pointer, intrinsic);
499 conf (cray_pointer, in_namelist);
500 conf (cray_pointer, function);
501 conf (cray_pointer, subroutine);
502 conf (cray_pointer, entry);
503
504 conf (cray_pointee, allocatable);
505 conf (cray_pointee, intent);
506 conf (cray_pointee, optional);
507 conf (cray_pointee, dummy);
508 conf (cray_pointee, target);
509 conf (cray_pointee, intrinsic);
510 conf (cray_pointee, pointer);
511 conf (cray_pointee, entry);
512 conf (cray_pointee, in_common);
513 conf (cray_pointee, in_equivalence);
514 conf (cray_pointee, threadprivate);
515
516 conf (data, dummy);
517 conf (data, function);
518 conf (data, result);
519 conf (data, allocatable);
520 conf (data, use_assoc);
521
522 conf (value, pointer)
523 conf (value, allocatable)
524 conf (value, subroutine)
525 conf (value, function)
526 conf (value, volatile_)
527 conf (value, dimension)
528 conf (value, external)
529
530 if (attr->value
531 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
532 {
533 a1 = value;
534 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
535 goto conflict;
536 }
537
538 conf (protected, intrinsic)
539 conf (protected, external)
540 conf (protected, in_common)
541
542 conf (volatile_, intrinsic)
543 conf (volatile_, external)
544
545 if (attr->volatile_ && attr->intent == INTENT_IN)
546 {
547 a1 = volatile_;
548 a2 = intent_in;
549 goto conflict;
550 }
551
552 conf (procedure, allocatable)
553 conf (procedure, dimension)
554 conf (procedure, intrinsic)
555 conf (procedure, protected)
556 conf (procedure, target)
557 conf (procedure, value)
558 conf (procedure, volatile_)
559 conf (procedure, entry)
560 /* TODO: Implement procedure pointers. */
561 if (attr->procedure && attr->pointer)
562 {
563 gfc_error ("Fortran 2003: Procedure pointers at %L are "
564 "not yet implemented in gfortran", where);
565 return FAILURE;
566 }
567
568 a1 = gfc_code2string (flavors, attr->flavor);
569
570 if (attr->in_namelist
571 && attr->flavor != FL_VARIABLE
572 && attr->flavor != FL_PROCEDURE
573 && attr->flavor != FL_UNKNOWN)
574 {
575 a2 = in_namelist;
576 goto conflict;
577 }
578
579 switch (attr->flavor)
580 {
581 case FL_PROGRAM:
582 case FL_BLOCK_DATA:
583 case FL_MODULE:
584 case FL_LABEL:
585 conf2 (dimension);
586 conf2 (dummy);
587 conf2 (volatile_);
588 conf2 (pointer);
589 conf2 (protected);
590 conf2 (target);
591 conf2 (external);
592 conf2 (intrinsic);
593 conf2 (allocatable);
594 conf2 (result);
595 conf2 (in_namelist);
596 conf2 (optional);
597 conf2 (function);
598 conf2 (subroutine);
599 conf2 (threadprivate);
600
601 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
602 {
603 a2 = attr->access == ACCESS_PUBLIC ? public : private;
604 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
605 name, where);
606 return FAILURE;
607 }
608
609 if (attr->is_bind_c)
610 {
611 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
612 return FAILURE;
613 }
614
615 break;
616
617 case FL_VARIABLE:
618 case FL_NAMELIST:
619 break;
620
621 case FL_PROCEDURE:
622 conf2 (intent);
623
624 if (attr->subroutine)
625 {
626 conf2 (pointer);
627 conf2 (target);
628 conf2 (allocatable);
629 conf2 (result);
630 conf2 (in_namelist);
631 conf2 (dimension);
632 conf2 (function);
633 conf2 (threadprivate);
634 }
635
636 switch (attr->proc)
637 {
638 case PROC_ST_FUNCTION:
639 conf2 (in_common);
640 conf2 (dummy);
641 break;
642
643 case PROC_MODULE:
644 conf2 (dummy);
645 break;
646
647 case PROC_DUMMY:
648 conf2 (result);
649 conf2 (in_common);
650 conf2 (threadprivate);
651 break;
652
653 default:
654 break;
655 }
656
657 break;
658
659 case FL_DERIVED:
660 conf2 (dummy);
661 conf2 (pointer);
662 conf2 (target);
663 conf2 (external);
664 conf2 (intrinsic);
665 conf2 (allocatable);
666 conf2 (optional);
667 conf2 (entry);
668 conf2 (function);
669 conf2 (subroutine);
670 conf2 (threadprivate);
671
672 if (attr->intent != INTENT_UNKNOWN)
673 {
674 a2 = intent;
675 goto conflict;
676 }
677 break;
678
679 case FL_PARAMETER:
680 conf2 (external);
681 conf2 (intrinsic);
682 conf2 (optional);
683 conf2 (allocatable);
684 conf2 (function);
685 conf2 (subroutine);
686 conf2 (entry);
687 conf2 (pointer);
688 conf2 (protected);
689 conf2 (target);
690 conf2 (dummy);
691 conf2 (in_common);
692 conf2 (value);
693 conf2 (volatile_);
694 conf2 (threadprivate);
695 conf2 (value);
696 conf2 (is_bind_c);
697 break;
698
699 default:
700 break;
701 }
702
703 return SUCCESS;
704
705 conflict:
706 if (name == NULL)
707 gfc_error ("%s attribute conflicts with %s attribute at %L",
708 a1, a2, where);
709 else
710 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
711 a1, a2, name, where);
712
713 return FAILURE;
714
715 conflict_std:
716 if (name == NULL)
717 {
718 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
719 "with %s attribute at %L", a1, a2,
720 where);
721 }
722 else
723 {
724 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
725 "with %s attribute in '%s' at %L",
726 a1, a2, name, where);
727 }
728 }
729
730 #undef conf
731 #undef conf2
732 #undef conf_std
733
734
735 /* Mark a symbol as referenced. */
736
737 void
738 gfc_set_sym_referenced (gfc_symbol *sym)
739 {
740
741 if (sym->attr.referenced)
742 return;
743
744 sym->attr.referenced = 1;
745
746 /* Remember which order dummy variables are accessed in. */
747 if (sym->attr.dummy)
748 sym->dummy_order = next_dummy_order++;
749 }
750
751
752 /* Common subroutine called by attribute changing subroutines in order
753 to prevent them from changing a symbol that has been
754 use-associated. Returns zero if it is OK to change the symbol,
755 nonzero if not. */
756
757 static int
758 check_used (symbol_attribute *attr, const char *name, locus *where)
759 {
760
761 if (attr->use_assoc == 0)
762 return 0;
763
764 if (where == NULL)
765 where = &gfc_current_locus;
766
767 if (name == NULL)
768 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
769 where);
770 else
771 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
772 name, where);
773
774 return 1;
775 }
776
777
778 /* Generate an error because of a duplicate attribute. */
779
780 static void
781 duplicate_attr (const char *attr, locus *where)
782 {
783
784 if (where == NULL)
785 where = &gfc_current_locus;
786
787 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
788 }
789
790
791 /* Called from decl.c (attr_decl1) to check attributes, when declared
792 separately. */
793
794 try
795 gfc_add_attribute (symbol_attribute *attr, locus *where)
796 {
797
798 if (check_used (attr, NULL, where))
799 return FAILURE;
800
801 return check_conflict (attr, NULL, where);
802 }
803
804 try
805 gfc_add_allocatable (symbol_attribute *attr, locus *where)
806 {
807
808 if (check_used (attr, NULL, where))
809 return FAILURE;
810
811 if (attr->allocatable)
812 {
813 duplicate_attr ("ALLOCATABLE", where);
814 return FAILURE;
815 }
816
817 attr->allocatable = 1;
818 return check_conflict (attr, NULL, where);
819 }
820
821
822 try
823 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
824 {
825
826 if (check_used (attr, name, where))
827 return FAILURE;
828
829 if (attr->dimension)
830 {
831 duplicate_attr ("DIMENSION", where);
832 return FAILURE;
833 }
834
835 attr->dimension = 1;
836 return check_conflict (attr, name, where);
837 }
838
839
840 try
841 gfc_add_external (symbol_attribute *attr, locus *where)
842 {
843
844 if (check_used (attr, NULL, where))
845 return FAILURE;
846
847 if (attr->external)
848 {
849 duplicate_attr ("EXTERNAL", where);
850 return FAILURE;
851 }
852
853 attr->external = 1;
854
855 return check_conflict (attr, NULL, where);
856 }
857
858
859 try
860 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
861 {
862
863 if (check_used (attr, NULL, where))
864 return FAILURE;
865
866 if (attr->intrinsic)
867 {
868 duplicate_attr ("INTRINSIC", where);
869 return FAILURE;
870 }
871
872 attr->intrinsic = 1;
873
874 return check_conflict (attr, NULL, where);
875 }
876
877
878 try
879 gfc_add_optional (symbol_attribute *attr, locus *where)
880 {
881
882 if (check_used (attr, NULL, where))
883 return FAILURE;
884
885 if (attr->optional)
886 {
887 duplicate_attr ("OPTIONAL", where);
888 return FAILURE;
889 }
890
891 attr->optional = 1;
892 return check_conflict (attr, NULL, where);
893 }
894
895
896 try
897 gfc_add_pointer (symbol_attribute *attr, locus *where)
898 {
899
900 if (check_used (attr, NULL, where))
901 return FAILURE;
902
903 attr->pointer = 1;
904 return check_conflict (attr, NULL, where);
905 }
906
907
908 try
909 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
910 {
911
912 if (check_used (attr, NULL, where))
913 return FAILURE;
914
915 attr->cray_pointer = 1;
916 return check_conflict (attr, NULL, where);
917 }
918
919
920 try
921 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
922 {
923
924 if (check_used (attr, NULL, where))
925 return FAILURE;
926
927 if (attr->cray_pointee)
928 {
929 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
930 " statements", where);
931 return FAILURE;
932 }
933
934 attr->cray_pointee = 1;
935 return check_conflict (attr, NULL, where);
936 }
937
938
939 try
940 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
941 {
942 if (check_used (attr, name, where))
943 return FAILURE;
944
945 if (attr->protected)
946 {
947 if (gfc_notify_std (GFC_STD_LEGACY,
948 "Duplicate PROTECTED attribute specified at %L",
949 where)
950 == FAILURE)
951 return FAILURE;
952 }
953
954 attr->protected = 1;
955 return check_conflict (attr, name, where);
956 }
957
958
959 try
960 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
961 {
962
963 if (check_used (attr, name, where))
964 return FAILURE;
965
966 attr->result = 1;
967 return check_conflict (attr, name, where);
968 }
969
970
971 try
972 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
973 {
974
975 if (check_used (attr, name, where))
976 return FAILURE;
977
978 if (gfc_pure (NULL))
979 {
980 gfc_error
981 ("SAVE attribute at %L cannot be specified in a PURE procedure",
982 where);
983 return FAILURE;
984 }
985
986 if (attr->save == SAVE_EXPLICIT)
987 {
988 if (gfc_notify_std (GFC_STD_LEGACY,
989 "Duplicate SAVE attribute specified at %L",
990 where)
991 == FAILURE)
992 return FAILURE;
993 }
994
995 attr->save = SAVE_EXPLICIT;
996 return check_conflict (attr, name, where);
997 }
998
999
1000 try
1001 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1002 {
1003
1004 if (check_used (attr, name, where))
1005 return FAILURE;
1006
1007 if (attr->value)
1008 {
1009 if (gfc_notify_std (GFC_STD_LEGACY,
1010 "Duplicate VALUE attribute specified at %L",
1011 where)
1012 == FAILURE)
1013 return FAILURE;
1014 }
1015
1016 attr->value = 1;
1017 return check_conflict (attr, name, where);
1018 }
1019
1020
1021 try
1022 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1023 {
1024 /* No check_used needed as 11.2.1 of the F2003 standard allows
1025 that the local identifier made accessible by a use statement can be
1026 given a VOLATILE attribute. */
1027
1028 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1029 if (gfc_notify_std (GFC_STD_LEGACY,
1030 "Duplicate VOLATILE attribute specified at %L", where)
1031 == FAILURE)
1032 return FAILURE;
1033
1034 attr->volatile_ = 1;
1035 attr->volatile_ns = gfc_current_ns;
1036 return check_conflict (attr, name, where);
1037 }
1038
1039
1040 try
1041 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1042 {
1043
1044 if (check_used (attr, name, where))
1045 return FAILURE;
1046
1047 if (attr->threadprivate)
1048 {
1049 duplicate_attr ("THREADPRIVATE", where);
1050 return FAILURE;
1051 }
1052
1053 attr->threadprivate = 1;
1054 return check_conflict (attr, name, where);
1055 }
1056
1057
1058 try
1059 gfc_add_target (symbol_attribute *attr, locus *where)
1060 {
1061
1062 if (check_used (attr, NULL, where))
1063 return FAILURE;
1064
1065 if (attr->target)
1066 {
1067 duplicate_attr ("TARGET", where);
1068 return FAILURE;
1069 }
1070
1071 attr->target = 1;
1072 return check_conflict (attr, NULL, where);
1073 }
1074
1075
1076 try
1077 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1078 {
1079
1080 if (check_used (attr, name, where))
1081 return FAILURE;
1082
1083 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1084 attr->dummy = 1;
1085 return check_conflict (attr, name, where);
1086 }
1087
1088
1089 try
1090 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1091 {
1092
1093 if (check_used (attr, name, where))
1094 return FAILURE;
1095
1096 /* Duplicate attribute already checked for. */
1097 attr->in_common = 1;
1098 if (check_conflict (attr, name, where) == FAILURE)
1099 return FAILURE;
1100
1101 if (attr->flavor == FL_VARIABLE)
1102 return SUCCESS;
1103
1104 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1105 }
1106
1107
1108 try
1109 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1110 {
1111
1112 /* Duplicate attribute already checked for. */
1113 attr->in_equivalence = 1;
1114 if (check_conflict (attr, name, where) == FAILURE)
1115 return FAILURE;
1116
1117 if (attr->flavor == FL_VARIABLE)
1118 return SUCCESS;
1119
1120 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1121 }
1122
1123
1124 try
1125 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1126 {
1127
1128 if (check_used (attr, name, where))
1129 return FAILURE;
1130
1131 attr->data = 1;
1132 return check_conflict (attr, name, where);
1133 }
1134
1135
1136 try
1137 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1138 {
1139
1140 attr->in_namelist = 1;
1141 return check_conflict (attr, name, where);
1142 }
1143
1144
1145 try
1146 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1147 {
1148
1149 if (check_used (attr, name, where))
1150 return FAILURE;
1151
1152 attr->sequence = 1;
1153 return check_conflict (attr, name, where);
1154 }
1155
1156
1157 try
1158 gfc_add_elemental (symbol_attribute *attr, locus *where)
1159 {
1160
1161 if (check_used (attr, NULL, where))
1162 return FAILURE;
1163
1164 if (attr->elemental)
1165 {
1166 duplicate_attr ("ELEMENTAL", where);
1167 return FAILURE;
1168 }
1169
1170 attr->elemental = 1;
1171 return check_conflict (attr, NULL, where);
1172 }
1173
1174
1175 try
1176 gfc_add_pure (symbol_attribute *attr, locus *where)
1177 {
1178
1179 if (check_used (attr, NULL, where))
1180 return FAILURE;
1181
1182 if (attr->pure)
1183 {
1184 duplicate_attr ("PURE", where);
1185 return FAILURE;
1186 }
1187
1188 attr->pure = 1;
1189 return check_conflict (attr, NULL, where);
1190 }
1191
1192
1193 try
1194 gfc_add_recursive (symbol_attribute *attr, locus *where)
1195 {
1196
1197 if (check_used (attr, NULL, where))
1198 return FAILURE;
1199
1200 if (attr->recursive)
1201 {
1202 duplicate_attr ("RECURSIVE", where);
1203 return FAILURE;
1204 }
1205
1206 attr->recursive = 1;
1207 return check_conflict (attr, NULL, where);
1208 }
1209
1210
1211 try
1212 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1213 {
1214
1215 if (check_used (attr, name, where))
1216 return FAILURE;
1217
1218 if (attr->entry)
1219 {
1220 duplicate_attr ("ENTRY", where);
1221 return FAILURE;
1222 }
1223
1224 attr->entry = 1;
1225 return check_conflict (attr, name, where);
1226 }
1227
1228
1229 try
1230 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1231 {
1232
1233 if (attr->flavor != FL_PROCEDURE
1234 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1235 return FAILURE;
1236
1237 attr->function = 1;
1238 return check_conflict (attr, name, where);
1239 }
1240
1241
1242 try
1243 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1244 {
1245
1246 if (attr->flavor != FL_PROCEDURE
1247 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1248 return FAILURE;
1249
1250 attr->subroutine = 1;
1251 return check_conflict (attr, name, where);
1252 }
1253
1254
1255 try
1256 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1257 {
1258
1259 if (attr->flavor != FL_PROCEDURE
1260 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1261 return FAILURE;
1262
1263 attr->generic = 1;
1264 return check_conflict (attr, name, where);
1265 }
1266
1267
1268 try
1269 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1270 {
1271
1272 if (check_used (attr, NULL, where))
1273 return FAILURE;
1274
1275 if (attr->flavor != FL_PROCEDURE
1276 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1277 return FAILURE;
1278
1279 if (attr->procedure)
1280 {
1281 duplicate_attr ("PROCEDURE", where);
1282 return FAILURE;
1283 }
1284
1285 attr->procedure = 1;
1286
1287 return check_conflict (attr, NULL, where);
1288 }
1289
1290
1291 /* Flavors are special because some flavors are not what Fortran
1292 considers attributes and can be reaffirmed multiple times. */
1293
1294 try
1295 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1296 locus *where)
1297 {
1298
1299 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1300 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1301 || f == FL_NAMELIST) && check_used (attr, name, where))
1302 return FAILURE;
1303
1304 if (attr->flavor == f && f == FL_VARIABLE)
1305 return SUCCESS;
1306
1307 if (attr->flavor != FL_UNKNOWN)
1308 {
1309 if (where == NULL)
1310 where = &gfc_current_locus;
1311
1312 if (name)
1313 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1314 gfc_code2string (flavors, attr->flavor), name,
1315 gfc_code2string (flavors, f), where);
1316 else
1317 gfc_error ("%s attribute conflicts with %s attribute at %L",
1318 gfc_code2string (flavors, attr->flavor),
1319 gfc_code2string (flavors, f), where);
1320
1321 return FAILURE;
1322 }
1323
1324 attr->flavor = f;
1325
1326 return check_conflict (attr, name, where);
1327 }
1328
1329
1330 try
1331 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1332 const char *name, locus *where)
1333 {
1334
1335 if (check_used (attr, name, where))
1336 return FAILURE;
1337
1338 if (attr->flavor != FL_PROCEDURE
1339 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1340 return FAILURE;
1341
1342 if (where == NULL)
1343 where = &gfc_current_locus;
1344
1345 if (attr->proc != PROC_UNKNOWN)
1346 {
1347 gfc_error ("%s procedure at %L is already declared as %s procedure",
1348 gfc_code2string (procedures, t), where,
1349 gfc_code2string (procedures, attr->proc));
1350
1351 return FAILURE;
1352 }
1353
1354 attr->proc = t;
1355
1356 /* Statement functions are always scalar and functions. */
1357 if (t == PROC_ST_FUNCTION
1358 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1359 || attr->dimension))
1360 return FAILURE;
1361
1362 return check_conflict (attr, name, where);
1363 }
1364
1365
1366 try
1367 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1368 {
1369
1370 if (check_used (attr, NULL, where))
1371 return FAILURE;
1372
1373 if (attr->intent == INTENT_UNKNOWN)
1374 {
1375 attr->intent = intent;
1376 return check_conflict (attr, NULL, where);
1377 }
1378
1379 if (where == NULL)
1380 where = &gfc_current_locus;
1381
1382 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1383 gfc_intent_string (attr->intent),
1384 gfc_intent_string (intent), where);
1385
1386 return FAILURE;
1387 }
1388
1389
1390 /* No checks for use-association in public and private statements. */
1391
1392 try
1393 gfc_add_access (symbol_attribute *attr, gfc_access access,
1394 const char *name, locus *where)
1395 {
1396
1397 if (attr->access == ACCESS_UNKNOWN)
1398 {
1399 attr->access = access;
1400 return check_conflict (attr, name, where);
1401 }
1402
1403 if (where == NULL)
1404 where = &gfc_current_locus;
1405 gfc_error ("ACCESS specification at %L was already specified", where);
1406
1407 return FAILURE;
1408 }
1409
1410
1411 /* Set the is_bind_c field for the given symbol_attribute. */
1412
1413 try
1414 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1415 int is_proc_lang_bind_spec)
1416 {
1417
1418 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1419 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1420 "variables or common blocks", where);
1421 else if (attr->is_bind_c)
1422 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1423 else
1424 attr->is_bind_c = 1;
1425
1426 if (where == NULL)
1427 where = &gfc_current_locus;
1428
1429 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1430 == FAILURE)
1431 return FAILURE;
1432
1433 return check_conflict (attr, name, where);
1434 }
1435
1436
1437 try
1438 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1439 gfc_formal_arglist * formal, locus *where)
1440 {
1441
1442 if (check_used (&sym->attr, sym->name, where))
1443 return FAILURE;
1444
1445 if (where == NULL)
1446 where = &gfc_current_locus;
1447
1448 if (sym->attr.if_source != IFSRC_UNKNOWN
1449 && sym->attr.if_source != IFSRC_DECL)
1450 {
1451 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1452 sym->name, where);
1453 return FAILURE;
1454 }
1455
1456 sym->formal = formal;
1457 sym->attr.if_source = source;
1458
1459 return SUCCESS;
1460 }
1461
1462
1463 /* Add a type to a symbol. */
1464
1465 try
1466 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1467 {
1468 sym_flavor flavor;
1469
1470 if (where == NULL)
1471 where = &gfc_current_locus;
1472
1473 if (sym->ts.type != BT_UNKNOWN)
1474 {
1475 const char *msg = "Symbol '%s' at %L already has basic type of %s";
1476 if (!(sym->ts.type == ts->type
1477 && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
1478 || gfc_notification_std (GFC_STD_GNU) == ERROR
1479 || pedantic)
1480 {
1481 gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1482 return FAILURE;
1483 }
1484 else if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1485 gfc_basic_typename (sym->ts.type)) == FAILURE)
1486 return FAILURE;
1487 }
1488
1489 flavor = sym->attr.flavor;
1490
1491 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1492 || flavor == FL_LABEL
1493 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1494 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1495 {
1496 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1497 return FAILURE;
1498 }
1499
1500 sym->ts = *ts;
1501 return SUCCESS;
1502 }
1503
1504
1505 /* Clears all attributes. */
1506
1507 void
1508 gfc_clear_attr (symbol_attribute *attr)
1509 {
1510 memset (attr, 0, sizeof (symbol_attribute));
1511 }
1512
1513
1514 /* Check for missing attributes in the new symbol. Currently does
1515 nothing, but it's not clear that it is unnecessary yet. */
1516
1517 try
1518 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1519 locus *where ATTRIBUTE_UNUSED)
1520 {
1521
1522 return SUCCESS;
1523 }
1524
1525
1526 /* Copy an attribute to a symbol attribute, bit by bit. Some
1527 attributes have a lot of side-effects but cannot be present given
1528 where we are called from, so we ignore some bits. */
1529
1530 try
1531 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1532 {
1533 int is_proc_lang_bind_spec;
1534
1535 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1536 goto fail;
1537
1538 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1539 goto fail;
1540 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1541 goto fail;
1542 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1543 goto fail;
1544 if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1545 goto fail;
1546 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1547 goto fail;
1548 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1549 goto fail;
1550 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1551 goto fail;
1552 if (src->threadprivate
1553 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1554 goto fail;
1555 if (src->target && gfc_add_target (dest, where) == FAILURE)
1556 goto fail;
1557 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1558 goto fail;
1559 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1560 goto fail;
1561 if (src->entry)
1562 dest->entry = 1;
1563
1564 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1565 goto fail;
1566
1567 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1568 goto fail;
1569
1570 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1571 goto fail;
1572 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1573 goto fail;
1574 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1575 goto fail;
1576
1577 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1578 goto fail;
1579 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1580 goto fail;
1581 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1582 goto fail;
1583 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1584 goto fail;
1585
1586 if (src->flavor != FL_UNKNOWN
1587 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1588 goto fail;
1589
1590 if (src->intent != INTENT_UNKNOWN
1591 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1592 goto fail;
1593
1594 if (src->access != ACCESS_UNKNOWN
1595 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1596 goto fail;
1597
1598 if (gfc_missing_attr (dest, where) == FAILURE)
1599 goto fail;
1600
1601 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1602 goto fail;
1603 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1604 goto fail;
1605
1606 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1607 if (src->is_bind_c
1608 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1609 != SUCCESS)
1610 return FAILURE;
1611
1612 if (src->is_c_interop)
1613 dest->is_c_interop = 1;
1614 if (src->is_iso_c)
1615 dest->is_iso_c = 1;
1616
1617 if (src->external && gfc_add_external (dest, where) == FAILURE)
1618 goto fail;
1619 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1620 goto fail;
1621
1622 return SUCCESS;
1623
1624 fail:
1625 return FAILURE;
1626 }
1627
1628
1629 /************** Component name management ************/
1630
1631 /* Component names of a derived type form their own little namespaces
1632 that are separate from all other spaces. The space is composed of
1633 a singly linked list of gfc_component structures whose head is
1634 located in the parent symbol. */
1635
1636
1637 /* Add a component name to a symbol. The call fails if the name is
1638 already present. On success, the component pointer is modified to
1639 point to the additional component structure. */
1640
1641 try
1642 gfc_add_component (gfc_symbol *sym, const char *name,
1643 gfc_component **component)
1644 {
1645 gfc_component *p, *tail;
1646
1647 tail = NULL;
1648
1649 for (p = sym->components; p; p = p->next)
1650 {
1651 if (strcmp (p->name, name) == 0)
1652 {
1653 gfc_error ("Component '%s' at %C already declared at %L",
1654 name, &p->loc);
1655 return FAILURE;
1656 }
1657
1658 tail = p;
1659 }
1660
1661 /* Allocate a new component. */
1662 p = gfc_get_component ();
1663
1664 if (tail == NULL)
1665 sym->components = p;
1666 else
1667 tail->next = p;
1668
1669 p->name = gfc_get_string (name);
1670 p->loc = gfc_current_locus;
1671
1672 *component = p;
1673 return SUCCESS;
1674 }
1675
1676
1677 /* Recursive function to switch derived types of all symbol in a
1678 namespace. */
1679
1680 static void
1681 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1682 {
1683 gfc_symbol *sym;
1684
1685 if (st == NULL)
1686 return;
1687
1688 sym = st->n.sym;
1689 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1690 sym->ts.derived = to;
1691
1692 switch_types (st->left, from, to);
1693 switch_types (st->right, from, to);
1694 }
1695
1696
1697 /* This subroutine is called when a derived type is used in order to
1698 make the final determination about which version to use. The
1699 standard requires that a type be defined before it is 'used', but
1700 such types can appear in IMPLICIT statements before the actual
1701 definition. 'Using' in this context means declaring a variable to
1702 be that type or using the type constructor.
1703
1704 If a type is used and the components haven't been defined, then we
1705 have to have a derived type in a parent unit. We find the node in
1706 the other namespace and point the symtree node in this namespace to
1707 that node. Further reference to this name point to the correct
1708 node. If we can't find the node in a parent namespace, then we have
1709 an error.
1710
1711 This subroutine takes a pointer to a symbol node and returns a
1712 pointer to the translated node or NULL for an error. Usually there
1713 is no translation and we return the node we were passed. */
1714
1715 gfc_symbol *
1716 gfc_use_derived (gfc_symbol *sym)
1717 {
1718 gfc_symbol *s;
1719 gfc_typespec *t;
1720 gfc_symtree *st;
1721 int i;
1722
1723 if (sym->components != NULL || sym->attr.zero_comp)
1724 return sym; /* Already defined. */
1725
1726 if (sym->ns->parent == NULL)
1727 goto bad;
1728
1729 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1730 {
1731 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1732 return NULL;
1733 }
1734
1735 if (s == NULL || s->attr.flavor != FL_DERIVED)
1736 goto bad;
1737
1738 /* Get rid of symbol sym, translating all references to s. */
1739 for (i = 0; i < GFC_LETTERS; i++)
1740 {
1741 t = &sym->ns->default_type[i];
1742 if (t->derived == sym)
1743 t->derived = s;
1744 }
1745
1746 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1747 st->n.sym = s;
1748
1749 s->refs++;
1750
1751 /* Unlink from list of modified symbols. */
1752 gfc_commit_symbol (sym);
1753
1754 switch_types (sym->ns->sym_root, sym, s);
1755
1756 /* TODO: Also have to replace sym -> s in other lists like
1757 namelists, common lists and interface lists. */
1758 gfc_free_symbol (sym);
1759
1760 return s;
1761
1762 bad:
1763 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1764 sym->name);
1765 return NULL;
1766 }
1767
1768
1769 /* Given a derived type node and a component name, try to locate the
1770 component structure. Returns the NULL pointer if the component is
1771 not found or the components are private. */
1772
1773 gfc_component *
1774 gfc_find_component (gfc_symbol *sym, const char *name)
1775 {
1776 gfc_component *p;
1777
1778 if (name == NULL)
1779 return NULL;
1780
1781 sym = gfc_use_derived (sym);
1782
1783 if (sym == NULL)
1784 return NULL;
1785
1786 for (p = sym->components; p; p = p->next)
1787 if (strcmp (p->name, name) == 0)
1788 break;
1789
1790 if (p == NULL)
1791 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1792 name, sym->name);
1793 else
1794 {
1795 if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE
1796 || p->access == ACCESS_PRIVATE))
1797 {
1798 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1799 name, sym->name);
1800 p = NULL;
1801 }
1802 }
1803
1804 return p;
1805 }
1806
1807
1808 /* Given a symbol, free all of the component structures and everything
1809 they point to. */
1810
1811 static void
1812 free_components (gfc_component *p)
1813 {
1814 gfc_component *q;
1815
1816 for (; p; p = q)
1817 {
1818 q = p->next;
1819
1820 gfc_free_array_spec (p->as);
1821 gfc_free_expr (p->initializer);
1822
1823 gfc_free (p);
1824 }
1825 }
1826
1827
1828 /* Set component attributes from a standard symbol attribute structure. */
1829
1830 void
1831 gfc_set_component_attr (gfc_component *c, symbol_attribute *attr)
1832 {
1833
1834 c->dimension = attr->dimension;
1835 c->pointer = attr->pointer;
1836 c->allocatable = attr->allocatable;
1837 c->access = attr->access;
1838 }
1839
1840
1841 /* Get a standard symbol attribute structure given the component
1842 structure. */
1843
1844 void
1845 gfc_get_component_attr (symbol_attribute *attr, gfc_component *c)
1846 {
1847
1848 gfc_clear_attr (attr);
1849 attr->dimension = c->dimension;
1850 attr->pointer = c->pointer;
1851 attr->allocatable = c->allocatable;
1852 attr->access = c->access;
1853 }
1854
1855
1856 /******************** Statement label management ********************/
1857
1858 /* Comparison function for statement labels, used for managing the
1859 binary tree. */
1860
1861 static int
1862 compare_st_labels (void *a1, void *b1)
1863 {
1864 int a = ((gfc_st_label *) a1)->value;
1865 int b = ((gfc_st_label *) b1)->value;
1866
1867 return (b - a);
1868 }
1869
1870
1871 /* Free a single gfc_st_label structure, making sure the tree is not
1872 messed up. This function is called only when some parse error
1873 occurs. */
1874
1875 void
1876 gfc_free_st_label (gfc_st_label *label)
1877 {
1878
1879 if (label == NULL)
1880 return;
1881
1882 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1883
1884 if (label->format != NULL)
1885 gfc_free_expr (label->format);
1886
1887 gfc_free (label);
1888 }
1889
1890
1891 /* Free a whole tree of gfc_st_label structures. */
1892
1893 static void
1894 free_st_labels (gfc_st_label *label)
1895 {
1896
1897 if (label == NULL)
1898 return;
1899
1900 free_st_labels (label->left);
1901 free_st_labels (label->right);
1902
1903 if (label->format != NULL)
1904 gfc_free_expr (label->format);
1905 gfc_free (label);
1906 }
1907
1908
1909 /* Given a label number, search for and return a pointer to the label
1910 structure, creating it if it does not exist. */
1911
1912 gfc_st_label *
1913 gfc_get_st_label (int labelno)
1914 {
1915 gfc_st_label *lp;
1916
1917 /* First see if the label is already in this namespace. */
1918 lp = gfc_current_ns->st_labels;
1919 while (lp)
1920 {
1921 if (lp->value == labelno)
1922 return lp;
1923
1924 if (lp->value < labelno)
1925 lp = lp->left;
1926 else
1927 lp = lp->right;
1928 }
1929
1930 lp = gfc_getmem (sizeof (gfc_st_label));
1931
1932 lp->value = labelno;
1933 lp->defined = ST_LABEL_UNKNOWN;
1934 lp->referenced = ST_LABEL_UNKNOWN;
1935
1936 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
1937
1938 return lp;
1939 }
1940
1941
1942 /* Called when a statement with a statement label is about to be
1943 accepted. We add the label to the list of the current namespace,
1944 making sure it hasn't been defined previously and referenced
1945 correctly. */
1946
1947 void
1948 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
1949 {
1950 int labelno;
1951
1952 labelno = lp->value;
1953
1954 if (lp->defined != ST_LABEL_UNKNOWN)
1955 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1956 &lp->where, label_locus);
1957 else
1958 {
1959 lp->where = *label_locus;
1960
1961 switch (type)
1962 {
1963 case ST_LABEL_FORMAT:
1964 if (lp->referenced == ST_LABEL_TARGET)
1965 gfc_error ("Label %d at %C already referenced as branch target",
1966 labelno);
1967 else
1968 lp->defined = ST_LABEL_FORMAT;
1969
1970 break;
1971
1972 case ST_LABEL_TARGET:
1973 if (lp->referenced == ST_LABEL_FORMAT)
1974 gfc_error ("Label %d at %C already referenced as a format label",
1975 labelno);
1976 else
1977 lp->defined = ST_LABEL_TARGET;
1978
1979 break;
1980
1981 default:
1982 lp->defined = ST_LABEL_BAD_TARGET;
1983 lp->referenced = ST_LABEL_BAD_TARGET;
1984 }
1985 }
1986 }
1987
1988
1989 /* Reference a label. Given a label and its type, see if that
1990 reference is consistent with what is known about that label,
1991 updating the unknown state. Returns FAILURE if something goes
1992 wrong. */
1993
1994 try
1995 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
1996 {
1997 gfc_sl_type label_type;
1998 int labelno;
1999 try rc;
2000
2001 if (lp == NULL)
2002 return SUCCESS;
2003
2004 labelno = lp->value;
2005
2006 if (lp->defined != ST_LABEL_UNKNOWN)
2007 label_type = lp->defined;
2008 else
2009 {
2010 label_type = lp->referenced;
2011 lp->where = gfc_current_locus;
2012 }
2013
2014 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2015 {
2016 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2017 rc = FAILURE;
2018 goto done;
2019 }
2020
2021 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2022 && type == ST_LABEL_FORMAT)
2023 {
2024 gfc_error ("Label %d at %C previously used as branch target", labelno);
2025 rc = FAILURE;
2026 goto done;
2027 }
2028
2029 lp->referenced = type;
2030 rc = SUCCESS;
2031
2032 done:
2033 return rc;
2034 }
2035
2036
2037 /*******A helper function for creating new expressions*************/
2038
2039
2040 gfc_expr *
2041 gfc_lval_expr_from_sym (gfc_symbol *sym)
2042 {
2043 gfc_expr *lval;
2044 lval = gfc_get_expr ();
2045 lval->expr_type = EXPR_VARIABLE;
2046 lval->where = sym->declared_at;
2047 lval->ts = sym->ts;
2048 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2049
2050 /* It will always be a full array. */
2051 lval->rank = sym->as ? sym->as->rank : 0;
2052 if (lval->rank)
2053 {
2054 lval->ref = gfc_get_ref ();
2055 lval->ref->type = REF_ARRAY;
2056 lval->ref->u.ar.type = AR_FULL;
2057 lval->ref->u.ar.dimen = lval->rank;
2058 lval->ref->u.ar.where = sym->declared_at;
2059 lval->ref->u.ar.as = sym->as;
2060 }
2061
2062 return lval;
2063 }
2064
2065
2066 /************** Symbol table management subroutines ****************/
2067
2068 /* Basic details: Fortran 95 requires a potentially unlimited number
2069 of distinct namespaces when compiling a program unit. This case
2070 occurs during a compilation of internal subprograms because all of
2071 the internal subprograms must be read before we can start
2072 generating code for the host.
2073
2074 Given the tricky nature of the Fortran grammar, we must be able to
2075 undo changes made to a symbol table if the current interpretation
2076 of a statement is found to be incorrect. Whenever a symbol is
2077 looked up, we make a copy of it and link to it. All of these
2078 symbols are kept in a singly linked list so that we can commit or
2079 undo the changes at a later time.
2080
2081 A symtree may point to a symbol node outside of its namespace. In
2082 this case, that symbol has been used as a host associated variable
2083 at some previous time. */
2084
2085 /* Allocate a new namespace structure. Copies the implicit types from
2086 PARENT if PARENT_TYPES is set. */
2087
2088 gfc_namespace *
2089 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2090 {
2091 gfc_namespace *ns;
2092 gfc_typespec *ts;
2093 gfc_intrinsic_op in;
2094 int i;
2095
2096 ns = gfc_getmem (sizeof (gfc_namespace));
2097 ns->sym_root = NULL;
2098 ns->uop_root = NULL;
2099 ns->default_access = ACCESS_UNKNOWN;
2100 ns->parent = parent;
2101
2102 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2103 ns->operator_access[in] = ACCESS_UNKNOWN;
2104
2105 /* Initialize default implicit types. */
2106 for (i = 'a'; i <= 'z'; i++)
2107 {
2108 ns->set_flag[i - 'a'] = 0;
2109 ts = &ns->default_type[i - 'a'];
2110
2111 if (parent_types && ns->parent != NULL)
2112 {
2113 /* Copy parent settings. */
2114 *ts = ns->parent->default_type[i - 'a'];
2115 continue;
2116 }
2117
2118 if (gfc_option.flag_implicit_none != 0)
2119 {
2120 gfc_clear_ts (ts);
2121 continue;
2122 }
2123
2124 if ('i' <= i && i <= 'n')
2125 {
2126 ts->type = BT_INTEGER;
2127 ts->kind = gfc_default_integer_kind;
2128 }
2129 else
2130 {
2131 ts->type = BT_REAL;
2132 ts->kind = gfc_default_real_kind;
2133 }
2134 }
2135
2136 ns->refs = 1;
2137
2138 return ns;
2139 }
2140
2141
2142 /* Comparison function for symtree nodes. */
2143
2144 static int
2145 compare_symtree (void *_st1, void *_st2)
2146 {
2147 gfc_symtree *st1, *st2;
2148
2149 st1 = (gfc_symtree *) _st1;
2150 st2 = (gfc_symtree *) _st2;
2151
2152 return strcmp (st1->name, st2->name);
2153 }
2154
2155
2156 /* Allocate a new symtree node and associate it with the new symbol. */
2157
2158 gfc_symtree *
2159 gfc_new_symtree (gfc_symtree **root, const char *name)
2160 {
2161 gfc_symtree *st;
2162
2163 st = gfc_getmem (sizeof (gfc_symtree));
2164 st->name = gfc_get_string (name);
2165
2166 gfc_insert_bbt (root, st, compare_symtree);
2167 return st;
2168 }
2169
2170
2171 /* Delete a symbol from the tree. Does not free the symbol itself! */
2172
2173 void
2174 gfc_delete_symtree (gfc_symtree **root, const char *name)
2175 {
2176 gfc_symtree st, *st0;
2177
2178 st0 = gfc_find_symtree (*root, name);
2179
2180 st.name = gfc_get_string (name);
2181 gfc_delete_bbt (root, &st, compare_symtree);
2182
2183 gfc_free (st0);
2184 }
2185
2186
2187 /* Given a root symtree node and a name, try to find the symbol within
2188 the namespace. Returns NULL if the symbol is not found. */
2189
2190 gfc_symtree *
2191 gfc_find_symtree (gfc_symtree *st, const char *name)
2192 {
2193 int c;
2194
2195 while (st != NULL)
2196 {
2197 c = strcmp (name, st->name);
2198 if (c == 0)
2199 return st;
2200
2201 st = (c < 0) ? st->left : st->right;
2202 }
2203
2204 return NULL;
2205 }
2206
2207
2208 /* Return a symtree node with a name that is guaranteed to be unique
2209 within the namespace and corresponds to an illegal fortran name. */
2210
2211 gfc_symtree *
2212 gfc_get_unique_symtree (gfc_namespace *ns)
2213 {
2214 char name[GFC_MAX_SYMBOL_LEN + 1];
2215 static int serial = 0;
2216
2217 sprintf (name, "@%d", serial++);
2218 return gfc_new_symtree (&ns->sym_root, name);
2219 }
2220
2221
2222 /* Given a name find a user operator node, creating it if it doesn't
2223 exist. These are much simpler than symbols because they can't be
2224 ambiguous with one another. */
2225
2226 gfc_user_op *
2227 gfc_get_uop (const char *name)
2228 {
2229 gfc_user_op *uop;
2230 gfc_symtree *st;
2231
2232 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2233 if (st != NULL)
2234 return st->n.uop;
2235
2236 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2237
2238 uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
2239 uop->name = gfc_get_string (name);
2240 uop->access = ACCESS_UNKNOWN;
2241 uop->ns = gfc_current_ns;
2242
2243 return uop;
2244 }
2245
2246
2247 /* Given a name find the user operator node. Returns NULL if it does
2248 not exist. */
2249
2250 gfc_user_op *
2251 gfc_find_uop (const char *name, gfc_namespace *ns)
2252 {
2253 gfc_symtree *st;
2254
2255 if (ns == NULL)
2256 ns = gfc_current_ns;
2257
2258 st = gfc_find_symtree (ns->uop_root, name);
2259 return (st == NULL) ? NULL : st->n.uop;
2260 }
2261
2262
2263 /* Remove a gfc_symbol structure and everything it points to. */
2264
2265 void
2266 gfc_free_symbol (gfc_symbol *sym)
2267 {
2268
2269 if (sym == NULL)
2270 return;
2271
2272 gfc_free_array_spec (sym->as);
2273
2274 free_components (sym->components);
2275
2276 gfc_free_expr (sym->value);
2277
2278 gfc_free_namelist (sym->namelist);
2279
2280 gfc_free_namespace (sym->formal_ns);
2281
2282 if (!sym->attr.generic_copy)
2283 gfc_free_interface (sym->generic);
2284
2285 gfc_free_formal_arglist (sym->formal);
2286
2287 gfc_free (sym);
2288 }
2289
2290
2291 /* Allocate and initialize a new symbol node. */
2292
2293 gfc_symbol *
2294 gfc_new_symbol (const char *name, gfc_namespace *ns)
2295 {
2296 gfc_symbol *p;
2297
2298 p = gfc_getmem (sizeof (gfc_symbol));
2299
2300 gfc_clear_ts (&p->ts);
2301 gfc_clear_attr (&p->attr);
2302 p->ns = ns;
2303
2304 p->declared_at = gfc_current_locus;
2305
2306 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2307 gfc_internal_error ("new_symbol(): Symbol name too long");
2308
2309 p->name = gfc_get_string (name);
2310
2311 /* Make sure flags for symbol being C bound are clear initially. */
2312 p->attr.is_bind_c = 0;
2313 p->attr.is_iso_c = 0;
2314 /* Make sure the binding label field has a Nul char to start. */
2315 p->binding_label[0] = '\0';
2316
2317 /* Clear the ptrs we may need. */
2318 p->common_block = NULL;
2319
2320 return p;
2321 }
2322
2323
2324 /* Generate an error if a symbol is ambiguous. */
2325
2326 static void
2327 ambiguous_symbol (const char *name, gfc_symtree *st)
2328 {
2329
2330 if (st->n.sym->module)
2331 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2332 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2333 else
2334 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2335 "from current program unit", name, st->n.sym->name);
2336 }
2337
2338
2339 /* Search for a symtree starting in the current namespace, resorting to
2340 any parent namespaces if requested by a nonzero parent_flag.
2341 Returns nonzero if the name is ambiguous. */
2342
2343 int
2344 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2345 gfc_symtree **result)
2346 {
2347 gfc_symtree *st;
2348
2349 if (ns == NULL)
2350 ns = gfc_current_ns;
2351
2352 do
2353 {
2354 st = gfc_find_symtree (ns->sym_root, name);
2355 if (st != NULL)
2356 {
2357 *result = st;
2358 /* Ambiguous generic interfaces are permitted, as long
2359 as the specific interfaces are different. */
2360 if (st->ambiguous && !st->n.sym->attr.generic)
2361 {
2362 ambiguous_symbol (name, st);
2363 return 1;
2364 }
2365
2366 return 0;
2367 }
2368
2369 if (!parent_flag)
2370 break;
2371
2372 ns = ns->parent;
2373 }
2374 while (ns != NULL);
2375
2376 *result = NULL;
2377 return 0;
2378 }
2379
2380
2381 /* Same, but returns the symbol instead. */
2382
2383 int
2384 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2385 gfc_symbol **result)
2386 {
2387 gfc_symtree *st;
2388 int i;
2389
2390 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2391
2392 if (st == NULL)
2393 *result = NULL;
2394 else
2395 *result = st->n.sym;
2396
2397 return i;
2398 }
2399
2400
2401 /* Save symbol with the information necessary to back it out. */
2402
2403 static void
2404 save_symbol_data (gfc_symbol *sym)
2405 {
2406
2407 if (sym->new || sym->old_symbol != NULL)
2408 return;
2409
2410 sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
2411 *(sym->old_symbol) = *sym;
2412
2413 sym->tlink = changed_syms;
2414 changed_syms = sym;
2415 }
2416
2417
2418 /* Given a name, find a symbol, or create it if it does not exist yet
2419 in the current namespace. If the symbol is found we make sure that
2420 it's OK.
2421
2422 The integer return code indicates
2423 0 All OK
2424 1 The symbol name was ambiguous
2425 2 The name meant to be established was already host associated.
2426
2427 So if the return value is nonzero, then an error was issued. */
2428
2429 int
2430 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
2431 {
2432 gfc_symtree *st;
2433 gfc_symbol *p;
2434
2435 /* This doesn't usually happen during resolution. */
2436 if (ns == NULL)
2437 ns = gfc_current_ns;
2438
2439 /* Try to find the symbol in ns. */
2440 st = gfc_find_symtree (ns->sym_root, name);
2441
2442 if (st == NULL)
2443 {
2444 /* If not there, create a new symbol. */
2445 p = gfc_new_symbol (name, ns);
2446
2447 /* Add to the list of tentative symbols. */
2448 p->old_symbol = NULL;
2449 p->tlink = changed_syms;
2450 p->mark = 1;
2451 p->new = 1;
2452 changed_syms = p;
2453
2454 st = gfc_new_symtree (&ns->sym_root, name);
2455 st->n.sym = p;
2456 p->refs++;
2457
2458 }
2459 else
2460 {
2461 /* Make sure the existing symbol is OK. Ambiguous
2462 generic interfaces are permitted, as long as the
2463 specific interfaces are different. */
2464 if (st->ambiguous && !st->n.sym->attr.generic)
2465 {
2466 ambiguous_symbol (name, st);
2467 return 1;
2468 }
2469
2470 p = st->n.sym;
2471
2472 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2473 && !(ns->proc_name
2474 && ns->proc_name->attr.if_source == IFSRC_IFBODY
2475 && (ns->has_import_set || p->attr.imported)))
2476 {
2477 /* Symbol is from another namespace. */
2478 gfc_error ("Symbol '%s' at %C has already been host associated",
2479 name);
2480 return 2;
2481 }
2482
2483 p->mark = 1;
2484
2485 /* Copy in case this symbol is changed. */
2486 save_symbol_data (p);
2487 }
2488
2489 *result = st;
2490 return 0;
2491 }
2492
2493
2494 int
2495 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2496 {
2497 gfc_symtree *st;
2498 int i;
2499
2500 i = gfc_get_sym_tree (name, ns, &st);
2501 if (i != 0)
2502 return i;
2503
2504 if (st)
2505 *result = st->n.sym;
2506 else
2507 *result = NULL;
2508 return i;
2509 }
2510
2511
2512 /* Subroutine that searches for a symbol, creating it if it doesn't
2513 exist, but tries to host-associate the symbol if possible. */
2514
2515 int
2516 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2517 {
2518 gfc_symtree *st;
2519 int i;
2520
2521 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2522 if (st != NULL)
2523 {
2524 save_symbol_data (st->n.sym);
2525 *result = st;
2526 return i;
2527 }
2528
2529 if (gfc_current_ns->parent != NULL)
2530 {
2531 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2532 if (i)
2533 return i;
2534
2535 if (st != NULL)
2536 {
2537 *result = st;
2538 return 0;
2539 }
2540 }
2541
2542 return gfc_get_sym_tree (name, gfc_current_ns, result);
2543 }
2544
2545
2546 int
2547 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2548 {
2549 int i;
2550 gfc_symtree *st;
2551
2552 i = gfc_get_ha_sym_tree (name, &st);
2553
2554 if (st)
2555 *result = st->n.sym;
2556 else
2557 *result = NULL;
2558
2559 return i;
2560 }
2561
2562 /* Return true if both symbols could refer to the same data object. Does
2563 not take account of aliasing due to equivalence statements. */
2564
2565 int
2566 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2567 {
2568 /* Aliasing isn't possible if the symbols have different base types. */
2569 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2570 return 0;
2571
2572 /* Pointers can point to other pointers, target objects and allocatable
2573 objects. Two allocatable objects cannot share the same storage. */
2574 if (lsym->attr.pointer
2575 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2576 return 1;
2577 if (lsym->attr.target && rsym->attr.pointer)
2578 return 1;
2579 if (lsym->attr.allocatable && rsym->attr.pointer)
2580 return 1;
2581
2582 return 0;
2583 }
2584
2585
2586 /* Undoes all the changes made to symbols in the current statement.
2587 This subroutine is made simpler due to the fact that attributes are
2588 never removed once added. */
2589
2590 void
2591 gfc_undo_symbols (void)
2592 {
2593 gfc_symbol *p, *q, *old;
2594
2595 for (p = changed_syms; p; p = q)
2596 {
2597 q = p->tlink;
2598
2599 if (p->new)
2600 {
2601 /* Symbol was new. */
2602 if (p->attr.in_common && p->common_block->head)
2603 {
2604 /* If the symbol was added to any common block, it
2605 needs to be removed to stop the resolver looking
2606 for a (possibly) dead symbol. */
2607
2608 if (p->common_block->head == p)
2609 p->common_block->head = p->common_next;
2610 else
2611 {
2612 gfc_symbol *cparent, *csym;
2613
2614 cparent = p->common_block->head;
2615 csym = cparent->common_next;
2616
2617 while (csym != p)
2618 {
2619 cparent = csym;
2620 csym = csym->common_next;
2621 }
2622
2623 gcc_assert(cparent->common_next == p);
2624
2625 cparent->common_next = csym->common_next;
2626 }
2627 }
2628
2629 gfc_delete_symtree (&p->ns->sym_root, p->name);
2630
2631 p->refs--;
2632 if (p->refs < 0)
2633 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2634 if (p->refs == 0)
2635 gfc_free_symbol (p);
2636 continue;
2637 }
2638
2639 /* Restore previous state of symbol. Just copy simple stuff. */
2640 p->mark = 0;
2641 old = p->old_symbol;
2642
2643 p->ts.type = old->ts.type;
2644 p->ts.kind = old->ts.kind;
2645
2646 p->attr = old->attr;
2647
2648 if (p->value != old->value)
2649 {
2650 gfc_free_expr (old->value);
2651 p->value = NULL;
2652 }
2653
2654 if (p->as != old->as)
2655 {
2656 if (p->as)
2657 gfc_free_array_spec (p->as);
2658 p->as = old->as;
2659 }
2660
2661 p->generic = old->generic;
2662 p->component_access = old->component_access;
2663
2664 if (p->namelist != NULL && old->namelist == NULL)
2665 {
2666 gfc_free_namelist (p->namelist);
2667 p->namelist = NULL;
2668 }
2669 else
2670 {
2671 if (p->namelist_tail != old->namelist_tail)
2672 {
2673 gfc_free_namelist (old->namelist_tail);
2674 old->namelist_tail->next = NULL;
2675 }
2676 }
2677
2678 p->namelist_tail = old->namelist_tail;
2679
2680 if (p->formal != old->formal)
2681 {
2682 gfc_free_formal_arglist (p->formal);
2683 p->formal = old->formal;
2684 }
2685
2686 gfc_free (p->old_symbol);
2687 p->old_symbol = NULL;
2688 p->tlink = NULL;
2689 }
2690
2691 changed_syms = NULL;
2692 }
2693
2694
2695 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2696 components of old_symbol that might need deallocation are the "allocatables"
2697 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2698 namelist_tail. In case these differ between old_symbol and sym, it's just
2699 because sym->namelist has gotten a few more items. */
2700
2701 static void
2702 free_old_symbol (gfc_symbol *sym)
2703 {
2704
2705 if (sym->old_symbol == NULL)
2706 return;
2707
2708 if (sym->old_symbol->as != sym->as)
2709 gfc_free_array_spec (sym->old_symbol->as);
2710
2711 if (sym->old_symbol->value != sym->value)
2712 gfc_free_expr (sym->old_symbol->value);
2713
2714 if (sym->old_symbol->formal != sym->formal)
2715 gfc_free_formal_arglist (sym->old_symbol->formal);
2716
2717 gfc_free (sym->old_symbol);
2718 sym->old_symbol = NULL;
2719 }
2720
2721
2722 /* Makes the changes made in the current statement permanent-- gets
2723 rid of undo information. */
2724
2725 void
2726 gfc_commit_symbols (void)
2727 {
2728 gfc_symbol *p, *q;
2729
2730 for (p = changed_syms; p; p = q)
2731 {
2732 q = p->tlink;
2733 p->tlink = NULL;
2734 p->mark = 0;
2735 p->new = 0;
2736 free_old_symbol (p);
2737 }
2738 changed_syms = NULL;
2739 }
2740
2741
2742 /* Makes the changes made in one symbol permanent -- gets rid of undo
2743 information. */
2744
2745 void
2746 gfc_commit_symbol (gfc_symbol *sym)
2747 {
2748 gfc_symbol *p;
2749
2750 if (changed_syms == sym)
2751 changed_syms = sym->tlink;
2752 else
2753 {
2754 for (p = changed_syms; p; p = p->tlink)
2755 if (p->tlink == sym)
2756 {
2757 p->tlink = sym->tlink;
2758 break;
2759 }
2760 }
2761
2762 sym->tlink = NULL;
2763 sym->mark = 0;
2764 sym->new = 0;
2765
2766 free_old_symbol (sym);
2767 }
2768
2769
2770 /* Recursive function that deletes an entire tree and all the common
2771 head structures it points to. */
2772
2773 static void
2774 free_common_tree (gfc_symtree * common_tree)
2775 {
2776 if (common_tree == NULL)
2777 return;
2778
2779 free_common_tree (common_tree->left);
2780 free_common_tree (common_tree->right);
2781
2782 gfc_free (common_tree);
2783 }
2784
2785
2786 /* Recursive function that deletes an entire tree and all the user
2787 operator nodes that it contains. */
2788
2789 static void
2790 free_uop_tree (gfc_symtree *uop_tree)
2791 {
2792
2793 if (uop_tree == NULL)
2794 return;
2795
2796 free_uop_tree (uop_tree->left);
2797 free_uop_tree (uop_tree->right);
2798
2799 gfc_free_interface (uop_tree->n.uop->operator);
2800
2801 gfc_free (uop_tree->n.uop);
2802 gfc_free (uop_tree);
2803 }
2804
2805
2806 /* Recursive function that deletes an entire tree and all the symbols
2807 that it contains. */
2808
2809 static void
2810 free_sym_tree (gfc_symtree *sym_tree)
2811 {
2812 gfc_namespace *ns;
2813 gfc_symbol *sym;
2814
2815 if (sym_tree == NULL)
2816 return;
2817
2818 free_sym_tree (sym_tree->left);
2819 free_sym_tree (sym_tree->right);
2820
2821 sym = sym_tree->n.sym;
2822
2823 sym->refs--;
2824 if (sym->refs < 0)
2825 gfc_internal_error ("free_sym_tree(): Negative refs");
2826
2827 if (sym->formal_ns != NULL && sym->refs == 1)
2828 {
2829 /* As formal_ns contains a reference to sym, delete formal_ns just
2830 before the deletion of sym. */
2831 ns = sym->formal_ns;
2832 sym->formal_ns = NULL;
2833 gfc_free_namespace (ns);
2834 }
2835 else if (sym->refs == 0)
2836 {
2837 /* Go ahead and delete the symbol. */
2838 gfc_free_symbol (sym);
2839 }
2840
2841 gfc_free (sym_tree);
2842 }
2843
2844
2845 /* Free the derived type list. */
2846
2847 static void
2848 gfc_free_dt_list (void)
2849 {
2850 gfc_dt_list *dt, *n;
2851
2852 for (dt = gfc_derived_types; dt; dt = n)
2853 {
2854 n = dt->next;
2855 gfc_free (dt);
2856 }
2857
2858 gfc_derived_types = NULL;
2859 }
2860
2861
2862 /* Free the gfc_equiv_info's. */
2863
2864 static void
2865 gfc_free_equiv_infos (gfc_equiv_info *s)
2866 {
2867 if (s == NULL)
2868 return;
2869 gfc_free_equiv_infos (s->next);
2870 gfc_free (s);
2871 }
2872
2873
2874 /* Free the gfc_equiv_lists. */
2875
2876 static void
2877 gfc_free_equiv_lists (gfc_equiv_list *l)
2878 {
2879 if (l == NULL)
2880 return;
2881 gfc_free_equiv_lists (l->next);
2882 gfc_free_equiv_infos (l->equiv);
2883 gfc_free (l);
2884 }
2885
2886
2887 /* Free a namespace structure and everything below it. Interface
2888 lists associated with intrinsic operators are not freed. These are
2889 taken care of when a specific name is freed. */
2890
2891 void
2892 gfc_free_namespace (gfc_namespace *ns)
2893 {
2894 gfc_charlen *cl, *cl2;
2895 gfc_namespace *p, *q;
2896 gfc_intrinsic_op i;
2897
2898 if (ns == NULL)
2899 return;
2900
2901 ns->refs--;
2902 if (ns->refs > 0)
2903 return;
2904 gcc_assert (ns->refs == 0);
2905
2906 gfc_free_statements (ns->code);
2907
2908 free_sym_tree (ns->sym_root);
2909 free_uop_tree (ns->uop_root);
2910 free_common_tree (ns->common_root);
2911
2912 for (cl = ns->cl_list; cl; cl = cl2)
2913 {
2914 cl2 = cl->next;
2915 gfc_free_expr (cl->length);
2916 gfc_free (cl);
2917 }
2918
2919 free_st_labels (ns->st_labels);
2920
2921 gfc_free_equiv (ns->equiv);
2922 gfc_free_equiv_lists (ns->equiv_lists);
2923
2924 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2925 gfc_free_interface (ns->operator[i]);
2926
2927 gfc_free_data (ns->data);
2928 p = ns->contained;
2929 gfc_free (ns);
2930
2931 /* Recursively free any contained namespaces. */
2932 while (p != NULL)
2933 {
2934 q = p;
2935 p = p->sibling;
2936 gfc_free_namespace (q);
2937 }
2938 }
2939
2940
2941 void
2942 gfc_symbol_init_2 (void)
2943 {
2944
2945 gfc_current_ns = gfc_get_namespace (NULL, 0);
2946 }
2947
2948
2949 void
2950 gfc_symbol_done_2 (void)
2951 {
2952
2953 gfc_free_namespace (gfc_current_ns);
2954 gfc_current_ns = NULL;
2955 gfc_free_dt_list ();
2956 }
2957
2958
2959 /* Clear mark bits from symbol nodes associated with a symtree node. */
2960
2961 static void
2962 clear_sym_mark (gfc_symtree *st)
2963 {
2964
2965 st->n.sym->mark = 0;
2966 }
2967
2968
2969 /* Recursively traverse the symtree nodes. */
2970
2971 void
2972 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
2973 {
2974 if (!st)
2975 return;
2976
2977 gfc_traverse_symtree (st->left, func);
2978 (*func) (st);
2979 gfc_traverse_symtree (st->right, func);
2980 }
2981
2982
2983 /* Recursive namespace traversal function. */
2984
2985 static void
2986 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
2987 {
2988
2989 if (st == NULL)
2990 return;
2991
2992 traverse_ns (st->left, func);
2993
2994 if (st->n.sym->mark == 0)
2995 (*func) (st->n.sym);
2996 st->n.sym->mark = 1;
2997
2998 traverse_ns (st->right, func);
2999 }
3000
3001
3002 /* Call a given function for all symbols in the namespace. We take
3003 care that each gfc_symbol node is called exactly once. */
3004
3005 void
3006 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3007 {
3008
3009 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3010
3011 traverse_ns (ns->sym_root, func);
3012 }
3013
3014
3015 /* Return TRUE when name is the name of an intrinsic type. */
3016
3017 bool
3018 gfc_is_intrinsic_typename (const char *name)
3019 {
3020 if (strcmp (name, "integer") == 0
3021 || strcmp (name, "real") == 0
3022 || strcmp (name, "character") == 0
3023 || strcmp (name, "logical") == 0
3024 || strcmp (name, "complex") == 0
3025 || strcmp (name, "doubleprecision") == 0
3026 || strcmp (name, "doublecomplex") == 0)
3027 return true;
3028 else
3029 return false;
3030 }
3031
3032
3033 /* Return TRUE if the symbol is an automatic variable. */
3034
3035 static bool
3036 gfc_is_var_automatic (gfc_symbol *sym)
3037 {
3038 /* Pointer and allocatable variables are never automatic. */
3039 if (sym->attr.pointer || sym->attr.allocatable)
3040 return false;
3041 /* Check for arrays with non-constant size. */
3042 if (sym->attr.dimension && sym->as
3043 && !gfc_is_compile_time_shape (sym->as))
3044 return true;
3045 /* Check for non-constant length character variables. */
3046 if (sym->ts.type == BT_CHARACTER
3047 && sym->ts.cl
3048 && !gfc_is_constant_expr (sym->ts.cl->length))
3049 return true;
3050 return false;
3051 }
3052
3053 /* Given a symbol, mark it as SAVEd if it is allowed. */
3054
3055 static void
3056 save_symbol (gfc_symbol *sym)
3057 {
3058
3059 if (sym->attr.use_assoc)
3060 return;
3061
3062 if (sym->attr.in_common
3063 || sym->attr.dummy
3064 || sym->attr.flavor != FL_VARIABLE)
3065 return;
3066 /* Automatic objects are not saved. */
3067 if (gfc_is_var_automatic (sym))
3068 return;
3069 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3070 }
3071
3072
3073 /* Mark those symbols which can be SAVEd as such. */
3074
3075 void
3076 gfc_save_all (gfc_namespace *ns)
3077 {
3078
3079 gfc_traverse_ns (ns, save_symbol);
3080 }
3081
3082
3083 #ifdef GFC_DEBUG
3084 /* Make sure that no changes to symbols are pending. */
3085
3086 void
3087 gfc_symbol_state(void) {
3088
3089 if (changed_syms != NULL)
3090 gfc_internal_error("Symbol changes still pending!");
3091 }
3092 #endif
3093
3094
3095 /************** Global symbol handling ************/
3096
3097
3098 /* Search a tree for the global symbol. */
3099
3100 gfc_gsymbol *
3101 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3102 {
3103 int c;
3104
3105 if (symbol == NULL)
3106 return NULL;
3107
3108 while (symbol)
3109 {
3110 c = strcmp (name, symbol->name);
3111 if (!c)
3112 return symbol;
3113
3114 symbol = (c < 0) ? symbol->left : symbol->right;
3115 }
3116
3117 return NULL;
3118 }
3119
3120
3121 /* Compare two global symbols. Used for managing the BB tree. */
3122
3123 static int
3124 gsym_compare (void *_s1, void *_s2)
3125 {
3126 gfc_gsymbol *s1, *s2;
3127
3128 s1 = (gfc_gsymbol *) _s1;
3129 s2 = (gfc_gsymbol *) _s2;
3130 return strcmp (s1->name, s2->name);
3131 }
3132
3133
3134 /* Get a global symbol, creating it if it doesn't exist. */
3135
3136 gfc_gsymbol *
3137 gfc_get_gsymbol (const char *name)
3138 {
3139 gfc_gsymbol *s;
3140
3141 s = gfc_find_gsymbol (gfc_gsym_root, name);
3142 if (s != NULL)
3143 return s;
3144
3145 s = gfc_getmem (sizeof (gfc_gsymbol));
3146 s->type = GSYM_UNKNOWN;
3147 s->name = gfc_get_string (name);
3148
3149 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3150
3151 return s;
3152 }
3153
3154
3155 static gfc_symbol *
3156 get_iso_c_binding_dt (int sym_id)
3157 {
3158 gfc_dt_list *dt_list;
3159
3160 dt_list = gfc_derived_types;
3161
3162 /* Loop through the derived types in the name list, searching for
3163 the desired symbol from iso_c_binding. Search the parent namespaces
3164 if necessary and requested to (parent_flag). */
3165 while (dt_list != NULL)
3166 {
3167 if (dt_list->derived->from_intmod != INTMOD_NONE
3168 && dt_list->derived->intmod_sym_id == sym_id)
3169 return dt_list->derived;
3170
3171 dt_list = dt_list->next;
3172 }
3173
3174 return NULL;
3175 }
3176
3177
3178 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3179 with C. This is necessary for any derived type that is BIND(C) and for
3180 derived types that are parameters to functions that are BIND(C). All
3181 fields of the derived type are required to be interoperable, and are tested
3182 for such. If an error occurs, the errors are reported here, allowing for
3183 multiple errors to be handled for a single derived type. */
3184
3185 try
3186 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3187 {
3188 gfc_component *curr_comp = NULL;
3189 try is_c_interop = FAILURE;
3190 try retval = SUCCESS;
3191
3192 if (derived_sym == NULL)
3193 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3194 "unexpectedly NULL");
3195
3196 /* If we've already looked at this derived symbol, do not look at it again
3197 so we don't repeat warnings/errors. */
3198 if (derived_sym->ts.is_c_interop)
3199 return SUCCESS;
3200
3201 /* The derived type must have the BIND attribute to be interoperable
3202 J3/04-007, Section 15.2.3. */
3203 if (derived_sym->attr.is_bind_c != 1)
3204 {
3205 derived_sym->ts.is_c_interop = 0;
3206 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3207 "attribute to be C interoperable", derived_sym->name,
3208 &(derived_sym->declared_at));
3209 retval = FAILURE;
3210 }
3211
3212 curr_comp = derived_sym->components;
3213
3214 /* TODO: is this really an error? */
3215 if (curr_comp == NULL)
3216 {
3217 gfc_error ("Derived type '%s' at %L is empty",
3218 derived_sym->name, &(derived_sym->declared_at));
3219 return FAILURE;
3220 }
3221
3222 /* Initialize the derived type as being C interoperable.
3223 If we find an error in the components, this will be set false. */
3224 derived_sym->ts.is_c_interop = 1;
3225
3226 /* Loop through the list of components to verify that the kind of
3227 each is a C interoperable type. */
3228 do
3229 {
3230 /* The components cannot be pointers (fortran sense).
3231 J3/04-007, Section 15.2.3, C1505. */
3232 if (curr_comp->pointer != 0)
3233 {
3234 gfc_error ("Component '%s' at %L cannot have the "
3235 "POINTER attribute because it is a member "
3236 "of the BIND(C) derived type '%s' at %L",
3237 curr_comp->name, &(curr_comp->loc),
3238 derived_sym->name, &(derived_sym->declared_at));
3239 retval = FAILURE;
3240 }
3241
3242 /* The components cannot be allocatable.
3243 J3/04-007, Section 15.2.3, C1505. */
3244 if (curr_comp->allocatable != 0)
3245 {
3246 gfc_error ("Component '%s' at %L cannot have the "
3247 "ALLOCATABLE attribute because it is a member "
3248 "of the BIND(C) derived type '%s' at %L",
3249 curr_comp->name, &(curr_comp->loc),
3250 derived_sym->name, &(derived_sym->declared_at));
3251 retval = FAILURE;
3252 }
3253
3254 /* BIND(C) derived types must have interoperable components. */
3255 if (curr_comp->ts.type == BT_DERIVED
3256 && curr_comp->ts.derived->ts.is_iso_c != 1
3257 && curr_comp->ts.derived != derived_sym)
3258 {
3259 /* This should be allowed; the draft says a derived-type can not
3260 have type parameters if it is has the BIND attribute. Type
3261 parameters seem to be for making parameterized derived types.
3262 There's no need to verify the type if it is c_ptr/c_funptr. */
3263 retval = verify_bind_c_derived_type (curr_comp->ts.derived);
3264 }
3265 else
3266 {
3267 /* Grab the typespec for the given component and test the kind. */
3268 is_c_interop = verify_c_interop (&(curr_comp->ts), curr_comp->name,
3269 &(curr_comp->loc));
3270
3271 if (is_c_interop != SUCCESS)
3272 {
3273 /* Report warning and continue since not fatal. The
3274 draft does specify a constraint that requires all fields
3275 to interoperate, but if the user says real(4), etc., it
3276 may interoperate with *something* in C, but the compiler
3277 most likely won't know exactly what. Further, it may not
3278 interoperate with the same data type(s) in C if the user
3279 recompiles with different flags (e.g., -m32 and -m64 on
3280 x86_64 and using integer(4) to claim interop with a
3281 C_LONG). */
3282 if (derived_sym->attr.is_bind_c == 1)
3283 /* If the derived type is bind(c), all fields must be
3284 interop. */
3285 gfc_warning ("Component '%s' in derived type '%s' at %L "
3286 "may not be C interoperable, even though "
3287 "derived type '%s' is BIND(C)",
3288 curr_comp->name, derived_sym->name,
3289 &(curr_comp->loc), derived_sym->name);
3290 else
3291 /* If derived type is param to bind(c) routine, or to one
3292 of the iso_c_binding procs, it must be interoperable, so
3293 all fields must interop too. */
3294 gfc_warning ("Component '%s' in derived type '%s' at %L "
3295 "may not be C interoperable",
3296 curr_comp->name, derived_sym->name,
3297 &(curr_comp->loc));
3298 }
3299 }
3300
3301 curr_comp = curr_comp->next;
3302 } while (curr_comp != NULL);
3303
3304
3305 /* Make sure we don't have conflicts with the attributes. */
3306 if (derived_sym->attr.access == ACCESS_PRIVATE)
3307 {
3308 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3309 "PRIVATE and BIND(C) attributes", derived_sym->name,
3310 &(derived_sym->declared_at));
3311 retval = FAILURE;
3312 }
3313
3314 if (derived_sym->attr.sequence != 0)
3315 {
3316 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3317 "attribute because it is BIND(C)", derived_sym->name,
3318 &(derived_sym->declared_at));
3319 retval = FAILURE;
3320 }
3321
3322 /* Mark the derived type as not being C interoperable if we found an
3323 error. If there were only warnings, proceed with the assumption
3324 it's interoperable. */
3325 if (retval == FAILURE)
3326 derived_sym->ts.is_c_interop = 0;
3327
3328 return retval;
3329 }
3330
3331
3332 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3333
3334 static try
3335 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3336 const char *module_name)
3337 {
3338 gfc_symtree *tmp_symtree;
3339 gfc_symbol *tmp_sym;
3340
3341 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3342
3343 if (tmp_symtree != NULL)
3344 tmp_sym = tmp_symtree->n.sym;
3345 else
3346 {
3347 tmp_sym = NULL;
3348 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3349 "create symbol for %s", ptr_name);
3350 }
3351
3352 /* Set up the symbol's important fields. Save attr required so we can
3353 initialize the ptr to NULL. */
3354 tmp_sym->attr.save = SAVE_EXPLICIT;
3355 tmp_sym->ts.is_c_interop = 1;
3356 tmp_sym->attr.is_c_interop = 1;
3357 tmp_sym->ts.is_iso_c = 1;
3358 tmp_sym->ts.type = BT_DERIVED;
3359
3360 /* The c_ptr and c_funptr derived types will provide the
3361 definition for c_null_ptr and c_null_funptr, respectively. */
3362 if (ptr_id == ISOCBINDING_NULL_PTR)
3363 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3364 else
3365 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3366 if (tmp_sym->ts.derived == NULL)
3367 {
3368 /* This can occur if the user forgot to declare c_ptr or
3369 c_funptr and they're trying to use one of the procedures
3370 that has arg(s) of the missing type. In this case, a
3371 regular version of the thing should have been put in the
3372 current ns. */
3373 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3374 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3375 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3376 ? "_gfortran_iso_c_binding_c_ptr"
3377 : "_gfortran_iso_c_binding_c_funptr"));
3378
3379 tmp_sym->ts.derived =
3380 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3381 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3382 }
3383
3384 /* Module name is some mangled version of iso_c_binding. */
3385 tmp_sym->module = gfc_get_string (module_name);
3386
3387 /* Say it's from the iso_c_binding module. */
3388 tmp_sym->attr.is_iso_c = 1;
3389
3390 tmp_sym->attr.use_assoc = 1;
3391 tmp_sym->attr.is_bind_c = 1;
3392 /* Set the binding_label. */
3393 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3394
3395 /* Set the c_address field of c_null_ptr and c_null_funptr to
3396 the value of NULL. */
3397 tmp_sym->value = gfc_get_expr ();
3398 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3399 tmp_sym->value->ts.type = BT_DERIVED;
3400 tmp_sym->value->ts.derived = tmp_sym->ts.derived;
3401 /* Create a constructor with no expr, that way we can recognize if the user
3402 tries to call the structure constructor for one of the iso_c_binding
3403 derived types during resolution (resolve_structure_cons). */
3404 tmp_sym->value->value.constructor = gfc_get_constructor ();
3405 /* Must declare c_null_ptr and c_null_funptr as having the
3406 PARAMETER attribute so they can be used in init expressions. */
3407 tmp_sym->attr.flavor = FL_PARAMETER;
3408
3409 return SUCCESS;
3410 }
3411
3412
3413 /* Add a formal argument, gfc_formal_arglist, to the
3414 end of the given list of arguments. Set the reference to the
3415 provided symbol, param_sym, in the argument. */
3416
3417 static void
3418 add_formal_arg (gfc_formal_arglist **head,
3419 gfc_formal_arglist **tail,
3420 gfc_formal_arglist *formal_arg,
3421 gfc_symbol *param_sym)
3422 {
3423 /* Put in list, either as first arg or at the tail (curr arg). */
3424 if (*head == NULL)
3425 *head = *tail = formal_arg;
3426 else
3427 {
3428 (*tail)->next = formal_arg;
3429 (*tail) = formal_arg;
3430 }
3431
3432 (*tail)->sym = param_sym;
3433 (*tail)->next = NULL;
3434
3435 return;
3436 }
3437
3438
3439 /* Generates a symbol representing the CPTR argument to an
3440 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3441 CPTR and add it to the provided argument list. */
3442
3443 static void
3444 gen_cptr_param (gfc_formal_arglist **head,
3445 gfc_formal_arglist **tail,
3446 const char *module_name,
3447 gfc_namespace *ns, const char *c_ptr_name,
3448 int iso_c_sym_id)
3449 {
3450 gfc_symbol *param_sym = NULL;
3451 gfc_symbol *c_ptr_sym = NULL;
3452 gfc_symtree *param_symtree = NULL;
3453 gfc_formal_arglist *formal_arg = NULL;
3454 const char *c_ptr_in;
3455 const char *c_ptr_type = NULL;
3456
3457 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3458 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3459 else
3460 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3461
3462 if(c_ptr_name == NULL)
3463 c_ptr_in = "gfc_cptr__";
3464 else
3465 c_ptr_in = c_ptr_name;
3466 gfc_get_sym_tree (c_ptr_in, ns, &param_symtree);
3467 if (param_symtree != NULL)
3468 param_sym = param_symtree->n.sym;
3469 else
3470 gfc_internal_error ("gen_cptr_param(): Unable to "
3471 "create symbol for %s", c_ptr_in);
3472
3473 /* Set up the appropriate fields for the new c_ptr param sym. */
3474 param_sym->refs++;
3475 param_sym->attr.flavor = FL_DERIVED;
3476 param_sym->ts.type = BT_DERIVED;
3477 param_sym->attr.intent = INTENT_IN;
3478 param_sym->attr.dummy = 1;
3479
3480 /* This will pass the ptr to the iso_c routines as a (void *). */
3481 param_sym->attr.value = 1;
3482 param_sym->attr.use_assoc = 1;
3483
3484 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3485 (user renamed). */
3486 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3487 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3488 else
3489 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3490 if (c_ptr_sym == NULL)
3491 {
3492 /* This can happen if the user did not define c_ptr but they are
3493 trying to use one of the iso_c_binding functions that need it. */
3494 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3495 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3496 (const char *)c_ptr_type);
3497 else
3498 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3499 (const char *)c_ptr_type);
3500
3501 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3502 }
3503
3504 param_sym->ts.derived = c_ptr_sym;
3505 param_sym->module = gfc_get_string (module_name);
3506
3507 /* Make new formal arg. */
3508 formal_arg = gfc_get_formal_arglist ();
3509 /* Add arg to list of formal args (the CPTR arg). */
3510 add_formal_arg (head, tail, formal_arg, param_sym);
3511 }
3512
3513
3514 /* Generates a symbol representing the FPTR argument to an
3515 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3516 FPTR and add it to the provided argument list. */
3517
3518 static void
3519 gen_fptr_param (gfc_formal_arglist **head,
3520 gfc_formal_arglist **tail,
3521 const char *module_name,
3522 gfc_namespace *ns, const char *f_ptr_name)
3523 {
3524 gfc_symbol *param_sym = NULL;
3525 gfc_symtree *param_symtree = NULL;
3526 gfc_formal_arglist *formal_arg = NULL;
3527 const char *f_ptr_out = "gfc_fptr__";
3528
3529 if (f_ptr_name != NULL)
3530 f_ptr_out = f_ptr_name;
3531
3532 gfc_get_sym_tree (f_ptr_out, ns, &param_symtree);
3533 if (param_symtree != NULL)
3534 param_sym = param_symtree->n.sym;
3535 else
3536 gfc_internal_error ("generateFPtrParam(): Unable to "
3537 "create symbol for %s", f_ptr_out);
3538
3539 /* Set up the necessary fields for the fptr output param sym. */
3540 param_sym->refs++;
3541 param_sym->attr.pointer = 1;
3542 param_sym->attr.dummy = 1;
3543 param_sym->attr.use_assoc = 1;
3544
3545 /* ISO C Binding type to allow any pointer type as actual param. */
3546 param_sym->ts.type = BT_VOID;
3547 param_sym->module = gfc_get_string (module_name);
3548
3549 /* Make the arg. */
3550 formal_arg = gfc_get_formal_arglist ();
3551 /* Add arg to list of formal args. */
3552 add_formal_arg (head, tail, formal_arg, param_sym);
3553 }
3554
3555
3556 /* Generates a symbol representing the optional SHAPE argument for the
3557 iso_c_binding c_f_pointer() procedure. Also, create a
3558 gfc_formal_arglist for the SHAPE and add it to the provided
3559 argument list. */
3560
3561 static void
3562 gen_shape_param (gfc_formal_arglist **head,
3563 gfc_formal_arglist **tail,
3564 const char *module_name,
3565 gfc_namespace *ns, const char *shape_param_name)
3566 {
3567 gfc_symbol *param_sym = NULL;
3568 gfc_symtree *param_symtree = NULL;
3569 gfc_formal_arglist *formal_arg = NULL;
3570 const char *shape_param = "gfc_shape_array__";
3571 int i;
3572
3573 if (shape_param_name != NULL)
3574 shape_param = shape_param_name;
3575
3576 gfc_get_sym_tree (shape_param, ns, &param_symtree);
3577 if (param_symtree != NULL)
3578 param_sym = param_symtree->n.sym;
3579 else
3580 gfc_internal_error ("generateShapeParam(): Unable to "
3581 "create symbol for %s", shape_param);
3582
3583 /* Set up the necessary fields for the shape input param sym. */
3584 param_sym->refs++;
3585 param_sym->attr.dummy = 1;
3586 param_sym->attr.use_assoc = 1;
3587
3588 /* Integer array, rank 1, describing the shape of the object. Make it's
3589 type BT_VOID initially so we can accept any type/kind combination of
3590 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3591 of BT_INTEGER type. */
3592 param_sym->ts.type = BT_VOID;
3593
3594 /* Initialize the kind to default integer. However, it will be overridden
3595 during resolution to match the kind of the SHAPE parameter given as
3596 the actual argument (to allow for any valid integer kind). */
3597 param_sym->ts.kind = gfc_default_integer_kind;
3598 param_sym->as = gfc_get_array_spec ();
3599
3600 /* Clear out the dimension info for the array. */
3601 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3602 {
3603 param_sym->as->lower[i] = NULL;
3604 param_sym->as->upper[i] = NULL;
3605 }
3606 param_sym->as->rank = 1;
3607 param_sym->as->lower[0] = gfc_int_expr (1);
3608
3609 /* The extent is unknown until we get it. The length give us
3610 the rank the incoming pointer. */
3611 param_sym->as->type = AS_ASSUMED_SHAPE;
3612
3613 /* The arg is also optional; it is required iff the second arg
3614 (fptr) is to an array, otherwise, it's ignored. */
3615 param_sym->attr.optional = 1;
3616 param_sym->attr.intent = INTENT_IN;
3617 param_sym->attr.dimension = 1;
3618 param_sym->module = gfc_get_string (module_name);
3619
3620 /* Make the arg. */
3621 formal_arg = gfc_get_formal_arglist ();
3622 /* Add arg to list of formal args. */
3623 add_formal_arg (head, tail, formal_arg, param_sym);
3624 }
3625
3626 /* Add a procedure interface to the given symbol (i.e., store a
3627 reference to the list of formal arguments). */
3628
3629 static void
3630 add_proc_interface (gfc_symbol *sym, ifsrc source,
3631 gfc_formal_arglist *formal)
3632 {
3633
3634 sym->formal = formal;
3635 sym->attr.if_source = source;
3636 }
3637
3638 /* Copy the formal args from an existing symbol, src, into a new
3639 symbol, dest. New formal args are created, and the description of
3640 each arg is set according to the existing ones. This function is
3641 used when creating procedure declaration variables from a procedure
3642 declaration statement (see match_proc_decl()) to create the formal
3643 args based on the args of a given named interface. */
3644
3645 void
3646 copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3647 {
3648 gfc_formal_arglist *head = NULL;
3649 gfc_formal_arglist *tail = NULL;
3650 gfc_formal_arglist *formal_arg = NULL;
3651 gfc_formal_arglist *curr_arg = NULL;
3652 gfc_formal_arglist *formal_prev = NULL;
3653 /* Save current namespace so we can change it for formal args. */
3654 gfc_namespace *parent_ns = gfc_current_ns;
3655
3656 /* Create a new namespace, which will be the formal ns (namespace
3657 of the formal args). */
3658 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3659 gfc_current_ns->proc_name = dest;
3660
3661 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3662 {
3663 formal_arg = gfc_get_formal_arglist ();
3664 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3665
3666 /* May need to copy more info for the symbol. */
3667 formal_arg->sym->attr = curr_arg->sym->attr;
3668 formal_arg->sym->ts = curr_arg->sym->ts;
3669 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3670
3671 /* If this isn't the first arg, set up the next ptr. For the
3672 last arg built, the formal_arg->next will never get set to
3673 anything other than NULL. */
3674 if (formal_prev != NULL)
3675 formal_prev->next = formal_arg;
3676 else
3677 formal_arg->next = NULL;
3678
3679 formal_prev = formal_arg;
3680
3681 /* Add arg to list of formal args. */
3682 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3683 }
3684
3685 /* Add the interface to the symbol. */
3686 add_proc_interface (dest, IFSRC_DECL, head);
3687
3688 /* Store the formal namespace information. */
3689 if (dest->formal != NULL)
3690 /* The current ns should be that for the dest proc. */
3691 dest->formal_ns = gfc_current_ns;
3692 /* Restore the current namespace to what it was on entry. */
3693 gfc_current_ns = parent_ns;
3694 }
3695
3696 /* Builds the parameter list for the iso_c_binding procedure
3697 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3698 generic version of either the c_f_pointer or c_f_procpointer
3699 functions. The new_proc_sym represents a "resolved" version of the
3700 symbol. The functions are resolved to match the types of their
3701 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3702 something similar to c_f_pointer_i4 if the type of data object fptr
3703 pointed to was a default integer. The actual name of the resolved
3704 procedure symbol is further mangled with the module name, etc., but
3705 the idea holds true. */
3706
3707 static void
3708 build_formal_args (gfc_symbol *new_proc_sym,
3709 gfc_symbol *old_sym, int add_optional_arg)
3710 {
3711 gfc_formal_arglist *head = NULL, *tail = NULL;
3712 gfc_namespace *parent_ns = NULL;
3713
3714 parent_ns = gfc_current_ns;
3715 /* Create a new namespace, which will be the formal ns (namespace
3716 of the formal args). */
3717 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
3718 gfc_current_ns->proc_name = new_proc_sym;
3719
3720 /* Generate the params. */
3721 if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3722 (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3723 {
3724 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3725 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3726 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3727 gfc_current_ns, "fptr");
3728
3729 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3730 if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3731 {
3732 gen_shape_param (&head, &tail,
3733 (const char *) new_proc_sym->module,
3734 gfc_current_ns, "shape");
3735 }
3736 }
3737 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3738 {
3739 /* c_associated has one required arg and one optional; both
3740 are c_ptrs. */
3741 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3742 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
3743 if (add_optional_arg)
3744 {
3745 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3746 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
3747 /* The last param is optional so mark it as such. */
3748 tail->sym->attr.optional = 1;
3749 }
3750 }
3751
3752 /* Add the interface (store formal args to new_proc_sym). */
3753 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
3754
3755 /* Set up the formal_ns pointer to the one created for the
3756 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3757 new_proc_sym->formal_ns = gfc_current_ns;
3758
3759 gfc_current_ns = parent_ns;
3760 }
3761
3762 static int
3763 std_for_isocbinding_symbol (int id)
3764 {
3765 switch (id)
3766 {
3767 #define NAMED_INTCST(a,b,c,d) \
3768 case a:\
3769 return d;
3770 #include "iso-c-binding.def"
3771 #undef NAMED_INTCST
3772 default:
3773 return GFC_STD_F2003;
3774 }
3775 }
3776
3777 /* Generate the given set of C interoperable kind objects, or all
3778 interoperable kinds. This function will only be given kind objects
3779 for valid iso_c_binding defined types because this is verified when
3780 the 'use' statement is parsed. If the user gives an 'only' clause,
3781 the specific kinds are looked up; if they don't exist, an error is
3782 reported. If the user does not give an 'only' clause, all
3783 iso_c_binding symbols are generated. If a list of specific kinds
3784 is given, it must have a NULL in the first empty spot to mark the
3785 end of the list. */
3786
3787
3788 void
3789 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
3790 const char *local_name)
3791 {
3792 const char *const name = (local_name && local_name[0]) ? local_name
3793 : c_interop_kinds_table[s].name;
3794 gfc_symtree *tmp_symtree = NULL;
3795 gfc_symbol *tmp_sym = NULL;
3796 gfc_dt_list **dt_list_ptr = NULL;
3797 gfc_component *tmp_comp = NULL;
3798 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
3799 int index;
3800
3801 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == FAILURE)
3802 return;
3803 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
3804
3805 /* Already exists in this scope so don't re-add it.
3806 TODO: we should probably check that it's really the same symbol. */
3807 if (tmp_symtree != NULL)
3808 return;
3809
3810 /* Create the sym tree in the current ns. */
3811 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
3812 if (tmp_symtree)
3813 tmp_sym = tmp_symtree->n.sym;
3814 else
3815 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3816 "create symbol");
3817
3818 /* Say what module this symbol belongs to. */
3819 tmp_sym->module = gfc_get_string (mod_name);
3820 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
3821 tmp_sym->intmod_sym_id = s;
3822
3823 switch (s)
3824 {
3825
3826 #define NAMED_INTCST(a,b,c,d) case a :
3827 #define NAMED_REALCST(a,b,c) case a :
3828 #define NAMED_CMPXCST(a,b,c) case a :
3829 #define NAMED_LOGCST(a,b,c) case a :
3830 #define NAMED_CHARKNDCST(a,b,c) case a :
3831 #include "iso-c-binding.def"
3832
3833 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
3834
3835 /* Initialize an integer constant expression node. */
3836 tmp_sym->attr.flavor = FL_PARAMETER;
3837 tmp_sym->ts.type = BT_INTEGER;
3838 tmp_sym->ts.kind = gfc_default_integer_kind;
3839
3840 /* Mark this type as a C interoperable one. */
3841 tmp_sym->ts.is_c_interop = 1;
3842 tmp_sym->ts.is_iso_c = 1;
3843 tmp_sym->value->ts.is_c_interop = 1;
3844 tmp_sym->value->ts.is_iso_c = 1;
3845 tmp_sym->attr.is_c_interop = 1;
3846
3847 /* Tell what f90 type this c interop kind is valid. */
3848 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
3849
3850 /* Say it's from the iso_c_binding module. */
3851 tmp_sym->attr.is_iso_c = 1;
3852
3853 /* Make it use associated. */
3854 tmp_sym->attr.use_assoc = 1;
3855 break;
3856
3857
3858 #define NAMED_CHARCST(a,b,c) case a :
3859 #include "iso-c-binding.def"
3860
3861 /* Initialize an integer constant expression node for the
3862 length of the character. */
3863 tmp_sym->value = gfc_get_expr ();
3864 tmp_sym->value->expr_type = EXPR_CONSTANT;
3865 tmp_sym->value->ts.type = BT_CHARACTER;
3866 tmp_sym->value->ts.kind = gfc_default_character_kind;
3867 tmp_sym->value->where = gfc_current_locus;
3868 tmp_sym->value->ts.is_c_interop = 1;
3869 tmp_sym->value->ts.is_iso_c = 1;
3870 tmp_sym->value->value.character.length = 1;
3871 tmp_sym->value->value.character.string = gfc_get_wide_string (2);
3872 tmp_sym->value->value.character.string[0]
3873 = (gfc_char_t) c_interop_kinds_table[s].value;
3874 tmp_sym->value->value.character.string[1] = '\0';
3875 tmp_sym->ts.cl = gfc_get_charlen ();
3876 tmp_sym->ts.cl->length = gfc_int_expr (1);
3877
3878 /* May not need this in both attr and ts, but do need in
3879 attr for writing module file. */
3880 tmp_sym->attr.is_c_interop = 1;
3881
3882 tmp_sym->attr.flavor = FL_PARAMETER;
3883 tmp_sym->ts.type = BT_CHARACTER;
3884
3885 /* Need to set it to the C_CHAR kind. */
3886 tmp_sym->ts.kind = gfc_default_character_kind;
3887
3888 /* Mark this type as a C interoperable one. */
3889 tmp_sym->ts.is_c_interop = 1;
3890 tmp_sym->ts.is_iso_c = 1;
3891
3892 /* Tell what f90 type this c interop kind is valid. */
3893 tmp_sym->ts.f90_type = BT_CHARACTER;
3894
3895 /* Say it's from the iso_c_binding module. */
3896 tmp_sym->attr.is_iso_c = 1;
3897
3898 /* Make it use associated. */
3899 tmp_sym->attr.use_assoc = 1;
3900 break;
3901
3902 case ISOCBINDING_PTR:
3903 case ISOCBINDING_FUNPTR:
3904
3905 /* Initialize an integer constant expression node. */
3906 tmp_sym->attr.flavor = FL_DERIVED;
3907 tmp_sym->ts.is_c_interop = 1;
3908 tmp_sym->attr.is_c_interop = 1;
3909 tmp_sym->attr.is_iso_c = 1;
3910 tmp_sym->ts.is_iso_c = 1;
3911 tmp_sym->ts.type = BT_DERIVED;
3912
3913 /* A derived type must have the bind attribute to be
3914 interoperable (J3/04-007, Section 15.2.3), even though
3915 the binding label is not used. */
3916 tmp_sym->attr.is_bind_c = 1;
3917
3918 tmp_sym->attr.referenced = 1;
3919
3920 tmp_sym->ts.derived = tmp_sym;
3921
3922 /* Add the symbol created for the derived type to the current ns. */
3923 dt_list_ptr = &(gfc_derived_types);
3924 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
3925 dt_list_ptr = &((*dt_list_ptr)->next);
3926
3927 /* There is already at least one derived type in the list, so append
3928 the one we're currently building for c_ptr or c_funptr. */
3929 if (*dt_list_ptr != NULL)
3930 dt_list_ptr = &((*dt_list_ptr)->next);
3931 (*dt_list_ptr) = gfc_get_dt_list ();
3932 (*dt_list_ptr)->derived = tmp_sym;
3933 (*dt_list_ptr)->next = NULL;
3934
3935 /* Set up the component of the derived type, which will be
3936 an integer with kind equal to c_ptr_size. Mangle the name of
3937 the field for the c_address to prevent the curious user from
3938 trying to access it from Fortran. */
3939 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
3940 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
3941 if (tmp_comp == NULL)
3942 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3943 "create component for c_address");
3944
3945 tmp_comp->ts.type = BT_INTEGER;
3946
3947 /* Set this because the module will need to read/write this field. */
3948 tmp_comp->ts.f90_type = BT_INTEGER;
3949
3950 /* The kinds for c_ptr and c_funptr are the same. */
3951 index = get_c_kind ("c_ptr", c_interop_kinds_table);
3952 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
3953
3954 tmp_comp->pointer = 0;
3955 tmp_comp->dimension = 0;
3956
3957 /* Mark the component as C interoperable. */
3958 tmp_comp->ts.is_c_interop = 1;
3959
3960 /* Make it use associated (iso_c_binding module). */
3961 tmp_sym->attr.use_assoc = 1;
3962 break;
3963
3964 case ISOCBINDING_NULL_PTR:
3965 case ISOCBINDING_NULL_FUNPTR:
3966 gen_special_c_interop_ptr (s, name, mod_name);
3967 break;
3968
3969 case ISOCBINDING_F_POINTER:
3970 case ISOCBINDING_ASSOCIATED:
3971 case ISOCBINDING_LOC:
3972 case ISOCBINDING_FUNLOC:
3973 case ISOCBINDING_F_PROCPOINTER:
3974
3975 tmp_sym->attr.proc = PROC_MODULE;
3976
3977 /* Use the procedure's name as it is in the iso_c_binding module for
3978 setting the binding label in case the user renamed the symbol. */
3979 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
3980 c_interop_kinds_table[s].name);
3981 tmp_sym->attr.is_iso_c = 1;
3982 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
3983 tmp_sym->attr.subroutine = 1;
3984 else
3985 {
3986 /* TODO! This needs to be finished more for the expr of the
3987 function or something!
3988 This may not need to be here, because trying to do c_loc
3989 as an external. */
3990 if (s == ISOCBINDING_ASSOCIATED)
3991 {
3992 tmp_sym->attr.function = 1;
3993 tmp_sym->ts.type = BT_LOGICAL;
3994 tmp_sym->ts.kind = gfc_default_logical_kind;
3995 tmp_sym->result = tmp_sym;
3996 }
3997 else
3998 {
3999 /* Here, we're taking the simple approach. We're defining
4000 c_loc as an external identifier so the compiler will put
4001 what we expect on the stack for the address we want the
4002 C address of. */
4003 tmp_sym->ts.type = BT_DERIVED;
4004 if (s == ISOCBINDING_LOC)
4005 tmp_sym->ts.derived =
4006 get_iso_c_binding_dt (ISOCBINDING_PTR);
4007 else
4008 tmp_sym->ts.derived =
4009 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4010
4011 if (tmp_sym->ts.derived == NULL)
4012 {
4013 /* Create the necessary derived type so we can continue
4014 processing the file. */
4015 generate_isocbinding_symbol
4016 (mod_name, s == ISOCBINDING_FUNLOC
4017 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4018 (const char *)(s == ISOCBINDING_FUNLOC
4019 ? "_gfortran_iso_c_binding_c_funptr"
4020 : "_gfortran_iso_c_binding_c_ptr"));
4021 tmp_sym->ts.derived =
4022 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4023 ? ISOCBINDING_FUNPTR
4024 : ISOCBINDING_PTR);
4025 }
4026
4027 /* The function result is itself (no result clause). */
4028 tmp_sym->result = tmp_sym;
4029 tmp_sym->attr.external = 1;
4030 tmp_sym->attr.use_assoc = 0;
4031 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4032 tmp_sym->attr.proc = PROC_UNKNOWN;
4033 }
4034 }
4035
4036 tmp_sym->attr.flavor = FL_PROCEDURE;
4037 tmp_sym->attr.contained = 0;
4038
4039 /* Try using this builder routine, with the new and old symbols
4040 both being the generic iso_c proc sym being created. This
4041 will create the formal args (and the new namespace for them).
4042 Don't build an arg list for c_loc because we're going to treat
4043 c_loc as an external procedure. */
4044 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4045 /* The 1 says to add any optional args, if applicable. */
4046 build_formal_args (tmp_sym, tmp_sym, 1);
4047
4048 /* Set this after setting up the symbol, to prevent error messages. */
4049 tmp_sym->attr.use_assoc = 1;
4050
4051 /* This symbol will not be referenced directly. It will be
4052 resolved to the implementation for the given f90 kind. */
4053 tmp_sym->attr.referenced = 0;
4054
4055 break;
4056
4057 default:
4058 gcc_unreachable ();
4059 }
4060 }
4061
4062
4063 /* Creates a new symbol based off of an old iso_c symbol, with a new
4064 binding label. This function can be used to create a new,
4065 resolved, version of a procedure symbol for c_f_pointer or
4066 c_f_procpointer that is based on the generic symbols. A new
4067 parameter list is created for the new symbol using
4068 build_formal_args(). The add_optional_flag specifies whether the
4069 to add the optional SHAPE argument. The new symbol is
4070 returned. */
4071
4072 gfc_symbol *
4073 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4074 char *new_binding_label, int add_optional_arg)
4075 {
4076 gfc_symtree *new_symtree = NULL;
4077
4078 /* See if we have a symbol by that name already available, looking
4079 through any parent namespaces. */
4080 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4081 if (new_symtree != NULL)
4082 /* Return the existing symbol. */
4083 return new_symtree->n.sym;
4084
4085 /* Create the symtree/symbol, with attempted host association. */
4086 gfc_get_ha_sym_tree (new_name, &new_symtree);
4087 if (new_symtree == NULL)
4088 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4089 "symtree for '%s'", new_name);
4090
4091 /* Now fill in the fields of the resolved symbol with the old sym. */
4092 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4093 new_symtree->n.sym->attr = old_sym->attr;
4094 new_symtree->n.sym->ts = old_sym->ts;
4095 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4096 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4097 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4098 /* Build the formal arg list. */
4099 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4100
4101 gfc_commit_symbol (new_symtree->n.sym);
4102
4103 return new_symtree->n.sym;
4104 }
4105