fdoc

subroutinebuild_relationsprivate

subroutine build_relations(p, relations)

Build the relations between entities.

Arguments

NameTypeIntentAttributesDescription
ptype(project_t)in

the project

relationstype(adjacency_t)outdimension(NUM_RELATIONS)

the relations

Calls

Source

Show the code
subroutine build_relations(p, relations)
    type(project_t), intent(in) :: p                        !! the project
    type(adjacency_t), intent(out) :: relations(NUM_RELATIONS)  !! the relations
    integer, allocatable :: seen(:)
    logical, allocatable :: done(:)
    logical :: changed
    integer :: r, k, j, target, seen_stamp

    allocate (seen(p%list%n))
    seen = 0
    seen_stamp = 0
    do r = 1, NUM_RELATIONS
        allocate (relations(r)%out(p%list%n), relations(r)%in(p%list%n), relations(r)%labels(p%list%n))
    end do
    do k = 1, p%list%n
        associate (e => p%list%box(k)%e)
            if (e%kind == E_NONE) cycle
            if (allocated(e%more%uses)) then
                do j = 1, size(e%more%uses)
                    if (e%more%uses(j)%target > 0) call connect(relations(REL_USES), k, e%more%uses(j)%target)
                end do
            end if
            if (e%kind == E_SUBMODULE) then
                if (e%parent_submodule_id > 0) then
                    call connect(relations(REL_USES), k, e%parent_submodule_id)
                else if (e%ancestor_id > 0) then
                    call connect(relations(REL_USES), k, e%ancestor_id)
                end if
            end if
            if (e%visible .and. e%kind /= E_BOUNDPROC) then
                seen_stamp = seen_stamp + 1
                call visible_calls(p, k, k, seen, seen_stamp, relations(REL_CALLS))
            end if
            if (allocated(e%more%modproc_ids)) then
                do j = 1, size(e%more%modproc_ids)
                    if (e%more%modproc_ids(j) == 0) cycle
                    if (p%list%box(e%more%modproc_ids(j))%e%visible) call connect(relations(REL_CALLS), k, e%more%modproc_ids(j))
                end do
            end if
            if (e%kind == E_INTERFACE) then
                do j = 1, size(e%children)
                    if (p%list%box(e%children(j))%e%visible) call connect(relations(REL_CALLS), k, e%children(j))
                end do
            end if
            if (e%extends_id > 0) call connect(relations(REL_INHERITS), k, e%extends_id)
            if (e%kind == E_TYPE .and. e%visible) then
                do j = 1, size(e%children)
                    associate (c => p%list%box(e%children(j))%e)
                        if (c%kind /= E_VARIABLE .or. c%proto_id == 0) cycle
                        if (p%list%box(c%proto_id)%e%kind == E_TYPE) then
                            call connect(relations(REL_INHERITS), k, c%proto_id, c%name)
                        end if
                    end associate
                end do
            end if
            if (e%file > 0 .and. allocated(e%more%uses)) then
                do j = 1, size(e%more%uses)
                    target = e%more%uses(j)%target
                    if (target == 0) cycle
                    target = p%list%box(target)%e%file
                    if (target > 0 .and. target /= e%file) call connect(relations(REL_FILES), e%file, target)
                end do
            end if
        end associate
    end do

    ! a generic binding is a node only once something refers to it
    allocate (done(p%list%n))
    done = .false.
    changed = .true.
    do while (changed)
        changed = .false.
        do k = 1, p%list%n
            if (done(k) .or. p%list%box(k)%e%kind /= E_BOUNDPROC) cycle
            if (.not. allocated(relations(REL_CALLS)%in(k)%ids)) cycle
            done(k) = .true.
            changed = .true.
            seen_stamp = seen_stamp + 1
            call visible_calls(p, k, k, seen, seen_stamp, relations(REL_CALLS))
        end do
    end do
end subroutine build_relations

Graphs

Calls

Called by