diff --git a/CHANGELOG.md b/CHANGELOG.md index 9e985518..403c291d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,12 @@ and this project adheres to [Semantic Versioning](http://semver.org/). ## [Unreleased] +### Changed + +- Fixes syntax highlighting for nested case-select constructs + ([#181](https://github.com/krvajal/vscode-fortran-support/issues/181)) via + ([#218](https://github.com/krvajal/vscode-fortran-support/pull/218)) + ## [2.2.1] - 2020-04-11 ### Fixed diff --git a/syntaxes/fortran_free-form.tmLanguage.json b/syntaxes/fortran_free-form.tmLanguage.json index 099a032f..fc98bc68 100644 --- a/syntaxes/fortran_free-form.tmLanguage.json +++ b/syntaxes/fortran_free-form.tmLanguage.json @@ -982,8 +982,8 @@ "named-control-constructs": { "comment": "Introduced in the Fortran 1990 standard.", "contentName": "meta.named-construct.fortran.modern", - "begin": "(?ix)([a-z]\\w*)\\s*(:)(?=\\s*(?:associate|block(?!\\s*data)|critical|do|forall|if|select|where)\\b)", - "end": "(?i)\\s*(?!\\b(?:associate|block(?!\\s*data)|critical|do|forall|if|select|where)\\b)\\b(?:\\b(\\1)\\b)?(?:\\s*([^\\s;!][^;!\\n]*?))?(?=\\s*[;!\\n])", + "begin": "(?ix)([a-z]\\w*)\\s*(:)(?=\\s*(?:associate|block(?!\\s*data)|critical|do|forall|if|select\\s*case|select\\s*type|select\\s*rank|where)\\b)", + "end": "(?i)\\s*(?!\\b(?:associate|block(?!\\s*data)|critical|do|forall|if|select\\s*case|select\\s*type|select\\s*rank|where)\\b)\\b(?:\\b(\\1)\\b)?(?:\\s*([^\\s;!][^;!\\n]*?))?(?=\\s*[;!\\n])", "endCaptures": { "2": { "name": "invalid.error.fortran.modern" @@ -1303,18 +1303,16 @@ } ] }, - "select-case-construct":{ + "select-case-construct": { "comment": "Select case construct. Introduced in the Fortran 1990 standard.", - "begin": "(?i)\\b(select)\\s*(case)\\b", + "name": "meta.block.select.case.fortran", + "begin": "(?i)\\b(select\\s*case)\\b", "beginCaptures": { "1": { - "name": "keyword.control.select.fortran" - }, - "2": { - "name": "keyword.control.case.fortran" + "name": "keyword.control.selectcase.fortran" } }, - "end": "(?i)(?=\\b(end\\s*select)\\b)", + "end": "(?i)\\b(end\\s*select)\\b", "endCaptures": { "1": { "name": "keyword.control.endselect.fortran" @@ -1354,18 +1352,16 @@ } ] }, - "select-type-construct":{ + "select-type-construct": { "comment": "Select type construct. Introduced in the Fortran 2003 standard.", - "begin": "(?i)\\b(select)\\s*(type)\\b", + "name": "meta.block.select.type.fortran", + "begin": "(?i)\\b(select\\s*type)\\b", "beginCaptures": { "1": { - "name": "keyword.control.select.fortran" - }, - "2": { - "name": "keyword.control.type.fortran" + "name": "keyword.control.selecttype.fortran" } }, - "end": "(?i)(?=\\b(end\\s*select)\\b)", + "end": "(?i)\\b(end\\s*select)\\b", "endCaptures": { "1": { "name": "keyword.control.endselect.fortran" @@ -1376,7 +1372,7 @@ "include": "#parentheses" }, { - "begin": "(?i)\\b(?:(class)|(type))", + "begin": "(?i)\\b(?:(class)|(type))\\b", "beginCaptures": { "1": { "name": "keyword.control.class.fortran" @@ -1396,7 +1392,7 @@ } }, { - "match": "(?i)\\G\\s*(is)\\b", + "match": "(?i)\\G\\s*\\b(is)\\b", "captures": { "1": { "name": "keyword.control.is.fortran" @@ -1416,18 +1412,16 @@ } ] }, - "select-rank-construct":{ + "select-rank-construct": { "comment": "Select rank construct. Introduced in the Fortran 2008 standard.", - "begin": "(?i)\\b(select)\\s*(rank)\\b", + "name": "meta.block.select.rank.fortran", + "begin": "(?i)\\b(select\\s*rank)\\b", "beginCaptures": { "1": { - "name": "keyword.control.select.fortran" - }, - "2": { - "name": "keyword.control.rank.fortran" + "name": "keyword.control.selectrank.fortran" } }, - "end": "(?i)(?=\\b(end\\s*select)\\b)", + "end": "(?i)\\b(end\\s*select)\\b", "endCaptures": { "1": { "name": "keyword.control.endselect.fortran" diff --git a/test/resources/class.f90 b/test/resources/class.f90 new file mode 100644 index 00000000..e517ecdb --- /dev/null +++ b/test/resources/class.f90 @@ -0,0 +1,41 @@ +module main + + use iso_fortran_env, only: real64 + implicit none + private + + type, public :: test_t + real(real64) :: a, b + contains + procedure, private :: init_sub + generic :: init => init_sub + end type test_t + + type :: node + private + type(node), pointer :: next => null() + class(*), allocatable :: item + + contains + final :: node_finalizer + + end type node + + contains + + subroutine init_sub(this, a, b) + + class( test_t ) :: this + real(real64),intent(in) :: a, b + + this%a = a + this%b = b + + end subroutine init_sub + + subroutine node_finalizer(a) + type(node) :: a + + end subroutine node_finalizer + +end module main \ No newline at end of file diff --git a/test/resources/select_case.f90 b/test/resources/select_case.f90 new file mode 100644 index 00000000..061cb6bc --- /dev/null +++ b/test/resources/select_case.f90 @@ -0,0 +1,38 @@ + +! ------------------------------------------------------------------------------ +! +! Tests the syntax highlighting of nested case select constructs is correct +!------------------------------------------------------------------------------- + +program select_case_test + implicit none + + integer :: i, j, k + + + select case(i) + case(1) + select case(j) + case(1) + print*, i, j + case(2) + print*, i, j + case default + print*, i, j + end select + + case(2) + select case(k) + case(1) + print*, i, j + case(2) + print*, i, j + case default + print*, i, j + end select + + case default + print*, i, j + end select + +end program select_case_test \ No newline at end of file diff --git a/test/resources/select_rank.f90 b/test/resources/select_rank.f90 new file mode 100644 index 00000000..b33ed212 --- /dev/null +++ b/test/resources/select_rank.f90 @@ -0,0 +1,85 @@ + + +! ------------------------------------------------------------------------------ +! +! Tests the syntax highlighting of nested rank select constructs is correct +! @note requires GCC 10.0+ to compile or ifort 2019.1+ +!------------------------------------------------------------------------------- + +program select_rank_test + implicit none + + real, dimension(2, 2) :: a, b + + a = -666.0; b = -666.0 + call initialize(a) + call nested_initialise(a, b) + + print*, a + print*, b + + contains + + subroutine initialize (arg) + real :: arg(..) + select rank (arg) + rank (0) ! scalar + arg = 0.0 + rank (1) + arg(:) = 0.0 + rank (2) + arg(:, :) = 0.0 + rank default + print *, "Subroutine initialize called with unexpected rank argument" + end select + return + end subroutine + + subroutine nested_initialise(arg1, arg2) + !< @note this is meant to test the syntax highlighting, nothing else! + real :: arg1(..), arg2(..) + select rank (arg1) + rank (0) ! scalar + arg1 = 0.0 + select rank (arg2) + rank (0) ! scalar + arg2 = 0.0 + rank (1) + arg2(:) = 0.0 + rank (2) + arg2(:, :) = 0.0 + rank default + print *, "Subroutine initialize called with unexpected rank argument" + end select + rank (1) + arg1(:) = 0.0 + select rank (arg2) + rank (0) ! scalar + arg2 = 0.0 + rank (1) + arg2(:) = 0.0 + rank (2) + arg2(:, :) = 0.0 + rank default + print *, "Subroutine initialize called with unexpected rank argument" + end select + rank (2) + arg1(:, :) = 0.0 + select rank (arg2) + rank (0) ! scalar + arg2 = 0.0 + rank (1) + arg2(:) = 0.0 + rank (2) + arg2(:, :) = 0.0 + rank default + print *, "Subroutine initialize called with unexpected rank argument" + end select + rank default + print *, "Subroutine initialize called with unexpected rank argument" + end select + return + + end subroutine nested_initialise + +end program select_rank_test \ No newline at end of file diff --git a/test/resources/select_type.f90 b/test/resources/select_type.f90 new file mode 100644 index 00000000..a2b5bd85 --- /dev/null +++ b/test/resources/select_type.f90 @@ -0,0 +1,63 @@ + +! ------------------------------------------------------------------------------ +! +! Tests the syntax highlighting of nested type select constructs is correct +!------------------------------------------------------------------------------- + +program select_type_test + implicit none + + + type :: point + real :: x, y + end type point + + type, extends(point) :: point_3d + real :: z + end type point_3d + + type, extends(point) :: color_point + integer :: color + end type color_point + + type(point_3d), target :: p3 + type(color_point), target :: c + class(point), pointer :: p_or_c + class(point), pointer :: p + + p_or_c => c + p => p3 + select type ( a => p_or_c ) + class is ( point ) + ! "class ( point ) :: a" implied here + print *, a%x, a%y ! this block executes + select type(a) + type is (point_3d) + print*, "type(point_3d)" + type is (color_point) + print*, "type(color_point)" + class default + print*, "no matching type" + end select + + class is (color_point) ! does not execute + select type(p) + class is (point_3d) + print*, "class(point_3d)" + class is (color_point) + print*, "class(color_point)" + class is (point) + print*, "class(point)" + class default + print*, "no matching class" + end select + + type is ( point_3d ) ! does not execute + ! "type ( point_3d ) :: a" implied here + print *, a%x, a%y, a%z + class default + print*, "no matching class" + end select + + +end program select_type_test \ No newline at end of file