* Re: [Patch, fortran] Parameterized Derived Types
@ 2017-09-09 11:15 Paul Richard Thomas
2017-09-09 11:27 ` Damian Rouson
2018-09-07 8:43 ` Bernhard Reutner-Fischer
0 siblings, 2 replies; 10+ messages in thread
From: Paul Richard Thomas @ 2017-09-09 11:15 UTC (permalink / raw)
To: fortran, gcc-patches; +Cc: Damian Rouson, Mark LeAir
Dear All,
The patch has been committed as revision 251925.
I look forward to "feedback" (aka PRs) in the coming weeks. I will
return to Parameterized Derived Types at the end of this month to
clear up some of the known deficiencies (see the notes attached to the
patch submission) and any PRs that arise.
Regards
Paul
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] Parameterized Derived Types
2017-09-09 11:15 [Patch, fortran] Parameterized Derived Types Paul Richard Thomas
@ 2017-09-09 11:27 ` Damian Rouson
2017-09-09 19:08 ` Janus Weil
2018-09-07 8:43 ` Bernhard Reutner-Fischer
1 sibling, 1 reply; 10+ messages in thread
From: Damian Rouson @ 2017-09-09 11:27 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: gfortran
Hooray!!!! Great work, Paul. I’ve already launched a build.
One small step for gfortran. One big step for the Fortran world. I hope you’ll be announcing this on comp.lang.fortran.
:D
On September 9, 2017 at 4:15:37 AM, Paul Richard Thomas (paul.richard.thomas@gmail.com(mailto:paul.richard.thomas@gmail.com)) wrote:
> Dear All,
>
> The patch has been committed as revision 251925.
>
> I look forward to "feedback" (aka PRs) in the coming weeks. I will
> return to Parameterized Derived Types at the end of this month to
> clear up some of the known deficiencies (see the notes attached to the
> patch submission) and any PRs that arise.
>
> Regards
>
> Paul
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] Parameterized Derived Types
2017-09-09 11:27 ` Damian Rouson
@ 2017-09-09 19:08 ` Janus Weil
2017-09-10 8:18 ` Paul Richard Thomas
0 siblings, 1 reply; 10+ messages in thread
From: Janus Weil @ 2017-09-09 19:08 UTC (permalink / raw)
To: Damian Rouson; +Cc: Paul Richard Thomas, gfortran
[-- Attachment #1: Type: text/plain, Size: 1721 bytes --]
2017-09-09 13:27 GMT+02:00 Damian Rouson <damian@sourceryinstitute.org>:
>
> Hooray!!!! Great work, Paul.
+1 :D
As promised, I have done some testing by now, and found several
problems (ICE-on-invalid, accepts-invalid and rejects-valid), see the
attached test cases. Nothing too severe I guess.
> One small step for gfortran. One big step for the Fortran world.
I have never looked very closely into PDTs, but now that I do, it
seems like the step for the Fortran world is not quite as big as it
could be (or as I had hoped).
The restriction that KIND parameters cannot be assumed/deferred is a
pretty severe one, isn't it? In terms of "generic programming" it
makes PDTs far less powerful than e.g. C++ templates (I knew that they
are less powerful, but with this restriction it's worse than I
thought).
In particular, it seems that I can define a nice 'generic' type that
deals with arbitrary KIND values in theory, but then all the functions
/ TBPs that work on my type need to be implemented separately for each
KIND value (which means lots of cod duplication), right? Or am I
overlooking anything here? Is anyone aware if this restriction is
lifted in F08 or later, or is planned to be lifted?
Cheers,
Janus
> On September 9, 2017 at 4:15:37 AM, Paul Richard Thomas (paul.richard.thomas@gmail.com(mailto:paul.richard.thomas@gmail.com)) wrote:
>
>> Dear All,
>>
>> The patch has been committed as revision 251925.
>>
>> I look forward to "feedback" (aka PRs) in the coming weeks. I will
>> return to Parameterized Derived Types at the end of this month to
>> clear up some of the known deficiencies (see the notes attached to the
>> patch submission) and any PRs that arise.
>>
>> Regards
>>
>> Paul
>
[-- Attachment #2: pdt1.f90 --]
[-- Type: text/x-fortran, Size: 561 bytes --]
! ICE on invalid & accepts invalid
implicit none
type :: param_matrix(c,r)
integer, len :: c,r
real :: m(c,r)
end type
type real_array(k)
integer, kind :: k
real(kind=k), allocatable :: r(:)
end type
type(param_matrix(1)) :: m1 ! segfault in gfc_get_pdt_instance (decl.c)
type(param_matrix(1,2)) :: m2 ! ok
type(param_matrix(1,2,3)) :: m3 ! accepted, but invalid
type(param_matrix(1,2.5)) :: m4 ! accepted, but invalid
type(real_array(4)) :: a1 ! ok
type(real_array(5)) :: a2 ! segfault in tree_class_check (tree.h)
end
[-- Attachment #3: pdt2.f90 --]
[-- Type: text/x-fortran, Size: 259 bytes --]
! accepts invalid
implicit none
type :: t(k,i,a,x,y)
integer, kind :: k
integer :: i ! KIND or LEN missing
integer :: a(3) ! must be scalar
real :: x ! must be integer
! y is not declared at all
end type
end
[-- Attachment #4: pdt3.f90 --]
[-- Type: text/x-fortran, Size: 266 bytes --]
! rejects valid
implicit none
type :: param_matrix(k,c,r)
integer, kind :: k
integer, len :: c,r
real(kind=k) :: m(c,r)
end type
type(param_matrix(8,3,2)) :: mat
real(kind=mat%k) :: m ! Error: Parameter ‘mat’ at (1) has not been declared or ...
end
[-- Attachment #5: pdt4.f90 --]
[-- Type: text/x-fortran, Size: 696 bytes --]
! rejects valid
module my_matrix
type :: param_matrix(k,c,r)
integer, kind :: k
integer, len :: r
integer, len :: c
real(kind=k) :: m(c,r)
end type param_matrix
interface process_matrix
module procedure process_matrix_4
module procedure process_matrix_8
end interface
contains
subroutine process_matrix_4(m)
type(param_matrix(4,*,*)) :: m ! Derived type ‘pdtparam_matrix_4’ at (1) is being used before it is defined
end subroutine process_matrix_4
subroutine process_matrix_8(m)
type(param_matrix(8,*,*)) :: m ! Derived type ‘pdtparam_matrix_8’ at (1) is being used before it is defined
end subroutine process_matrix_8
end module
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] Parameterized Derived Types
2017-09-09 19:08 ` Janus Weil
@ 2017-09-10 8:18 ` Paul Richard Thomas
2017-09-11 20:23 ` Janus Weil
0 siblings, 1 reply; 10+ messages in thread
From: Paul Richard Thomas @ 2017-09-10 8:18 UTC (permalink / raw)
To: Janus Weil; +Cc: Damian Rouson, gfortran
Dear Janus,
Many thanks for doing some testing and for the failing testcases.
I agree that not allowing ASSUMED or DEFERRED KIND parameters is a
limitation. As far as I am aware there are no plans to change this but
there have been discussions concerning generic programming for F20xx
on clf. The consensus is that PDTs were a step in the wrong direction
:-) I was mulling over laying out how some of the proposals could be
implemented to add my 1 centime's worth to the discussion.
Cheers
Paul
On 9 September 2017 at 20:08, Janus Weil <janus@gcc.gnu.org> wrote:
> 2017-09-09 13:27 GMT+02:00 Damian Rouson <damian@sourceryinstitute.org>:
>>
>> Hooray!!!! Great work, Paul.
>
> +1 :D
>
>
> As promised, I have done some testing by now, and found several
> problems (ICE-on-invalid, accepts-invalid and rejects-valid), see the
> attached test cases. Nothing too severe I guess.
>
>
>
>> One small step for gfortran. One big step for the Fortran world.
>
> I have never looked very closely into PDTs, but now that I do, it
> seems like the step for the Fortran world is not quite as big as it
> could be (or as I had hoped).
>
> The restriction that KIND parameters cannot be assumed/deferred is a
> pretty severe one, isn't it? In terms of "generic programming" it
> makes PDTs far less powerful than e.g. C++ templates (I knew that they
> are less powerful, but with this restriction it's worse than I
> thought).
>
> In particular, it seems that I can define a nice 'generic' type that
> deals with arbitrary KIND values in theory, but then all the functions
> / TBPs that work on my type need to be implemented separately for each
> KIND value (which means lots of cod duplication), right? Or am I
> overlooking anything here? Is anyone aware if this restriction is
> lifted in F08 or later, or is planned to be lifted?
>
> Cheers,
> Janus
>
>
>
>
>> On September 9, 2017 at 4:15:37 AM, Paul Richard Thomas (paul.richard.thomas@gmail.com(mailto:paul.richard.thomas@gmail.com)) wrote:
>>
>>> Dear All,
>>>
>>> The patch has been committed as revision 251925.
>>>
>>> I look forward to "feedback" (aka PRs) in the coming weeks. I will
>>> return to Parameterized Derived Types at the end of this month to
>>> clear up some of the known deficiencies (see the notes attached to the
>>> patch submission) and any PRs that arise.
>>>
>>> Regards
>>>
>>> Paul
>>
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] Parameterized Derived Types
2017-09-10 8:18 ` Paul Richard Thomas
@ 2017-09-11 20:23 ` Janus Weil
0 siblings, 0 replies; 10+ messages in thread
From: Janus Weil @ 2017-09-11 20:23 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: Damian Rouson, gfortran
2017-09-10 10:18 GMT+02:00 Paul Richard Thomas <paul.richard.thomas@gmail.com>:
> I agree that not allowing ASSUMED or DEFERRED KIND parameters is a
> limitation. As far as I am aware there are no plans to change this but
> there have been discussions concerning generic programming for F20xx
> on clf. The consensus is that PDTs were a step in the wrong direction
I wouldn't say the direction is completely wrong, but certainly
F03-PDTs do not go far enough to provide full-blown generic
programming.
One problem is the limitation that I mentioned earlier. Another one is
the fact that PDTs only provide mechanisms that are generic among a
single type (with different kind and len parameters), but none that
are generic across different types (such as e.g. unlimited
polymorphism or C++ templates).
> I was mulling over laying out how some of the proposals could be
> implemented to add my 1 centime's worth to the discussion.
For the start, maybe you could comment on the question, whether it
would be feasible in your implementation of PDTs in gfortran to
support assumed/deferred KIND parameters (as a straightforward
extension to the F03 standard, without any conceptually-new
additions).
Certainly the compiler would have to do a bit more work, namely for
each PDT-generic function (i.e. one that takes a PDT argument)
generate different versions of the function for the supported / used
kind values. Do you think that's possible without too much effort? My
feeling is that it would be quite useful (I don't see myself using
PDTs anytime soon unless this limitation is lifted).
Cheers,
Janus
> On 9 September 2017 at 20:08, Janus Weil <janus@gcc.gnu.org> wrote:
>> 2017-09-09 13:27 GMT+02:00 Damian Rouson <damian@sourceryinstitute.org>:
>>>
>>> Hooray!!!! Great work, Paul.
>>
>> +1 :D
>>
>>
>> As promised, I have done some testing by now, and found several
>> problems (ICE-on-invalid, accepts-invalid and rejects-valid), see the
>> attached test cases. Nothing too severe I guess.
>>
>>
>>
>>> One small step for gfortran. One big step for the Fortran world.
>>
>> I have never looked very closely into PDTs, but now that I do, it
>> seems like the step for the Fortran world is not quite as big as it
>> could be (or as I had hoped).
>>
>> The restriction that KIND parameters cannot be assumed/deferred is a
>> pretty severe one, isn't it? In terms of "generic programming" it
>> makes PDTs far less powerful than e.g. C++ templates (I knew that they
>> are less powerful, but with this restriction it's worse than I
>> thought).
>>
>> In particular, it seems that I can define a nice 'generic' type that
>> deals with arbitrary KIND values in theory, but then all the functions
>> / TBPs that work on my type need to be implemented separately for each
>> KIND value (which means lots of cod duplication), right? Or am I
>> overlooking anything here? Is anyone aware if this restriction is
>> lifted in F08 or later, or is planned to be lifted?
>>
>> Cheers,
>> Janus
>>
>>
>>
>>
>>> On September 9, 2017 at 4:15:37 AM, Paul Richard Thomas (paul.richard.thomas@gmail.com(mailto:paul.richard.thomas@gmail.com)) wrote:
>>>
>>>> Dear All,
>>>>
>>>> The patch has been committed as revision 251925.
>>>>
>>>> I look forward to "feedback" (aka PRs) in the coming weeks. I will
>>>> return to Parameterized Derived Types at the end of this month to
>>>> clear up some of the known deficiencies (see the notes attached to the
>>>> patch submission) and any PRs that arise.
>>>>
>>>> Regards
>>>>
>>>> Paul
>>>
>
>
>
> --
> "If you can't explain it simply, you don't understand it well enough"
> - Albert Einstein
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] Parameterized Derived Types
2017-09-09 11:15 [Patch, fortran] Parameterized Derived Types Paul Richard Thomas
2017-09-09 11:27 ` Damian Rouson
@ 2018-09-07 8:43 ` Bernhard Reutner-Fischer
1 sibling, 0 replies; 10+ messages in thread
From: Bernhard Reutner-Fischer @ 2018-09-07 8:43 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: gfortran
On Sat, 9 Sep 2017 at 13:15, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
>
> Dear All,
>
> The patch has been committed as revision 251925.
>
> I look forward to "feedback" (aka PRs) in the coming weeks. I will
nit: s/uneeded/unneeded/
(as is this nit ;)
cheers,
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] Parameterized Derived Types
2017-09-06 13:05 Paul Richard Thomas
2017-09-06 17:38 ` Janus Weil
@ 2017-09-06 18:37 ` Damian Rouson
1 sibling, 0 replies; 10+ messages in thread
From: Damian Rouson @ 2017-09-06 18:37 UTC (permalink / raw)
To: fortran, Paul Richard Thomas, gcc-patches; +Cc: Mark LeAir
Thanks for your tireless efforts on this, Paul! I look forward to trying this out after it hits the trunk.
Your phrase “last unimplemented F2003” feature bolsters my suspicion that it might be ok to switch the features listed as “Partial” on the Fortran wiki to “Yes." I suppose the difference depends on developer intent. If the developer(s) intended to leave some aspect of a feature unimplemented (as might be evidenced by an appropriate compiler message), then “Partial” seems best. Otherwise, “Yes” seems appropriate even in the presence of bugs. I’ll send a separate email to the list with further thoughts on this.
Best Regards,
_______________________
Damian Rouson, Ph.D., P.E.
President, Sourcery Institute
www.sourceryinstitute.org(http://www.sourceryinstitute.org)
+1-510-600-2992 (mobile)
On September 6, 2017 at 6:04:47 AM, Paul Richard Thomas (paul.richard.thomas@gmail.com(mailto:paul.richard.thomas@gmail.com)) wrote:
> Dear All,
>
> Since my message to the list of 16 August 2017 I have put in another
> intense period of activity to develop a patch to implement PDTs in
> gfortran. I have now temporarily run out of time to develop it
> further; partly because of a backlog of other patches and PRs to deal
> with but also pressure from daytime work.
>
> The patch adds the last unimplemented F2003 feature to gfortran.
>
> As in the provisional patch, I have attached some notes on the
> implementation. This indicates some of the weaknesses, problem areas
> and TODOs.
>
> Suggest that a good read of Mark Leair's excellent PGInsider article
> on PDTs - http://www.pgroup.com/lit/articles/insider/v5n2a4.htm is a
> worthwhile exercise.
>
> To judge by the complete silence following my previous message, I will
> have a problem getting this patch reviewed. I would welcome any
> remarks or reviews but intend to commit, warts and all, on Saturday
> unless something fundamentally wrong comes out of the woodwork.
>
> Note that the PDT parts in the compiler are rather well insulated from
> the rest of fortran and that I do not believe that any regressions
> will result.
>
> I hope that a month or two of testing in other hands will add to the
> list of TODOs and that when I return to PDTs a greatly improved
> version will result.
>
> Bootstrapped and regtested on FC23/x86_4 - OK for trunk? (Note above
> remark about committing on Saturday in the absence of a review.)
>
> Best regards
>
> Paul
>
> 2017-09-05 Paul Thomas
>
> * decl.c : Add decl_type_param_list, type_param_spec_list as
> static variables to hold PDT spec lists.
> (build_sym): Copy 'type_param_spec_list' to symbol spec_list.
> (build_struct): Copy the 'saved_kind_expr' to the component
> 'kind_expr'. Check that KIND or LEN components appear in the
> decl_type_param_list. These should appear as symbols in the
> f2k_derived namespace. If the component is itself a PDT type,
> copy the decl_type_param_list to the component param_list.
> (gfc_match_kind_spec): If the KIND expression is parameterized
> set KIND to zero and store the expression in 'saved_kind_expr'.
> (insert_parameter_exprs): New function.
> (gfc_insert_kind_parameter_exprs): New function.
> (gfc_insert_parameter_exprs): New function.
> (gfc_get_pdt_instance): New function.
> (gfc_match_decl_type_spec): Match the decl_type_spec_list if it
> is present. If it is, call 'gfc_get_pdt_instance' to obtain the
> specific instance of the PDT.
> (match_attr_spec): Match KIND and LEN attributes. Check for the
> standard and for type/kind of the parameter. They are also not
> allowed outside a derived type definition.
> (gfc_match_data_decl): Null the decl_type_param_list and the
> type_param_spec_list on entry and free them on exit.
> (gfc_match_formal_arglist): If 'typeparam' is true, add the
> formal symbol to the f2k_derived namespace.
> (gfc_match_derived_decl): Register the decl_type_param_list
> if this is a PDT. If this is a type extension, gather up all
> the type parameters and put them in the right order.
> *dump-parse-tree.c (show_attr): Signal PDT templates and the
> parameter attributes.
> (show_components): Output parameter atrributes and component
> parameter list.
> (show_symbol): Show variable parameter lists.
> * expr.c (expr.c): Copy the expression parameter list.
> (gfc_is_constant_expr): Pass on symbols representing PDT
> parameters.
> (gfc_check_init_expr): Break on PDT KIND parameters and
> PDT parameter expressions.
> (gfc_check_assign): Assigning to KIND or LEN components is an
> error.
> (derived_parameter_expr): New function.
> (gfc_derived_parameter_expr): New function.
> (gfc_spec_list_type): New function.
> * gfortran.h : Add enum gfc_param_spec_type. Add the PDT attrs
> to the structure symbol_attr. Add the 'kind_expr' and
> 'param_list' field to the gfc_component structure. Comment on
> the reuse of the gfc_actual_arglist structure as storage for
> type parameter spec lists. Add the new field 'spec_type' to
> this structure. Add 'param_list' fields to gfc_symbol and
> gfc_expr. Add prototypes for gfc_insert_kind_parameter_exprs,
> gfc_insert_parameter_exprs, gfc_add_kind, gfc_add_len,
> gfc_derived_parameter_expr and gfc_spec_list_type.
> * interface.c (gfc_compare_derived_types): Treat PDTs in the
> same way as sequence types.
> * match.c : Add variable 'type_param_spec_list'.
> (gfc_op2string, gfc_match_member_sep, gfc_match_label): Remove
> trailing whitespace.
> (match_derived_type_spec): Match PDTs and find specific
> instance.
> (gfc_match_type_spec): Remove more trailing whitespace.
> (gfc_match_allocate): Assumed or deferred parameters cannot
> appear here. Copy the type parameter spec list to the expr for
> the allocatable entity. Free 'type_param_spec_list'.
> (gfc_match_common, gfc_match_namelist, gfc_match_module): Still
> more trailing whitespace to remove.
> (gfc_match_type_is): Allow PDT typespecs.
> * match.h : Modify prototypes for gfc_match_formal_arglist and
> gfc_match_actual_arglist.
> * module.c (ab_attribute, mstring attr_bits): PDT attributes
> added.
> (mio_symbol_attribute): PDT attributes handled.
> (mio_component): Deal with 'kind_expr' field.
> (mio_full_f2k_derived): For PDT templates, transfer the formal
> namespace symroot to the f2k_derived namespace.
> *primary.c (match_keyword_arg, gfc_match_actual_arglist): Add
> modifications to handle PDT spec lists. These are flagged in
> both cases by new boolean arguments, whose prototype defaults
> are false.
> (gfc_match_structure_constructor, match_variable): Remove yet
> more trailing whitespace.
> * resolve.c (get_pdt_spec_expr, get_pdt_constructor): New
> functions.
> (resolve_structure_cons): If the constructor is a PDT template,
> call get_pdt_constructor to build it using the parameter lists
> and then get the specific instance of the PDT.
> (resolve_component): PDT strings need a hidden string length
> component like deferred characters.
> (resolve_symbol): Dummy PDTs cannot have deferred parameters.
> * symbol.c (gfc_add_kind, gfc_add_len): New functions.
> (free_components): Free 'kind_expr' and 'param_list' fields.
> (gfc_free_symbol): Free the 'param_list' field.
> (gfc_find_sym_tree): If the current state is a PDT template,
> look for the symtree in the f2k_derived namspaces.
> trans-array.c (structure_alloc_comps): Allocate and deallocate
> PDTs. Check dummy arguments for compliance of LEN parameters.
> Add the new functions to the preceeding enum.
> (gfc_allocate_pdt_comp, gfc_deallocate_pdt_comp and
> gfc_check_pdt_dummy): New functions calling above.
> * trans-array.h : Add prototypes for these functions.
> trans-decl.c (gfc_get_symbol_decl): Call gfc_defer_symbol_init
> as appropriate for PDT symbols.
> (gfc_trans_deferred_vars): Allocate/deallocate PDT entities as
> they come into and out of scope. Exclude pdt_types from being
> 'gcc_unreachable'.
> (gfc_trans_subcomponent_assign): PDT array components must be
> handles as if they are allocatable.
> * trans-stmt.c (gfc_trans_allocate): Handle initialization of
> PDT entities.
> (gfc_trans_deallocate): Likewise.
> * trans-types.c (gfc_get_derived_type): PDT templates must not
> arrive here. PDT string components are handles as if deferred.
> Similarly, PDT arrays are treated as if allocatable. PDT
> strings are pointer types.
> * trans.c (gfc_deferred_strlen): Handle PDT strings in the same
> way as deferred characters.
>
>
> 2017-09-05 Paul Thomas
>
> * gfortran.dg/pdt_1.f03 : New test.
> * gfortran.dg/pdt_2.f03 : New test.
> * gfortran.dg/pdt_3.f03 : New test.
> * gfortran.dg/pdt_4.f03 : New test.
> * gfortran.dg/pdt_5.f03 : New test.
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: [Patch, fortran] Parameterized Derived Types
2017-09-06 13:05 Paul Richard Thomas
@ 2017-09-06 17:38 ` Janus Weil
2017-09-06 18:37 ` Damian Rouson
1 sibling, 0 replies; 10+ messages in thread
From: Janus Weil @ 2017-09-06 17:38 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: fortran, gcc-patches, Damian Rouson, Mark LeAir
Hi Paul,
thanks for your patch! It's really great to finally see PDTs come to
gfortran. You're a hero, man ;)
Also: Sorry about the silence. It's certainly not due to lack of
interest, but rather lack of time (day job and private life taking up
all of mine at the moment).
In my current situation I can not promise a complete review of this
beast of a patch, but I will try to do some testing and at least skim
over the diff. I will probably not get to it before the weekend,
though.
Cheers,
Janus
2017-09-06 15:04 GMT+02:00 Paul Richard Thomas <paul.richard.thomas@gmail.com>:
> Dear All,
>
> Since my message to the list of 16 August 2017 I have put in another
> intense period of activity to develop a patch to implement PDTs in
> gfortran. I have now temporarily run out of time to develop it
> further; partly because of a backlog of other patches and PRs to deal
> with but also pressure from daytime work.
>
> The patch adds the last unimplemented F2003 feature to gfortran.
>
> As in the provisional patch, I have attached some notes on the
> implementation. This indicates some of the weaknesses, problem areas
> and TODOs.
>
> Suggest that a good read of Mark Leair's excellent PGInsider article
> on PDTs - http://www.pgroup.com/lit/articles/insider/v5n2a4.htm is a
> worthwhile exercise.
>
> To judge by the complete silence following my previous message, I will
> have a problem getting this patch reviewed. I would welcome any
> remarks or reviews but intend to commit, warts and all, on Saturday
> unless something fundamentally wrong comes out of the woodwork.
>
> Note that the PDT parts in the compiler are rather well insulated from
> the rest of fortran and that I do not believe that any regressions
> will result.
>
> I hope that a month or two of testing in other hands will add to the
> list of TODOs and that when I return to PDTs a greatly improved
> version will result.
>
> Bootstrapped and regtested on FC23/x86_4 - OK for trunk? (Note above
> remark about committing on Saturday in the absence of a review.)
>
> Best regards
>
> Paul
>
> 2017-09-05 Paul Thomas <pault@gcc.gnu.org>
>
> * decl.c : Add decl_type_param_list, type_param_spec_list as
> static variables to hold PDT spec lists.
> (build_sym): Copy 'type_param_spec_list' to symbol spec_list.
> (build_struct): Copy the 'saved_kind_expr' to the component
> 'kind_expr'. Check that KIND or LEN components appear in the
> decl_type_param_list. These should appear as symbols in the
> f2k_derived namespace. If the component is itself a PDT type,
> copy the decl_type_param_list to the component param_list.
> (gfc_match_kind_spec): If the KIND expression is parameterized
> set KIND to zero and store the expression in 'saved_kind_expr'.
> (insert_parameter_exprs): New function.
> (gfc_insert_kind_parameter_exprs): New function.
> (gfc_insert_parameter_exprs): New function.
> (gfc_get_pdt_instance): New function.
> (gfc_match_decl_type_spec): Match the decl_type_spec_list if it
> is present. If it is, call 'gfc_get_pdt_instance' to obtain the
> specific instance of the PDT.
> (match_attr_spec): Match KIND and LEN attributes. Check for the
> standard and for type/kind of the parameter. They are also not
> allowed outside a derived type definition.
> (gfc_match_data_decl): Null the decl_type_param_list and the
> type_param_spec_list on entry and free them on exit.
> (gfc_match_formal_arglist): If 'typeparam' is true, add the
> formal symbol to the f2k_derived namespace.
> (gfc_match_derived_decl): Register the decl_type_param_list
> if this is a PDT. If this is a type extension, gather up all
> the type parameters and put them in the right order.
> *dump-parse-tree.c (show_attr): Signal PDT templates and the
> parameter attributes.
> (show_components): Output parameter atrributes and component
> parameter list.
> (show_symbol): Show variable parameter lists.
> * expr.c (expr.c): Copy the expression parameter list.
> (gfc_is_constant_expr): Pass on symbols representing PDT
> parameters.
> (gfc_check_init_expr): Break on PDT KIND parameters and
> PDT parameter expressions.
> (gfc_check_assign): Assigning to KIND or LEN components is an
> error.
> (derived_parameter_expr): New function.
> (gfc_derived_parameter_expr): New function.
> (gfc_spec_list_type): New function.
> * gfortran.h : Add enum gfc_param_spec_type. Add the PDT attrs
> to the structure symbol_attr. Add the 'kind_expr' and
> 'param_list' field to the gfc_component structure. Comment on
> the reuse of the gfc_actual_arglist structure as storage for
> type parameter spec lists. Add the new field 'spec_type' to
> this structure. Add 'param_list' fields to gfc_symbol and
> gfc_expr. Add prototypes for gfc_insert_kind_parameter_exprs,
> gfc_insert_parameter_exprs, gfc_add_kind, gfc_add_len,
> gfc_derived_parameter_expr and gfc_spec_list_type.
> * interface.c (gfc_compare_derived_types): Treat PDTs in the
> same way as sequence types.
> * match.c : Add variable 'type_param_spec_list'.
> (gfc_op2string, gfc_match_member_sep, gfc_match_label): Remove
> trailing whitespace.
> (match_derived_type_spec): Match PDTs and find specific
> instance.
> (gfc_match_type_spec): Remove more trailing whitespace.
> (gfc_match_allocate): Assumed or deferred parameters cannot
> appear here. Copy the type parameter spec list to the expr for
> the allocatable entity. Free 'type_param_spec_list'.
> (gfc_match_common, gfc_match_namelist, gfc_match_module): Still
> more trailing whitespace to remove.
> (gfc_match_type_is): Allow PDT typespecs.
> * match.h : Modify prototypes for gfc_match_formal_arglist and
> gfc_match_actual_arglist.
> * module.c (ab_attribute, mstring attr_bits): PDT attributes
> added.
> (mio_symbol_attribute): PDT attributes handled.
> (mio_component): Deal with 'kind_expr' field.
> (mio_full_f2k_derived): For PDT templates, transfer the formal
> namespace symroot to the f2k_derived namespace.
> *primary.c (match_keyword_arg, gfc_match_actual_arglist): Add
> modifications to handle PDT spec lists. These are flagged in
> both cases by new boolean arguments, whose prototype defaults
> are false.
> (gfc_match_structure_constructor, match_variable): Remove yet
> more trailing whitespace.
> * resolve.c (get_pdt_spec_expr, get_pdt_constructor): New
> functions.
> (resolve_structure_cons): If the constructor is a PDT template,
> call get_pdt_constructor to build it using the parameter lists
> and then get the specific instance of the PDT.
> (resolve_component): PDT strings need a hidden string length
> component like deferred characters.
> (resolve_symbol): Dummy PDTs cannot have deferred parameters.
> * symbol.c (gfc_add_kind, gfc_add_len): New functions.
> (free_components): Free 'kind_expr' and 'param_list' fields.
> (gfc_free_symbol): Free the 'param_list' field.
> (gfc_find_sym_tree): If the current state is a PDT template,
> look for the symtree in the f2k_derived namspaces.
> trans-array.c (structure_alloc_comps): Allocate and deallocate
> PDTs. Check dummy arguments for compliance of LEN parameters.
> Add the new functions to the preceeding enum.
> (gfc_allocate_pdt_comp, gfc_deallocate_pdt_comp and
> gfc_check_pdt_dummy): New functions calling above.
> * trans-array.h : Add prototypes for these functions.
> trans-decl.c (gfc_get_symbol_decl): Call gfc_defer_symbol_init
> as appropriate for PDT symbols.
> (gfc_trans_deferred_vars): Allocate/deallocate PDT entities as
> they come into and out of scope. Exclude pdt_types from being
> 'gcc_unreachable'.
> (gfc_trans_subcomponent_assign): PDT array components must be
> handles as if they are allocatable.
> * trans-stmt.c (gfc_trans_allocate): Handle initialization of
> PDT entities.
> (gfc_trans_deallocate): Likewise.
> * trans-types.c (gfc_get_derived_type): PDT templates must not
> arrive here. PDT string components are handles as if deferred.
> Similarly, PDT arrays are treated as if allocatable. PDT
> strings are pointer types.
> * trans.c (gfc_deferred_strlen): Handle PDT strings in the same
> way as deferred characters.
>
>
> 2017-09-05 Paul Thomas <pault@gcc.gnu.org>
>
> * gfortran.dg/pdt_1.f03 : New test.
> * gfortran.dg/pdt_2.f03 : New test.
> * gfortran.dg/pdt_3.f03 : New test.
> * gfortran.dg/pdt_4.f03 : New test.
> * gfortran.dg/pdt_5.f03 : New test.
^ permalink raw reply [flat|nested] 10+ messages in thread
* [Patch, fortran] Parameterized Derived Types
@ 2017-09-06 14:55 Paul Richard Thomas
0 siblings, 0 replies; 10+ messages in thread
From: Paul Richard Thomas @ 2017-09-06 14:55 UTC (permalink / raw)
To: fortran
[-- Attachment #1: Type: text/plain, Size: 7943 bytes --]
Dear All,
Since my message to the list of 16 August 2017 I have put in another
intense period of activity to develop a patch to implement PDTs in
gfortran. I have now temporarily run out of time to develop it
further; partly because of a backlog of other patches and PRs to deal
with but also pressure from daytime work.
The patch adds the last unimplemented F2003 feature to gfortran.
As in the provisional patch, I have attached some notes on the
implementation. This indicates some of the weaknesses, problem areas
and TODOs.
Suggest that a good read of Mark Leair's excellent PGInsider article
on PDTs - http://www.pgroup.com/lit/articles/insider/v5n2a4.htm is a
worthwhile exercise.
To judge by the complete silence following my previous message, I will
have a problem getting this patch reviewed. I would welcome any
remarks or reviews but intend to commit, warts and all, on Saturday
unless something fundamentally wrong comes out of the woodwork.
Note that the PDT parts in the compiler are rather well insulated from
the rest of fortran and that I do not believe that any regressions
will result.
I hope that a month or two of testing in other hands will add to the
list of TODOs and that when I return to PDTs a greatly improved
version will result.
Bootstrapped and regtested on FC23/x86_4 - OK for trunk? (Note above
remark about committing on Saturday in the absence of a review.)
Best regards
Paul
2017-09-05 Paul Thomas <pault@gcc.gnu.org>
* decl.c : Add decl_type_param_list, type_param_spec_list as
static variables to hold PDT spec lists.
(build_sym): Copy 'type_param_spec_list' to symbol spec_list.
(build_struct): Copy the 'saved_kind_expr' to the component
'kind_expr'. Check that KIND or LEN components appear in the
decl_type_param_list. These should appear as symbols in the
f2k_derived namespace. If the component is itself a PDT type,
copy the decl_type_param_list to the component param_list.
(gfc_match_kind_spec): If the KIND expression is parameterized
set KIND to zero and store the expression in 'saved_kind_expr'.
(insert_parameter_exprs): New function.
(gfc_insert_kind_parameter_exprs): New function.
(gfc_insert_parameter_exprs): New function.
(gfc_get_pdt_instance): New function.
(gfc_match_decl_type_spec): Match the decl_type_spec_list if it
is present. If it is, call 'gfc_get_pdt_instance' to obtain the
specific instance of the PDT.
(match_attr_spec): Match KIND and LEN attributes. Check for the
standard and for type/kind of the parameter. They are also not
allowed outside a derived type definition.
(gfc_match_data_decl): Null the decl_type_param_list and the
type_param_spec_list on entry and free them on exit.
(gfc_match_formal_arglist): If 'typeparam' is true, add the
formal symbol to the f2k_derived namespace.
(gfc_match_derived_decl): Register the decl_type_param_list
if this is a PDT. If this is a type extension, gather up all
the type parameters and put them in the right order.
*dump-parse-tree.c (show_attr): Signal PDT templates and the
parameter attributes.
(show_components): Output parameter atrributes and component
parameter list.
(show_symbol): Show variable parameter lists.
* expr.c (expr.c): Copy the expression parameter list.
(gfc_is_constant_expr): Pass on symbols representing PDT
parameters.
(gfc_check_init_expr): Break on PDT KIND parameters and
PDT parameter expressions.
(gfc_check_assign): Assigning to KIND or LEN components is an
error.
(derived_parameter_expr): New function.
(gfc_derived_parameter_expr): New function.
(gfc_spec_list_type): New function.
* gfortran.h : Add enum gfc_param_spec_type. Add the PDT attrs
to the structure symbol_attr. Add the 'kind_expr' and
'param_list' field to the gfc_component structure. Comment on
the reuse of the gfc_actual_arglist structure as storage for
type parameter spec lists. Add the new field 'spec_type' to
this structure. Add 'param_list' fields to gfc_symbol and
gfc_expr. Add prototypes for gfc_insert_kind_parameter_exprs,
gfc_insert_parameter_exprs, gfc_add_kind, gfc_add_len,
gfc_derived_parameter_expr and gfc_spec_list_type.
* interface.c (gfc_compare_derived_types): Treat PDTs in the
same way as sequence types.
* match.c : Add variable 'type_param_spec_list'.
(gfc_op2string, gfc_match_member_sep, gfc_match_label): Remove
trailing whitespace.
(match_derived_type_spec): Match PDTs and find specific
instance.
(gfc_match_type_spec): Remove more trailing whitespace.
(gfc_match_allocate): Assumed or deferred parameters cannot
appear here. Copy the type parameter spec list to the expr for
the allocatable entity. Free 'type_param_spec_list'.
(gfc_match_common, gfc_match_namelist, gfc_match_module): Still
more trailing whitespace to remove.
(gfc_match_type_is): Allow PDT typespecs.
* match.h : Modify prototypes for gfc_match_formal_arglist and
gfc_match_actual_arglist.
* module.c (ab_attribute, mstring attr_bits): PDT attributes
added.
(mio_symbol_attribute): PDT attributes handled.
(mio_component): Deal with 'kind_expr' field.
(mio_full_f2k_derived): For PDT templates, transfer the formal
namespace symroot to the f2k_derived namespace.
*primary.c (match_keyword_arg, gfc_match_actual_arglist): Add
modifications to handle PDT spec lists. These are flagged in
both cases by new boolean arguments, whose prototype defaults
are false.
(gfc_match_structure_constructor, match_variable): Remove yet
more trailing whitespace.
* resolve.c (get_pdt_spec_expr, get_pdt_constructor): New
functions.
(resolve_structure_cons): If the constructor is a PDT template,
call get_pdt_constructor to build it using the parameter lists
and then get the specific instance of the PDT.
(resolve_component): PDT strings need a hidden string length
component like deferred characters.
(resolve_symbol): Dummy PDTs cannot have deferred parameters.
* symbol.c (gfc_add_kind, gfc_add_len): New functions.
(free_components): Free 'kind_expr' and 'param_list' fields.
(gfc_free_symbol): Free the 'param_list' field.
(gfc_find_sym_tree): If the current state is a PDT template,
look for the symtree in the f2k_derived namspaces.
trans-array.c (structure_alloc_comps): Allocate and deallocate
PDTs. Check dummy arguments for compliance of LEN parameters.
Add the new functions to the preceeding enum.
(gfc_allocate_pdt_comp, gfc_deallocate_pdt_comp and
gfc_check_pdt_dummy): New functions calling above.
* trans-array.h : Add prototypes for these functions.
trans-decl.c (gfc_get_symbol_decl): Call gfc_defer_symbol_init
as appropriate for PDT symbols.
(gfc_trans_deferred_vars): Allocate/deallocate PDT entities as
they come into and out of scope. Exclude pdt_types from being
'gcc_unreachable'.
(gfc_trans_subcomponent_assign): PDT array components must be
handles as if they are allocatable.
* trans-stmt.c (gfc_trans_allocate): Handle initialization of
PDT entities.
(gfc_trans_deallocate): Likewise.
* trans-types.c (gfc_get_derived_type): PDT templates must not
arrive here. PDT string components are handles as if deferred.
Similarly, PDT arrays are treated as if allocatable. PDT
strings are pointer types.
* trans.c (gfc_deferred_strlen): Handle PDT strings in the same
way as deferred characters.
2017-09-05 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/pdt_1.f03 : New test.
* gfortran.dg/pdt_2.f03 : New test.
* gfortran.dg/pdt_3.f03 : New test.
* gfortran.dg/pdt_4.f03 : New test.
* gfortran.dg/pdt_5.f03 : New test.
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
[-- Attachment #2: notes0609.txt --]
[-- Type: text/plain, Size: 7886 bytes --]
Notes on implementation of Parameterized Derived Types in gfortran
1) Derived type definition:
___________________________
R425
derived-type-def is derived-type-stmt
[ type-param-def-stmt ]
[ private-or-sequence ] ...
[ component-part ]
[ type-bound-procedure-part ]
end-type-stmt
R426
derived-type-stmt is TYPE [ [ , type-attr-spec-list ] :: ] type-name [ ( type-param-name-list ) ]
Example in Note 4.23:
The following example uses derived-type parameters.
TYPE humongous_matrix(k, d) ! ( type-param-name-list ) = (k,d)
INTEGER, KIND :: k = kind(0.0) ! KIND parameter values known at compile time.
INTEGER(selected_int_kind(12)), LEN :: d ! LEN parameters may not be known at compile time
!-- Specify a nondefault kind for d.
REAL(k) :: element(d,d)
END TYPE
In the present version of the patch, the 'type-param-name-list' is stored as a formal_arglist in the 'formal' field of the derived type symbol, since it is not otherwise used.
The gfc_symbols associated with the formal_arglist are added to the derived type 'f2k_derived' namespace, which was one of the reasons why this namespace was introduced in the first place.
In this example, 'humongous_matrix is marked with the attribute pdt_template and the components {k,d,element} with attributes {pdt_kind,pdt_len,pdt_array}
A new gfc_component field 'kind_expr' has been added, such that kind expressions, such as that for 'element' can be stored. The array bound expressions are stored in the arrayspec as usual.
Type extension has been implemented and ensures that the extension picks up a copy of the 'type-param-name-list' of the extended type, which is concatenated with such new 'type-param-name-list' as there might be.
2) Type declaration statements:
_______________________________
R501
type-declaration-stmt is declaration-type-spec [ [ , attr-spec ] ... :: ] entity-decl -list
R403
declaration-type-spec is intrinsic-type-spec
or TYPE ( intrinsic-type-spec )
or TYPE ( derived-type-spec )
or CLASS ( derived-type-spec )
or CLASS ( * )
R453
derived-type-spec is type-name [ ( type-param-spec-list ) ]
R454 type-param-spec is [ keyword = ] type-param-value
R401
type-param-value is scalar-int-expr
or *
or :
Example in Note 5.1:
TYPE (humongous_matrix (k=8, d=1000)) :: mat
Given the similarity to actual arguments, gfc_actual_arglist has been taken over to represent the type_param_spec_list.
'param_list' fields have been added to gfc_expr, gfc_symbol and gfc_component to store all or part of the type-param-spec-list, as required.
The workhorse in the present implementation is decl.c(gfc_get_pdt_instance), which converts the pdt templates into instances of pdt types. These have the attribute pdt_type naturally enough.
'gfc_get_pdt_instance' ensures that the expressions for the KIND parameters can be simplified to constant expressions and the instance naming is Pdt//template_name//_kind.val1_kind.val2...
The instance of the example above is named 'Pdthumongous_matrix_8
Ideally, the name would have started with a non_alpha character so that it would not be possible to cause a clash with an explicitly declared entity. Unfortunately, this would interfere with the mechanism distinguishing the type from its constructor, where leading upper and lower case are used respectively. Using '@' between 'Pdt' and the template name worked until CLASS declarations were introduced, when all sorts of linker problems were caused by the naming of the functions associated with the vtables. This will have to be fixed sometime.
TODO Error messages at the moment use the name of the specific instance. This will have to be changed so that the names appear as per a PDT declaration.
It should be noted that I have thus far been rather cavalier about assumed and deferred parameters. The requisite checks will have to be added to comply with all the relevant constraints.
Where explicit 'type-param-value's are given to dummy arguments, a rudimentary runtime check has been implemented to assert that the actual argument parameter values are compliant.
TODO Determine if it really is an error for dummy arguments to have deferred type parameters.
I have done a reasonably thorough job to ensure that all the spec_lists are freed as well as the kind expressions.
TODO Check that no new memory leaks have been introduced in the compiler.
3) Matching typespecs in other situations (eg. ALLOCATE or TYPE IS statements)
___________________________________________________________________
This has been done in match.c(gfc_match_decl_type_spec) using 'gfc_get_pdt_instance'. Notice that this is only used in the ALLOCATE and TYPE IS statements in the present patch. In the PGInsider article on the subject of PDTs, allocate(adj_matrix(8,c,r)::mat) appears, which is matched by this mechanism.
TODO For reasons that I have not yet identified, allocate(adj_matrix(4,size(s,1),size(s,2))::d) causes link errors due to 'undefined size_'.
4) Runtime initialization of PDT entities
_________________________________________
This has been accomplished by extending the allocatable component workhorse trans-array.c(structure_alloc_comps) to include the calls 'gfc_allocate_pdt_comp', 'gfc_deallocate_pdt_comp' and 'gfc_check_pdt_dummy'.
The implementation allows recursion into extended types and PDT components.
The handling of assumed and deferred parameters still needs a bit of cleaning up.
TODO I have yet to peruse the standard to understood what should happen to use associated PDT entities. On the face of it, it is difficult to see when and how these should be initialized.
trans_decl.c(gfc_trans_deferred_vars) handles the intialization and automatic deallocation calls.
trans-stmt.c(gfc_trans_allocate) & (gfc_trans_deallocate) seem to work correctly and to call 'gfc_allocate_pdt_comp' as required.
TODO Note that in PDT_5.f03, the allocate with MOLD is perturbed by the defined assignment definitions and that the LEN parameters are not being set. This likely needs yet another function in trans-array.c to copy PDT entities.
I have not checked fully for runtime memory leaks.
5) Other remarks
________________
I have restricted LEN parameters to be of default integer kind. I note from the standard, for example i 1) above, that this is not necessary.
I made some changes to dump-parse-tree.c because components in particular were getting very cluttered with the new fields.
interface.c(gfc_compare_derived_types) had to be modified to ensure that like 'pdt_type's were not rejected.
In module.c(mio_full_f2k_derived) the 'sym_root' of the formal namespace is hijacked and appended to the 'f2k_derived' namespace.
The new function resolve.c(get_pdt_constructor) sorts out the parameter expressions for the component expressions.
TODO I rather think that the handling of CLASS PDTs is in one or two places wrong or inconsistent.
TODO I rather think that much of the new content in decl.c should be moved to class.c or expr.c. Since this does not affect the functionality, I have left this task until I have some more time to spend on PDTs.
6) Tests
________
pdt_1.f03 - checks basic PDT functionality
pdt_2.f03 - tests runtime error for mismatch between actual and dummy len parameters
pdt_3.f03 - checks type extension and basic OOP, including SELECT TYPE
pdt_4.f03 - exercises the compile time errors.
pdt_5.f03 - this is a modified version of the third example in the PGInsider article on PDTs.
TODO Some of the modifications in pdt_5.f03 are due to some apparent shortcomings in gfortran; eg. allocating intrinsic types with an unlimited polymorphic source. Also need to find out why the declarations in the main program had to be changed for CLASS to TYPE and what is happening with the use of SIZE in the typespecs. All these points are commented in the test.
[-- Attachment #3: check0609.diff --]
[-- Type: text/plain, Size: 113658 bytes --]
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 251546)
--- gcc/fortran/decl.c (working copy)
*************** gfc_symbol *gfc_new_block;
*** 95,100 ****
--- 95,109 ----
bool gfc_matching_function;
+ /* If a kind expression of a component of a parameterized derived type is
+ parameterized, temporarily store the expression here. */
+ static gfc_expr *saved_kind_expr = NULL;
+
+ /* Used to store the parameter list arising in a PDT declaration and
+ in the typespec of a PDT variable or component. */
+ static gfc_actual_arglist *decl_type_param_list;
+ static gfc_actual_arglist *type_param_spec_list;
+
/********************* DATA statement subroutines *********************/
*************** build_sym (const char *name, gfc_charlen
*** 1500,1505 ****
--- 1509,1519 ----
sym->attr.implied_index = 0;
+ /* Use the parameter expressions for a parameterized derived type. */
+ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
+ sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
+
if (sym->ts.type == BT_CLASS)
return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
*************** build_struct (const char *name, gfc_char
*** 1946,1951 ****
--- 1960,1970 ----
c->ts = current_ts;
if (c->ts.type == BT_CHARACTER)
c->ts.u.cl = cl;
+
+ if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
+ && c->ts.kind == 0 && saved_kind_expr != NULL)
+ c->kind_expr = gfc_copy_expr (saved_kind_expr);
+
c->attr = current_attr;
c->initializer = *init;
*************** scalar:
*** 1999,2004 ****
--- 2018,2048 ----
if (c->ts.type == BT_CLASS)
return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
+ if (c->attr.pdt_kind || c->attr.pdt_len)
+ {
+ gfc_symbol *sym;
+ gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
+ 0, &sym);
+ if (sym == NULL)
+ {
+ gfc_error ("Type parameter %qs at %C has no corresponding entry "
+ "in the type parameter name list at %L",
+ c->name, &gfc_current_block ()->declared_at);
+ return false;
+ }
+ sym->ts = c->ts;
+ sym->attr.pdt_kind = c->attr.pdt_kind;
+ sym->attr.pdt_len = c->attr.pdt_len;
+ if (c->initializer)
+ sym->value = gfc_copy_expr (c->initializer);
+ sym->attr.flavor = FL_VARIABLE;
+ }
+
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
+ && decl_type_param_list)
+ c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
+
return true;
}
*************** gfc_match_kind_spec (gfc_typespec *ts, b
*** 2612,2617 ****
--- 2656,2662 ----
m = MATCH_NO;
n = MATCH_YES;
e = NULL;
+ saved_kind_expr = NULL;
where = loc = gfc_current_locus;
*************** gfc_match_kind_spec (gfc_typespec *ts, b
*** 2628,2635 ****
--- 2673,2688 ----
loc = gfc_current_locus;
kind_expr:
+
n = gfc_match_init_expr (&e);
+ if (gfc_derived_parameter_expr (e))
+ {
+ ts->kind = 0;
+ saved_kind_expr = gfc_copy_expr (e);
+ goto close_brackets;
+ }
+
if (n != MATCH_YES)
{
if (gfc_matching_function)
*************** kind_expr:
*** 2707,2712 ****
--- 2760,2767 ----
"is %s", gfc_basic_typename (ts->f90_type), &where,
gfc_basic_typename (ts->type));
+ close_brackets:
+
gfc_gobble_whitespace ();
if ((c = gfc_next_ascii_char ()) != ')'
&& (ts->type != BT_CHARACTER || c != ','))
*************** match_record_decl (char *name)
*** 3030,3035 ****
--- 3085,3507 ----
return MATCH_ERROR;
}
+
+ /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
+ of expressions to substitute into the possibly parameterized expression
+ 'e'. Using a list is inefficient but should not be too bad since the
+ number of type parameters is not likely to be large. */
+ static bool
+ insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+ int* f)
+ {
+ gfc_actual_arglist *param;
+ gfc_expr *copy;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ gcc_assert (e->symtree);
+ if (e->symtree->n.sym->attr.pdt_kind
+ || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
+ {
+ for (param = type_param_spec_list; param; param = param->next)
+ if (strcmp (e->symtree->n.sym->name, param->name) == 0)
+ break;
+
+ if (param)
+ {
+ copy = gfc_copy_expr (param->expr);
+ *e = *copy;
+ free (copy);
+ }
+ }
+
+ return false;
+ }
+
+
+ bool
+ gfc_insert_kind_parameter_exprs (gfc_expr *e)
+ {
+ return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
+ }
+
+
+ bool
+ gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
+ {
+ gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
+ type_param_spec_list = param_list;
+ return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
+ type_param_spec_list = NULL;
+ type_param_spec_list = old_param_spec_list;
+ }
+
+ /* Determines the instance of a parameterized derived type to be used by
+ matching determining the values of the kind parameters and using them
+ in the name of the instance. If the instance exists, it is used, otherwise
+ a new derived type is created. */
+ match
+ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
+ gfc_actual_arglist **ext_param_list)
+ {
+ /* The PDT template symbol. */
+ gfc_symbol *pdt = *sym;
+ /* The symbol for the parameter in the template f2k_namespace. */
+ gfc_symbol *param;
+ /* The hoped for instance of the PDT. */
+ gfc_symbol *instance;
+ /* The list of parameters appearing in the PDT declaration. */
+ gfc_formal_arglist *type_param_name_list;
+ /* Used to store the parameter specification list during recursive calls. */
+ gfc_actual_arglist *old_param_spec_list;
+ /* Pointers to the parameter specification being used. */
+ gfc_actual_arglist *actual_param;
+ gfc_actual_arglist *tail = NULL;
+ /* Used to build up the name of the PDT instance. The prefix uses 4
+ characters and each KIND parameter 2 more. Allow 8 of the latter. */
+ char name[GFC_MAX_SYMBOL_LEN + 21];
+
+ bool name_seen = (param_list == NULL);
+ bool assumed_seen = false;
+ bool deferred_seen = false;
+ bool spec_error = false;
+ int kind_value, i;
+ gfc_expr *kind_expr;
+ gfc_component *c1, *c2;
+ match m;
+
+ type_param_spec_list = NULL;
+
+ type_param_name_list = pdt->formal;
+ actual_param = param_list;
+ sprintf (name, "Pdt%s", pdt->name);
+
+ /* Run through the parameter name list and pick up the actual
+ parameter values or use the default values in the PDT declaration. */
+ for (; type_param_name_list;
+ type_param_name_list = type_param_name_list->next)
+ {
+ if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
+ {
+ if (actual_param->spec_type == SPEC_ASSUMED)
+ spec_error = deferred_seen;
+ else
+ spec_error = assumed_seen;
+
+ if (spec_error)
+ {
+ gfc_error ("The type parameter spec list at %C cannot contain "
+ "both ASSUMED and DEFERRED parameters");
+ gfc_free_actual_arglist (type_param_spec_list);
+ return MATCH_ERROR;
+ }
+ }
+
+ if (actual_param && actual_param->name)
+ name_seen = true;
+ param = type_param_name_list->sym;
+
+ kind_expr = NULL;
+ if (!name_seen)
+ {
+ if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
+ kind_expr = gfc_copy_expr (actual_param->expr);
+ }
+ else
+ {
+ actual_param = param_list;
+ for (;actual_param; actual_param = actual_param->next)
+ if (actual_param->name
+ && strcmp (actual_param->name, param->name) == 0)
+ break;
+ if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
+ kind_expr = gfc_copy_expr (actual_param->expr);
+ else
+ {
+ if (param->value)
+ kind_expr = gfc_copy_expr (param->value);
+ else if (!(actual_param && param->attr.pdt_len))
+ {
+ gfc_error ("The derived parameter '%qs' at %C does not "
+ "have a default value", param->name);
+ return MATCH_ERROR;
+ }
+ }
+ }
+
+ /* Store the current parameter expressions in a temporary actual
+ arglist 'list' so that they can be substituted in the corresponding
+ expressions in the PDT instance. */
+ if (type_param_spec_list == NULL)
+ {
+ type_param_spec_list = gfc_get_actual_arglist ();
+ tail = type_param_spec_list;
+ }
+ else
+ {
+ tail->next = gfc_get_actual_arglist ();
+ tail = tail->next;
+ }
+ tail->name = param->name;
+
+ if (kind_expr)
+ {
+ tail->expr = gfc_copy_expr (kind_expr);
+ /* Try simplification even for LEN expressions. */
+ gfc_simplify_expr (tail->expr, 1);
+ }
+
+ if (actual_param)
+ tail->spec_type = actual_param->spec_type;
+
+ if (!param->attr.pdt_kind)
+ {
+ if (!name_seen)
+ actual_param = actual_param->next;
+ if (kind_expr)
+ {
+ gfc_free_expr (kind_expr);
+ kind_expr = NULL;
+ }
+ continue;
+ }
+
+ if (actual_param
+ && (actual_param->spec_type == SPEC_ASSUMED
+ || actual_param->spec_type == SPEC_DEFERRED))
+ {
+ gfc_error ("The KIND parameter '%qs' at %C cannot either be "
+ "ASSUMED or DEFERRED", param->name);
+ gfc_free_actual_arglist (type_param_spec_list);
+ return MATCH_ERROR;
+ }
+
+ if (!kind_expr || !gfc_is_constant_expr (kind_expr))
+ {
+ gfc_error ("The value for the KIND parameter '%qs' at %C does not "
+ "reduce to a constant expression", param->name);
+ gfc_free_actual_arglist (type_param_spec_list);
+ return MATCH_ERROR;
+ }
+
+ gfc_extract_int (kind_expr, &kind_value);
+ sprintf (name, "%s_%d", name, kind_value);
+
+ if (!name_seen && actual_param)
+ actual_param = actual_param->next;
+ gfc_free_expr (kind_expr);
+ }
+
+ /* Now we search for the PDT instance 'name'. If it doesn't exist, we
+ build it, using 'pdt' as a template. */
+ if (gfc_get_symbol (name, pdt->ns, &instance))
+ {
+ gfc_error ("Parameterized derived type at %C is ambiguous");
+ return MATCH_ERROR;
+ }
+
+ m = MATCH_YES;
+
+ if (instance->attr.flavor == FL_DERIVED
+ && instance->attr.pdt_type)
+ {
+ instance->refs++;
+ if (ext_param_list)
+ *ext_param_list = type_param_spec_list;
+ *sym = instance;
+ gfc_commit_symbols ();
+ return m;
+ }
+
+ /* Start building the new instance of the parameterized type. */
+ gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
+ instance->attr.pdt_template = 0;
+ instance->attr.pdt_type = 1;
+ instance->declared_at = gfc_current_locus;
+
+ /* Add the components, replacing the parameters in all expressions
+ with the expressions for their values in 'type_param_spec_list'. */
+ c1 = pdt->components;
+ tail = type_param_spec_list;
+ for (; c1; c1 = c1->next)
+ {
+ gfc_add_component (instance, c1->name, &c2);
+ c2->ts = c1->ts;
+ c2->attr = c1->attr;
+
+ /* Deal with type extension by recursively calling this function
+ to obtain the instance of the extended type. */
+ if (gfc_current_state () != COMP_DERIVED
+ && c1 == pdt->components
+ && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
+ && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
+ && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
+ {
+ gfc_formal_arglist *f;
+
+ old_param_spec_list = type_param_spec_list;
+
+ /* Obtain a spec list appropriate to the extended type..*/
+ actual_param = gfc_copy_actual_arglist (type_param_spec_list);
+ type_param_spec_list = actual_param;
+ for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
+ actual_param = actual_param->next;
+ if (actual_param)
+ {
+ gfc_free_actual_arglist (actual_param->next);
+ actual_param->next = NULL;
+ }
+
+ /* Now obtain the PDT instance for the extended type. */
+ c2->param_list = type_param_spec_list;
+ m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
+ NULL);
+ type_param_spec_list = old_param_spec_list;
+
+ c2->ts.u.derived->refs++;
+ gfc_set_sym_referenced (c2->ts.u.derived);
+
+ /* Set extension level. */
+ if (c2->ts.u.derived->attr.extension == 255)
+ {
+ /* Since the extension field is 8 bit wide, we can only have
+ up to 255 extension levels. */
+ gfc_error ("Maximum extension level reached with type %qs at %L",
+ c2->ts.u.derived->name,
+ &c2->ts.u.derived->declared_at);
+ return MATCH_ERROR;
+ }
+ instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
+
+ /* Advance the position in the spec list by the number of
+ parameters in the extended type. */
+ tail = type_param_spec_list;
+ for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
+ tail = tail->next;
+
+ continue;
+ }
+
+ /* Set the component kind using the parameterized expression. */
+ if (c1->ts.kind == 0 && c1->kind_expr != NULL)
+ {
+ gfc_expr *e = gfc_copy_expr (c1->kind_expr);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_extract_int (e, &c2->ts.kind);
+ gfc_free_expr (e);
+ }
+
+ /* Similarly, set the string length if parameterized. */
+ if (c1->ts.type == BT_CHARACTER
+ && c1->ts.u.cl->length
+ && gfc_derived_parameter_expr (c1->ts.u.cl->length))
+ {
+ gfc_expr *e;
+ e = gfc_copy_expr (c1->ts.u.cl->length);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ c2->ts.u.cl->length = e;
+ c2->attr.pdt_string = 1;
+ }
+
+ /* Set up either the KIND/LEN initializer, if constant,
+ or the parameterized expression. Use the template
+ initializer if one is not already set in this instance. */
+ if (c2->attr.pdt_kind || c2->attr.pdt_len)
+ {
+ if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
+ c2->initializer = gfc_copy_expr (tail->expr);
+ else if (tail && tail->expr)
+ {
+ c2->param_list = gfc_get_actual_arglist ();
+ c2->param_list->name = tail->name;
+ c2->param_list->expr = gfc_copy_expr (tail->expr);
+ c2->param_list->next = NULL;
+ }
+
+ if (!c2->initializer && c1->initializer)
+ c2->initializer = gfc_copy_expr (c1->initializer);
+
+ tail = tail->next;
+ }
+
+ /* Copy the array spec. */
+ c2->as = gfc_copy_array_spec (c1->as);
+ if (c1->ts.type == BT_CLASS)
+ CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
+
+ /* Determine if an array spec is parameterized. If so, substitute
+ in the parameter expressions for the bounds and set the pdt_array
+ attribute. Notice that this attribute must be unconditionally set
+ if this is an array of parameterized character length. */
+ if (c1->as && c1->as->type == AS_EXPLICIT)
+ {
+ bool pdt_array = false;
+
+ /* Are the bounds of the array parameterized? */
+ for (i = 0; i < c1->as->rank; i++)
+ {
+ if (gfc_derived_parameter_expr (c1->as->lower[i]))
+ pdt_array = true;
+ if (gfc_derived_parameter_expr (c1->as->upper[i]))
+ pdt_array = true;
+ }
+
+ /* If they are, free the expressions for the bounds and
+ replace them with the template expressions with substitute
+ values. */
+ for (i = 0; pdt_array && i < c1->as->rank; i++)
+ {
+ gfc_expr *e;
+ e = gfc_copy_expr (c1->as->lower[i]);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ gfc_free_expr (c2->as->lower[i]);
+ c2->as->lower[i] = e;
+ e = gfc_copy_expr (c1->as->upper[i]);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ gfc_free_expr (c2->as->upper[i]);
+ c2->as->upper[i] = e;
+ }
+ c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
+ }
+
+ /* Recurse into this function for PDT components. */
+ if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
+ && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
+ {
+ gfc_actual_arglist *params;
+ /* The component in the template has a list of specification
+ expressions derived from its declaration. */
+ params = gfc_copy_actual_arglist (c1->param_list);
+ actual_param = params;
+ /* Substitute the template parameters with the expressions
+ from the specification list. */
+ for (;actual_param; actual_param = actual_param->next)
+ gfc_insert_parameter_exprs (actual_param->expr,
+ type_param_spec_list);
+
+ /* Now obtain the PDT instance for the component. */
+ old_param_spec_list = type_param_spec_list;
+ m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL);
+ type_param_spec_list = old_param_spec_list;
+
+ c2->param_list = params;
+ c2->initializer = gfc_default_initializer (&c2->ts);
+ }
+ }
+
+ gfc_commit_symbol (instance);
+ if (ext_param_list)
+ *ext_param_list = type_param_spec_list;
+ *sym = instance;
+ return m;
+ }
+
+
/* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
structure to the matched specification. This is necessary for FUNCTION and
IMPLICIT statements.
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3048,3053 ****
--- 3520,3527 ----
bool seen_deferred_kind, matched_type;
const char *dt_name;
+ decl_type_param_list = NULL;
+
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3196,3202 ****
--- 3670,3682 ----
}
if (matched_type)
+ {
+ m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+ if (m == MATCH_ERROR)
+ return m;
+
m = gfc_match_char (')');
+ }
if (m != MATCH_YES)
m = match_record_decl (name);
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3211,3216 ****
--- 3691,3709 ----
gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
+
+ if (sym && sym->attr.flavor == FL_DERIVED
+ && sym->attr.pdt_template
+ && gfc_current_state () != COMP_DERIVED)
+ {
+ m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
+ if (m != MATCH_YES)
+ return m;
+ gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
+ ts->u.derived = sym;
+ strcpy (name, gfc_dt_lower_string (sym->name));
+ }
+
if (sym && sym->attr.flavor == FL_STRUCT)
{
ts->u.derived = sym;
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3279,3291 ****
return m;
}
! m = gfc_match (" class ( %n )", name);
if (m != MATCH_YES)
return m;
ts->type = BT_CLASS;
if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
return MATCH_ERROR;
}
/* Defer association of the derived type until the end of the
--- 3772,3798 ----
return m;
}
! m = gfc_match (" class (");
!
! if (m == MATCH_YES)
! m = gfc_match ("%n", name);
! else
! return m;
!
if (m != MATCH_YES)
return m;
ts->type = BT_CLASS;
if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
return MATCH_ERROR;
+
+ m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+ if (m == MATCH_ERROR)
+ return m;
+
+ m = gfc_match_char (')');
+ if (m != MATCH_YES)
+ return m;
}
/* Defer association of the derived type until the end of the
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3351,3356 ****
--- 3858,3875 ----
return MATCH_ERROR;
}
+ if (sym && sym->attr.flavor == FL_DERIVED
+ && sym->attr.pdt_template
+ && gfc_current_state () != COMP_DERIVED)
+ {
+ m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
+ if (m != MATCH_YES)
+ return m;
+ gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
+ ts->u.derived = sym;
+ strcpy (name, gfc_dt_lower_string (sym->name));
+ }
+
gfc_save_symbol_data (sym);
gfc_set_sym_referenced (sym);
if (!sym->attr.generic
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3361,3366 ****
--- 3880,3895 ----
&& !gfc_add_function (&sym->attr, sym->name, NULL))
return MATCH_ERROR;
+ if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
+ && dt_sym->attr.pdt_template
+ && gfc_current_state () != COMP_DERIVED)
+ {
+ m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
+ if (m != MATCH_YES)
+ return m;
+ gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
+ }
+
if (!dt_sym)
{
gfc_interface *intr, *head;
*************** match_attr_spec (void)
*** 3890,3896 ****
DECL_STATIC, DECL_AUTOMATIC,
DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
! DECL_NONE, GFC_DECL_END /* Sentinel */
};
/* GFC_DECL_END is the sentinel, index starts at 0. */
--- 4419,4425 ----
DECL_STATIC, DECL_AUTOMATIC,
DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
! DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
};
/* GFC_DECL_END is the sentinel, index starts at 0. */
*************** match_attr_spec (void)
*** 4033,4038 ****
--- 4562,4577 ----
}
break;
+ case 'k':
+ if (match_string_p ("kind"))
+ d = DECL_KIND;
+ break;
+
+ case 'l':
+ if (match_string_p ("len"))
+ d = DECL_LEN;
+ break;
+
case 'o':
if (match_string_p ("optional"))
d = DECL_OPTIONAL;
*************** match_attr_spec (void)
*** 4226,4231 ****
--- 4765,4776 ----
case DECL_OPTIONAL:
attr = "OPTIONAL";
break;
+ case DECL_KIND:
+ attr = "KIND";
+ break;
+ case DECL_LEN:
+ attr = "LEN";
+ break;
case DECL_PARAMETER:
attr = "PARAMETER";
break;
*************** match_attr_spec (void)
*** 4307,4312 ****
--- 4852,4905 ----
goto cleanup;
}
}
+ else if (d == DECL_KIND)
+ {
+ if (!gfc_notify_std (GFC_STD_F2003, "KIND "
+ "attribute at %C in a TYPE definition"))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.type != BT_INTEGER)
+ {
+ gfc_error ("Component with KIND attribute at %C must be "
+ "INTEGER");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.kind != gfc_default_integer_kind)
+ {
+ gfc_error ("Component with KIND attribute at %C must be "
+ "default integer kind (%d)",
+ gfc_default_integer_kind);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+ else if (d == DECL_LEN)
+ {
+ if (!gfc_notify_std (GFC_STD_F2003, "LEN "
+ "attribute at %C in a TYPE definition"))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.type != BT_INTEGER)
+ {
+ gfc_error ("Component with LEN attribute at %C must be "
+ "INTEGER");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.kind != gfc_default_integer_kind)
+ {
+ gfc_error ("Component with LEN attribute at %C must be "
+ "default integer kind (%d)",
+ gfc_default_integer_kind);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
else
{
gfc_error ("Attribute at %L is not allowed in a TYPE definition",
*************** match_attr_spec (void)
*** 4344,4349 ****
--- 4937,4951 ----
}
}
+ if (gfc_current_state () != COMP_DERIVED
+ && (d == DECL_KIND || d == DECL_LEN))
+ {
+ gfc_error ("Attribute at %L is not allowed outside a TYPE "
+ "definition", &seen_at[d]);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
switch (d)
{
case DECL_ALLOCATABLE:
*************** match_attr_spec (void)
*** 4396,4401 ****
--- 4998,5011 ----
t = gfc_add_optional (¤t_attr, &seen_at[d]);
break;
+ case DECL_KIND:
+ t = gfc_add_kind (¤t_attr, &seen_at[d]);
+ break;
+
+ case DECL_LEN:
+ t = gfc_add_len (¤t_attr, &seen_at[d]);
+ break;
+
case DECL_PARAMETER:
t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
break;
*************** gfc_match_data_decl (void)
*** 4886,4891 ****
--- 5496,5504 ----
match m;
int elem;
+ type_param_spec_list = NULL;
+ decl_type_param_list = NULL;
+
num_idents_on_line = 0;
m = gfc_match_decl_type_spec (¤t_ts, 0);
*************** ok:
*** 5000,5005 ****
--- 5613,5625 ----
gfc_free_data_all (gfc_current_ns);
cleanup:
+ if (saved_kind_expr)
+ gfc_free_expr (saved_kind_expr);
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+ if (decl_type_param_list)
+ gfc_free_actual_arglist (decl_type_param_list);
+ saved_kind_expr = NULL;
gfc_free_array_spec (current_as);
current_as = NULL;
return m;
*************** copy_prefix (symbol_attribute *dest, loc
*** 5173,5182 ****
}
! /* Match a formal argument list. */
match
! gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
{
gfc_formal_arglist *head, *tail, *p, *q;
char name[GFC_MAX_SYMBOL_LEN + 1];
--- 5793,5804 ----
}
! /* Match a formal argument list or, if typeparam is true, a
! type_param_name_list. */
match
! gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
! int null_flag, bool typeparam)
{
gfc_formal_arglist *head, *tail, *p, *q;
char name[GFC_MAX_SYMBOL_LEN + 1];
*************** gfc_match_formal_arglist (gfc_symbol *pr
*** 5228,5234 ****
if (m != MATCH_YES)
goto cleanup;
! if (gfc_get_symbol (name, NULL, &sym))
goto cleanup;
}
--- 5850,5859 ----
if (m != MATCH_YES)
goto cleanup;
! if (!typeparam && gfc_get_symbol (name, NULL, &sym))
! goto cleanup;
! else if (typeparam
! && gfc_get_symbol (name, progname->f2k_derived, &sym))
goto cleanup;
}
*************** gfc_match_derived_decl (void)
*** 8945,8950 ****
--- 9570,9577 ----
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
gfc_interface *intr = NULL, *head;
+ bool parameterized_type = false;
+ bool seen_colons = false;
if (gfc_comp_struct (gfc_current_state ()))
return MATCH_NO;
*************** gfc_match_derived_decl (void)
*** 8972,8987 ****
if (parent[0] && !extended)
return MATCH_ERROR;
! if (gfc_match (" ::") != MATCH_YES && seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
return MATCH_ERROR;
}
! m = gfc_match (" %n%t", name);
if (m != MATCH_YES)
return m;
/* Make sure the name is not the name of an intrinsic type. */
if (gfc_is_intrinsic_typename (name))
{
--- 9599,9636 ----
if (parent[0] && !extended)
return MATCH_ERROR;
! m = gfc_match (" ::");
! if (m == MATCH_YES)
! {
! seen_colons = true;
! }
! else if (seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
return MATCH_ERROR;
}
! m = gfc_match (" %n ", name);
if (m != MATCH_YES)
return m;
+ /* Make sure that we don't identify TYPE IS (...) as a parameterized
+ derived type named 'is'.
+ TODO Expand the check, when 'name' = "is" by matching " (tname) "
+ and checking if this is a(n intrinsic) typename. his picks up
+ misplaced TYPE IS statements such as in select_type_1.f03. */
+ if (gfc_peek_ascii_char () == '(')
+ {
+ if (gfc_current_state () == COMP_SELECT_TYPE
+ || (!seen_colons && !strcmp (name, "is")))
+ return MATCH_NO;
+ parameterized_type = true;
+ }
+
+ m = gfc_match_eos ();
+ if (m != MATCH_YES && !parameterized_type)
+ return m;
+
/* Make sure the name is not the name of an intrinsic type. */
if (gfc_is_intrinsic_typename (name))
{
*************** gfc_match_derived_decl (void)
*** 9062,9070 ****
--- 9711,9731 ----
if (!sym->f2k_derived)
sym->f2k_derived = gfc_get_namespace (NULL, 0);
+ if (parameterized_type)
+ {
+ m = gfc_match_formal_arglist (sym, 0, 0, true);
+ if (m != MATCH_YES)
+ return m;
+ m = gfc_match_eos ();
+ if (m != MATCH_YES)
+ return m;
+ sym->attr.pdt_template = 1;
+ }
+
if (extended && !sym->components)
{
gfc_component *p;
+ gfc_formal_arglist *f, *g, *h;
/* Add the extended derived type as the first component. */
gfc_add_component (sym, parent, &p);
*************** gfc_match_derived_decl (void)
*** 9089,9094 ****
--- 9750,9780 ----
/* Provide the links between the extended type and its extension. */
if (!extended->f2k_derived)
extended->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ /* Copy the extended type-param-name-list from the extended type,
+ append those of the extension and add the whole lot to the
+ extension. */
+ if (extended->attr.pdt_template)
+ {
+ g = h = NULL;
+ sym->attr.pdt_template = 1;
+ for (f = extended->formal; f; f = f->next)
+ {
+ if (f == extended->formal)
+ {
+ g = gfc_get_formal_arglist ();
+ h = g;
+ }
+ else
+ {
+ g->next = gfc_get_formal_arglist ();
+ g = g->next;
+ }
+ g->sym = f->sym;
+ }
+ g->next = sym->formal;
+ sym->formal = h;
+ }
}
if (!sym->hash_value)
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c (revision 251546)
--- gcc/fortran/dump-parse-tree.c (working copy)
*************** static void
*** 627,633 ****
--- 627,638 ----
show_attr (symbol_attribute *attr, const char * module)
{
if (attr->flavor != FL_UNKNOWN)
+ {
+ if (attr->flavor == FL_DERIVED && attr->pdt_template)
+ fputs (" (PDT template", dumpfile);
+ else
fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor));
+ }
if (attr->access != ACCESS_UNKNOWN)
fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access));
if (attr->proc != PROC_UNKNOWN)
*************** show_attr (symbol_attribute *attr, const
*** 653,658 ****
--- 658,667 ----
fputs (" INTRINSIC", dumpfile);
if (attr->optional)
fputs (" OPTIONAL", dumpfile);
+ if (attr->pdt_kind)
+ fputs (" KIND", dumpfile);
+ if (attr->pdt_len)
+ fputs (" LEN", dumpfile);
if (attr->pointer)
fputs (" POINTER", dumpfile);
if (attr->is_protected)
*************** show_components (gfc_symbol *sym)
*** 724,733 ****
--- 733,758 ----
for (c = sym->components; c; c = c->next)
{
+ show_indent ();
fprintf (dumpfile, "(%s ", c->name);
show_typespec (&c->ts);
+ if (c->kind_expr)
+ {
+ fputs (" kind_expr: ", dumpfile);
+ show_expr (c->kind_expr);
+ }
+ if (c->param_list)
+ {
+ fputs ("PDT parameters", dumpfile);
+ show_actual_arglist (c->param_list);
+ }
+
if (c->attr.allocatable)
fputs (" ALLOCATABLE", dumpfile);
+ if (c->attr.pdt_kind)
+ fputs (" KIND", dumpfile);
+ if (c->attr.pdt_len)
+ fputs (" LEN", dumpfile);
if (c->attr.pointer)
fputs (" POINTER", dumpfile);
if (c->attr.proc_pointer)
*************** show_symbol (gfc_symbol *sym)
*** 935,940 ****
--- 960,974 ----
fputs ("Formal namespace", dumpfile);
show_namespace (sym->formal_ns);
}
+
+ if (sym->attr.flavor == FL_VARIABLE
+ && sym->param_list)
+ {
+ show_indent ();
+ fputs ("PDT parameters", dumpfile);
+ show_actual_arglist (sym->param_list);
+
+ }
--show_level;
}
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 251546)
--- gcc/fortran/expr.c (working copy)
*************** gfc_copy_expr (gfc_expr *p)
*** 394,399 ****
--- 394,402 ----
q->ref = gfc_copy_ref (p->ref);
+ if (p->param_list)
+ q->param_list = gfc_copy_actual_arglist (p->param_list);
+
return q;
}
*************** free_expr0 (gfc_expr *e)
*** 499,504 ****
--- 502,509 ----
gfc_free_ref_list (e->ref);
+ gfc_free_actual_arglist (e->param_list);
+
memset (e, '\0', sizeof (gfc_expr));
}
*************** gfc_free_actual_arglist (gfc_actual_argl
*** 525,530 ****
--- 530,536 ----
while (a1)
{
a2 = a1->next;
+ if (a1->expr)
gfc_free_expr (a1->expr);
free (a1);
a1 = a2;
*************** gfc_is_constant_expr (gfc_expr *e)
*** 917,922 ****
--- 923,933 ----
|| gfc_is_constant_expr (e->value.op.op2)));
case EXPR_VARIABLE:
+ /* The only context in which this can occur is in a parameterized
+ derived type declaration, so returning true is OK. */
+ if (e->symtree->n.sym->attr.pdt_len
+ || e->symtree->n.sym->attr.pdt_kind)
+ return true;
return false;
case EXPR_FUNCTION:
*************** gfc_check_init_expr (gfc_expr *e)
*** 2531,2536 ****
--- 2542,2551 ----
case EXPR_VARIABLE:
t = true;
+ /* This occurs when parsing pdt templates. */
+ if (e->symtree->n.sym->attr.pdt_kind)
+ break;
+
if (gfc_check_iter_variable (e))
break;
*************** gfc_match_init_expr (gfc_expr **result)
*** 2700,2705 ****
--- 2715,2727 ----
return m;
}
+ if (gfc_derived_parameter_expr (expr))
+ {
+ *result = expr;
+ gfc_init_expr_flag = false;
+ return m;
+ }
+
t = gfc_reduce_init_expr (expr);
if (!t)
{
*************** gfc_check_assign (gfc_expr *lvalue, gfc_
*** 3282,3287 ****
--- 3304,3317 ----
}
}
+ if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len)
+ {
+ gfc_error ("The assignment to a KIND or LEN component of a "
+ "parameterized type at %L is not allowed",
+ &lvalue->where);
+ return false;
+ }
+
if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
return true;
*************** gfc_expr_check_typed (gfc_expr* e, gfc_n
*** 4837,4842 ****
--- 4867,4942 ----
}
+ /* This function returns true if it contains any references to PDT KIND
+ or LEN parameters. */
+
+ static bool
+ derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+ int* f ATTRIBUTE_UNUSED)
+ {
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ gcc_assert (e->symtree);
+ if (e->symtree->n.sym->attr.pdt_kind
+ || e->symtree->n.sym->attr.pdt_len)
+ return true;
+
+ return false;
+ }
+
+
+ bool
+ gfc_derived_parameter_expr (gfc_expr *e)
+ {
+ return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0);
+ }
+
+
+ /* This function returns the overall type of a type parameter spec list.
+ If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
+ parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
+ unless derived is not NULL. In this latter case, all the LEN parameters
+ must be either assumed or deferred for the return argument to be set to
+ anything other than SPEC_EXPLICIT. */
+
+ gfc_param_spec_type
+ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
+ {
+ gfc_param_spec_type res = SPEC_EXPLICIT;
+ gfc_component *c;
+ bool seen_assumed = false;
+ bool seen_deferred = false;
+
+ if (derived == NULL)
+ {
+ for (; param_list; param_list = param_list->next)
+ if (param_list->spec_type == SPEC_ASSUMED
+ || param_list->spec_type == SPEC_DEFERRED)
+ return param_list->spec_type;
+ }
+ else
+ {
+ for (; param_list; param_list = param_list->next)
+ {
+ c = gfc_find_component (derived, param_list->name,
+ true, true, NULL);
+ gcc_assert (c != NULL);
+ if (c->attr.pdt_kind)
+ continue;
+ else if (param_list->spec_type == SPEC_EXPLICIT)
+ return SPEC_EXPLICIT;
+ seen_assumed = param_list->spec_type == SPEC_ASSUMED;
+ seen_deferred = param_list->spec_type == SPEC_DEFERRED;
+ if (seen_assumed && seen_deferred)
+ return SPEC_EXPLICIT;
+ }
+ res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED;
+ }
+ return res;
+ }
+
+
bool
gfc_ref_this_image (gfc_ref *ref)
{
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 251546)
--- gcc/fortran/gfortran.h (working copy)
*************** enum gfc_reverse
*** 646,651 ****
--- 646,658 ----
GFC_INHIBIT_REVERSE
};
+ enum gfc_param_spec_type
+ {
+ SPEC_EXPLICIT,
+ SPEC_ASSUMED,
+ SPEC_DEFERRED
+ };
+
/************************* Structures *****************************/
/* Used for keeping things in balanced binary trees. */
*************** typedef struct
*** 869,874 ****
--- 876,886 ----
variable for SELECT_TYPE or ASSOCIATE. */
unsigned select_type_temporary:1, associate_var:1;
+ /* These are the attributes required for parameterized derived
+ types. */
+ unsigned pdt_kind:1, pdt_len:1, pdt_type:1, pdt_template:1,
+ pdt_array:1, pdt_string:1;
+
/* This is omp_{out,in,priv,orig} artificial variable in
!$OMP DECLARE REDUCTION. */
unsigned omp_udr_artificial_var:1;
*************** typedef struct gfc_component
*** 1053,1058 ****
--- 1065,1075 ----
tree norestrict_decl;
locus loc;
struct gfc_expr *initializer;
+ /* Used in parameterized derived type declarations to store parameterized
+ kind expressions. */
+ struct gfc_expr *kind_expr;
+ struct gfc_actual_arglist *param_list;
+
struct gfc_component *next;
/* Needed for procedure pointer components. */
*************** gfc_formal_arglist;
*** 1077,1083 ****
#define gfc_get_formal_arglist() XCNEW (gfc_formal_arglist)
! /* The gfc_actual_arglist structure is for actual arguments. */
typedef struct gfc_actual_arglist
{
const char *name;
--- 1094,1101 ----
#define gfc_get_formal_arglist() XCNEW (gfc_formal_arglist)
! /* The gfc_actual_arglist structure is for actual arguments and
! for type parameter specification lists. */
typedef struct gfc_actual_arglist
{
const char *name;
*************** typedef struct gfc_actual_arglist
*** 1089,1094 ****
--- 1107,1114 ----
argument has to be added to a function call. */
bt missing_arg_type;
+ gfc_param_spec_type spec_type;
+
struct gfc_expr *expr;
struct gfc_actual_arglist *next;
}
*************** typedef struct gfc_symbol
*** 1507,1512 ****
--- 1527,1535 ----
struct gfc_namespace *formal_ns;
struct gfc_namespace *f2k_derived;
+ /* List of PDT parameter expressions */
+ struct gfc_actual_arglist *param_list;
+
struct gfc_expr *value; /* Parameter/Initializer value */
gfc_array_spec *as;
struct gfc_symbol *result; /* function result symbol */
*************** typedef struct gfc_expr
*** 2179,2184 ****
--- 2202,2210 ----
}
value;
+ /* Used to store PDT expression lists associated with expressions. */
+ gfc_actual_arglist *param_list;
+
}
gfc_expr;
*************** gfc_finalizer;
*** 2699,2704 ****
--- 2725,2736 ----
bool gfc_in_match_data (void);
match gfc_match_char_spec (gfc_typespec *);
+ /* Handling Parameterized Derived Types */
+ bool gfc_insert_kind_parameter_exprs (gfc_expr *);
+ bool gfc_insert_parameter_exprs (gfc_expr *, gfc_actual_arglist *);
+ match gfc_get_pdt_instance (gfc_actual_arglist *, gfc_symbol **,
+ gfc_actual_arglist **);
+
/* scanner.c */
void gfc_scanner_done_1 (void);
void gfc_scanner_init_1 (void);
*************** bool gfc_add_dimension (symbol_attribute
*** 2880,2885 ****
--- 2912,2919 ----
bool gfc_add_external (symbol_attribute *, locus *);
bool gfc_add_intrinsic (symbol_attribute *, locus *);
bool gfc_add_optional (symbol_attribute *, locus *);
+ bool gfc_add_kind (symbol_attribute *, locus *);
+ bool gfc_add_len (symbol_attribute *, locus *);
bool gfc_add_pointer (symbol_attribute *, locus *);
bool gfc_add_cray_pointer (symbol_attribute *, locus *);
bool gfc_add_cray_pointee (symbol_attribute *, locus *);
*************** bool gfc_traverse_expr (gfc_expr *, gfc_
*** 3143,3149 ****
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
bool gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
!
gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
bool gfc_is_proc_ptr_comp (gfc_expr *);
bool gfc_is_alloc_class_scalar_function (gfc_expr *);
--- 3177,3184 ----
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
bool gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
! bool gfc_derived_parameter_expr (gfc_expr *);
! gfc_param_spec_type gfc_spec_list_type (gfc_actual_arglist *, gfc_symbol *);
gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
bool gfc_is_proc_ptr_comp (gfc_expr *);
bool gfc_is_alloc_class_scalar_function (gfc_expr *);
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 251546)
--- gcc/fortran/interface.c (working copy)
*************** gfc_compare_derived_types (gfc_symbol *d
*** 645,651 ****
return false;
if (!(derived1->attr.sequence && derived2->attr.sequence)
! && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
return false;
/* Protect against null components. */
--- 645,652 ----
return false;
if (!(derived1->attr.sequence && derived2->attr.sequence)
! && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c)
! && !(derived1->attr.pdt_type && derived2->attr.pdt_type))
return false;
/* Protect against null components. */
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 251546)
--- gcc/fortran/match.c (working copy)
*************** bool gfc_matching_prefix = false;
*** 33,38 ****
--- 33,41 ----
/* Stack of SELECT TYPE statements. */
gfc_select_type_stack *select_type_stack = NULL;
+ /* List of type parameter expressions. */
+ gfc_actual_arglist *type_param_spec_list;
+
/* For debugging and diagnostic purposes. Return the textual representation
of the intrinsic operator OP. */
const char *
*************** gfc_op2string (gfc_intrinsic_op op)
*** 132,143 ****
(1) If any user defined operator ".y." exists, this is always y(x,z)
(even if ".y." is the wrong type and/or x has a member y).
(2) Otherwise if x has a member y, and y is itself a derived type,
! this is (x->y)->z, even if an intrinsic operator exists which
! can handle (x,z).
! (3) If x has no member y or (x->y) is not a derived type but ".y."
is an intrinsic operator (such as ".eq."), this is y(x,z).
(4) Lastly if there is no operator ".y." and x has no member "y", it is an
! error.
It is worth noting that the logic here does not support mixed use of member
accessors within a single string. That is, even if x has component y and y
has component z, the following are all syntax errors:
--- 135,146 ----
(1) If any user defined operator ".y." exists, this is always y(x,z)
(even if ".y." is the wrong type and/or x has a member y).
(2) Otherwise if x has a member y, and y is itself a derived type,
! this is (x->y)->z, even if an intrinsic operator exists which
! can handle (x,z).
! (3) If x has no member y or (x->y) is not a derived type but ".y."
is an intrinsic operator (such as ".eq."), this is y(x,z).
(4) Lastly if there is no operator ".y." and x has no member "y", it is an
! error.
It is worth noting that the logic here does not support mixed use of member
accessors within a single string. That is, even if x has component y and y
has component z, the following are all syntax errors:
*************** gfc_match_member_sep(gfc_symbol *sym)
*** 165,171 ****
tsym = NULL;
/* We may be given either a derived type variable or the derived type
! declaration itself (which actually contains the components);
we need the latter to search for components. */
if (gfc_fl_struct (sym->attr.flavor))
tsym = sym;
--- 168,174 ----
tsym = NULL;
/* We may be given either a derived type variable or the derived type
! declaration itself (which actually contains the components);
we need the latter to search for components. */
if (gfc_fl_struct (sym->attr.flavor))
tsym = sym;
*************** gfc_match_member_sep(gfc_symbol *sym)
*** 205,211 ****
if (gfc_find_uop (name, sym->ns) != NULL)
goto no;
! /* Match accesses to existing derived-type components for
derived-type vars: "x.y.z" = (x->y)->z */
c = gfc_find_component(tsym, name, false, true, NULL);
if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
--- 208,214 ----
if (gfc_find_uop (name, sym->ns) != NULL)
goto no;
! /* Match accesses to existing derived-type components for
derived-type vars: "x.y.z" = (x->y)->z */
c = gfc_find_component(tsym, name, false, true, NULL);
if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
*************** gfc_match_member_sep(gfc_symbol *sym)
*** 216,222 ****
if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
{
/* If ".y." is not an intrinsic operator but y was a valid non-
! structure component, match and leave the trailing dot to be
dealt with later. */
if (c)
goto yes;
--- 219,225 ----
if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
{
/* If ".y." is not an intrinsic operator but y was a valid non-
! structure component, match and leave the trailing dot to be
dealt with later. */
if (c)
goto yes;
*************** gfc_match_label (void)
*** 623,629 ****
return MATCH_ERROR;
}
! if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
gfc_new_block->name, NULL))
return MATCH_ERROR;
--- 626,632 ----
return MATCH_ERROR;
}
! if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
gfc_new_block->name, NULL))
return MATCH_ERROR;
*************** match_derived_type_spec (gfc_typespec *t
*** 1955,1961 ****
{
char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_locus;
! gfc_symbol *derived;
old_locus = gfc_current_locus;
--- 1958,1967 ----
{
char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_locus;
! gfc_symbol *derived, *der_type;
! match m = MATCH_YES;
! gfc_actual_arglist *decl_type_param_list = NULL;
! bool is_pdt_template = false;
old_locus = gfc_current_locus;
*************** match_derived_type_spec (gfc_typespec *t
*** 1967,1975 ****
--- 1973,2023 ----
gfc_find_symbol (name, NULL, 1, &derived);
+ /* Match the PDT spec list, if there. */
+ if (derived && derived->attr.flavor == FL_PROCEDURE)
+ {
+ gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type);
+ is_pdt_template = der_type
+ && der_type->attr.flavor == FL_DERIVED
+ && der_type->attr.pdt_template;
+ }
+
+ if (is_pdt_template)
+ m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+
+ if (m == MATCH_ERROR)
+ {
+ gfc_free_actual_arglist (decl_type_param_list);
+ return m;
+ }
+
if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
+ /* If this is a PDT, find the specific instance. */
+ if (m == MATCH_YES && is_pdt_template)
+ {
+ gfc_namespace *old_ns;
+
+ old_ns = gfc_current_ns;
+ while (gfc_current_ns && gfc_current_ns->parent)
+ gfc_current_ns = gfc_current_ns->parent;
+
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+ m = gfc_get_pdt_instance (decl_type_param_list, &der_type,
+ &type_param_spec_list);
+ gfc_free_actual_arglist (decl_type_param_list);
+
+ if (m != MATCH_YES)
+ return m;
+ derived = der_type;
+ gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type);
+ gfc_set_sym_referenced (derived);
+
+ gfc_current_ns = old_ns;
+ }
+
if (derived && derived->attr.flavor == FL_DERIVED)
{
ts->type = BT_DERIVED;
*************** gfc_match_type_spec (gfc_typespec *ts)
*** 1999,2004 ****
--- 2047,2053 ----
gfc_clear_ts (ts);
gfc_gobble_whitespace ();
old_locus = gfc_current_locus;
+ type_param_spec_list = NULL;
if (match_derived_type_spec (ts) == MATCH_YES)
{
*************** gfc_match_stopcode (gfc_statement st)
*** 2869,2875 ****
| GFC_STD_F2008_OBS);
/* Set f03 for -std=f2003. */
! f03 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
| GFC_STD_F2008_OBS | GFC_STD_F2003);
/* Look for a blank between STOP and the stop-code for F2008 or later. */
--- 2918,2924 ----
| GFC_STD_F2008_OBS);
/* Set f03 for -std=f2003. */
! f03 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
| GFC_STD_F2008_OBS | GFC_STD_F2003);
/* Look for a blank between STOP and the stop-code for F2008 or later. */
*************** gfc_match_allocate (void)
*** 3935,3941 ****
{
if (gfc_match (" :: ") == MATCH_YES)
{
! if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
&old_locus))
goto cleanup;
--- 3984,3990 ----
{
if (gfc_match (" :: ") == MATCH_YES)
{
! if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
&old_locus))
goto cleanup;
*************** gfc_match_allocate (void)
*** 3948,3953 ****
--- 3997,4012 ----
if (ts.type == BT_CHARACTER)
ts.u.cl->length_from_typespec = true;
+
+ /* TODO understand why this error does not appear but, instead,
+ the derived type is caught as a variable in primary.c. */
+ if (gfc_spec_list_type (type_param_spec_list, NULL) != SPEC_EXPLICIT)
+ {
+ gfc_error ("The type parameter spec list in the type-spec at "
+ "%L cannot contain ASSUMED or DEFERRED parameters",
+ &old_locus);
+ goto cleanup;
+ }
}
else
{
*************** gfc_match_allocate (void)
*** 4059,4064 ****
--- 4118,4126 ----
if (tail->expr->ts.type == BT_DERIVED)
tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
+ if (type_param_spec_list)
+ tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list);
+
saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
*************** alloc_opt_list:
*** 4143,4149 ****
if (head->next
&& !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
! " with more than a single allocate object",
&tmp->where))
goto cleanup;
--- 4205,4211 ----
if (head->next
&& !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
! " with more than a single allocate object",
&tmp->where))
goto cleanup;
*************** alloc_opt_list:
*** 4236,4241 ****
--- 4298,4306 ----
new_st.ext.alloc.list = head;
new_st.ext.alloc.ts = ts;
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+
return MATCH_YES;
syntax:
*************** cleanup:
*** 4248,4253 ****
--- 4313,4320 ----
gfc_free_expr (mold);
if (tmp && tmp->expr_type) gfc_free_expr (tmp);
gfc_free_alloc_list (head);
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
return MATCH_ERROR;
}
*************** gfc_match_common (void)
*** 4901,4907 ****
|| sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
{
if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
! "%C can only be COMMON in BLOCK DATA",
sym->name))
goto cleanup;
}
--- 4968,4974 ----
|| sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
{
if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
! "%C can only be COMMON in BLOCK DATA",
sym->name))
goto cleanup;
}
*************** gfc_match_namelist (void)
*** 5114,5120 ****
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
! && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
group_name->name, NULL))
return MATCH_ERROR;
--- 5181,5187 ----
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
! && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
group_name->name, NULL))
return MATCH_ERROR;
*************** gfc_match_module (void)
*** 5193,5199 ****
if (m != MATCH_YES)
return m;
! if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL))
return MATCH_ERROR;
--- 5260,5266 ----
if (m != MATCH_YES)
return m;
! if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL))
return MATCH_ERROR;
*************** gfc_match_type_is (void)
*** 6114,6126 ****
return MATCH_ERROR;
}
/* Create temporary variable. */
select_type_set_tmp (&c->ts);
return MATCH_YES;
syntax:
! gfc_error ("Syntax error in TYPE IS specification at %C");
cleanup:
if (c != NULL)
--- 6181,6203 ----
return MATCH_ERROR;
}
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+ && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived)
+ != SPEC_ASSUMED)
+ {
+ gfc_error ("All the LEN type parameters in the TYPE IS statement "
+ "at %C must be ASSUMED");
+ return MATCH_ERROR;
+ }
+
/* Create temporary variable. */
select_type_set_tmp (&c->ts);
return MATCH_YES;
syntax:
! gfc_error ("Ssyntax error in TYPE IS specification at %C");
cleanup:
if (c != NULL)
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 251546)
--- gcc/fortran/match.h (working copy)
*************** match gfc_match_decl_type_spec (gfc_type
*** 213,219 ****
match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
! match gfc_match_formal_arglist (gfc_symbol *, int, int);
match gfc_match_procedure (void);
match gfc_match_generic (void);
match gfc_match_function_decl (void);
--- 213,219 ----
match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
! match gfc_match_formal_arglist (gfc_symbol *, int, int, bool = false);
match gfc_match_procedure (void);
match gfc_match_generic (void);
match gfc_match_function_decl (void);
*************** match gfc_get_type_attr_spec (symbol_att
*** 274,280 ****
match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
! match gfc_match_actual_arglist (int, gfc_actual_arglist **);
match gfc_match_literal_constant (gfc_expr **, int);
/* expr.c -- FIXME: this one should be eliminated by moving the
--- 274,280 ----
match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
! match gfc_match_actual_arglist (int, gfc_actual_arglist **, bool = false);
match gfc_match_literal_constant (gfc_expr **, int);
/* expr.c -- FIXME: this one should be eliminated by moving the
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 251546)
--- gcc/fortran/module.c (working copy)
*************** enum ab_attribute
*** 1998,2004 ****
AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
! AB_OMP_DECLARE_TARGET_LINK
};
static const mstring attr_bits[] =
--- 1998,2005 ----
AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
! AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE,
! AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING
};
static const mstring attr_bits[] =
*************** static const mstring attr_bits[] =
*** 2062,2067 ****
--- 2063,2074 ----
minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT),
minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK),
minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK),
+ minit ("PDT_KIND", AB_PDT_KIND),
+ minit ("PDT_LEN", AB_PDT_LEN),
+ minit ("PDT_TYPE", AB_PDT_TYPE),
+ minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE),
+ minit ("PDT_ARRAY", AB_PDT_ARRAY),
+ minit ("PDT_STRING", AB_PDT_STRING),
minit (NULL, -1)
};
*************** mio_symbol_attribute (symbol_attribute *
*** 2260,2265 ****
--- 2267,2284 ----
MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits);
if (attr->omp_declare_target_link)
MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
+ if (attr->pdt_kind)
+ MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits);
+ if (attr->pdt_len)
+ MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits);
+ if (attr->pdt_type)
+ MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits);
+ if (attr->pdt_template)
+ MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits);
+ if (attr->pdt_array)
+ MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits);
+ if (attr->pdt_string)
+ MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits);
mio_rparen ();
*************** mio_symbol_attribute (symbol_attribute *
*** 2453,2458 ****
--- 2472,2495 ----
case AB_OACC_DECLARE_LINK:
attr->oacc_declare_link = 1;
break;
+ case AB_PDT_KIND:
+ attr->pdt_kind = 1;
+ break;
+ case AB_PDT_LEN:
+ attr->pdt_len = 1;
+ break;
+ case AB_PDT_TYPE:
+ attr->pdt_type = 1;
+ break;
+ case AB_PDT_TEMPLATE:
+ attr->pdt_template = 1;
+ break;
+ case AB_PDT_ARRAY:
+ attr->pdt_array = 1;
+ break;
+ case AB_PDT_STRING:
+ attr->pdt_string = 1;
+ break;
}
}
}
*************** mio_component (gfc_component *c, int vty
*** 2779,2784 ****
--- 2816,2824 ----
mio_typespec (&c->ts);
mio_array_spec (&c->as);
+ /* PDT templates store the expression for the kind of a component here. */
+ mio_expr (&c->kind_expr);
+
mio_symbol_attribute (&c->attr);
if (c->ts.type == BT_CLASS)
c->attr.class_ok = 1;
*************** mio_full_f2k_derived (gfc_symbol *sym)
*** 3998,4004 ****
--- 4038,4061 ----
{
if (peek_atom () != ATOM_RPAREN)
{
+ gfc_namespace *ns;
+
sym->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ /* PDT templates make use of the mechanisms for formal args
+ and so the parameter symbols are stored in the formal
+ namespace. Transfer the sym_root to f2k_derived and then
+ free the formal namespace since it is uneeded. */
+ if (sym->attr.pdt_template && sym->formal && sym->formal->sym)
+ {
+ ns = sym->formal->sym->ns;
+ sym->f2k_derived->sym_root = ns->sym_root;
+ ns->sym_root = NULL;
+ ns->refs++;
+ gfc_free_namespace (ns);
+ ns = NULL;
+ }
+
mio_f2k_derived (sym->f2k_derived);
}
else
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 251546)
--- gcc/fortran/primary.c (working copy)
*************** match_actual_arg (gfc_expr **result)
*** 1609,1618 ****
}
! /* Match a keyword argument. */
static match
! match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a;
--- 1609,1618 ----
}
! /* Match a keyword argument or type parameter spec list.. */
static match
! match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a;
*************** match_keyword_arg (gfc_actual_arglist *a
*** 1630,1641 ****
goto cleanup;
}
m = match_actual_arg (&actual->expr);
if (m != MATCH_YES)
goto cleanup;
/* Make sure this name has not appeared yet. */
!
if (name[0] != '\0')
{
for (a = base; a; a = a->next)
--- 1630,1657 ----
goto cleanup;
}
+ if (pdt)
+ {
+ if (gfc_match_char ('*') == MATCH_YES)
+ {
+ actual->spec_type = SPEC_ASSUMED;
+ goto add_name;
+ }
+ else if (gfc_match_char (':') == MATCH_YES)
+ {
+ actual->spec_type = SPEC_DEFERRED;
+ goto add_name;
+ }
+ else
+ actual->spec_type = SPEC_EXPLICIT;
+ }
+
m = match_actual_arg (&actual->expr);
if (m != MATCH_YES)
goto cleanup;
/* Make sure this name has not appeared yet. */
! add_name:
if (name[0] != '\0')
{
for (a = base; a; a = a->next)
*************** cleanup:
*** 1737,1746 ****
list is assumed to allow keyword arguments because we don't know if
the symbol associated with the procedure has an implicit interface
or not. We make sure keywords are unique. If sub_flag is set,
! we're matching the argument list of a subroutine. */
match
! gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
{
gfc_actual_arglist *head, *tail;
int seen_keyword;
--- 1753,1767 ----
list is assumed to allow keyword arguments because we don't know if
the symbol associated with the procedure has an implicit interface
or not. We make sure keywords are unique. If sub_flag is set,
! we're matching the argument list of a subroutine.
!
! NOTE: An alternative use for this function is to match type parameter
! spec lists, which are so similar to actual argument lists that the
! machinery can be reused. This use is flagged by the optional argument
! 'pdt'. */
match
! gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
{
gfc_actual_arglist *head, *tail;
int seen_keyword;
*************** gfc_match_actual_arglist (int sub_flag,
*** 1758,1763 ****
--- 1779,1785 ----
if (gfc_match_char (')') == MATCH_YES)
return MATCH_YES;
+
head = NULL;
matching_actual_arglist++;
*************** gfc_match_actual_arglist (int sub_flag,
*** 1772,1779 ****
tail = tail->next;
}
! if (sub_flag && gfc_match_char ('*') == MATCH_YES)
{
m = gfc_match_st_label (&label);
if (m == MATCH_NO)
gfc_error ("Expected alternate return label at %C");
--- 1794,1806 ----
tail = tail->next;
}
! if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES)
{
+ if (pdt)
+ {
+ tail->spec_type = SPEC_ASSUMED;
+ goto next;
+ }
m = gfc_match_st_label (&label);
if (m == MATCH_NO)
gfc_error ("Expected alternate return label at %C");
*************** gfc_match_actual_arglist (int sub_flag,
*** 1788,1798 ****
goto next;
}
/* After the first keyword argument is seen, the following
arguments must also have keywords. */
if (seen_keyword)
{
! m = match_keyword_arg (tail, head);
if (m == MATCH_ERROR)
goto cleanup;
--- 1815,1841 ----
goto next;
}
+ if (pdt && !seen_keyword)
+ {
+ if (gfc_match_char (':') == MATCH_YES)
+ {
+ tail->spec_type = SPEC_DEFERRED;
+ goto next;
+ }
+ else if (gfc_match_char ('*') == MATCH_YES)
+ {
+ tail->spec_type = SPEC_ASSUMED;
+ goto next;
+ }
+ else
+ tail->spec_type = SPEC_EXPLICIT;
+ }
+
/* After the first keyword argument is seen, the following
arguments must also have keywords. */
if (seen_keyword)
{
! m = match_keyword_arg (tail, head, pdt);
if (m == MATCH_ERROR)
goto cleanup;
*************** gfc_match_actual_arglist (int sub_flag,
*** 1813,1819 ****
/* See if we have the first keyword argument. */
if (m == MATCH_NO)
{
! m = match_keyword_arg (tail, head);
if (m == MATCH_YES)
seen_keyword = 1;
if (m == MATCH_ERROR)
--- 1856,1862 ----
/* See if we have the first keyword argument. */
if (m == MATCH_NO)
{
! m = match_keyword_arg (tail, head, false);
if (m == MATCH_YES)
seen_keyword = 1;
if (m == MATCH_ERROR)
*************** gfc_match_structure_constructor (gfc_sym
*** 2948,2954 ****
expression here. */
if (gfc_in_match_data ())
gfc_reduce_init_expr (e);
!
*result = e;
return MATCH_YES;
}
--- 2991,2997 ----
expression here. */
if (gfc_in_match_data ())
gfc_reduce_init_expr (e);
!
*result = e;
return MATCH_YES;
}
*************** match_variable (gfc_expr **result, int e
*** 3662,3668 ****
implicit_ns = gfc_current_ns;
else
implicit_ns = sym->ns;
!
old_loc = gfc_current_locus;
if (gfc_match_member_sep (sym) == MATCH_YES
&& sym->ts.type == BT_UNKNOWN
--- 3705,3711 ----
implicit_ns = gfc_current_ns;
else
implicit_ns = sym->ns;
!
old_loc = gfc_current_locus;
if (gfc_match_member_sep (sym) == MATCH_YES
&& sym->ts.type == BT_UNKNOWN
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 251546)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_contained_functions (gfc_namespa
*** 1130,1135 ****
--- 1130,1218 ----
}
+
+ /* A Parameterized Derived Type constructor must contain values for
+ the PDT KIND parameters or they must have a default initializer.
+ Go through the constructor picking out the KIND expressions,
+ storing them in 'param_list' and then call gfc_get_pdt_instance
+ to obtain the PDT instance. */
+
+ static gfc_actual_arglist *param_list, *param_tail, *param;
+
+ static bool
+ get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
+ {
+ param = gfc_get_actual_arglist ();
+ if (!param_list)
+ param_list = param_tail = param;
+ else
+ {
+ param_tail->next = param;
+ param_tail = param_tail->next;
+ }
+
+ param_tail->name = c->name;
+ if (expr)
+ param_tail->expr = gfc_copy_expr (expr);
+ else if (c->initializer)
+ param_tail->expr = gfc_copy_expr (c->initializer);
+ else
+ {
+ param_tail->spec_type = SPEC_ASSUMED;
+ if (c->attr.pdt_kind)
+ {
+ gfc_error ("The KIND parameter in the PDT constructor "
+ "at %C has no value");
+ return false;
+ }
+ }
+
+ return true;
+ }
+
+ static bool
+ get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
+ gfc_symbol *derived)
+ {
+ gfc_constructor *cons;
+ gfc_component *comp;
+ bool t = true;
+
+ if (expr && expr->expr_type == EXPR_STRUCTURE)
+ cons = gfc_constructor_first (expr->value.constructor);
+ else if (constr)
+ cons = *constr;
+ gcc_assert (cons);
+
+ comp = derived->components;
+
+ for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
+ {
+ if (cons->expr->expr_type == EXPR_STRUCTURE
+ && comp->ts.type == BT_DERIVED)
+ {
+ t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
+ if (!t)
+ return t;
+ }
+ else if (comp->ts.type == BT_DERIVED)
+ {
+ t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
+ if (!t)
+ return t;
+ }
+ else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
+ && derived->attr.pdt_template)
+ {
+ t = get_pdt_spec_expr (comp, cons->expr);
+ if (!t)
+ return t;
+ }
+ }
+ return t;
+ }
+
+
static bool resolve_fl_derived0 (gfc_symbol *sym);
static bool resolve_fl_struct (gfc_symbol *sym);
*************** resolve_structure_cons (gfc_expr *expr,
*** 1154,1159 ****
--- 1237,1261 ----
resolve_fl_derived0 (expr->ts.u.derived);
else
resolve_fl_struct (expr->ts.u.derived);
+
+ /* If this is a Parameterized Derived Type template, find the
+ instance corresponding to the PDT kind parameters. */
+ if (expr->ts.u.derived->attr.pdt_template)
+ {
+ param_list = NULL;
+ t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
+ if (!t)
+ return t;
+ gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
+
+ expr->param_list = gfc_copy_actual_arglist (param_list);
+
+ if (param_list)
+ gfc_free_actual_arglist (param_list);
+
+ if (!expr->ts.u.derived->attr.pdt_type)
+ return false;
+ }
}
cons = gfc_constructor_first (expr->value.constructor);
*************** resolve_component (gfc_component *c, gfc
*** 13547,13553 ****
}
/* Add the hidden deferred length field. */
! if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function
&& !sym->attr.is_class)
{
char name[GFC_MAX_SYMBOL_LEN+9];
--- 13649,13657 ----
}
/* Add the hidden deferred length field. */
! if (c->ts.type == BT_CHARACTER
! && (c->ts.deferred || c->attr.pdt_string)
! && !c->attr.function
&& !sym->attr.is_class)
{
char name[GFC_MAX_SYMBOL_LEN+9];
*************** resolve_component (gfc_component *c, gfc
*** 13647,13652 ****
--- 13751,13757 ----
return false;
if (c->initializer && !sym->attr.vtype
+ && !c->attr.pdt_kind && !c->attr.pdt_len
&& !gfc_check_assign_symbol (sym, c, c->initializer))
return false;
*************** resolve_symbol (gfc_symbol *sym)
*** 14276,14281 ****
--- 14381,14395 ----
return;
}
+ if (sym->attr.dummy && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.pdt_type
+ && gfc_spec_list_type (sym->param_list, NULL) == SPEC_DEFERRED)
+ {
+ gfc_error ("%qs at %L cannot have DEFERRED type parameters because "
+ "it is a dummy argument", sym->name, &sym->declared_at);
+ return;
+ }
+
if (sym->attr.value && sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.u.cl;
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 251546)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_add_optional (symbol_attribute *attr
*** 1106,1111 ****
--- 1106,1137 ----
return check_conflict (attr, NULL, where);
}
+ bool
+ gfc_add_kind (symbol_attribute *attr, locus *where)
+ {
+ if (attr->pdt_kind)
+ {
+ duplicate_attr ("KIND", where);
+ return false;
+ }
+
+ attr->pdt_kind = 1;
+ return check_conflict (attr, NULL, where);
+ }
+
+ bool
+ gfc_add_len (symbol_attribute *attr, locus *where)
+ {
+ if (attr->pdt_len)
+ {
+ duplicate_attr ("LEN", where);
+ return false;
+ }
+
+ attr->pdt_len = 1;
+ return check_conflict (attr, NULL, where);
+ }
+
bool
gfc_add_pointer (symbol_attribute *attr, locus *where)
*************** free_components (gfc_component *p)
*** 2447,2452 ****
--- 2473,2482 ----
gfc_free_array_spec (p->as);
gfc_free_expr (p->initializer);
+ if (p->kind_expr)
+ gfc_free_expr (p->kind_expr);
+ if (p->param_list)
+ gfc_free_actual_arglist (p->param_list);
free (p->tb);
free (p);
*************** gfc_free_symbol (gfc_symbol *sym)
*** 2929,2934 ****
--- 2959,2967 ----
set_symbol_common_block (sym, NULL);
+ if (sym->param_list)
+ gfc_free_actual_arglist (sym->param_list);
+
free (sym);
}
*************** gfc_find_sym_tree (const char *name, gfc
*** 3091,3097 ****
--- 3124,3148 ----
}
while (ns != NULL);
+ if (gfc_current_state() == COMP_DERIVED
+ && gfc_current_block ()->attr.pdt_template)
+ {
+ gfc_symbol *der = gfc_current_block ();
+ for (; der; der = gfc_get_derived_super_type (der))
+ {
+ if (der->f2k_derived && der->f2k_derived->sym_root)
+ {
+ st = gfc_find_symtree (der->f2k_derived->sym_root, name);
+ if (st)
+ break;
+ }
+ }
+ *result = st;
+ return 0;
+ }
+
*result = NULL;
+
return 0;
}
*************** gfc_free_namespace (gfc_namespace *ns)
*** 3890,3895 ****
--- 3941,3947 ----
ns->refs--;
if (ns->refs > 0)
return;
+
gcc_assert (ns->refs == 0);
gfc_free_statements (ns->code);
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 251546)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_caf_is_dealloc_only (int caf_mode)
*** 8073,8079 ****
function for the functions named in this enum. */
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
! COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP};
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
--- 8073,8082 ----
function for the functions named in this enum. */
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
! COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
! ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY};
!
! static gfc_actual_arglist *pdt_param_list;
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
*************** structure_alloc_comps (gfc_symbol * der_
*** 8735,8740 ****
--- 8738,8992 ----
break;
+ case ALLOCATE_PDT_COMP:
+
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+
+ /* Set the PDT KIND and LEN fields. */
+ if (c->attr.pdt_kind || c->attr.pdt_len)
+ {
+ gfc_se tse;
+ gfc_expr *c_expr = NULL;
+ gfc_actual_arglist *param = pdt_param_list;
+ gfc_init_se (&tse, NULL);
+ for (; param; param = param->next)
+ if (!strcmp (c->name, param->name))
+ c_expr = param->expr;
+
+ if (!c_expr)
+ c_expr = c->initializer;
+
+ if (c_expr)
+ {
+ gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+ gfc_add_modify (&fnblock, comp, tse.expr);
+ }
+ }
+
+ if (c->attr.pdt_string)
+ {
+ gfc_se tse;
+ gfc_init_se (&tse, NULL);
+ tree strlen;
+ /* Convert the parameterized string length to its value. The
+ string length is stored in a hidden field in the same way as
+ deferred string lengths. */
+ gfc_insert_parameter_exprs (c->ts.u.cl->length, pdt_param_list);
+ if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
+ {
+ gfc_conv_expr_type (&tse, c->ts.u.cl->length,
+ TREE_TYPE (strlen));
+ strlen = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (strlen),
+ decl, strlen, NULL_TREE);
+ gfc_add_modify (&fnblock, strlen, tse.expr);
+ c->ts.u.cl->backend_decl = strlen;
+ }
+ /* Scalar parameterizied strings can be allocated now. */
+ if (!c->as)
+ {
+ tmp = fold_convert (gfc_array_index_type, strlen);
+ tmp = size_of_string_in_bytes (c->ts.kind, tmp);
+ tmp = gfc_evaluate_now (tmp, &fnblock);
+ tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
+ gfc_add_modify (&fnblock, comp, tmp);
+ }
+ }
+
+ /* Allocate paramterized arrays of parameterized derived types. */
+ if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
+ && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+ continue;
+
+ if (c->ts.type == BT_CLASS)
+ comp = gfc_class_data_get (comp);
+
+ if (c->attr.pdt_array)
+ {
+ gfc_se tse;
+ int i;
+ tree size = gfc_index_one_node;
+ tree offset = gfc_index_zero_node;
+ tree lower, upper;
+ gfc_expr *e;
+
+ /* This chunk takes the expressions for 'lower' and 'upper'
+ in the arrayspec and substitutes in the expressions for
+ the parameters from 'pdt_param_list'. The descriptor
+ fields can then be filled from the values so obtained. */
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
+ for (i = 0; i < c->as->rank; i++)
+ {
+ gfc_init_se (&tse, NULL);
+ e = gfc_copy_expr (c->as->lower[i]);
+ gfc_insert_parameter_exprs (e, pdt_param_list);
+ gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+ gfc_free_expr (e);
+ lower = tse.expr;
+ gfc_conv_descriptor_lbound_set (&fnblock, comp,
+ gfc_rank_cst[i],
+ lower);
+ e = gfc_copy_expr (c->as->upper[i]);
+ gfc_insert_parameter_exprs (e, pdt_param_list);
+ gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+ gfc_free_expr (e);
+ upper = tse.expr;
+ gfc_conv_descriptor_ubound_set (&fnblock, comp,
+ gfc_rank_cst[i],
+ upper);
+ gfc_conv_descriptor_stride_set (&fnblock, comp,
+ gfc_rank_cst[i],
+ size);
+ size = gfc_evaluate_now (size, &fnblock);
+ offset = fold_build2_loc (input_location,
+ MINUS_EXPR,
+ gfc_array_index_type,
+ offset, size);
+ offset = gfc_evaluate_now (offset, &fnblock);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ upper, lower);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ }
+ gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
+ if (c->ts.type == BT_CLASS)
+ {
+ tmp = gfc_get_vptr_from_expr (comp);
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = gfc_vptr_size_get (tmp);
+ }
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ size = gfc_evaluate_now (size, &fnblock);
+ tmp = gfc_call_malloc (&fnblock, NULL, size);
+ gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
+ tmp = gfc_conv_descriptor_dtype (comp);
+ gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
+ }
+
+ /* Recurse in to PDT components. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ {
+ bool is_deferred = false;
+ gfc_actual_arglist *tail = c->param_list;
+
+ for (; tail; tail = tail->next)
+ if (!tail->expr)
+ is_deferred = true;
+
+ tail = is_deferred ? pdt_param_list : c->param_list;
+ tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
+ c->as ? c->as->rank : 0,
+ tail);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ break;
+
+ case DEALLOCATE_PDT_COMP:
+ /* Deallocate array or parameterized string length components
+ of parameterized derived types. */
+ if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
+ && !c->attr.pdt_string
+ && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+ continue;
+
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ if (c->ts.type == BT_CLASS)
+ comp = gfc_class_data_get (comp);
+
+ /* Recurse in to PDT components. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
+ c->as ? c->as->rank : 0);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ if (c->attr.pdt_array)
+ {
+ tmp = gfc_conv_descriptor_data_get (comp);
+ tmp = gfc_call_free (tmp);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+ }
+ else if (c->attr.pdt_string)
+ {
+ tmp = gfc_call_free (comp);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
+ gfc_add_modify (&fnblock, comp, tmp);
+ }
+
+ break;
+
+ case CHECK_PDT_DUMMY:
+
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ if (c->ts.type == BT_CLASS)
+ comp = gfc_class_data_get (comp);
+
+ /* Recurse in to PDT components. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
+ c->as ? c->as->rank : 0,
+ pdt_param_list);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ if (!c->attr.pdt_len)
+ continue;
+ else
+ {
+ gfc_se tse;
+ gfc_expr *c_expr = NULL;
+ gfc_actual_arglist *param = pdt_param_list;
+
+ gfc_init_se (&tse, NULL);
+ for (; param; param = param->next)
+ if (!strcmp (c->name, param->name))
+ c_expr = param->expr;
+
+ if (c_expr)
+ {
+ tree error, cond, cname;
+ gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node,
+ comp, tse.expr);
+ cname = gfc_build_cstring_const (c->name);
+ cname = gfc_build_addr_expr (pchar_type_node, cname);
+ error = gfc_trans_runtime_error (true, NULL,
+ "The value of the PDT LEN "
+ "parameter '%s' does not "
+ "agree with that in the "
+ "dummy declaration",
+ cname);
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, cond, error,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ }
+ break;
+
default:
gcc_unreachable ();
break;
*************** gfc_copy_only_alloc_comp (gfc_symbol * d
*** 8814,8819 ****
--- 9066,9115 ----
}
+ /* Recursively traverse an object of paramterized derived type, generating
+ code to allocate parameterized components. */
+
+ tree
+ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
+ gfc_actual_arglist *param_list)
+ {
+ tree res;
+ gfc_actual_arglist *old_param_list = pdt_param_list;
+ pdt_param_list = param_list;
+ res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ ALLOCATE_PDT_COMP, 0);
+ pdt_param_list = old_param_list;
+ return res;
+ }
+
+ /* Recursively traverse an object of paramterized derived type, generating
+ code to deallocate parameterized components. */
+
+ tree
+ gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
+ {
+ return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ DEALLOCATE_PDT_COMP, 0);
+ }
+
+
+ /* Recursively traverse a dummy of paramterized derived type to check the
+ values of LEN parameters. */
+
+ tree
+ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
+ gfc_actual_arglist *param_list)
+ {
+ tree res;
+ gfc_actual_arglist *old_param_list = pdt_param_list;
+ pdt_param_list = param_list;
+ res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ CHECK_PDT_DUMMY, 0);
+ pdt_param_list = old_param_list;
+ return res;
+ }
+
+
/* Returns the value of LBOUND for an expression. This could be broken out
from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
called by gfc_alloc_allocatable_for_assignment. */
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 251546)
--- gcc/fortran/trans-array.h (working copy)
*************** tree gfc_copy_alloc_comp (gfc_symbol *,
*** 59,64 ****
--- 59,68 ----
tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
+ tree gfc_allocate_pdt_comp (gfc_symbol *, tree, int, gfc_actual_arglist *);
+ tree gfc_deallocate_pdt_comp (gfc_symbol *, tree, int);
+ tree gfc_check_pdt_dummy (gfc_symbol *, tree, int, gfc_actual_arglist *);
+
tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*);
/* Add initialization for deferred arrays. */
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 251546)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1483,1488 ****
--- 1483,1503 ----
}
}
+ /* PDT parameterized array components and string_lengths must have the
+ 'len' parameters substituted for the expressions appearing in the
+ declaration of the entity and memory allocated/deallocated. */
+ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ && sym->param_list != NULL
+ && !(sym->attr.host_assoc || sym->attr.use_assoc || sym->attr.dummy))
+ gfc_defer_symbol_init (sym);
+
+ /* Dummy PDT 'len' parameters should be checked when they are explicit. */
+ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ && sym->param_list != NULL
+ && sym->attr.dummy)
+ gfc_defer_symbol_init (sym);
+
/* All deferred character length procedures need to retain the backend
decl, which is a pointer to the character length in the caller's
namespace and to declare a local character length. */
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4159,4164 ****
--- 4174,4180 ----
gfc_formal_arglist *f;
stmtblock_t tmpblock;
bool seen_trans_deferred_array = false;
+ bool is_pdt_type = false;
tree tmp = NULL;
gfc_expr *e;
gfc_se se;
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4269,4274 ****
--- 4285,4352 ----
if (sym->assoc)
continue;
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived
+ && sym->ts.u.derived->attr.pdt_type)
+ {
+ is_pdt_type = true;
+ gfc_init_block (&tmpblock);
+ if (!(sym->attr.dummy
+ || sym->attr.pointer
+ || sym->attr.allocatable))
+ {
+ tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
+ sym->backend_decl,
+ sym->as ? sym->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
+ sym->backend_decl,
+ sym->as ? sym->as->rank : 0);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
+ }
+ else if (sym->attr.dummy)
+ {
+ tmp = gfc_check_pdt_dummy (sym->ts.u.derived,
+ sym->backend_decl,
+ sym->as ? sym->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
+ }
+ }
+ else if (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->ts.u.derived
+ && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
+ {
+ gfc_component *data = CLASS_DATA (sym);
+ is_pdt_type = true;
+ gfc_init_block (&tmpblock);
+ if (!(sym->attr.dummy
+ || CLASS_DATA (sym)->attr.pointer
+ || CLASS_DATA (sym)->attr.allocatable))
+ {
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp,
+ data->as ? data->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
+ data->as ? data->as->rank : 0);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
+ }
+ else if (sym->attr.dummy)
+ {
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp,
+ data->as ? data->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
+ }
+ }
+
if (sym->attr.subref_array_pointer
&& GFC_DECL_SPAN (sym->backend_decl)
&& !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4601,4607 ****
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
! else if (!(UNLIMITED_POLY(sym)))
gcc_unreachable ();
}
--- 4679,4685 ----
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
! else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
gcc_unreachable ();
}
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 251546)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_trans_subcomponent_assign (tree dest
*** 7286,7292 ****
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
! else if (cm->attr.allocatable)
{
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
--- 7286,7292 ----
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
! else if (cm->attr.allocatable || cm->attr.pdt_array)
{
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 251546)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5545,5550 ****
--- 5545,5551 ----
bool needs_caf_sync, caf_refs_comp;
gfc_symtree *newsym = NULL;
symbol_attribute caf_attr;
+ gfc_actual_arglist *param_list;
if (!code->ext.alloc.list)
return NULL_TREE;
*************** gfc_trans_allocate (gfc_code * code)
*** 6326,6331 ****
--- 6327,6361 ----
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
+ /* Set KIND and LEN PDT components and allocate those that are
+ parameterized. */
+ else if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.pdt_type)
+ {
+ if (code->expr3 && code->expr3->param_list)
+ param_list = code->expr3->param_list;
+ else if (expr->param_list)
+ param_list = expr->param_list;
+ else
+ param_list = expr->symtree->n.sym->param_list;
+ tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr,
+ expr->rank, param_list);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ /* Ditto for CLASS expressions. */
+ else if (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type)
+ {
+ if (code->expr3 && code->expr3->param_list)
+ param_list = code->expr3->param_list;
+ else if (expr->param_list)
+ param_list = expr->param_list;
+ else
+ param_list = expr->symtree->n.sym->param_list;
+ tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
+ se.expr, expr->rank, param_list);
+ gfc_add_expr_to_block (&block, tmp);
+ }
else if (code->expr3 && code->expr3->mold
&& code->expr3->ts.type == BT_CLASS)
{
*************** gfc_trans_deallocate (gfc_code *code)
*** 6533,6538 ****
--- 6563,6583 ----
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
+ /* Deallocate PDT components that are parameterized. */
+ tmp = NULL;
+ if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.pdt_type
+ && expr->symtree->n.sym->param_list)
+ tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank);
+ else if (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type
+ && expr->symtree->n.sym->param_list)
+ tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
+ se.expr, expr->rank);
+
+ if (tmp)
+ gfc_add_expr_to_block (&block, tmp);
+
if (flag_coarray == GFC_FCOARRAY_LIB
|| flag_coarray == GFC_FCOARRAY_SINGLE)
{
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c (revision 251546)
--- gcc/fortran/trans-types.c (working copy)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2441,2446 ****
--- 2441,2448 ----
gfc_namespace *ns;
tree tmp;
+ gcc_assert (!derived->attr.pdt_template);
+
if (derived->attr.unlimited_polymorphic
|| (flag_coarray == GFC_FCOARRAY_LIB
&& derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2635,2641 ****
field_type = c->ts.u.derived->backend_decl;
else
{
! if (c->ts.type == BT_CHARACTER && !c->ts.deferred)
{
/* Evaluate the string length. */
gfc_conv_const_charlen (c->ts.u.cl);
--- 2637,2644 ----
field_type = c->ts.u.derived->backend_decl;
else
{
! if (c->ts.type == BT_CHARACTER
! && !c->ts.deferred && !c->attr.pdt_string)
{
/* Evaluate the string length. */
gfc_conv_const_charlen (c->ts.u.cl);
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2652,2658 ****
required. */
if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
{
! if (c->attr.pointer || c->attr.allocatable)
{
enum gfc_array_kind akind;
if (c->attr.pointer)
--- 2655,2661 ----
required. */
if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
{
! if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
{
enum gfc_array_kind akind;
if (c->attr.pointer)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2673,2679 ****
PACKED_STATIC,
!c->attr.target);
}
! else if ((c->attr.pointer || c->attr.allocatable)
&& !c->attr.proc_pointer
&& !(unlimited_entity && c == derived->components))
field_type = build_pointer_type (field_type);
--- 2676,2682 ----
PACKED_STATIC,
!c->attr.target);
}
! else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
&& !c->attr.proc_pointer
&& !(unlimited_entity && c == derived->components))
field_type = build_pointer_type (field_type);
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 251546)
--- gcc/fortran/trans.c (working copy)
*************** gfc_deferred_strlen (gfc_component *c, t
*** 2302,2308 ****
{
char name[GFC_MAX_SYMBOL_LEN+9];
gfc_component *strlen;
! if (!(c->ts.type == BT_CHARACTER && c->ts.deferred))
return false;
sprintf (name, "_%s_length", c->name);
for (strlen = c; strlen; strlen = strlen->next)
--- 2302,2309 ----
{
char name[GFC_MAX_SYMBOL_LEN+9];
gfc_component *strlen;
! if (!(c->ts.type == BT_CHARACTER
! && (c->ts.deferred || c->attr.pdt_string)))
return false;
sprintf (name, "_%s_length", c->name);
for (strlen = c; strlen; strlen = strlen->next)
Index: gcc/testsuite/gfortran.dg/pdt_1.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_1.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_1.f03 (working copy)
***************
*** 0 ****
--- 1,62 ----
+ ! { dg-do run }
+ ! { dg-options "-fcheck=all" }
+ !
+ ! Basic check of Parameterized Derived Types.
+ !
+ ! -fcheck=all is used here to ensure that when the parameter
+ ! 'b' of the dummy in 'foo' is assumed, there is no error.
+ ! Likewise in 'bar' and 'foobar', when 'b' has the correct
+ ! explicit value.
+ !
+ implicit none
+ integer, parameter :: ftype = kind(0.0e0)
+ integer :: pdt_len = 4
+ integer :: i
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0d0)
+ integer, LEN :: b
+ integer :: i
+ real(kind = a) :: d(b, b)
+ character (len = b*b) :: chr
+ end type
+
+ type(mytype(b=4)) :: z(2)
+ type(mytype(ftype, pdt_len)) :: z2
+
+ z(1)%i = 1
+ z(2)%i = 2
+ z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4])
+ z(2)%d = 10*z(1)%d
+ z(1)%chr = "hello pdt"
+ z(2)%chr = "goodbye pdt"
+
+ z2%d = z(1)%d * 10 - 1
+ z2%chr = "scalar pdt"
+
+ call foo (z)
+ call bar (z)
+ call foobar (z2)
+ contains
+ elemental subroutine foo (arg)
+ type(mytype(8,*)), intent(in) :: arg
+ if (arg%i .eq. 1) then
+ if (trim (arg%chr) .ne. "hello pdt") error stop
+ if (int (sum (arg%d)) .ne. 136) error stop
+ else if (arg%i .eq. 2 ) then
+ if (trim (arg%chr) .ne. "goodbye pdt") error stop
+ if (int (sum (arg%d)) .ne. 1360) error stop
+ else
+ error stop
+ end if
+ end subroutine
+ subroutine bar (arg)
+ type(mytype(b=4)) :: arg(:)
+ if (int (sum (arg(1)%d)) .ne. 136) call abort
+ if (trim (arg(2)%chr) .ne. "goodbye pdt") call abort
+ end subroutine
+ subroutine foobar (arg)
+ type(mytype(ftype, pdt_len)) :: arg
+ if (int (sum (arg%d)) .ne. 1344) call abort
+ if (trim (arg%chr) .ne. "scalar pdt") call abort
+ end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/pdt_2.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_2.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_2.f03 (working copy)
***************
*** 0 ****
--- 1,27 ----
+ ! { dg-do run }
+ ! { dg-options "-fcheck=all" }
+ ! { dg-shouldfail "value of the PDT LEN parameter" }
+ !
+ ! Reduced version of pdt_1.f03 to check that an incorrect
+ ! value for the parameter 'b' in the dummy is picked up.
+ !
+ implicit none
+ integer, parameter :: ftype = kind(0.0e0)
+ integer :: pdt_len = 4
+ integer :: i
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0d0)
+ integer, LEN :: b
+ integer :: i
+ real(kind = a) :: d(b, b)
+ character (len = b*b) :: chr
+ end type
+
+ type(mytype(ftype, pdt_len)) :: z2
+ call foobar (z2)
+ contains
+ subroutine foobar (arg)
+ type(mytype(ftype, 8)) :: arg
+ print *, arg%i
+ end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/pdt_3.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_3.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_3.f03 (working copy)
***************
*** 0 ****
--- 1,79 ----
+ ! { dg-do run }
+ !
+ ! Check PDT type extension and simple OOP.
+ !
+ module vars
+ integer :: d_dim = 4
+ integer :: mat_dim = 256
+ integer, parameter :: ftype = kind(0.0d0)
+ end module
+
+ use vars
+ implicit none
+ integer :: i
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0e0)
+ integer, LEN :: b = 4
+ integer :: i
+ real(kind = a) :: d(b, b)
+ end type
+
+ type, extends(mytype) :: thytype(h)
+ integer, kind :: h
+ integer(kind = h) :: j
+ end type
+
+ type x (q, r, s)
+ integer, kind :: q
+ integer, kind :: r
+ integer, LEN :: s
+ integer(kind = q) :: idx_mat(2,2) ! check these do not get treated as pdt_arrays.
+ type (mytype (b=s)) :: mat1
+ type (mytype (b=s*2)) :: mat2
+ end type x
+
+ real, allocatable :: matrix (:,:)
+ type(thytype(ftype, 4, 4)) :: w
+ type(x(8,4,mat_dim)) :: q
+ class(mytype(ftype, :)), allocatable :: cz
+
+ w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])
+
+ ! Make sure that the type extension is ordering the parameters correctly.
+ if (w%a .ne. ftype) call abort
+ if (w%b .ne. 4) call abort
+ if (w%h .ne. 4) call abort
+ if (size (w%d) .ne. 16) call abort
+ if (int (w%d(2,4)) .ne. 14) call abort
+ if (kind (w%j) .ne. w%h) call abort
+
+ ! As a side issue, ensure PDT components are OK
+ if (q%mat1%b .ne. q%s) call abort
+ if (q%mat2%b .ne. q%s*2) call abort
+ if (size (q%mat1%d) .ne. mat_dim**2) call abort
+ if (size (q%mat2%d) .ne. 4*mat_dim**2) call abort
+
+ ! Now check some basic OOP with PDTs
+ matrix = w%d
+
+ ! TODO - for some reason, using w%d directly in the source causes a seg fault.
+ allocate (cz, source = mytype(ftype, d_dim, 0, matrix))
+ select type (cz)
+ type is (mytype(ftype, *))
+ if (int (sum (cz%d)) .ne. 136) call abort
+ type is (thytype(ftype, *, 8))
+ call abort
+ end select
+ deallocate (cz)
+
+ allocate (thytype(ftype, d_dim*2, 8) :: cz)
+ cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b])
+ select type (cz)
+ type is (mytype(ftype, *))
+ call abort
+ type is (thytype(ftype, *, 8))
+ if (int (sum (cz%d)) .ne. 20800) call abort
+ end select
+
+ deallocate (cz)
+ end
Index: gcc/testsuite/gfortran.dg/pdt_4.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_4.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_4.f03 (working copy)
***************
*** 0 ****
--- 1,90 ----
+ ! { dg-do compile }
+ !
+ ! Test bad PDT coding: Based on pdt_3.f03
+ !
+ module vars
+ integer :: d_dim = 4
+ integer :: mat_dim = 256
+ integer, parameter :: ftype = kind(0.0d0)
+ end module
+
+ use vars
+ implicit none
+ integer :: i
+ integer, kind :: bad_kind ! { dg-error "not allowed outside a TYPE definition" }
+ integer, len :: bad_len ! { dg-error "not allowed outside a TYPE definition" }
+
+ type :: bad_pdt (a,b, c, d)
+ real, kind :: a ! { dg-error "must be INTEGER" }
+ INTEGER(8), kind :: b ! { dg-error "be default integer kind" }
+ real, LEN :: c ! { dg-error "must be INTEGER" }
+ INTEGER(8), LEN :: d ! { dg-error "be default integer kind" }
+ end type
+
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0e0)
+ integer, LEN :: b = 4
+ integer :: i
+ real(kind = a) :: d(b, b)
+ end type
+
+ type, extends(mytype) :: thytype(h)
+ integer, kind :: h
+ integer(kind = h) :: j
+ end type
+
+ type x (q, r, s)
+ integer, kind :: q
+ integer, kind :: r
+ integer, LEN :: s
+ integer(kind = q) :: idx_mat(2,2)
+ type (mytype (b=s)) :: mat1
+ type (mytype (b=s*2)) :: mat2
+ end type x
+
+ real, allocatable :: matrix (:,:)
+
+ ! Bad KIND parameters
+ type(thytype(d_dim, 4, 4)) :: wbad ! { dg-error "does not reduce to a constant" }
+ type(thytype(*, 4, 4)) :: worse ! { dg-error "cannot either be ASSUMED or DEFERRED" }
+ type(thytype(:, 4, 4)) :: w_ugh ! { dg-error "cannot either be ASSUMED or DEFERRED" }
+
+ type(thytype(ftype, b=4, h=4)) :: w
+ type(x(8,4,mat_dim)) :: q
+ class(mytype(ftype, :)), allocatable :: cz
+
+ w%a = 1 ! { dg-error "assignment to a KIND or LEN component" }
+ w%b = 2 ! { dg-error "assignment to a KIND or LEN component" }
+ w%h = 3 ! { dg-error "assignment to a KIND or LEN component" }
+
+ w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])
+
+ matrix = w%d
+
+ allocate (cz, source = mytype(*, d_dim, 0, matrix)) ! { dg-error "Syntax error" }
+ allocate (cz, source = mytype(ftype, :, 0, matrix)) ! { dg-error "Syntax error" }
+ select type (cz)
+ type is (mytype(ftype, d_dim)) ! { dg-error "must be ASSUMED" }
+ if (int (sum (cz%d)) .ne. 136) call abort ! { dg-error "Expected TYPE IS" }
+ type is (thytype(ftype, *, 8))
+ call abort
+ end select
+ deallocate (cz)
+
+ allocate (thytype(ftype, d_dim*2, 8) :: cz)
+ cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b])
+ select type (cz)
+ type is (mytype(4, *)) ! { dg-error "must be an extension" }
+ call abort
+ type is (thytype(ftype, *, 8))
+ if (int (sum (cz%d)) .ne. 20800) call abort
+ end select
+ deallocate (cz)
+ contains
+ subroutine foo(arg) ! { dg-error "has no IMPLICIT type" }
+ type (mytype(4, *)) :: arg ! { dg-error "is being used before it is defined" }
+ end subroutine
+ subroutine bar(arg) ! { dg-error "cannot have DEFERRED type parameters" }
+ type (thytype(8, :, 4) :: arg
+ end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/pdt_5.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_5.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_5.f03 (working copy)
***************
*** 0 ****
--- 1,223 ----
+ ! { dg-do run }
+ !
+ ! Third, complete example from the PGInsider article:
+ ! "Object-Oriented Programming in Fortran 2003 Part 3: Parameterized Derived Types"
+ ! by Mark Leair
+ !
+ ! Copyright (c) 2013, NVIDIA CORPORATION. All rights reserved.
+ !
+ ! NVIDIA CORPORATION and its licensors retain all intellectual property
+ ! and proprietary rights in and to this software, related documentation
+ ! and any modifications thereto. Any use, reproduction, disclosure or
+ ! distribution of this software and related documentation without an express
+ ! license agreement from NVIDIA CORPORATION is strictly prohibited.
+ !
+
+ ! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
+ ! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
+ ! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
+ ! FITNESS FOR A PARTICULAR PURPOSE.
+ !
+ ! Note that modification had to be made all of which are commented.
+ !
+ module matrix
+
+ type :: base_matrix(k,c,r)
+ private
+ integer, kind :: k = 4
+ integer, len :: c = 1
+ integer, len :: r = 1
+ end type base_matrix
+
+ type, extends(base_matrix) :: adj_matrix
+ private
+ class(*), pointer :: m(:,:) => null()
+ end type adj_matrix
+
+ interface getKind
+ module procedure getKind4
+ module procedure getKind8
+ end interface getKind
+
+ interface getColumns
+ module procedure getNumCols4
+ module procedure getNumCols8
+ end interface getColumns
+
+ interface getRows
+ module procedure getNumRows4
+ module procedure getNumRows8
+ end interface getRows
+
+ interface adj_matrix
+ module procedure construct_4 ! kind=4 constructor
+ module procedure construct_8 ! kind=8 constructor
+ end interface adj_matrix
+
+ interface assignment(=)
+ module procedure m2m4 ! assign kind=4 matrix
+ module procedure a2m4 ! assign kind=4 array
+ module procedure m2m8 ! assign kind=8 matrix
+ module procedure a2m8 ! assign kind=8 array
+ module procedure m2a4 ! assign kind=4 matrix to array
+ module procedure m2a8 ! assign kind=8 matrix to array
+ end interface assignment(=)
+
+
+ contains
+
+ function getKind4(this) result(rslt)
+ class(adj_matrix(4,*,*)) :: this
+ integer :: rslt
+ rslt = this%k
+ end function getKind4
+
+ function getKind8(this) result(rslt)
+ class(adj_matrix(8,*,*)) :: this
+ integer :: rslt
+ rslt = this%k
+ end function getKind8
+
+ function getNumCols4(this) result(rslt)
+ class(adj_matrix(4,*,*)) :: this
+ integer :: rslt
+ rslt = this%c
+ end function getNumCols4
+
+ function getNumCols8(this) result(rslt)
+ class(adj_matrix(8,*,*)) :: this
+ integer :: rslt
+ rslt = this%c
+ end function getNumCols8
+
+ function getNumRows4(this) result(rslt)
+ class(adj_matrix(4,*,*)) :: this
+ integer :: rslt
+ rslt = this%r
+ end function getNumRows4
+
+ function getNumRows8(this) result(rslt)
+ class(adj_matrix(8,*,*)) :: this
+ integer :: rslt
+ rslt = this%r
+ end function getNumRows8
+
+
+ function construct_4(k,c,r) result(mat)
+ integer(4) :: k
+ integer :: c
+ integer :: r
+ class(adj_matrix(4,:,:)),allocatable :: mat
+
+ allocate(adj_matrix(4,c,r)::mat)
+
+ end function construct_4
+
+ function construct_8(k,c,r) result(mat)
+ integer(8) :: k
+ integer :: c
+ integer :: r
+ class(adj_matrix(8,:,:)),allocatable :: mat
+
+ allocate(adj_matrix(8,c,r)::mat)
+
+ end function construct_8
+
+ subroutine a2m4(d,s)
+ class(adj_matrix(4,:,:)),allocatable :: d
+ class(*),dimension(:,:) :: s
+
+ if (allocated(d)) deallocate(d)
+ ! allocate(adj_matrix(4,size(s,1),size(s,2))::d) ! generates assembler error
+ allocate(d, mold = adj_matrix(4,size(s,1),size(s,2)))
+ allocate(d%m(size(s,1),size(s,2)),source=s)
+ end subroutine a2m4
+
+ subroutine a2m8(d,s)
+ class(adj_matrix(8,:,:)),allocatable :: d
+ class(*),dimension(:,:) :: s
+
+ if (allocated(d)) deallocate(d)
+ ! allocate(adj_matrix(8,size(s,1),size(s,2))::d) ! generates assembler error
+ allocate(d, mold = adj_matrix(8_8,size(s,1),size(s,2))) ! Needs 8_8 to match arg1 of 'construct_8'
+ allocate(d%m(size(s,1),size(s,2)),source=s)
+ end subroutine a2m8
+
+ subroutine m2a8(a,this)
+ class(adj_matrix(8,*,*)), intent(in) :: this ! Intents required for
+ real(8),allocatable, intent(out) :: a(:,:) ! defined assignment
+ select type (array => this%m) ! Added SELECT TYPE because...
+ type is (real(8))
+ if (allocated(a)) deallocate(a)
+ allocate(a,source=array)
+ end select
+ ! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
+ end subroutine m2a8
+
+ subroutine m2a4(a,this)
+ class(adj_matrix(4,*,*)), intent(in) :: this ! Intents required for
+ real(4),allocatable, intent(out) :: a(:,:) ! defined assignment
+ select type (array => this%m) ! Added SELECT TYPE because...
+ type is (real(4))
+ if (allocated(a)) deallocate(a)
+ allocate(a,source=array)
+ end select
+ ! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
+ end subroutine m2a4
+
+ subroutine m2m4(d,s)
+ CLASS(adj_matrix(4,:,:)),allocatable, intent(OUT) :: d ! Intents required for
+ CLASS(adj_matrix(4,*,*)), intent(in) :: s ! defined assignment
+
+ if (allocated(d)) deallocate(d)
+ allocate(d,source=s)
+ end subroutine m2m4
+
+ subroutine m2m8(d,s)
+ CLASS(adj_matrix(8,:,:)),allocatable, intent(OUT) :: d ! Intents required for
+ CLASS(adj_matrix(8,*,*)), intent(in) :: s ! defined assignment
+
+ if (allocated(d)) deallocate(d)
+ allocate(d,source=s)
+ end subroutine m2m8
+
+
+ end module matrix
+
+
+ program adj3
+
+ use matrix
+ implicit none
+ integer(8) :: i
+
+ class(adj_matrix(8,:,:)),allocatable :: adj ! Was TYPE: Fails in
+ real(8) :: a(2,3) ! defined assignment
+ real(8),allocatable :: b(:,:)
+
+ class(adj_matrix(4,:,:)),allocatable :: adj_4 ! Ditto and ....
+ real(4) :: a_4(3,2) ! ... these declarations were
+ real(4),allocatable :: b_4(:,:) ! added to check KIND=4
+
+ ! Check constructor of PDT and instrinsic assignment
+ adj = adj_matrix(INT(8,8),2,4)
+ if (adj%k .ne. 8) call abort
+ if (adj%c .ne. 2) call abort
+ if (adj%r .ne. 4) call abort
+ a = reshape ([(i, i = 1, 6)], [2,3])
+ adj = a
+ b = adj
+ if (any (b .ne. a)) call abort
+
+ ! Check allocation with MOLD of PDT. Note that only KIND parameters set.
+ allocate (adj_4, mold = adj_matrix(4,3,2)) ! Added check of KIND = 4
+ if (adj_4%k .ne. 4) call abort
+ a_4 = reshape (a, [3,2])
+ adj_4 = a_4
+ b_4 = adj_4
+ if (any (b_4 .ne. a_4)) call abort
+
+ end program adj3
+
+
+
^ permalink raw reply [flat|nested] 10+ messages in thread
* [Patch, fortran] Parameterized Derived Types
@ 2017-09-06 13:05 Paul Richard Thomas
2017-09-06 17:38 ` Janus Weil
2017-09-06 18:37 ` Damian Rouson
0 siblings, 2 replies; 10+ messages in thread
From: Paul Richard Thomas @ 2017-09-06 13:05 UTC (permalink / raw)
To: fortran, gcc-patches; +Cc: Damian Rouson, Mark LeAir
[-- Attachment #1: Type: text/plain, Size: 7849 bytes --]
Dear All,
Since my message to the list of 16 August 2017 I have put in another
intense period of activity to develop a patch to implement PDTs in
gfortran. I have now temporarily run out of time to develop it
further; partly because of a backlog of other patches and PRs to deal
with but also pressure from daytime work.
The patch adds the last unimplemented F2003 feature to gfortran.
As in the provisional patch, I have attached some notes on the
implementation. This indicates some of the weaknesses, problem areas
and TODOs.
Suggest that a good read of Mark Leair's excellent PGInsider article
on PDTs - http://www.pgroup.com/lit/articles/insider/v5n2a4.htm is a
worthwhile exercise.
To judge by the complete silence following my previous message, I will
have a problem getting this patch reviewed. I would welcome any
remarks or reviews but intend to commit, warts and all, on Saturday
unless something fundamentally wrong comes out of the woodwork.
Note that the PDT parts in the compiler are rather well insulated from
the rest of fortran and that I do not believe that any regressions
will result.
I hope that a month or two of testing in other hands will add to the
list of TODOs and that when I return to PDTs a greatly improved
version will result.
Bootstrapped and regtested on FC23/x86_4 - OK for trunk? (Note above
remark about committing on Saturday in the absence of a review.)
Best regards
Paul
2017-09-05 Paul Thomas <pault@gcc.gnu.org>
* decl.c : Add decl_type_param_list, type_param_spec_list as
static variables to hold PDT spec lists.
(build_sym): Copy 'type_param_spec_list' to symbol spec_list.
(build_struct): Copy the 'saved_kind_expr' to the component
'kind_expr'. Check that KIND or LEN components appear in the
decl_type_param_list. These should appear as symbols in the
f2k_derived namespace. If the component is itself a PDT type,
copy the decl_type_param_list to the component param_list.
(gfc_match_kind_spec): If the KIND expression is parameterized
set KIND to zero and store the expression in 'saved_kind_expr'.
(insert_parameter_exprs): New function.
(gfc_insert_kind_parameter_exprs): New function.
(gfc_insert_parameter_exprs): New function.
(gfc_get_pdt_instance): New function.
(gfc_match_decl_type_spec): Match the decl_type_spec_list if it
is present. If it is, call 'gfc_get_pdt_instance' to obtain the
specific instance of the PDT.
(match_attr_spec): Match KIND and LEN attributes. Check for the
standard and for type/kind of the parameter. They are also not
allowed outside a derived type definition.
(gfc_match_data_decl): Null the decl_type_param_list and the
type_param_spec_list on entry and free them on exit.
(gfc_match_formal_arglist): If 'typeparam' is true, add the
formal symbol to the f2k_derived namespace.
(gfc_match_derived_decl): Register the decl_type_param_list
if this is a PDT. If this is a type extension, gather up all
the type parameters and put them in the right order.
*dump-parse-tree.c (show_attr): Signal PDT templates and the
parameter attributes.
(show_components): Output parameter atrributes and component
parameter list.
(show_symbol): Show variable parameter lists.
* expr.c (expr.c): Copy the expression parameter list.
(gfc_is_constant_expr): Pass on symbols representing PDT
parameters.
(gfc_check_init_expr): Break on PDT KIND parameters and
PDT parameter expressions.
(gfc_check_assign): Assigning to KIND or LEN components is an
error.
(derived_parameter_expr): New function.
(gfc_derived_parameter_expr): New function.
(gfc_spec_list_type): New function.
* gfortran.h : Add enum gfc_param_spec_type. Add the PDT attrs
to the structure symbol_attr. Add the 'kind_expr' and
'param_list' field to the gfc_component structure. Comment on
the reuse of the gfc_actual_arglist structure as storage for
type parameter spec lists. Add the new field 'spec_type' to
this structure. Add 'param_list' fields to gfc_symbol and
gfc_expr. Add prototypes for gfc_insert_kind_parameter_exprs,
gfc_insert_parameter_exprs, gfc_add_kind, gfc_add_len,
gfc_derived_parameter_expr and gfc_spec_list_type.
* interface.c (gfc_compare_derived_types): Treat PDTs in the
same way as sequence types.
* match.c : Add variable 'type_param_spec_list'.
(gfc_op2string, gfc_match_member_sep, gfc_match_label): Remove
trailing whitespace.
(match_derived_type_spec): Match PDTs and find specific
instance.
(gfc_match_type_spec): Remove more trailing whitespace.
(gfc_match_allocate): Assumed or deferred parameters cannot
appear here. Copy the type parameter spec list to the expr for
the allocatable entity. Free 'type_param_spec_list'.
(gfc_match_common, gfc_match_namelist, gfc_match_module): Still
more trailing whitespace to remove.
(gfc_match_type_is): Allow PDT typespecs.
* match.h : Modify prototypes for gfc_match_formal_arglist and
gfc_match_actual_arglist.
* module.c (ab_attribute, mstring attr_bits): PDT attributes
added.
(mio_symbol_attribute): PDT attributes handled.
(mio_component): Deal with 'kind_expr' field.
(mio_full_f2k_derived): For PDT templates, transfer the formal
namespace symroot to the f2k_derived namespace.
*primary.c (match_keyword_arg, gfc_match_actual_arglist): Add
modifications to handle PDT spec lists. These are flagged in
both cases by new boolean arguments, whose prototype defaults
are false.
(gfc_match_structure_constructor, match_variable): Remove yet
more trailing whitespace.
* resolve.c (get_pdt_spec_expr, get_pdt_constructor): New
functions.
(resolve_structure_cons): If the constructor is a PDT template,
call get_pdt_constructor to build it using the parameter lists
and then get the specific instance of the PDT.
(resolve_component): PDT strings need a hidden string length
component like deferred characters.
(resolve_symbol): Dummy PDTs cannot have deferred parameters.
* symbol.c (gfc_add_kind, gfc_add_len): New functions.
(free_components): Free 'kind_expr' and 'param_list' fields.
(gfc_free_symbol): Free the 'param_list' field.
(gfc_find_sym_tree): If the current state is a PDT template,
look for the symtree in the f2k_derived namspaces.
trans-array.c (structure_alloc_comps): Allocate and deallocate
PDTs. Check dummy arguments for compliance of LEN parameters.
Add the new functions to the preceeding enum.
(gfc_allocate_pdt_comp, gfc_deallocate_pdt_comp and
gfc_check_pdt_dummy): New functions calling above.
* trans-array.h : Add prototypes for these functions.
trans-decl.c (gfc_get_symbol_decl): Call gfc_defer_symbol_init
as appropriate for PDT symbols.
(gfc_trans_deferred_vars): Allocate/deallocate PDT entities as
they come into and out of scope. Exclude pdt_types from being
'gcc_unreachable'.
(gfc_trans_subcomponent_assign): PDT array components must be
handles as if they are allocatable.
* trans-stmt.c (gfc_trans_allocate): Handle initialization of
PDT entities.
(gfc_trans_deallocate): Likewise.
* trans-types.c (gfc_get_derived_type): PDT templates must not
arrive here. PDT string components are handles as if deferred.
Similarly, PDT arrays are treated as if allocatable. PDT
strings are pointer types.
* trans.c (gfc_deferred_strlen): Handle PDT strings in the same
way as deferred characters.
2017-09-05 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/pdt_1.f03 : New test.
* gfortran.dg/pdt_2.f03 : New test.
* gfortran.dg/pdt_3.f03 : New test.
* gfortran.dg/pdt_4.f03 : New test.
* gfortran.dg/pdt_5.f03 : New test.
[-- Attachment #2: notes0609.txt --]
[-- Type: text/plain, Size: 7886 bytes --]
Notes on implementation of Parameterized Derived Types in gfortran
1) Derived type definition:
___________________________
R425
derived-type-def is derived-type-stmt
[ type-param-def-stmt ]
[ private-or-sequence ] ...
[ component-part ]
[ type-bound-procedure-part ]
end-type-stmt
R426
derived-type-stmt is TYPE [ [ , type-attr-spec-list ] :: ] type-name [ ( type-param-name-list ) ]
Example in Note 4.23:
The following example uses derived-type parameters.
TYPE humongous_matrix(k, d) ! ( type-param-name-list ) = (k,d)
INTEGER, KIND :: k = kind(0.0) ! KIND parameter values known at compile time.
INTEGER(selected_int_kind(12)), LEN :: d ! LEN parameters may not be known at compile time
!-- Specify a nondefault kind for d.
REAL(k) :: element(d,d)
END TYPE
In the present version of the patch, the 'type-param-name-list' is stored as a formal_arglist in the 'formal' field of the derived type symbol, since it is not otherwise used.
The gfc_symbols associated with the formal_arglist are added to the derived type 'f2k_derived' namespace, which was one of the reasons why this namespace was introduced in the first place.
In this example, 'humongous_matrix is marked with the attribute pdt_template and the components {k,d,element} with attributes {pdt_kind,pdt_len,pdt_array}
A new gfc_component field 'kind_expr' has been added, such that kind expressions, such as that for 'element' can be stored. The array bound expressions are stored in the arrayspec as usual.
Type extension has been implemented and ensures that the extension picks up a copy of the 'type-param-name-list' of the extended type, which is concatenated with such new 'type-param-name-list' as there might be.
2) Type declaration statements:
_______________________________
R501
type-declaration-stmt is declaration-type-spec [ [ , attr-spec ] ... :: ] entity-decl -list
R403
declaration-type-spec is intrinsic-type-spec
or TYPE ( intrinsic-type-spec )
or TYPE ( derived-type-spec )
or CLASS ( derived-type-spec )
or CLASS ( * )
R453
derived-type-spec is type-name [ ( type-param-spec-list ) ]
R454 type-param-spec is [ keyword = ] type-param-value
R401
type-param-value is scalar-int-expr
or *
or :
Example in Note 5.1:
TYPE (humongous_matrix (k=8, d=1000)) :: mat
Given the similarity to actual arguments, gfc_actual_arglist has been taken over to represent the type_param_spec_list.
'param_list' fields have been added to gfc_expr, gfc_symbol and gfc_component to store all or part of the type-param-spec-list, as required.
The workhorse in the present implementation is decl.c(gfc_get_pdt_instance), which converts the pdt templates into instances of pdt types. These have the attribute pdt_type naturally enough.
'gfc_get_pdt_instance' ensures that the expressions for the KIND parameters can be simplified to constant expressions and the instance naming is Pdt//template_name//_kind.val1_kind.val2...
The instance of the example above is named 'Pdthumongous_matrix_8
Ideally, the name would have started with a non_alpha character so that it would not be possible to cause a clash with an explicitly declared entity. Unfortunately, this would interfere with the mechanism distinguishing the type from its constructor, where leading upper and lower case are used respectively. Using '@' between 'Pdt' and the template name worked until CLASS declarations were introduced, when all sorts of linker problems were caused by the naming of the functions associated with the vtables. This will have to be fixed sometime.
TODO Error messages at the moment use the name of the specific instance. This will have to be changed so that the names appear as per a PDT declaration.
It should be noted that I have thus far been rather cavalier about assumed and deferred parameters. The requisite checks will have to be added to comply with all the relevant constraints.
Where explicit 'type-param-value's are given to dummy arguments, a rudimentary runtime check has been implemented to assert that the actual argument parameter values are compliant.
TODO Determine if it really is an error for dummy arguments to have deferred type parameters.
I have done a reasonably thorough job to ensure that all the spec_lists are freed as well as the kind expressions.
TODO Check that no new memory leaks have been introduced in the compiler.
3) Matching typespecs in other situations (eg. ALLOCATE or TYPE IS statements)
___________________________________________________________________
This has been done in match.c(gfc_match_decl_type_spec) using 'gfc_get_pdt_instance'. Notice that this is only used in the ALLOCATE and TYPE IS statements in the present patch. In the PGInsider article on the subject of PDTs, allocate(adj_matrix(8,c,r)::mat) appears, which is matched by this mechanism.
TODO For reasons that I have not yet identified, allocate(adj_matrix(4,size(s,1),size(s,2))::d) causes link errors due to 'undefined size_'.
4) Runtime initialization of PDT entities
_________________________________________
This has been accomplished by extending the allocatable component workhorse trans-array.c(structure_alloc_comps) to include the calls 'gfc_allocate_pdt_comp', 'gfc_deallocate_pdt_comp' and 'gfc_check_pdt_dummy'.
The implementation allows recursion into extended types and PDT components.
The handling of assumed and deferred parameters still needs a bit of cleaning up.
TODO I have yet to peruse the standard to understood what should happen to use associated PDT entities. On the face of it, it is difficult to see when and how these should be initialized.
trans_decl.c(gfc_trans_deferred_vars) handles the intialization and automatic deallocation calls.
trans-stmt.c(gfc_trans_allocate) & (gfc_trans_deallocate) seem to work correctly and to call 'gfc_allocate_pdt_comp' as required.
TODO Note that in PDT_5.f03, the allocate with MOLD is perturbed by the defined assignment definitions and that the LEN parameters are not being set. This likely needs yet another function in trans-array.c to copy PDT entities.
I have not checked fully for runtime memory leaks.
5) Other remarks
________________
I have restricted LEN parameters to be of default integer kind. I note from the standard, for example i 1) above, that this is not necessary.
I made some changes to dump-parse-tree.c because components in particular were getting very cluttered with the new fields.
interface.c(gfc_compare_derived_types) had to be modified to ensure that like 'pdt_type's were not rejected.
In module.c(mio_full_f2k_derived) the 'sym_root' of the formal namespace is hijacked and appended to the 'f2k_derived' namespace.
The new function resolve.c(get_pdt_constructor) sorts out the parameter expressions for the component expressions.
TODO I rather think that the handling of CLASS PDTs is in one or two places wrong or inconsistent.
TODO I rather think that much of the new content in decl.c should be moved to class.c or expr.c. Since this does not affect the functionality, I have left this task until I have some more time to spend on PDTs.
6) Tests
________
pdt_1.f03 - checks basic PDT functionality
pdt_2.f03 - tests runtime error for mismatch between actual and dummy len parameters
pdt_3.f03 - checks type extension and basic OOP, including SELECT TYPE
pdt_4.f03 - exercises the compile time errors.
pdt_5.f03 - this is a modified version of the third example in the PGInsider article on PDTs.
TODO Some of the modifications in pdt_5.f03 are due to some apparent shortcomings in gfortran; eg. allocating intrinsic types with an unlimited polymorphic source. Also need to find out why the declarations in the main program had to be changed for CLASS to TYPE and what is happening with the use of SIZE in the typespecs. All these points are commented in the test.
[-- Attachment #3: check0609.diff --]
[-- Type: text/plain, Size: 113658 bytes --]
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 251546)
--- gcc/fortran/decl.c (working copy)
*************** gfc_symbol *gfc_new_block;
*** 95,100 ****
--- 95,109 ----
bool gfc_matching_function;
+ /* If a kind expression of a component of a parameterized derived type is
+ parameterized, temporarily store the expression here. */
+ static gfc_expr *saved_kind_expr = NULL;
+
+ /* Used to store the parameter list arising in a PDT declaration and
+ in the typespec of a PDT variable or component. */
+ static gfc_actual_arglist *decl_type_param_list;
+ static gfc_actual_arglist *type_param_spec_list;
+
/********************* DATA statement subroutines *********************/
*************** build_sym (const char *name, gfc_charlen
*** 1500,1505 ****
--- 1509,1519 ----
sym->attr.implied_index = 0;
+ /* Use the parameter expressions for a parameterized derived type. */
+ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
+ sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
+
if (sym->ts.type == BT_CLASS)
return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
*************** build_struct (const char *name, gfc_char
*** 1946,1951 ****
--- 1960,1970 ----
c->ts = current_ts;
if (c->ts.type == BT_CHARACTER)
c->ts.u.cl = cl;
+
+ if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
+ && c->ts.kind == 0 && saved_kind_expr != NULL)
+ c->kind_expr = gfc_copy_expr (saved_kind_expr);
+
c->attr = current_attr;
c->initializer = *init;
*************** scalar:
*** 1999,2004 ****
--- 2018,2048 ----
if (c->ts.type == BT_CLASS)
return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
+ if (c->attr.pdt_kind || c->attr.pdt_len)
+ {
+ gfc_symbol *sym;
+ gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
+ 0, &sym);
+ if (sym == NULL)
+ {
+ gfc_error ("Type parameter %qs at %C has no corresponding entry "
+ "in the type parameter name list at %L",
+ c->name, &gfc_current_block ()->declared_at);
+ return false;
+ }
+ sym->ts = c->ts;
+ sym->attr.pdt_kind = c->attr.pdt_kind;
+ sym->attr.pdt_len = c->attr.pdt_len;
+ if (c->initializer)
+ sym->value = gfc_copy_expr (c->initializer);
+ sym->attr.flavor = FL_VARIABLE;
+ }
+
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
+ && decl_type_param_list)
+ c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
+
return true;
}
*************** gfc_match_kind_spec (gfc_typespec *ts, b
*** 2612,2617 ****
--- 2656,2662 ----
m = MATCH_NO;
n = MATCH_YES;
e = NULL;
+ saved_kind_expr = NULL;
where = loc = gfc_current_locus;
*************** gfc_match_kind_spec (gfc_typespec *ts, b
*** 2628,2635 ****
--- 2673,2688 ----
loc = gfc_current_locus;
kind_expr:
+
n = gfc_match_init_expr (&e);
+ if (gfc_derived_parameter_expr (e))
+ {
+ ts->kind = 0;
+ saved_kind_expr = gfc_copy_expr (e);
+ goto close_brackets;
+ }
+
if (n != MATCH_YES)
{
if (gfc_matching_function)
*************** kind_expr:
*** 2707,2712 ****
--- 2760,2767 ----
"is %s", gfc_basic_typename (ts->f90_type), &where,
gfc_basic_typename (ts->type));
+ close_brackets:
+
gfc_gobble_whitespace ();
if ((c = gfc_next_ascii_char ()) != ')'
&& (ts->type != BT_CHARACTER || c != ','))
*************** match_record_decl (char *name)
*** 3030,3035 ****
--- 3085,3507 ----
return MATCH_ERROR;
}
+
+ /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
+ of expressions to substitute into the possibly parameterized expression
+ 'e'. Using a list is inefficient but should not be too bad since the
+ number of type parameters is not likely to be large. */
+ static bool
+ insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+ int* f)
+ {
+ gfc_actual_arglist *param;
+ gfc_expr *copy;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ gcc_assert (e->symtree);
+ if (e->symtree->n.sym->attr.pdt_kind
+ || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
+ {
+ for (param = type_param_spec_list; param; param = param->next)
+ if (strcmp (e->symtree->n.sym->name, param->name) == 0)
+ break;
+
+ if (param)
+ {
+ copy = gfc_copy_expr (param->expr);
+ *e = *copy;
+ free (copy);
+ }
+ }
+
+ return false;
+ }
+
+
+ bool
+ gfc_insert_kind_parameter_exprs (gfc_expr *e)
+ {
+ return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
+ }
+
+
+ bool
+ gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
+ {
+ gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
+ type_param_spec_list = param_list;
+ return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
+ type_param_spec_list = NULL;
+ type_param_spec_list = old_param_spec_list;
+ }
+
+ /* Determines the instance of a parameterized derived type to be used by
+ matching determining the values of the kind parameters and using them
+ in the name of the instance. If the instance exists, it is used, otherwise
+ a new derived type is created. */
+ match
+ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
+ gfc_actual_arglist **ext_param_list)
+ {
+ /* The PDT template symbol. */
+ gfc_symbol *pdt = *sym;
+ /* The symbol for the parameter in the template f2k_namespace. */
+ gfc_symbol *param;
+ /* The hoped for instance of the PDT. */
+ gfc_symbol *instance;
+ /* The list of parameters appearing in the PDT declaration. */
+ gfc_formal_arglist *type_param_name_list;
+ /* Used to store the parameter specification list during recursive calls. */
+ gfc_actual_arglist *old_param_spec_list;
+ /* Pointers to the parameter specification being used. */
+ gfc_actual_arglist *actual_param;
+ gfc_actual_arglist *tail = NULL;
+ /* Used to build up the name of the PDT instance. The prefix uses 4
+ characters and each KIND parameter 2 more. Allow 8 of the latter. */
+ char name[GFC_MAX_SYMBOL_LEN + 21];
+
+ bool name_seen = (param_list == NULL);
+ bool assumed_seen = false;
+ bool deferred_seen = false;
+ bool spec_error = false;
+ int kind_value, i;
+ gfc_expr *kind_expr;
+ gfc_component *c1, *c2;
+ match m;
+
+ type_param_spec_list = NULL;
+
+ type_param_name_list = pdt->formal;
+ actual_param = param_list;
+ sprintf (name, "Pdt%s", pdt->name);
+
+ /* Run through the parameter name list and pick up the actual
+ parameter values or use the default values in the PDT declaration. */
+ for (; type_param_name_list;
+ type_param_name_list = type_param_name_list->next)
+ {
+ if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
+ {
+ if (actual_param->spec_type == SPEC_ASSUMED)
+ spec_error = deferred_seen;
+ else
+ spec_error = assumed_seen;
+
+ if (spec_error)
+ {
+ gfc_error ("The type parameter spec list at %C cannot contain "
+ "both ASSUMED and DEFERRED parameters");
+ gfc_free_actual_arglist (type_param_spec_list);
+ return MATCH_ERROR;
+ }
+ }
+
+ if (actual_param && actual_param->name)
+ name_seen = true;
+ param = type_param_name_list->sym;
+
+ kind_expr = NULL;
+ if (!name_seen)
+ {
+ if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
+ kind_expr = gfc_copy_expr (actual_param->expr);
+ }
+ else
+ {
+ actual_param = param_list;
+ for (;actual_param; actual_param = actual_param->next)
+ if (actual_param->name
+ && strcmp (actual_param->name, param->name) == 0)
+ break;
+ if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
+ kind_expr = gfc_copy_expr (actual_param->expr);
+ else
+ {
+ if (param->value)
+ kind_expr = gfc_copy_expr (param->value);
+ else if (!(actual_param && param->attr.pdt_len))
+ {
+ gfc_error ("The derived parameter '%qs' at %C does not "
+ "have a default value", param->name);
+ return MATCH_ERROR;
+ }
+ }
+ }
+
+ /* Store the current parameter expressions in a temporary actual
+ arglist 'list' so that they can be substituted in the corresponding
+ expressions in the PDT instance. */
+ if (type_param_spec_list == NULL)
+ {
+ type_param_spec_list = gfc_get_actual_arglist ();
+ tail = type_param_spec_list;
+ }
+ else
+ {
+ tail->next = gfc_get_actual_arglist ();
+ tail = tail->next;
+ }
+ tail->name = param->name;
+
+ if (kind_expr)
+ {
+ tail->expr = gfc_copy_expr (kind_expr);
+ /* Try simplification even for LEN expressions. */
+ gfc_simplify_expr (tail->expr, 1);
+ }
+
+ if (actual_param)
+ tail->spec_type = actual_param->spec_type;
+
+ if (!param->attr.pdt_kind)
+ {
+ if (!name_seen)
+ actual_param = actual_param->next;
+ if (kind_expr)
+ {
+ gfc_free_expr (kind_expr);
+ kind_expr = NULL;
+ }
+ continue;
+ }
+
+ if (actual_param
+ && (actual_param->spec_type == SPEC_ASSUMED
+ || actual_param->spec_type == SPEC_DEFERRED))
+ {
+ gfc_error ("The KIND parameter '%qs' at %C cannot either be "
+ "ASSUMED or DEFERRED", param->name);
+ gfc_free_actual_arglist (type_param_spec_list);
+ return MATCH_ERROR;
+ }
+
+ if (!kind_expr || !gfc_is_constant_expr (kind_expr))
+ {
+ gfc_error ("The value for the KIND parameter '%qs' at %C does not "
+ "reduce to a constant expression", param->name);
+ gfc_free_actual_arglist (type_param_spec_list);
+ return MATCH_ERROR;
+ }
+
+ gfc_extract_int (kind_expr, &kind_value);
+ sprintf (name, "%s_%d", name, kind_value);
+
+ if (!name_seen && actual_param)
+ actual_param = actual_param->next;
+ gfc_free_expr (kind_expr);
+ }
+
+ /* Now we search for the PDT instance 'name'. If it doesn't exist, we
+ build it, using 'pdt' as a template. */
+ if (gfc_get_symbol (name, pdt->ns, &instance))
+ {
+ gfc_error ("Parameterized derived type at %C is ambiguous");
+ return MATCH_ERROR;
+ }
+
+ m = MATCH_YES;
+
+ if (instance->attr.flavor == FL_DERIVED
+ && instance->attr.pdt_type)
+ {
+ instance->refs++;
+ if (ext_param_list)
+ *ext_param_list = type_param_spec_list;
+ *sym = instance;
+ gfc_commit_symbols ();
+ return m;
+ }
+
+ /* Start building the new instance of the parameterized type. */
+ gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
+ instance->attr.pdt_template = 0;
+ instance->attr.pdt_type = 1;
+ instance->declared_at = gfc_current_locus;
+
+ /* Add the components, replacing the parameters in all expressions
+ with the expressions for their values in 'type_param_spec_list'. */
+ c1 = pdt->components;
+ tail = type_param_spec_list;
+ for (; c1; c1 = c1->next)
+ {
+ gfc_add_component (instance, c1->name, &c2);
+ c2->ts = c1->ts;
+ c2->attr = c1->attr;
+
+ /* Deal with type extension by recursively calling this function
+ to obtain the instance of the extended type. */
+ if (gfc_current_state () != COMP_DERIVED
+ && c1 == pdt->components
+ && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
+ && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
+ && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
+ {
+ gfc_formal_arglist *f;
+
+ old_param_spec_list = type_param_spec_list;
+
+ /* Obtain a spec list appropriate to the extended type..*/
+ actual_param = gfc_copy_actual_arglist (type_param_spec_list);
+ type_param_spec_list = actual_param;
+ for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
+ actual_param = actual_param->next;
+ if (actual_param)
+ {
+ gfc_free_actual_arglist (actual_param->next);
+ actual_param->next = NULL;
+ }
+
+ /* Now obtain the PDT instance for the extended type. */
+ c2->param_list = type_param_spec_list;
+ m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
+ NULL);
+ type_param_spec_list = old_param_spec_list;
+
+ c2->ts.u.derived->refs++;
+ gfc_set_sym_referenced (c2->ts.u.derived);
+
+ /* Set extension level. */
+ if (c2->ts.u.derived->attr.extension == 255)
+ {
+ /* Since the extension field is 8 bit wide, we can only have
+ up to 255 extension levels. */
+ gfc_error ("Maximum extension level reached with type %qs at %L",
+ c2->ts.u.derived->name,
+ &c2->ts.u.derived->declared_at);
+ return MATCH_ERROR;
+ }
+ instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
+
+ /* Advance the position in the spec list by the number of
+ parameters in the extended type. */
+ tail = type_param_spec_list;
+ for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
+ tail = tail->next;
+
+ continue;
+ }
+
+ /* Set the component kind using the parameterized expression. */
+ if (c1->ts.kind == 0 && c1->kind_expr != NULL)
+ {
+ gfc_expr *e = gfc_copy_expr (c1->kind_expr);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_extract_int (e, &c2->ts.kind);
+ gfc_free_expr (e);
+ }
+
+ /* Similarly, set the string length if parameterized. */
+ if (c1->ts.type == BT_CHARACTER
+ && c1->ts.u.cl->length
+ && gfc_derived_parameter_expr (c1->ts.u.cl->length))
+ {
+ gfc_expr *e;
+ e = gfc_copy_expr (c1->ts.u.cl->length);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ c2->ts.u.cl->length = e;
+ c2->attr.pdt_string = 1;
+ }
+
+ /* Set up either the KIND/LEN initializer, if constant,
+ or the parameterized expression. Use the template
+ initializer if one is not already set in this instance. */
+ if (c2->attr.pdt_kind || c2->attr.pdt_len)
+ {
+ if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
+ c2->initializer = gfc_copy_expr (tail->expr);
+ else if (tail && tail->expr)
+ {
+ c2->param_list = gfc_get_actual_arglist ();
+ c2->param_list->name = tail->name;
+ c2->param_list->expr = gfc_copy_expr (tail->expr);
+ c2->param_list->next = NULL;
+ }
+
+ if (!c2->initializer && c1->initializer)
+ c2->initializer = gfc_copy_expr (c1->initializer);
+
+ tail = tail->next;
+ }
+
+ /* Copy the array spec. */
+ c2->as = gfc_copy_array_spec (c1->as);
+ if (c1->ts.type == BT_CLASS)
+ CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
+
+ /* Determine if an array spec is parameterized. If so, substitute
+ in the parameter expressions for the bounds and set the pdt_array
+ attribute. Notice that this attribute must be unconditionally set
+ if this is an array of parameterized character length. */
+ if (c1->as && c1->as->type == AS_EXPLICIT)
+ {
+ bool pdt_array = false;
+
+ /* Are the bounds of the array parameterized? */
+ for (i = 0; i < c1->as->rank; i++)
+ {
+ if (gfc_derived_parameter_expr (c1->as->lower[i]))
+ pdt_array = true;
+ if (gfc_derived_parameter_expr (c1->as->upper[i]))
+ pdt_array = true;
+ }
+
+ /* If they are, free the expressions for the bounds and
+ replace them with the template expressions with substitute
+ values. */
+ for (i = 0; pdt_array && i < c1->as->rank; i++)
+ {
+ gfc_expr *e;
+ e = gfc_copy_expr (c1->as->lower[i]);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ gfc_free_expr (c2->as->lower[i]);
+ c2->as->lower[i] = e;
+ e = gfc_copy_expr (c1->as->upper[i]);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ gfc_free_expr (c2->as->upper[i]);
+ c2->as->upper[i] = e;
+ }
+ c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
+ }
+
+ /* Recurse into this function for PDT components. */
+ if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
+ && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
+ {
+ gfc_actual_arglist *params;
+ /* The component in the template has a list of specification
+ expressions derived from its declaration. */
+ params = gfc_copy_actual_arglist (c1->param_list);
+ actual_param = params;
+ /* Substitute the template parameters with the expressions
+ from the specification list. */
+ for (;actual_param; actual_param = actual_param->next)
+ gfc_insert_parameter_exprs (actual_param->expr,
+ type_param_spec_list);
+
+ /* Now obtain the PDT instance for the component. */
+ old_param_spec_list = type_param_spec_list;
+ m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL);
+ type_param_spec_list = old_param_spec_list;
+
+ c2->param_list = params;
+ c2->initializer = gfc_default_initializer (&c2->ts);
+ }
+ }
+
+ gfc_commit_symbol (instance);
+ if (ext_param_list)
+ *ext_param_list = type_param_spec_list;
+ *sym = instance;
+ return m;
+ }
+
+
/* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
structure to the matched specification. This is necessary for FUNCTION and
IMPLICIT statements.
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3048,3053 ****
--- 3520,3527 ----
bool seen_deferred_kind, matched_type;
const char *dt_name;
+ decl_type_param_list = NULL;
+
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3196,3202 ****
--- 3670,3682 ----
}
if (matched_type)
+ {
+ m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+ if (m == MATCH_ERROR)
+ return m;
+
m = gfc_match_char (')');
+ }
if (m != MATCH_YES)
m = match_record_decl (name);
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3211,3216 ****
--- 3691,3709 ----
gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
+
+ if (sym && sym->attr.flavor == FL_DERIVED
+ && sym->attr.pdt_template
+ && gfc_current_state () != COMP_DERIVED)
+ {
+ m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
+ if (m != MATCH_YES)
+ return m;
+ gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
+ ts->u.derived = sym;
+ strcpy (name, gfc_dt_lower_string (sym->name));
+ }
+
if (sym && sym->attr.flavor == FL_STRUCT)
{
ts->u.derived = sym;
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3279,3291 ****
return m;
}
! m = gfc_match (" class ( %n )", name);
if (m != MATCH_YES)
return m;
ts->type = BT_CLASS;
if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
return MATCH_ERROR;
}
/* Defer association of the derived type until the end of the
--- 3772,3798 ----
return m;
}
! m = gfc_match (" class (");
!
! if (m == MATCH_YES)
! m = gfc_match ("%n", name);
! else
! return m;
!
if (m != MATCH_YES)
return m;
ts->type = BT_CLASS;
if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
return MATCH_ERROR;
+
+ m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+ if (m == MATCH_ERROR)
+ return m;
+
+ m = gfc_match_char (')');
+ if (m != MATCH_YES)
+ return m;
}
/* Defer association of the derived type until the end of the
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3351,3356 ****
--- 3858,3875 ----
return MATCH_ERROR;
}
+ if (sym && sym->attr.flavor == FL_DERIVED
+ && sym->attr.pdt_template
+ && gfc_current_state () != COMP_DERIVED)
+ {
+ m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
+ if (m != MATCH_YES)
+ return m;
+ gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
+ ts->u.derived = sym;
+ strcpy (name, gfc_dt_lower_string (sym->name));
+ }
+
gfc_save_symbol_data (sym);
gfc_set_sym_referenced (sym);
if (!sym->attr.generic
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3361,3366 ****
--- 3880,3895 ----
&& !gfc_add_function (&sym->attr, sym->name, NULL))
return MATCH_ERROR;
+ if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
+ && dt_sym->attr.pdt_template
+ && gfc_current_state () != COMP_DERIVED)
+ {
+ m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
+ if (m != MATCH_YES)
+ return m;
+ gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
+ }
+
if (!dt_sym)
{
gfc_interface *intr, *head;
*************** match_attr_spec (void)
*** 3890,3896 ****
DECL_STATIC, DECL_AUTOMATIC,
DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
! DECL_NONE, GFC_DECL_END /* Sentinel */
};
/* GFC_DECL_END is the sentinel, index starts at 0. */
--- 4419,4425 ----
DECL_STATIC, DECL_AUTOMATIC,
DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
! DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
};
/* GFC_DECL_END is the sentinel, index starts at 0. */
*************** match_attr_spec (void)
*** 4033,4038 ****
--- 4562,4577 ----
}
break;
+ case 'k':
+ if (match_string_p ("kind"))
+ d = DECL_KIND;
+ break;
+
+ case 'l':
+ if (match_string_p ("len"))
+ d = DECL_LEN;
+ break;
+
case 'o':
if (match_string_p ("optional"))
d = DECL_OPTIONAL;
*************** match_attr_spec (void)
*** 4226,4231 ****
--- 4765,4776 ----
case DECL_OPTIONAL:
attr = "OPTIONAL";
break;
+ case DECL_KIND:
+ attr = "KIND";
+ break;
+ case DECL_LEN:
+ attr = "LEN";
+ break;
case DECL_PARAMETER:
attr = "PARAMETER";
break;
*************** match_attr_spec (void)
*** 4307,4312 ****
--- 4852,4905 ----
goto cleanup;
}
}
+ else if (d == DECL_KIND)
+ {
+ if (!gfc_notify_std (GFC_STD_F2003, "KIND "
+ "attribute at %C in a TYPE definition"))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.type != BT_INTEGER)
+ {
+ gfc_error ("Component with KIND attribute at %C must be "
+ "INTEGER");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.kind != gfc_default_integer_kind)
+ {
+ gfc_error ("Component with KIND attribute at %C must be "
+ "default integer kind (%d)",
+ gfc_default_integer_kind);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+ else if (d == DECL_LEN)
+ {
+ if (!gfc_notify_std (GFC_STD_F2003, "LEN "
+ "attribute at %C in a TYPE definition"))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.type != BT_INTEGER)
+ {
+ gfc_error ("Component with LEN attribute at %C must be "
+ "INTEGER");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ if (current_ts.kind != gfc_default_integer_kind)
+ {
+ gfc_error ("Component with LEN attribute at %C must be "
+ "default integer kind (%d)",
+ gfc_default_integer_kind);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
else
{
gfc_error ("Attribute at %L is not allowed in a TYPE definition",
*************** match_attr_spec (void)
*** 4344,4349 ****
--- 4937,4951 ----
}
}
+ if (gfc_current_state () != COMP_DERIVED
+ && (d == DECL_KIND || d == DECL_LEN))
+ {
+ gfc_error ("Attribute at %L is not allowed outside a TYPE "
+ "definition", &seen_at[d]);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
switch (d)
{
case DECL_ALLOCATABLE:
*************** match_attr_spec (void)
*** 4396,4401 ****
--- 4998,5011 ----
t = gfc_add_optional (¤t_attr, &seen_at[d]);
break;
+ case DECL_KIND:
+ t = gfc_add_kind (¤t_attr, &seen_at[d]);
+ break;
+
+ case DECL_LEN:
+ t = gfc_add_len (¤t_attr, &seen_at[d]);
+ break;
+
case DECL_PARAMETER:
t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
break;
*************** gfc_match_data_decl (void)
*** 4886,4891 ****
--- 5496,5504 ----
match m;
int elem;
+ type_param_spec_list = NULL;
+ decl_type_param_list = NULL;
+
num_idents_on_line = 0;
m = gfc_match_decl_type_spec (¤t_ts, 0);
*************** ok:
*** 5000,5005 ****
--- 5613,5625 ----
gfc_free_data_all (gfc_current_ns);
cleanup:
+ if (saved_kind_expr)
+ gfc_free_expr (saved_kind_expr);
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+ if (decl_type_param_list)
+ gfc_free_actual_arglist (decl_type_param_list);
+ saved_kind_expr = NULL;
gfc_free_array_spec (current_as);
current_as = NULL;
return m;
*************** copy_prefix (symbol_attribute *dest, loc
*** 5173,5182 ****
}
! /* Match a formal argument list. */
match
! gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
{
gfc_formal_arglist *head, *tail, *p, *q;
char name[GFC_MAX_SYMBOL_LEN + 1];
--- 5793,5804 ----
}
! /* Match a formal argument list or, if typeparam is true, a
! type_param_name_list. */
match
! gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
! int null_flag, bool typeparam)
{
gfc_formal_arglist *head, *tail, *p, *q;
char name[GFC_MAX_SYMBOL_LEN + 1];
*************** gfc_match_formal_arglist (gfc_symbol *pr
*** 5228,5234 ****
if (m != MATCH_YES)
goto cleanup;
! if (gfc_get_symbol (name, NULL, &sym))
goto cleanup;
}
--- 5850,5859 ----
if (m != MATCH_YES)
goto cleanup;
! if (!typeparam && gfc_get_symbol (name, NULL, &sym))
! goto cleanup;
! else if (typeparam
! && gfc_get_symbol (name, progname->f2k_derived, &sym))
goto cleanup;
}
*************** gfc_match_derived_decl (void)
*** 8945,8950 ****
--- 9570,9577 ----
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
gfc_interface *intr = NULL, *head;
+ bool parameterized_type = false;
+ bool seen_colons = false;
if (gfc_comp_struct (gfc_current_state ()))
return MATCH_NO;
*************** gfc_match_derived_decl (void)
*** 8972,8987 ****
if (parent[0] && !extended)
return MATCH_ERROR;
! if (gfc_match (" ::") != MATCH_YES && seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
return MATCH_ERROR;
}
! m = gfc_match (" %n%t", name);
if (m != MATCH_YES)
return m;
/* Make sure the name is not the name of an intrinsic type. */
if (gfc_is_intrinsic_typename (name))
{
--- 9599,9636 ----
if (parent[0] && !extended)
return MATCH_ERROR;
! m = gfc_match (" ::");
! if (m == MATCH_YES)
! {
! seen_colons = true;
! }
! else if (seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
return MATCH_ERROR;
}
! m = gfc_match (" %n ", name);
if (m != MATCH_YES)
return m;
+ /* Make sure that we don't identify TYPE IS (...) as a parameterized
+ derived type named 'is'.
+ TODO Expand the check, when 'name' = "is" by matching " (tname) "
+ and checking if this is a(n intrinsic) typename. his picks up
+ misplaced TYPE IS statements such as in select_type_1.f03. */
+ if (gfc_peek_ascii_char () == '(')
+ {
+ if (gfc_current_state () == COMP_SELECT_TYPE
+ || (!seen_colons && !strcmp (name, "is")))
+ return MATCH_NO;
+ parameterized_type = true;
+ }
+
+ m = gfc_match_eos ();
+ if (m != MATCH_YES && !parameterized_type)
+ return m;
+
/* Make sure the name is not the name of an intrinsic type. */
if (gfc_is_intrinsic_typename (name))
{
*************** gfc_match_derived_decl (void)
*** 9062,9070 ****
--- 9711,9731 ----
if (!sym->f2k_derived)
sym->f2k_derived = gfc_get_namespace (NULL, 0);
+ if (parameterized_type)
+ {
+ m = gfc_match_formal_arglist (sym, 0, 0, true);
+ if (m != MATCH_YES)
+ return m;
+ m = gfc_match_eos ();
+ if (m != MATCH_YES)
+ return m;
+ sym->attr.pdt_template = 1;
+ }
+
if (extended && !sym->components)
{
gfc_component *p;
+ gfc_formal_arglist *f, *g, *h;
/* Add the extended derived type as the first component. */
gfc_add_component (sym, parent, &p);
*************** gfc_match_derived_decl (void)
*** 9089,9094 ****
--- 9750,9780 ----
/* Provide the links between the extended type and its extension. */
if (!extended->f2k_derived)
extended->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ /* Copy the extended type-param-name-list from the extended type,
+ append those of the extension and add the whole lot to the
+ extension. */
+ if (extended->attr.pdt_template)
+ {
+ g = h = NULL;
+ sym->attr.pdt_template = 1;
+ for (f = extended->formal; f; f = f->next)
+ {
+ if (f == extended->formal)
+ {
+ g = gfc_get_formal_arglist ();
+ h = g;
+ }
+ else
+ {
+ g->next = gfc_get_formal_arglist ();
+ g = g->next;
+ }
+ g->sym = f->sym;
+ }
+ g->next = sym->formal;
+ sym->formal = h;
+ }
}
if (!sym->hash_value)
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c (revision 251546)
--- gcc/fortran/dump-parse-tree.c (working copy)
*************** static void
*** 627,633 ****
--- 627,638 ----
show_attr (symbol_attribute *attr, const char * module)
{
if (attr->flavor != FL_UNKNOWN)
+ {
+ if (attr->flavor == FL_DERIVED && attr->pdt_template)
+ fputs (" (PDT template", dumpfile);
+ else
fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor));
+ }
if (attr->access != ACCESS_UNKNOWN)
fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access));
if (attr->proc != PROC_UNKNOWN)
*************** show_attr (symbol_attribute *attr, const
*** 653,658 ****
--- 658,667 ----
fputs (" INTRINSIC", dumpfile);
if (attr->optional)
fputs (" OPTIONAL", dumpfile);
+ if (attr->pdt_kind)
+ fputs (" KIND", dumpfile);
+ if (attr->pdt_len)
+ fputs (" LEN", dumpfile);
if (attr->pointer)
fputs (" POINTER", dumpfile);
if (attr->is_protected)
*************** show_components (gfc_symbol *sym)
*** 724,733 ****
--- 733,758 ----
for (c = sym->components; c; c = c->next)
{
+ show_indent ();
fprintf (dumpfile, "(%s ", c->name);
show_typespec (&c->ts);
+ if (c->kind_expr)
+ {
+ fputs (" kind_expr: ", dumpfile);
+ show_expr (c->kind_expr);
+ }
+ if (c->param_list)
+ {
+ fputs ("PDT parameters", dumpfile);
+ show_actual_arglist (c->param_list);
+ }
+
if (c->attr.allocatable)
fputs (" ALLOCATABLE", dumpfile);
+ if (c->attr.pdt_kind)
+ fputs (" KIND", dumpfile);
+ if (c->attr.pdt_len)
+ fputs (" LEN", dumpfile);
if (c->attr.pointer)
fputs (" POINTER", dumpfile);
if (c->attr.proc_pointer)
*************** show_symbol (gfc_symbol *sym)
*** 935,940 ****
--- 960,974 ----
fputs ("Formal namespace", dumpfile);
show_namespace (sym->formal_ns);
}
+
+ if (sym->attr.flavor == FL_VARIABLE
+ && sym->param_list)
+ {
+ show_indent ();
+ fputs ("PDT parameters", dumpfile);
+ show_actual_arglist (sym->param_list);
+
+ }
--show_level;
}
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 251546)
--- gcc/fortran/expr.c (working copy)
*************** gfc_copy_expr (gfc_expr *p)
*** 394,399 ****
--- 394,402 ----
q->ref = gfc_copy_ref (p->ref);
+ if (p->param_list)
+ q->param_list = gfc_copy_actual_arglist (p->param_list);
+
return q;
}
*************** free_expr0 (gfc_expr *e)
*** 499,504 ****
--- 502,509 ----
gfc_free_ref_list (e->ref);
+ gfc_free_actual_arglist (e->param_list);
+
memset (e, '\0', sizeof (gfc_expr));
}
*************** gfc_free_actual_arglist (gfc_actual_argl
*** 525,530 ****
--- 530,536 ----
while (a1)
{
a2 = a1->next;
+ if (a1->expr)
gfc_free_expr (a1->expr);
free (a1);
a1 = a2;
*************** gfc_is_constant_expr (gfc_expr *e)
*** 917,922 ****
--- 923,933 ----
|| gfc_is_constant_expr (e->value.op.op2)));
case EXPR_VARIABLE:
+ /* The only context in which this can occur is in a parameterized
+ derived type declaration, so returning true is OK. */
+ if (e->symtree->n.sym->attr.pdt_len
+ || e->symtree->n.sym->attr.pdt_kind)
+ return true;
return false;
case EXPR_FUNCTION:
*************** gfc_check_init_expr (gfc_expr *e)
*** 2531,2536 ****
--- 2542,2551 ----
case EXPR_VARIABLE:
t = true;
+ /* This occurs when parsing pdt templates. */
+ if (e->symtree->n.sym->attr.pdt_kind)
+ break;
+
if (gfc_check_iter_variable (e))
break;
*************** gfc_match_init_expr (gfc_expr **result)
*** 2700,2705 ****
--- 2715,2727 ----
return m;
}
+ if (gfc_derived_parameter_expr (expr))
+ {
+ *result = expr;
+ gfc_init_expr_flag = false;
+ return m;
+ }
+
t = gfc_reduce_init_expr (expr);
if (!t)
{
*************** gfc_check_assign (gfc_expr *lvalue, gfc_
*** 3282,3287 ****
--- 3304,3317 ----
}
}
+ if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len)
+ {
+ gfc_error ("The assignment to a KIND or LEN component of a "
+ "parameterized type at %L is not allowed",
+ &lvalue->where);
+ return false;
+ }
+
if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
return true;
*************** gfc_expr_check_typed (gfc_expr* e, gfc_n
*** 4837,4842 ****
--- 4867,4942 ----
}
+ /* This function returns true if it contains any references to PDT KIND
+ or LEN parameters. */
+
+ static bool
+ derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+ int* f ATTRIBUTE_UNUSED)
+ {
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ gcc_assert (e->symtree);
+ if (e->symtree->n.sym->attr.pdt_kind
+ || e->symtree->n.sym->attr.pdt_len)
+ return true;
+
+ return false;
+ }
+
+
+ bool
+ gfc_derived_parameter_expr (gfc_expr *e)
+ {
+ return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0);
+ }
+
+
+ /* This function returns the overall type of a type parameter spec list.
+ If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
+ parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
+ unless derived is not NULL. In this latter case, all the LEN parameters
+ must be either assumed or deferred for the return argument to be set to
+ anything other than SPEC_EXPLICIT. */
+
+ gfc_param_spec_type
+ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
+ {
+ gfc_param_spec_type res = SPEC_EXPLICIT;
+ gfc_component *c;
+ bool seen_assumed = false;
+ bool seen_deferred = false;
+
+ if (derived == NULL)
+ {
+ for (; param_list; param_list = param_list->next)
+ if (param_list->spec_type == SPEC_ASSUMED
+ || param_list->spec_type == SPEC_DEFERRED)
+ return param_list->spec_type;
+ }
+ else
+ {
+ for (; param_list; param_list = param_list->next)
+ {
+ c = gfc_find_component (derived, param_list->name,
+ true, true, NULL);
+ gcc_assert (c != NULL);
+ if (c->attr.pdt_kind)
+ continue;
+ else if (param_list->spec_type == SPEC_EXPLICIT)
+ return SPEC_EXPLICIT;
+ seen_assumed = param_list->spec_type == SPEC_ASSUMED;
+ seen_deferred = param_list->spec_type == SPEC_DEFERRED;
+ if (seen_assumed && seen_deferred)
+ return SPEC_EXPLICIT;
+ }
+ res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED;
+ }
+ return res;
+ }
+
+
bool
gfc_ref_this_image (gfc_ref *ref)
{
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 251546)
--- gcc/fortran/gfortran.h (working copy)
*************** enum gfc_reverse
*** 646,651 ****
--- 646,658 ----
GFC_INHIBIT_REVERSE
};
+ enum gfc_param_spec_type
+ {
+ SPEC_EXPLICIT,
+ SPEC_ASSUMED,
+ SPEC_DEFERRED
+ };
+
/************************* Structures *****************************/
/* Used for keeping things in balanced binary trees. */
*************** typedef struct
*** 869,874 ****
--- 876,886 ----
variable for SELECT_TYPE or ASSOCIATE. */
unsigned select_type_temporary:1, associate_var:1;
+ /* These are the attributes required for parameterized derived
+ types. */
+ unsigned pdt_kind:1, pdt_len:1, pdt_type:1, pdt_template:1,
+ pdt_array:1, pdt_string:1;
+
/* This is omp_{out,in,priv,orig} artificial variable in
!$OMP DECLARE REDUCTION. */
unsigned omp_udr_artificial_var:1;
*************** typedef struct gfc_component
*** 1053,1058 ****
--- 1065,1075 ----
tree norestrict_decl;
locus loc;
struct gfc_expr *initializer;
+ /* Used in parameterized derived type declarations to store parameterized
+ kind expressions. */
+ struct gfc_expr *kind_expr;
+ struct gfc_actual_arglist *param_list;
+
struct gfc_component *next;
/* Needed for procedure pointer components. */
*************** gfc_formal_arglist;
*** 1077,1083 ****
#define gfc_get_formal_arglist() XCNEW (gfc_formal_arglist)
! /* The gfc_actual_arglist structure is for actual arguments. */
typedef struct gfc_actual_arglist
{
const char *name;
--- 1094,1101 ----
#define gfc_get_formal_arglist() XCNEW (gfc_formal_arglist)
! /* The gfc_actual_arglist structure is for actual arguments and
! for type parameter specification lists. */
typedef struct gfc_actual_arglist
{
const char *name;
*************** typedef struct gfc_actual_arglist
*** 1089,1094 ****
--- 1107,1114 ----
argument has to be added to a function call. */
bt missing_arg_type;
+ gfc_param_spec_type spec_type;
+
struct gfc_expr *expr;
struct gfc_actual_arglist *next;
}
*************** typedef struct gfc_symbol
*** 1507,1512 ****
--- 1527,1535 ----
struct gfc_namespace *formal_ns;
struct gfc_namespace *f2k_derived;
+ /* List of PDT parameter expressions */
+ struct gfc_actual_arglist *param_list;
+
struct gfc_expr *value; /* Parameter/Initializer value */
gfc_array_spec *as;
struct gfc_symbol *result; /* function result symbol */
*************** typedef struct gfc_expr
*** 2179,2184 ****
--- 2202,2210 ----
}
value;
+ /* Used to store PDT expression lists associated with expressions. */
+ gfc_actual_arglist *param_list;
+
}
gfc_expr;
*************** gfc_finalizer;
*** 2699,2704 ****
--- 2725,2736 ----
bool gfc_in_match_data (void);
match gfc_match_char_spec (gfc_typespec *);
+ /* Handling Parameterized Derived Types */
+ bool gfc_insert_kind_parameter_exprs (gfc_expr *);
+ bool gfc_insert_parameter_exprs (gfc_expr *, gfc_actual_arglist *);
+ match gfc_get_pdt_instance (gfc_actual_arglist *, gfc_symbol **,
+ gfc_actual_arglist **);
+
/* scanner.c */
void gfc_scanner_done_1 (void);
void gfc_scanner_init_1 (void);
*************** bool gfc_add_dimension (symbol_attribute
*** 2880,2885 ****
--- 2912,2919 ----
bool gfc_add_external (symbol_attribute *, locus *);
bool gfc_add_intrinsic (symbol_attribute *, locus *);
bool gfc_add_optional (symbol_attribute *, locus *);
+ bool gfc_add_kind (symbol_attribute *, locus *);
+ bool gfc_add_len (symbol_attribute *, locus *);
bool gfc_add_pointer (symbol_attribute *, locus *);
bool gfc_add_cray_pointer (symbol_attribute *, locus *);
bool gfc_add_cray_pointee (symbol_attribute *, locus *);
*************** bool gfc_traverse_expr (gfc_expr *, gfc_
*** 3143,3149 ****
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
bool gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
!
gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
bool gfc_is_proc_ptr_comp (gfc_expr *);
bool gfc_is_alloc_class_scalar_function (gfc_expr *);
--- 3177,3184 ----
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
bool gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
! bool gfc_derived_parameter_expr (gfc_expr *);
! gfc_param_spec_type gfc_spec_list_type (gfc_actual_arglist *, gfc_symbol *);
gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
bool gfc_is_proc_ptr_comp (gfc_expr *);
bool gfc_is_alloc_class_scalar_function (gfc_expr *);
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 251546)
--- gcc/fortran/interface.c (working copy)
*************** gfc_compare_derived_types (gfc_symbol *d
*** 645,651 ****
return false;
if (!(derived1->attr.sequence && derived2->attr.sequence)
! && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
return false;
/* Protect against null components. */
--- 645,652 ----
return false;
if (!(derived1->attr.sequence && derived2->attr.sequence)
! && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c)
! && !(derived1->attr.pdt_type && derived2->attr.pdt_type))
return false;
/* Protect against null components. */
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 251546)
--- gcc/fortran/match.c (working copy)
*************** bool gfc_matching_prefix = false;
*** 33,38 ****
--- 33,41 ----
/* Stack of SELECT TYPE statements. */
gfc_select_type_stack *select_type_stack = NULL;
+ /* List of type parameter expressions. */
+ gfc_actual_arglist *type_param_spec_list;
+
/* For debugging and diagnostic purposes. Return the textual representation
of the intrinsic operator OP. */
const char *
*************** gfc_op2string (gfc_intrinsic_op op)
*** 132,143 ****
(1) If any user defined operator ".y." exists, this is always y(x,z)
(even if ".y." is the wrong type and/or x has a member y).
(2) Otherwise if x has a member y, and y is itself a derived type,
! this is (x->y)->z, even if an intrinsic operator exists which
! can handle (x,z).
! (3) If x has no member y or (x->y) is not a derived type but ".y."
is an intrinsic operator (such as ".eq."), this is y(x,z).
(4) Lastly if there is no operator ".y." and x has no member "y", it is an
! error.
It is worth noting that the logic here does not support mixed use of member
accessors within a single string. That is, even if x has component y and y
has component z, the following are all syntax errors:
--- 135,146 ----
(1) If any user defined operator ".y." exists, this is always y(x,z)
(even if ".y." is the wrong type and/or x has a member y).
(2) Otherwise if x has a member y, and y is itself a derived type,
! this is (x->y)->z, even if an intrinsic operator exists which
! can handle (x,z).
! (3) If x has no member y or (x->y) is not a derived type but ".y."
is an intrinsic operator (such as ".eq."), this is y(x,z).
(4) Lastly if there is no operator ".y." and x has no member "y", it is an
! error.
It is worth noting that the logic here does not support mixed use of member
accessors within a single string. That is, even if x has component y and y
has component z, the following are all syntax errors:
*************** gfc_match_member_sep(gfc_symbol *sym)
*** 165,171 ****
tsym = NULL;
/* We may be given either a derived type variable or the derived type
! declaration itself (which actually contains the components);
we need the latter to search for components. */
if (gfc_fl_struct (sym->attr.flavor))
tsym = sym;
--- 168,174 ----
tsym = NULL;
/* We may be given either a derived type variable or the derived type
! declaration itself (which actually contains the components);
we need the latter to search for components. */
if (gfc_fl_struct (sym->attr.flavor))
tsym = sym;
*************** gfc_match_member_sep(gfc_symbol *sym)
*** 205,211 ****
if (gfc_find_uop (name, sym->ns) != NULL)
goto no;
! /* Match accesses to existing derived-type components for
derived-type vars: "x.y.z" = (x->y)->z */
c = gfc_find_component(tsym, name, false, true, NULL);
if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
--- 208,214 ----
if (gfc_find_uop (name, sym->ns) != NULL)
goto no;
! /* Match accesses to existing derived-type components for
derived-type vars: "x.y.z" = (x->y)->z */
c = gfc_find_component(tsym, name, false, true, NULL);
if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
*************** gfc_match_member_sep(gfc_symbol *sym)
*** 216,222 ****
if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
{
/* If ".y." is not an intrinsic operator but y was a valid non-
! structure component, match and leave the trailing dot to be
dealt with later. */
if (c)
goto yes;
--- 219,225 ----
if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
{
/* If ".y." is not an intrinsic operator but y was a valid non-
! structure component, match and leave the trailing dot to be
dealt with later. */
if (c)
goto yes;
*************** gfc_match_label (void)
*** 623,629 ****
return MATCH_ERROR;
}
! if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
gfc_new_block->name, NULL))
return MATCH_ERROR;
--- 626,632 ----
return MATCH_ERROR;
}
! if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
gfc_new_block->name, NULL))
return MATCH_ERROR;
*************** match_derived_type_spec (gfc_typespec *t
*** 1955,1961 ****
{
char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_locus;
! gfc_symbol *derived;
old_locus = gfc_current_locus;
--- 1958,1967 ----
{
char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_locus;
! gfc_symbol *derived, *der_type;
! match m = MATCH_YES;
! gfc_actual_arglist *decl_type_param_list = NULL;
! bool is_pdt_template = false;
old_locus = gfc_current_locus;
*************** match_derived_type_spec (gfc_typespec *t
*** 1967,1975 ****
--- 1973,2023 ----
gfc_find_symbol (name, NULL, 1, &derived);
+ /* Match the PDT spec list, if there. */
+ if (derived && derived->attr.flavor == FL_PROCEDURE)
+ {
+ gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type);
+ is_pdt_template = der_type
+ && der_type->attr.flavor == FL_DERIVED
+ && der_type->attr.pdt_template;
+ }
+
+ if (is_pdt_template)
+ m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+
+ if (m == MATCH_ERROR)
+ {
+ gfc_free_actual_arglist (decl_type_param_list);
+ return m;
+ }
+
if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
+ /* If this is a PDT, find the specific instance. */
+ if (m == MATCH_YES && is_pdt_template)
+ {
+ gfc_namespace *old_ns;
+
+ old_ns = gfc_current_ns;
+ while (gfc_current_ns && gfc_current_ns->parent)
+ gfc_current_ns = gfc_current_ns->parent;
+
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+ m = gfc_get_pdt_instance (decl_type_param_list, &der_type,
+ &type_param_spec_list);
+ gfc_free_actual_arglist (decl_type_param_list);
+
+ if (m != MATCH_YES)
+ return m;
+ derived = der_type;
+ gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type);
+ gfc_set_sym_referenced (derived);
+
+ gfc_current_ns = old_ns;
+ }
+
if (derived && derived->attr.flavor == FL_DERIVED)
{
ts->type = BT_DERIVED;
*************** gfc_match_type_spec (gfc_typespec *ts)
*** 1999,2004 ****
--- 2047,2053 ----
gfc_clear_ts (ts);
gfc_gobble_whitespace ();
old_locus = gfc_current_locus;
+ type_param_spec_list = NULL;
if (match_derived_type_spec (ts) == MATCH_YES)
{
*************** gfc_match_stopcode (gfc_statement st)
*** 2869,2875 ****
| GFC_STD_F2008_OBS);
/* Set f03 for -std=f2003. */
! f03 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
| GFC_STD_F2008_OBS | GFC_STD_F2003);
/* Look for a blank between STOP and the stop-code for F2008 or later. */
--- 2918,2924 ----
| GFC_STD_F2008_OBS);
/* Set f03 for -std=f2003. */
! f03 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
| GFC_STD_F2008_OBS | GFC_STD_F2003);
/* Look for a blank between STOP and the stop-code for F2008 or later. */
*************** gfc_match_allocate (void)
*** 3935,3941 ****
{
if (gfc_match (" :: ") == MATCH_YES)
{
! if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
&old_locus))
goto cleanup;
--- 3984,3990 ----
{
if (gfc_match (" :: ") == MATCH_YES)
{
! if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
&old_locus))
goto cleanup;
*************** gfc_match_allocate (void)
*** 3948,3953 ****
--- 3997,4012 ----
if (ts.type == BT_CHARACTER)
ts.u.cl->length_from_typespec = true;
+
+ /* TODO understand why this error does not appear but, instead,
+ the derived type is caught as a variable in primary.c. */
+ if (gfc_spec_list_type (type_param_spec_list, NULL) != SPEC_EXPLICIT)
+ {
+ gfc_error ("The type parameter spec list in the type-spec at "
+ "%L cannot contain ASSUMED or DEFERRED parameters",
+ &old_locus);
+ goto cleanup;
+ }
}
else
{
*************** gfc_match_allocate (void)
*** 4059,4064 ****
--- 4118,4126 ----
if (tail->expr->ts.type == BT_DERIVED)
tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
+ if (type_param_spec_list)
+ tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list);
+
saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
*************** alloc_opt_list:
*** 4143,4149 ****
if (head->next
&& !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
! " with more than a single allocate object",
&tmp->where))
goto cleanup;
--- 4205,4211 ----
if (head->next
&& !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
! " with more than a single allocate object",
&tmp->where))
goto cleanup;
*************** alloc_opt_list:
*** 4236,4241 ****
--- 4298,4306 ----
new_st.ext.alloc.list = head;
new_st.ext.alloc.ts = ts;
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+
return MATCH_YES;
syntax:
*************** cleanup:
*** 4248,4253 ****
--- 4313,4320 ----
gfc_free_expr (mold);
if (tmp && tmp->expr_type) gfc_free_expr (tmp);
gfc_free_alloc_list (head);
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
return MATCH_ERROR;
}
*************** gfc_match_common (void)
*** 4901,4907 ****
|| sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
{
if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
! "%C can only be COMMON in BLOCK DATA",
sym->name))
goto cleanup;
}
--- 4968,4974 ----
|| sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
{
if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
! "%C can only be COMMON in BLOCK DATA",
sym->name))
goto cleanup;
}
*************** gfc_match_namelist (void)
*** 5114,5120 ****
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
! && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
group_name->name, NULL))
return MATCH_ERROR;
--- 5181,5187 ----
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
! && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
group_name->name, NULL))
return MATCH_ERROR;
*************** gfc_match_module (void)
*** 5193,5199 ****
if (m != MATCH_YES)
return m;
! if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL))
return MATCH_ERROR;
--- 5260,5266 ----
if (m != MATCH_YES)
return m;
! if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL))
return MATCH_ERROR;
*************** gfc_match_type_is (void)
*** 6114,6126 ****
return MATCH_ERROR;
}
/* Create temporary variable. */
select_type_set_tmp (&c->ts);
return MATCH_YES;
syntax:
! gfc_error ("Syntax error in TYPE IS specification at %C");
cleanup:
if (c != NULL)
--- 6181,6203 ----
return MATCH_ERROR;
}
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+ && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived)
+ != SPEC_ASSUMED)
+ {
+ gfc_error ("All the LEN type parameters in the TYPE IS statement "
+ "at %C must be ASSUMED");
+ return MATCH_ERROR;
+ }
+
/* Create temporary variable. */
select_type_set_tmp (&c->ts);
return MATCH_YES;
syntax:
! gfc_error ("Ssyntax error in TYPE IS specification at %C");
cleanup:
if (c != NULL)
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 251546)
--- gcc/fortran/match.h (working copy)
*************** match gfc_match_decl_type_spec (gfc_type
*** 213,219 ****
match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
! match gfc_match_formal_arglist (gfc_symbol *, int, int);
match gfc_match_procedure (void);
match gfc_match_generic (void);
match gfc_match_function_decl (void);
--- 213,219 ----
match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
! match gfc_match_formal_arglist (gfc_symbol *, int, int, bool = false);
match gfc_match_procedure (void);
match gfc_match_generic (void);
match gfc_match_function_decl (void);
*************** match gfc_get_type_attr_spec (symbol_att
*** 274,280 ****
match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
! match gfc_match_actual_arglist (int, gfc_actual_arglist **);
match gfc_match_literal_constant (gfc_expr **, int);
/* expr.c -- FIXME: this one should be eliminated by moving the
--- 274,280 ----
match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
! match gfc_match_actual_arglist (int, gfc_actual_arglist **, bool = false);
match gfc_match_literal_constant (gfc_expr **, int);
/* expr.c -- FIXME: this one should be eliminated by moving the
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 251546)
--- gcc/fortran/module.c (working copy)
*************** enum ab_attribute
*** 1998,2004 ****
AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
! AB_OMP_DECLARE_TARGET_LINK
};
static const mstring attr_bits[] =
--- 1998,2005 ----
AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
! AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE,
! AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING
};
static const mstring attr_bits[] =
*************** static const mstring attr_bits[] =
*** 2062,2067 ****
--- 2063,2074 ----
minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT),
minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK),
minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK),
+ minit ("PDT_KIND", AB_PDT_KIND),
+ minit ("PDT_LEN", AB_PDT_LEN),
+ minit ("PDT_TYPE", AB_PDT_TYPE),
+ minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE),
+ minit ("PDT_ARRAY", AB_PDT_ARRAY),
+ minit ("PDT_STRING", AB_PDT_STRING),
minit (NULL, -1)
};
*************** mio_symbol_attribute (symbol_attribute *
*** 2260,2265 ****
--- 2267,2284 ----
MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits);
if (attr->omp_declare_target_link)
MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
+ if (attr->pdt_kind)
+ MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits);
+ if (attr->pdt_len)
+ MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits);
+ if (attr->pdt_type)
+ MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits);
+ if (attr->pdt_template)
+ MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits);
+ if (attr->pdt_array)
+ MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits);
+ if (attr->pdt_string)
+ MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits);
mio_rparen ();
*************** mio_symbol_attribute (symbol_attribute *
*** 2453,2458 ****
--- 2472,2495 ----
case AB_OACC_DECLARE_LINK:
attr->oacc_declare_link = 1;
break;
+ case AB_PDT_KIND:
+ attr->pdt_kind = 1;
+ break;
+ case AB_PDT_LEN:
+ attr->pdt_len = 1;
+ break;
+ case AB_PDT_TYPE:
+ attr->pdt_type = 1;
+ break;
+ case AB_PDT_TEMPLATE:
+ attr->pdt_template = 1;
+ break;
+ case AB_PDT_ARRAY:
+ attr->pdt_array = 1;
+ break;
+ case AB_PDT_STRING:
+ attr->pdt_string = 1;
+ break;
}
}
}
*************** mio_component (gfc_component *c, int vty
*** 2779,2784 ****
--- 2816,2824 ----
mio_typespec (&c->ts);
mio_array_spec (&c->as);
+ /* PDT templates store the expression for the kind of a component here. */
+ mio_expr (&c->kind_expr);
+
mio_symbol_attribute (&c->attr);
if (c->ts.type == BT_CLASS)
c->attr.class_ok = 1;
*************** mio_full_f2k_derived (gfc_symbol *sym)
*** 3998,4004 ****
--- 4038,4061 ----
{
if (peek_atom () != ATOM_RPAREN)
{
+ gfc_namespace *ns;
+
sym->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ /* PDT templates make use of the mechanisms for formal args
+ and so the parameter symbols are stored in the formal
+ namespace. Transfer the sym_root to f2k_derived and then
+ free the formal namespace since it is uneeded. */
+ if (sym->attr.pdt_template && sym->formal && sym->formal->sym)
+ {
+ ns = sym->formal->sym->ns;
+ sym->f2k_derived->sym_root = ns->sym_root;
+ ns->sym_root = NULL;
+ ns->refs++;
+ gfc_free_namespace (ns);
+ ns = NULL;
+ }
+
mio_f2k_derived (sym->f2k_derived);
}
else
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 251546)
--- gcc/fortran/primary.c (working copy)
*************** match_actual_arg (gfc_expr **result)
*** 1609,1618 ****
}
! /* Match a keyword argument. */
static match
! match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a;
--- 1609,1618 ----
}
! /* Match a keyword argument or type parameter spec list.. */
static match
! match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a;
*************** match_keyword_arg (gfc_actual_arglist *a
*** 1630,1641 ****
goto cleanup;
}
m = match_actual_arg (&actual->expr);
if (m != MATCH_YES)
goto cleanup;
/* Make sure this name has not appeared yet. */
!
if (name[0] != '\0')
{
for (a = base; a; a = a->next)
--- 1630,1657 ----
goto cleanup;
}
+ if (pdt)
+ {
+ if (gfc_match_char ('*') == MATCH_YES)
+ {
+ actual->spec_type = SPEC_ASSUMED;
+ goto add_name;
+ }
+ else if (gfc_match_char (':') == MATCH_YES)
+ {
+ actual->spec_type = SPEC_DEFERRED;
+ goto add_name;
+ }
+ else
+ actual->spec_type = SPEC_EXPLICIT;
+ }
+
m = match_actual_arg (&actual->expr);
if (m != MATCH_YES)
goto cleanup;
/* Make sure this name has not appeared yet. */
! add_name:
if (name[0] != '\0')
{
for (a = base; a; a = a->next)
*************** cleanup:
*** 1737,1746 ****
list is assumed to allow keyword arguments because we don't know if
the symbol associated with the procedure has an implicit interface
or not. We make sure keywords are unique. If sub_flag is set,
! we're matching the argument list of a subroutine. */
match
! gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
{
gfc_actual_arglist *head, *tail;
int seen_keyword;
--- 1753,1767 ----
list is assumed to allow keyword arguments because we don't know if
the symbol associated with the procedure has an implicit interface
or not. We make sure keywords are unique. If sub_flag is set,
! we're matching the argument list of a subroutine.
!
! NOTE: An alternative use for this function is to match type parameter
! spec lists, which are so similar to actual argument lists that the
! machinery can be reused. This use is flagged by the optional argument
! 'pdt'. */
match
! gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
{
gfc_actual_arglist *head, *tail;
int seen_keyword;
*************** gfc_match_actual_arglist (int sub_flag,
*** 1758,1763 ****
--- 1779,1785 ----
if (gfc_match_char (')') == MATCH_YES)
return MATCH_YES;
+
head = NULL;
matching_actual_arglist++;
*************** gfc_match_actual_arglist (int sub_flag,
*** 1772,1779 ****
tail = tail->next;
}
! if (sub_flag && gfc_match_char ('*') == MATCH_YES)
{
m = gfc_match_st_label (&label);
if (m == MATCH_NO)
gfc_error ("Expected alternate return label at %C");
--- 1794,1806 ----
tail = tail->next;
}
! if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES)
{
+ if (pdt)
+ {
+ tail->spec_type = SPEC_ASSUMED;
+ goto next;
+ }
m = gfc_match_st_label (&label);
if (m == MATCH_NO)
gfc_error ("Expected alternate return label at %C");
*************** gfc_match_actual_arglist (int sub_flag,
*** 1788,1798 ****
goto next;
}
/* After the first keyword argument is seen, the following
arguments must also have keywords. */
if (seen_keyword)
{
! m = match_keyword_arg (tail, head);
if (m == MATCH_ERROR)
goto cleanup;
--- 1815,1841 ----
goto next;
}
+ if (pdt && !seen_keyword)
+ {
+ if (gfc_match_char (':') == MATCH_YES)
+ {
+ tail->spec_type = SPEC_DEFERRED;
+ goto next;
+ }
+ else if (gfc_match_char ('*') == MATCH_YES)
+ {
+ tail->spec_type = SPEC_ASSUMED;
+ goto next;
+ }
+ else
+ tail->spec_type = SPEC_EXPLICIT;
+ }
+
/* After the first keyword argument is seen, the following
arguments must also have keywords. */
if (seen_keyword)
{
! m = match_keyword_arg (tail, head, pdt);
if (m == MATCH_ERROR)
goto cleanup;
*************** gfc_match_actual_arglist (int sub_flag,
*** 1813,1819 ****
/* See if we have the first keyword argument. */
if (m == MATCH_NO)
{
! m = match_keyword_arg (tail, head);
if (m == MATCH_YES)
seen_keyword = 1;
if (m == MATCH_ERROR)
--- 1856,1862 ----
/* See if we have the first keyword argument. */
if (m == MATCH_NO)
{
! m = match_keyword_arg (tail, head, false);
if (m == MATCH_YES)
seen_keyword = 1;
if (m == MATCH_ERROR)
*************** gfc_match_structure_constructor (gfc_sym
*** 2948,2954 ****
expression here. */
if (gfc_in_match_data ())
gfc_reduce_init_expr (e);
!
*result = e;
return MATCH_YES;
}
--- 2991,2997 ----
expression here. */
if (gfc_in_match_data ())
gfc_reduce_init_expr (e);
!
*result = e;
return MATCH_YES;
}
*************** match_variable (gfc_expr **result, int e
*** 3662,3668 ****
implicit_ns = gfc_current_ns;
else
implicit_ns = sym->ns;
!
old_loc = gfc_current_locus;
if (gfc_match_member_sep (sym) == MATCH_YES
&& sym->ts.type == BT_UNKNOWN
--- 3705,3711 ----
implicit_ns = gfc_current_ns;
else
implicit_ns = sym->ns;
!
old_loc = gfc_current_locus;
if (gfc_match_member_sep (sym) == MATCH_YES
&& sym->ts.type == BT_UNKNOWN
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 251546)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_contained_functions (gfc_namespa
*** 1130,1135 ****
--- 1130,1218 ----
}
+
+ /* A Parameterized Derived Type constructor must contain values for
+ the PDT KIND parameters or they must have a default initializer.
+ Go through the constructor picking out the KIND expressions,
+ storing them in 'param_list' and then call gfc_get_pdt_instance
+ to obtain the PDT instance. */
+
+ static gfc_actual_arglist *param_list, *param_tail, *param;
+
+ static bool
+ get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
+ {
+ param = gfc_get_actual_arglist ();
+ if (!param_list)
+ param_list = param_tail = param;
+ else
+ {
+ param_tail->next = param;
+ param_tail = param_tail->next;
+ }
+
+ param_tail->name = c->name;
+ if (expr)
+ param_tail->expr = gfc_copy_expr (expr);
+ else if (c->initializer)
+ param_tail->expr = gfc_copy_expr (c->initializer);
+ else
+ {
+ param_tail->spec_type = SPEC_ASSUMED;
+ if (c->attr.pdt_kind)
+ {
+ gfc_error ("The KIND parameter in the PDT constructor "
+ "at %C has no value");
+ return false;
+ }
+ }
+
+ return true;
+ }
+
+ static bool
+ get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
+ gfc_symbol *derived)
+ {
+ gfc_constructor *cons;
+ gfc_component *comp;
+ bool t = true;
+
+ if (expr && expr->expr_type == EXPR_STRUCTURE)
+ cons = gfc_constructor_first (expr->value.constructor);
+ else if (constr)
+ cons = *constr;
+ gcc_assert (cons);
+
+ comp = derived->components;
+
+ for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
+ {
+ if (cons->expr->expr_type == EXPR_STRUCTURE
+ && comp->ts.type == BT_DERIVED)
+ {
+ t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
+ if (!t)
+ return t;
+ }
+ else if (comp->ts.type == BT_DERIVED)
+ {
+ t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
+ if (!t)
+ return t;
+ }
+ else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
+ && derived->attr.pdt_template)
+ {
+ t = get_pdt_spec_expr (comp, cons->expr);
+ if (!t)
+ return t;
+ }
+ }
+ return t;
+ }
+
+
static bool resolve_fl_derived0 (gfc_symbol *sym);
static bool resolve_fl_struct (gfc_symbol *sym);
*************** resolve_structure_cons (gfc_expr *expr,
*** 1154,1159 ****
--- 1237,1261 ----
resolve_fl_derived0 (expr->ts.u.derived);
else
resolve_fl_struct (expr->ts.u.derived);
+
+ /* If this is a Parameterized Derived Type template, find the
+ instance corresponding to the PDT kind parameters. */
+ if (expr->ts.u.derived->attr.pdt_template)
+ {
+ param_list = NULL;
+ t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
+ if (!t)
+ return t;
+ gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
+
+ expr->param_list = gfc_copy_actual_arglist (param_list);
+
+ if (param_list)
+ gfc_free_actual_arglist (param_list);
+
+ if (!expr->ts.u.derived->attr.pdt_type)
+ return false;
+ }
}
cons = gfc_constructor_first (expr->value.constructor);
*************** resolve_component (gfc_component *c, gfc
*** 13547,13553 ****
}
/* Add the hidden deferred length field. */
! if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function
&& !sym->attr.is_class)
{
char name[GFC_MAX_SYMBOL_LEN+9];
--- 13649,13657 ----
}
/* Add the hidden deferred length field. */
! if (c->ts.type == BT_CHARACTER
! && (c->ts.deferred || c->attr.pdt_string)
! && !c->attr.function
&& !sym->attr.is_class)
{
char name[GFC_MAX_SYMBOL_LEN+9];
*************** resolve_component (gfc_component *c, gfc
*** 13647,13652 ****
--- 13751,13757 ----
return false;
if (c->initializer && !sym->attr.vtype
+ && !c->attr.pdt_kind && !c->attr.pdt_len
&& !gfc_check_assign_symbol (sym, c, c->initializer))
return false;
*************** resolve_symbol (gfc_symbol *sym)
*** 14276,14281 ****
--- 14381,14395 ----
return;
}
+ if (sym->attr.dummy && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.pdt_type
+ && gfc_spec_list_type (sym->param_list, NULL) == SPEC_DEFERRED)
+ {
+ gfc_error ("%qs at %L cannot have DEFERRED type parameters because "
+ "it is a dummy argument", sym->name, &sym->declared_at);
+ return;
+ }
+
if (sym->attr.value && sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.u.cl;
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 251546)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_add_optional (symbol_attribute *attr
*** 1106,1111 ****
--- 1106,1137 ----
return check_conflict (attr, NULL, where);
}
+ bool
+ gfc_add_kind (symbol_attribute *attr, locus *where)
+ {
+ if (attr->pdt_kind)
+ {
+ duplicate_attr ("KIND", where);
+ return false;
+ }
+
+ attr->pdt_kind = 1;
+ return check_conflict (attr, NULL, where);
+ }
+
+ bool
+ gfc_add_len (symbol_attribute *attr, locus *where)
+ {
+ if (attr->pdt_len)
+ {
+ duplicate_attr ("LEN", where);
+ return false;
+ }
+
+ attr->pdt_len = 1;
+ return check_conflict (attr, NULL, where);
+ }
+
bool
gfc_add_pointer (symbol_attribute *attr, locus *where)
*************** free_components (gfc_component *p)
*** 2447,2452 ****
--- 2473,2482 ----
gfc_free_array_spec (p->as);
gfc_free_expr (p->initializer);
+ if (p->kind_expr)
+ gfc_free_expr (p->kind_expr);
+ if (p->param_list)
+ gfc_free_actual_arglist (p->param_list);
free (p->tb);
free (p);
*************** gfc_free_symbol (gfc_symbol *sym)
*** 2929,2934 ****
--- 2959,2967 ----
set_symbol_common_block (sym, NULL);
+ if (sym->param_list)
+ gfc_free_actual_arglist (sym->param_list);
+
free (sym);
}
*************** gfc_find_sym_tree (const char *name, gfc
*** 3091,3097 ****
--- 3124,3148 ----
}
while (ns != NULL);
+ if (gfc_current_state() == COMP_DERIVED
+ && gfc_current_block ()->attr.pdt_template)
+ {
+ gfc_symbol *der = gfc_current_block ();
+ for (; der; der = gfc_get_derived_super_type (der))
+ {
+ if (der->f2k_derived && der->f2k_derived->sym_root)
+ {
+ st = gfc_find_symtree (der->f2k_derived->sym_root, name);
+ if (st)
+ break;
+ }
+ }
+ *result = st;
+ return 0;
+ }
+
*result = NULL;
+
return 0;
}
*************** gfc_free_namespace (gfc_namespace *ns)
*** 3890,3895 ****
--- 3941,3947 ----
ns->refs--;
if (ns->refs > 0)
return;
+
gcc_assert (ns->refs == 0);
gfc_free_statements (ns->code);
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 251546)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_caf_is_dealloc_only (int caf_mode)
*** 8073,8079 ****
function for the functions named in this enum. */
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
! COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP};
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
--- 8073,8082 ----
function for the functions named in this enum. */
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
! COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
! ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY};
!
! static gfc_actual_arglist *pdt_param_list;
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
*************** structure_alloc_comps (gfc_symbol * der_
*** 8735,8740 ****
--- 8738,8992 ----
break;
+ case ALLOCATE_PDT_COMP:
+
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+
+ /* Set the PDT KIND and LEN fields. */
+ if (c->attr.pdt_kind || c->attr.pdt_len)
+ {
+ gfc_se tse;
+ gfc_expr *c_expr = NULL;
+ gfc_actual_arglist *param = pdt_param_list;
+ gfc_init_se (&tse, NULL);
+ for (; param; param = param->next)
+ if (!strcmp (c->name, param->name))
+ c_expr = param->expr;
+
+ if (!c_expr)
+ c_expr = c->initializer;
+
+ if (c_expr)
+ {
+ gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+ gfc_add_modify (&fnblock, comp, tse.expr);
+ }
+ }
+
+ if (c->attr.pdt_string)
+ {
+ gfc_se tse;
+ gfc_init_se (&tse, NULL);
+ tree strlen;
+ /* Convert the parameterized string length to its value. The
+ string length is stored in a hidden field in the same way as
+ deferred string lengths. */
+ gfc_insert_parameter_exprs (c->ts.u.cl->length, pdt_param_list);
+ if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
+ {
+ gfc_conv_expr_type (&tse, c->ts.u.cl->length,
+ TREE_TYPE (strlen));
+ strlen = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (strlen),
+ decl, strlen, NULL_TREE);
+ gfc_add_modify (&fnblock, strlen, tse.expr);
+ c->ts.u.cl->backend_decl = strlen;
+ }
+ /* Scalar parameterizied strings can be allocated now. */
+ if (!c->as)
+ {
+ tmp = fold_convert (gfc_array_index_type, strlen);
+ tmp = size_of_string_in_bytes (c->ts.kind, tmp);
+ tmp = gfc_evaluate_now (tmp, &fnblock);
+ tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
+ gfc_add_modify (&fnblock, comp, tmp);
+ }
+ }
+
+ /* Allocate paramterized arrays of parameterized derived types. */
+ if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
+ && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+ continue;
+
+ if (c->ts.type == BT_CLASS)
+ comp = gfc_class_data_get (comp);
+
+ if (c->attr.pdt_array)
+ {
+ gfc_se tse;
+ int i;
+ tree size = gfc_index_one_node;
+ tree offset = gfc_index_zero_node;
+ tree lower, upper;
+ gfc_expr *e;
+
+ /* This chunk takes the expressions for 'lower' and 'upper'
+ in the arrayspec and substitutes in the expressions for
+ the parameters from 'pdt_param_list'. The descriptor
+ fields can then be filled from the values so obtained. */
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
+ for (i = 0; i < c->as->rank; i++)
+ {
+ gfc_init_se (&tse, NULL);
+ e = gfc_copy_expr (c->as->lower[i]);
+ gfc_insert_parameter_exprs (e, pdt_param_list);
+ gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+ gfc_free_expr (e);
+ lower = tse.expr;
+ gfc_conv_descriptor_lbound_set (&fnblock, comp,
+ gfc_rank_cst[i],
+ lower);
+ e = gfc_copy_expr (c->as->upper[i]);
+ gfc_insert_parameter_exprs (e, pdt_param_list);
+ gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+ gfc_free_expr (e);
+ upper = tse.expr;
+ gfc_conv_descriptor_ubound_set (&fnblock, comp,
+ gfc_rank_cst[i],
+ upper);
+ gfc_conv_descriptor_stride_set (&fnblock, comp,
+ gfc_rank_cst[i],
+ size);
+ size = gfc_evaluate_now (size, &fnblock);
+ offset = fold_build2_loc (input_location,
+ MINUS_EXPR,
+ gfc_array_index_type,
+ offset, size);
+ offset = gfc_evaluate_now (offset, &fnblock);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ upper, lower);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ }
+ gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
+ if (c->ts.type == BT_CLASS)
+ {
+ tmp = gfc_get_vptr_from_expr (comp);
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = gfc_vptr_size_get (tmp);
+ }
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ size = gfc_evaluate_now (size, &fnblock);
+ tmp = gfc_call_malloc (&fnblock, NULL, size);
+ gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
+ tmp = gfc_conv_descriptor_dtype (comp);
+ gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
+ }
+
+ /* Recurse in to PDT components. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ {
+ bool is_deferred = false;
+ gfc_actual_arglist *tail = c->param_list;
+
+ for (; tail; tail = tail->next)
+ if (!tail->expr)
+ is_deferred = true;
+
+ tail = is_deferred ? pdt_param_list : c->param_list;
+ tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
+ c->as ? c->as->rank : 0,
+ tail);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ break;
+
+ case DEALLOCATE_PDT_COMP:
+ /* Deallocate array or parameterized string length components
+ of parameterized derived types. */
+ if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
+ && !c->attr.pdt_string
+ && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+ continue;
+
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ if (c->ts.type == BT_CLASS)
+ comp = gfc_class_data_get (comp);
+
+ /* Recurse in to PDT components. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
+ c->as ? c->as->rank : 0);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ if (c->attr.pdt_array)
+ {
+ tmp = gfc_conv_descriptor_data_get (comp);
+ tmp = gfc_call_free (tmp);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+ }
+ else if (c->attr.pdt_string)
+ {
+ tmp = gfc_call_free (comp);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
+ gfc_add_modify (&fnblock, comp, tmp);
+ }
+
+ break;
+
+ case CHECK_PDT_DUMMY:
+
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ if (c->ts.type == BT_CLASS)
+ comp = gfc_class_data_get (comp);
+
+ /* Recurse in to PDT components. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
+ c->as ? c->as->rank : 0,
+ pdt_param_list);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ if (!c->attr.pdt_len)
+ continue;
+ else
+ {
+ gfc_se tse;
+ gfc_expr *c_expr = NULL;
+ gfc_actual_arglist *param = pdt_param_list;
+
+ gfc_init_se (&tse, NULL);
+ for (; param; param = param->next)
+ if (!strcmp (c->name, param->name))
+ c_expr = param->expr;
+
+ if (c_expr)
+ {
+ tree error, cond, cname;
+ gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node,
+ comp, tse.expr);
+ cname = gfc_build_cstring_const (c->name);
+ cname = gfc_build_addr_expr (pchar_type_node, cname);
+ error = gfc_trans_runtime_error (true, NULL,
+ "The value of the PDT LEN "
+ "parameter '%s' does not "
+ "agree with that in the "
+ "dummy declaration",
+ cname);
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, cond, error,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ }
+ break;
+
default:
gcc_unreachable ();
break;
*************** gfc_copy_only_alloc_comp (gfc_symbol * d
*** 8814,8819 ****
--- 9066,9115 ----
}
+ /* Recursively traverse an object of paramterized derived type, generating
+ code to allocate parameterized components. */
+
+ tree
+ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
+ gfc_actual_arglist *param_list)
+ {
+ tree res;
+ gfc_actual_arglist *old_param_list = pdt_param_list;
+ pdt_param_list = param_list;
+ res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ ALLOCATE_PDT_COMP, 0);
+ pdt_param_list = old_param_list;
+ return res;
+ }
+
+ /* Recursively traverse an object of paramterized derived type, generating
+ code to deallocate parameterized components. */
+
+ tree
+ gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
+ {
+ return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ DEALLOCATE_PDT_COMP, 0);
+ }
+
+
+ /* Recursively traverse a dummy of paramterized derived type to check the
+ values of LEN parameters. */
+
+ tree
+ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
+ gfc_actual_arglist *param_list)
+ {
+ tree res;
+ gfc_actual_arglist *old_param_list = pdt_param_list;
+ pdt_param_list = param_list;
+ res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ CHECK_PDT_DUMMY, 0);
+ pdt_param_list = old_param_list;
+ return res;
+ }
+
+
/* Returns the value of LBOUND for an expression. This could be broken out
from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
called by gfc_alloc_allocatable_for_assignment. */
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 251546)
--- gcc/fortran/trans-array.h (working copy)
*************** tree gfc_copy_alloc_comp (gfc_symbol *,
*** 59,64 ****
--- 59,68 ----
tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
+ tree gfc_allocate_pdt_comp (gfc_symbol *, tree, int, gfc_actual_arglist *);
+ tree gfc_deallocate_pdt_comp (gfc_symbol *, tree, int);
+ tree gfc_check_pdt_dummy (gfc_symbol *, tree, int, gfc_actual_arglist *);
+
tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*);
/* Add initialization for deferred arrays. */
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 251546)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1483,1488 ****
--- 1483,1503 ----
}
}
+ /* PDT parameterized array components and string_lengths must have the
+ 'len' parameters substituted for the expressions appearing in the
+ declaration of the entity and memory allocated/deallocated. */
+ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ && sym->param_list != NULL
+ && !(sym->attr.host_assoc || sym->attr.use_assoc || sym->attr.dummy))
+ gfc_defer_symbol_init (sym);
+
+ /* Dummy PDT 'len' parameters should be checked when they are explicit. */
+ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ && sym->param_list != NULL
+ && sym->attr.dummy)
+ gfc_defer_symbol_init (sym);
+
/* All deferred character length procedures need to retain the backend
decl, which is a pointer to the character length in the caller's
namespace and to declare a local character length. */
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4159,4164 ****
--- 4174,4180 ----
gfc_formal_arglist *f;
stmtblock_t tmpblock;
bool seen_trans_deferred_array = false;
+ bool is_pdt_type = false;
tree tmp = NULL;
gfc_expr *e;
gfc_se se;
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4269,4274 ****
--- 4285,4352 ----
if (sym->assoc)
continue;
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived
+ && sym->ts.u.derived->attr.pdt_type)
+ {
+ is_pdt_type = true;
+ gfc_init_block (&tmpblock);
+ if (!(sym->attr.dummy
+ || sym->attr.pointer
+ || sym->attr.allocatable))
+ {
+ tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
+ sym->backend_decl,
+ sym->as ? sym->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
+ sym->backend_decl,
+ sym->as ? sym->as->rank : 0);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
+ }
+ else if (sym->attr.dummy)
+ {
+ tmp = gfc_check_pdt_dummy (sym->ts.u.derived,
+ sym->backend_decl,
+ sym->as ? sym->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
+ }
+ }
+ else if (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->ts.u.derived
+ && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
+ {
+ gfc_component *data = CLASS_DATA (sym);
+ is_pdt_type = true;
+ gfc_init_block (&tmpblock);
+ if (!(sym->attr.dummy
+ || CLASS_DATA (sym)->attr.pointer
+ || CLASS_DATA (sym)->attr.allocatable))
+ {
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp,
+ data->as ? data->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
+ data->as ? data->as->rank : 0);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
+ }
+ else if (sym->attr.dummy)
+ {
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp,
+ data->as ? data->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
+ }
+ }
+
if (sym->attr.subref_array_pointer
&& GFC_DECL_SPAN (sym->backend_decl)
&& !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4601,4607 ****
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
! else if (!(UNLIMITED_POLY(sym)))
gcc_unreachable ();
}
--- 4679,4685 ----
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
! else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
gcc_unreachable ();
}
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 251546)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_trans_subcomponent_assign (tree dest
*** 7286,7292 ****
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
! else if (cm->attr.allocatable)
{
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
--- 7286,7292 ----
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
! else if (cm->attr.allocatable || cm->attr.pdt_array)
{
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 251546)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5545,5550 ****
--- 5545,5551 ----
bool needs_caf_sync, caf_refs_comp;
gfc_symtree *newsym = NULL;
symbol_attribute caf_attr;
+ gfc_actual_arglist *param_list;
if (!code->ext.alloc.list)
return NULL_TREE;
*************** gfc_trans_allocate (gfc_code * code)
*** 6326,6331 ****
--- 6327,6361 ----
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
+ /* Set KIND and LEN PDT components and allocate those that are
+ parameterized. */
+ else if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.pdt_type)
+ {
+ if (code->expr3 && code->expr3->param_list)
+ param_list = code->expr3->param_list;
+ else if (expr->param_list)
+ param_list = expr->param_list;
+ else
+ param_list = expr->symtree->n.sym->param_list;
+ tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr,
+ expr->rank, param_list);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ /* Ditto for CLASS expressions. */
+ else if (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type)
+ {
+ if (code->expr3 && code->expr3->param_list)
+ param_list = code->expr3->param_list;
+ else if (expr->param_list)
+ param_list = expr->param_list;
+ else
+ param_list = expr->symtree->n.sym->param_list;
+ tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
+ se.expr, expr->rank, param_list);
+ gfc_add_expr_to_block (&block, tmp);
+ }
else if (code->expr3 && code->expr3->mold
&& code->expr3->ts.type == BT_CLASS)
{
*************** gfc_trans_deallocate (gfc_code *code)
*** 6533,6538 ****
--- 6563,6583 ----
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
+ /* Deallocate PDT components that are parameterized. */
+ tmp = NULL;
+ if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.pdt_type
+ && expr->symtree->n.sym->param_list)
+ tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank);
+ else if (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type
+ && expr->symtree->n.sym->param_list)
+ tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
+ se.expr, expr->rank);
+
+ if (tmp)
+ gfc_add_expr_to_block (&block, tmp);
+
if (flag_coarray == GFC_FCOARRAY_LIB
|| flag_coarray == GFC_FCOARRAY_SINGLE)
{
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c (revision 251546)
--- gcc/fortran/trans-types.c (working copy)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2441,2446 ****
--- 2441,2448 ----
gfc_namespace *ns;
tree tmp;
+ gcc_assert (!derived->attr.pdt_template);
+
if (derived->attr.unlimited_polymorphic
|| (flag_coarray == GFC_FCOARRAY_LIB
&& derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2635,2641 ****
field_type = c->ts.u.derived->backend_decl;
else
{
! if (c->ts.type == BT_CHARACTER && !c->ts.deferred)
{
/* Evaluate the string length. */
gfc_conv_const_charlen (c->ts.u.cl);
--- 2637,2644 ----
field_type = c->ts.u.derived->backend_decl;
else
{
! if (c->ts.type == BT_CHARACTER
! && !c->ts.deferred && !c->attr.pdt_string)
{
/* Evaluate the string length. */
gfc_conv_const_charlen (c->ts.u.cl);
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2652,2658 ****
required. */
if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
{
! if (c->attr.pointer || c->attr.allocatable)
{
enum gfc_array_kind akind;
if (c->attr.pointer)
--- 2655,2661 ----
required. */
if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
{
! if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
{
enum gfc_array_kind akind;
if (c->attr.pointer)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2673,2679 ****
PACKED_STATIC,
!c->attr.target);
}
! else if ((c->attr.pointer || c->attr.allocatable)
&& !c->attr.proc_pointer
&& !(unlimited_entity && c == derived->components))
field_type = build_pointer_type (field_type);
--- 2676,2682 ----
PACKED_STATIC,
!c->attr.target);
}
! else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
&& !c->attr.proc_pointer
&& !(unlimited_entity && c == derived->components))
field_type = build_pointer_type (field_type);
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 251546)
--- gcc/fortran/trans.c (working copy)
*************** gfc_deferred_strlen (gfc_component *c, t
*** 2302,2308 ****
{
char name[GFC_MAX_SYMBOL_LEN+9];
gfc_component *strlen;
! if (!(c->ts.type == BT_CHARACTER && c->ts.deferred))
return false;
sprintf (name, "_%s_length", c->name);
for (strlen = c; strlen; strlen = strlen->next)
--- 2302,2309 ----
{
char name[GFC_MAX_SYMBOL_LEN+9];
gfc_component *strlen;
! if (!(c->ts.type == BT_CHARACTER
! && (c->ts.deferred || c->attr.pdt_string)))
return false;
sprintf (name, "_%s_length", c->name);
for (strlen = c; strlen; strlen = strlen->next)
Index: gcc/testsuite/gfortran.dg/pdt_1.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_1.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_1.f03 (working copy)
***************
*** 0 ****
--- 1,62 ----
+ ! { dg-do run }
+ ! { dg-options "-fcheck=all" }
+ !
+ ! Basic check of Parameterized Derived Types.
+ !
+ ! -fcheck=all is used here to ensure that when the parameter
+ ! 'b' of the dummy in 'foo' is assumed, there is no error.
+ ! Likewise in 'bar' and 'foobar', when 'b' has the correct
+ ! explicit value.
+ !
+ implicit none
+ integer, parameter :: ftype = kind(0.0e0)
+ integer :: pdt_len = 4
+ integer :: i
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0d0)
+ integer, LEN :: b
+ integer :: i
+ real(kind = a) :: d(b, b)
+ character (len = b*b) :: chr
+ end type
+
+ type(mytype(b=4)) :: z(2)
+ type(mytype(ftype, pdt_len)) :: z2
+
+ z(1)%i = 1
+ z(2)%i = 2
+ z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4])
+ z(2)%d = 10*z(1)%d
+ z(1)%chr = "hello pdt"
+ z(2)%chr = "goodbye pdt"
+
+ z2%d = z(1)%d * 10 - 1
+ z2%chr = "scalar pdt"
+
+ call foo (z)
+ call bar (z)
+ call foobar (z2)
+ contains
+ elemental subroutine foo (arg)
+ type(mytype(8,*)), intent(in) :: arg
+ if (arg%i .eq. 1) then
+ if (trim (arg%chr) .ne. "hello pdt") error stop
+ if (int (sum (arg%d)) .ne. 136) error stop
+ else if (arg%i .eq. 2 ) then
+ if (trim (arg%chr) .ne. "goodbye pdt") error stop
+ if (int (sum (arg%d)) .ne. 1360) error stop
+ else
+ error stop
+ end if
+ end subroutine
+ subroutine bar (arg)
+ type(mytype(b=4)) :: arg(:)
+ if (int (sum (arg(1)%d)) .ne. 136) call abort
+ if (trim (arg(2)%chr) .ne. "goodbye pdt") call abort
+ end subroutine
+ subroutine foobar (arg)
+ type(mytype(ftype, pdt_len)) :: arg
+ if (int (sum (arg%d)) .ne. 1344) call abort
+ if (trim (arg%chr) .ne. "scalar pdt") call abort
+ end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/pdt_2.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_2.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_2.f03 (working copy)
***************
*** 0 ****
--- 1,27 ----
+ ! { dg-do run }
+ ! { dg-options "-fcheck=all" }
+ ! { dg-shouldfail "value of the PDT LEN parameter" }
+ !
+ ! Reduced version of pdt_1.f03 to check that an incorrect
+ ! value for the parameter 'b' in the dummy is picked up.
+ !
+ implicit none
+ integer, parameter :: ftype = kind(0.0e0)
+ integer :: pdt_len = 4
+ integer :: i
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0d0)
+ integer, LEN :: b
+ integer :: i
+ real(kind = a) :: d(b, b)
+ character (len = b*b) :: chr
+ end type
+
+ type(mytype(ftype, pdt_len)) :: z2
+ call foobar (z2)
+ contains
+ subroutine foobar (arg)
+ type(mytype(ftype, 8)) :: arg
+ print *, arg%i
+ end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/pdt_3.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_3.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_3.f03 (working copy)
***************
*** 0 ****
--- 1,79 ----
+ ! { dg-do run }
+ !
+ ! Check PDT type extension and simple OOP.
+ !
+ module vars
+ integer :: d_dim = 4
+ integer :: mat_dim = 256
+ integer, parameter :: ftype = kind(0.0d0)
+ end module
+
+ use vars
+ implicit none
+ integer :: i
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0e0)
+ integer, LEN :: b = 4
+ integer :: i
+ real(kind = a) :: d(b, b)
+ end type
+
+ type, extends(mytype) :: thytype(h)
+ integer, kind :: h
+ integer(kind = h) :: j
+ end type
+
+ type x (q, r, s)
+ integer, kind :: q
+ integer, kind :: r
+ integer, LEN :: s
+ integer(kind = q) :: idx_mat(2,2) ! check these do not get treated as pdt_arrays.
+ type (mytype (b=s)) :: mat1
+ type (mytype (b=s*2)) :: mat2
+ end type x
+
+ real, allocatable :: matrix (:,:)
+ type(thytype(ftype, 4, 4)) :: w
+ type(x(8,4,mat_dim)) :: q
+ class(mytype(ftype, :)), allocatable :: cz
+
+ w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])
+
+ ! Make sure that the type extension is ordering the parameters correctly.
+ if (w%a .ne. ftype) call abort
+ if (w%b .ne. 4) call abort
+ if (w%h .ne. 4) call abort
+ if (size (w%d) .ne. 16) call abort
+ if (int (w%d(2,4)) .ne. 14) call abort
+ if (kind (w%j) .ne. w%h) call abort
+
+ ! As a side issue, ensure PDT components are OK
+ if (q%mat1%b .ne. q%s) call abort
+ if (q%mat2%b .ne. q%s*2) call abort
+ if (size (q%mat1%d) .ne. mat_dim**2) call abort
+ if (size (q%mat2%d) .ne. 4*mat_dim**2) call abort
+
+ ! Now check some basic OOP with PDTs
+ matrix = w%d
+
+ ! TODO - for some reason, using w%d directly in the source causes a seg fault.
+ allocate (cz, source = mytype(ftype, d_dim, 0, matrix))
+ select type (cz)
+ type is (mytype(ftype, *))
+ if (int (sum (cz%d)) .ne. 136) call abort
+ type is (thytype(ftype, *, 8))
+ call abort
+ end select
+ deallocate (cz)
+
+ allocate (thytype(ftype, d_dim*2, 8) :: cz)
+ cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b])
+ select type (cz)
+ type is (mytype(ftype, *))
+ call abort
+ type is (thytype(ftype, *, 8))
+ if (int (sum (cz%d)) .ne. 20800) call abort
+ end select
+
+ deallocate (cz)
+ end
Index: gcc/testsuite/gfortran.dg/pdt_4.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_4.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_4.f03 (working copy)
***************
*** 0 ****
--- 1,90 ----
+ ! { dg-do compile }
+ !
+ ! Test bad PDT coding: Based on pdt_3.f03
+ !
+ module vars
+ integer :: d_dim = 4
+ integer :: mat_dim = 256
+ integer, parameter :: ftype = kind(0.0d0)
+ end module
+
+ use vars
+ implicit none
+ integer :: i
+ integer, kind :: bad_kind ! { dg-error "not allowed outside a TYPE definition" }
+ integer, len :: bad_len ! { dg-error "not allowed outside a TYPE definition" }
+
+ type :: bad_pdt (a,b, c, d)
+ real, kind :: a ! { dg-error "must be INTEGER" }
+ INTEGER(8), kind :: b ! { dg-error "be default integer kind" }
+ real, LEN :: c ! { dg-error "must be INTEGER" }
+ INTEGER(8), LEN :: d ! { dg-error "be default integer kind" }
+ end type
+
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0e0)
+ integer, LEN :: b = 4
+ integer :: i
+ real(kind = a) :: d(b, b)
+ end type
+
+ type, extends(mytype) :: thytype(h)
+ integer, kind :: h
+ integer(kind = h) :: j
+ end type
+
+ type x (q, r, s)
+ integer, kind :: q
+ integer, kind :: r
+ integer, LEN :: s
+ integer(kind = q) :: idx_mat(2,2)
+ type (mytype (b=s)) :: mat1
+ type (mytype (b=s*2)) :: mat2
+ end type x
+
+ real, allocatable :: matrix (:,:)
+
+ ! Bad KIND parameters
+ type(thytype(d_dim, 4, 4)) :: wbad ! { dg-error "does not reduce to a constant" }
+ type(thytype(*, 4, 4)) :: worse ! { dg-error "cannot either be ASSUMED or DEFERRED" }
+ type(thytype(:, 4, 4)) :: w_ugh ! { dg-error "cannot either be ASSUMED or DEFERRED" }
+
+ type(thytype(ftype, b=4, h=4)) :: w
+ type(x(8,4,mat_dim)) :: q
+ class(mytype(ftype, :)), allocatable :: cz
+
+ w%a = 1 ! { dg-error "assignment to a KIND or LEN component" }
+ w%b = 2 ! { dg-error "assignment to a KIND or LEN component" }
+ w%h = 3 ! { dg-error "assignment to a KIND or LEN component" }
+
+ w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])
+
+ matrix = w%d
+
+ allocate (cz, source = mytype(*, d_dim, 0, matrix)) ! { dg-error "Syntax error" }
+ allocate (cz, source = mytype(ftype, :, 0, matrix)) ! { dg-error "Syntax error" }
+ select type (cz)
+ type is (mytype(ftype, d_dim)) ! { dg-error "must be ASSUMED" }
+ if (int (sum (cz%d)) .ne. 136) call abort ! { dg-error "Expected TYPE IS" }
+ type is (thytype(ftype, *, 8))
+ call abort
+ end select
+ deallocate (cz)
+
+ allocate (thytype(ftype, d_dim*2, 8) :: cz)
+ cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b])
+ select type (cz)
+ type is (mytype(4, *)) ! { dg-error "must be an extension" }
+ call abort
+ type is (thytype(ftype, *, 8))
+ if (int (sum (cz%d)) .ne. 20800) call abort
+ end select
+ deallocate (cz)
+ contains
+ subroutine foo(arg) ! { dg-error "has no IMPLICIT type" }
+ type (mytype(4, *)) :: arg ! { dg-error "is being used before it is defined" }
+ end subroutine
+ subroutine bar(arg) ! { dg-error "cannot have DEFERRED type parameters" }
+ type (thytype(8, :, 4) :: arg
+ end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/pdt_5.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_5.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_5.f03 (working copy)
***************
*** 0 ****
--- 1,223 ----
+ ! { dg-do run }
+ !
+ ! Third, complete example from the PGInsider article:
+ ! "Object-Oriented Programming in Fortran 2003 Part 3: Parameterized Derived Types"
+ ! by Mark Leair
+ !
+ ! Copyright (c) 2013, NVIDIA CORPORATION. All rights reserved.
+ !
+ ! NVIDIA CORPORATION and its licensors retain all intellectual property
+ ! and proprietary rights in and to this software, related documentation
+ ! and any modifications thereto. Any use, reproduction, disclosure or
+ ! distribution of this software and related documentation without an express
+ ! license agreement from NVIDIA CORPORATION is strictly prohibited.
+ !
+
+ ! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
+ ! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
+ ! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
+ ! FITNESS FOR A PARTICULAR PURPOSE.
+ !
+ ! Note that modification had to be made all of which are commented.
+ !
+ module matrix
+
+ type :: base_matrix(k,c,r)
+ private
+ integer, kind :: k = 4
+ integer, len :: c = 1
+ integer, len :: r = 1
+ end type base_matrix
+
+ type, extends(base_matrix) :: adj_matrix
+ private
+ class(*), pointer :: m(:,:) => null()
+ end type adj_matrix
+
+ interface getKind
+ module procedure getKind4
+ module procedure getKind8
+ end interface getKind
+
+ interface getColumns
+ module procedure getNumCols4
+ module procedure getNumCols8
+ end interface getColumns
+
+ interface getRows
+ module procedure getNumRows4
+ module procedure getNumRows8
+ end interface getRows
+
+ interface adj_matrix
+ module procedure construct_4 ! kind=4 constructor
+ module procedure construct_8 ! kind=8 constructor
+ end interface adj_matrix
+
+ interface assignment(=)
+ module procedure m2m4 ! assign kind=4 matrix
+ module procedure a2m4 ! assign kind=4 array
+ module procedure m2m8 ! assign kind=8 matrix
+ module procedure a2m8 ! assign kind=8 array
+ module procedure m2a4 ! assign kind=4 matrix to array
+ module procedure m2a8 ! assign kind=8 matrix to array
+ end interface assignment(=)
+
+
+ contains
+
+ function getKind4(this) result(rslt)
+ class(adj_matrix(4,*,*)) :: this
+ integer :: rslt
+ rslt = this%k
+ end function getKind4
+
+ function getKind8(this) result(rslt)
+ class(adj_matrix(8,*,*)) :: this
+ integer :: rslt
+ rslt = this%k
+ end function getKind8
+
+ function getNumCols4(this) result(rslt)
+ class(adj_matrix(4,*,*)) :: this
+ integer :: rslt
+ rslt = this%c
+ end function getNumCols4
+
+ function getNumCols8(this) result(rslt)
+ class(adj_matrix(8,*,*)) :: this
+ integer :: rslt
+ rslt = this%c
+ end function getNumCols8
+
+ function getNumRows4(this) result(rslt)
+ class(adj_matrix(4,*,*)) :: this
+ integer :: rslt
+ rslt = this%r
+ end function getNumRows4
+
+ function getNumRows8(this) result(rslt)
+ class(adj_matrix(8,*,*)) :: this
+ integer :: rslt
+ rslt = this%r
+ end function getNumRows8
+
+
+ function construct_4(k,c,r) result(mat)
+ integer(4) :: k
+ integer :: c
+ integer :: r
+ class(adj_matrix(4,:,:)),allocatable :: mat
+
+ allocate(adj_matrix(4,c,r)::mat)
+
+ end function construct_4
+
+ function construct_8(k,c,r) result(mat)
+ integer(8) :: k
+ integer :: c
+ integer :: r
+ class(adj_matrix(8,:,:)),allocatable :: mat
+
+ allocate(adj_matrix(8,c,r)::mat)
+
+ end function construct_8
+
+ subroutine a2m4(d,s)
+ class(adj_matrix(4,:,:)),allocatable :: d
+ class(*),dimension(:,:) :: s
+
+ if (allocated(d)) deallocate(d)
+ ! allocate(adj_matrix(4,size(s,1),size(s,2))::d) ! generates assembler error
+ allocate(d, mold = adj_matrix(4,size(s,1),size(s,2)))
+ allocate(d%m(size(s,1),size(s,2)),source=s)
+ end subroutine a2m4
+
+ subroutine a2m8(d,s)
+ class(adj_matrix(8,:,:)),allocatable :: d
+ class(*),dimension(:,:) :: s
+
+ if (allocated(d)) deallocate(d)
+ ! allocate(adj_matrix(8,size(s,1),size(s,2))::d) ! generates assembler error
+ allocate(d, mold = adj_matrix(8_8,size(s,1),size(s,2))) ! Needs 8_8 to match arg1 of 'construct_8'
+ allocate(d%m(size(s,1),size(s,2)),source=s)
+ end subroutine a2m8
+
+ subroutine m2a8(a,this)
+ class(adj_matrix(8,*,*)), intent(in) :: this ! Intents required for
+ real(8),allocatable, intent(out) :: a(:,:) ! defined assignment
+ select type (array => this%m) ! Added SELECT TYPE because...
+ type is (real(8))
+ if (allocated(a)) deallocate(a)
+ allocate(a,source=array)
+ end select
+ ! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
+ end subroutine m2a8
+
+ subroutine m2a4(a,this)
+ class(adj_matrix(4,*,*)), intent(in) :: this ! Intents required for
+ real(4),allocatable, intent(out) :: a(:,:) ! defined assignment
+ select type (array => this%m) ! Added SELECT TYPE because...
+ type is (real(4))
+ if (allocated(a)) deallocate(a)
+ allocate(a,source=array)
+ end select
+ ! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
+ end subroutine m2a4
+
+ subroutine m2m4(d,s)
+ CLASS(adj_matrix(4,:,:)),allocatable, intent(OUT) :: d ! Intents required for
+ CLASS(adj_matrix(4,*,*)), intent(in) :: s ! defined assignment
+
+ if (allocated(d)) deallocate(d)
+ allocate(d,source=s)
+ end subroutine m2m4
+
+ subroutine m2m8(d,s)
+ CLASS(adj_matrix(8,:,:)),allocatable, intent(OUT) :: d ! Intents required for
+ CLASS(adj_matrix(8,*,*)), intent(in) :: s ! defined assignment
+
+ if (allocated(d)) deallocate(d)
+ allocate(d,source=s)
+ end subroutine m2m8
+
+
+ end module matrix
+
+
+ program adj3
+
+ use matrix
+ implicit none
+ integer(8) :: i
+
+ class(adj_matrix(8,:,:)),allocatable :: adj ! Was TYPE: Fails in
+ real(8) :: a(2,3) ! defined assignment
+ real(8),allocatable :: b(:,:)
+
+ class(adj_matrix(4,:,:)),allocatable :: adj_4 ! Ditto and ....
+ real(4) :: a_4(3,2) ! ... these declarations were
+ real(4),allocatable :: b_4(:,:) ! added to check KIND=4
+
+ ! Check constructor of PDT and instrinsic assignment
+ adj = adj_matrix(INT(8,8),2,4)
+ if (adj%k .ne. 8) call abort
+ if (adj%c .ne. 2) call abort
+ if (adj%r .ne. 4) call abort
+ a = reshape ([(i, i = 1, 6)], [2,3])
+ adj = a
+ b = adj
+ if (any (b .ne. a)) call abort
+
+ ! Check allocation with MOLD of PDT. Note that only KIND parameters set.
+ allocate (adj_4, mold = adj_matrix(4,3,2)) ! Added check of KIND = 4
+ if (adj_4%k .ne. 4) call abort
+ a_4 = reshape (a, [3,2])
+ adj_4 = a_4
+ b_4 = adj_4
+ if (any (b_4 .ne. a_4)) call abort
+
+ end program adj3
+
+
+
^ permalink raw reply [flat|nested] 10+ messages in thread
end of thread, other threads:[~2018-09-07 8:43 UTC | newest]
Thread overview: 10+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2017-09-09 11:15 [Patch, fortran] Parameterized Derived Types Paul Richard Thomas
2017-09-09 11:27 ` Damian Rouson
2017-09-09 19:08 ` Janus Weil
2017-09-10 8:18 ` Paul Richard Thomas
2017-09-11 20:23 ` Janus Weil
2018-09-07 8:43 ` Bernhard Reutner-Fischer
-- strict thread matches above, loose matches on Subject: below --
2017-09-06 14:55 Paul Richard Thomas
2017-09-06 13:05 Paul Richard Thomas
2017-09-06 17:38 ` Janus Weil
2017-09-06 18:37 ` Damian Rouson
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).