Bug/nested case select

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

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"

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

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

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

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