a68: parser: syntax check for declarers

Thi pass checks the syntax of formal, actual and virtual declarers.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>

diff --git a/gcc/algol68/a68-parser-victal.cc b/gcc/algol68/a68-parser-victal.cc
new file mode 100644 (file)
index 0000000..b4162fc
--- /dev/null
+++ b/gcc/algol68/a68-parser-victal.cc
@@ -0,0 +1,362 @@
+/* Syntax check for formal, actual and virtual declarers.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 Jose E. Marchesi.
+
+   Original implementation by J. Marcel van der Veer.
+   Adapted for GCC by Jose E. Marchesi.
+
+   GCC is free software; you can redistribute it and/or modify it
+   under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3, or (at your option)
+   any later version.
+
+   GCC is distributed in the hope that it will be useful, but WITHOUT
+   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+   or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
+   License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with GCC; see the file COPYING3.  If not see
+   <http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+static bool victal_check_declarer (NODE_T *, int);
+
+/* Check generator.  */
+
+static void
+victal_check_generator (NODE_T * p)
+{
+  if (!victal_check_declarer (NEXT (p), ACTUAL_DECLARER_MARK))
+    a68_error (p, "Y expected", "actual declarer");
+}
+
+/* Check formal pack.  */
+
+static void
+victal_check_formal_pack (NODE_T *p, int x, bool *z)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, FORMAL_DECLARERS))
+       victal_check_formal_pack (SUB (p), x, z);
+      else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP))
+       victal_check_formal_pack (NEXT (p), x, z);
+      else if (IS (p, FORMAL_DECLARERS_LIST))
+       {
+         victal_check_formal_pack (NEXT (p), x, z);
+         victal_check_formal_pack (SUB (p), x, z);
+       }
+      else if (IS (p, DECLARER))
+       {
+         victal_check_formal_pack (NEXT (p), x, z);
+         (*z) &= victal_check_declarer (SUB (p), x);
+       }
+    }
+}
+
+/* Check operator declaration.  */
+
+static void
+victal_check_operator_dec (NODE_T *p)
+{
+  if (IS (NEXT (p), FORMAL_DECLARERS))
+    {
+      bool z = true;
+      victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z);
+      if (!z)
+       a68_error (p, "Y expected", "formal declarers");
+      FORWARD (p);
+  }
+  if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK))
+    a68_error (p, "Y expected", "formal declarer");
+}
+
+/* Check mode declaration.  */
+
+static void
+victal_check_mode_dec (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, MODE_DECLARATION))
+       {
+         victal_check_mode_dec (SUB (p));
+         victal_check_mode_dec (NEXT (p));
+       }
+      else if (a68_is_one_of (p, MODE_SYMBOL, DEFINING_INDICANT, STOP)
+               || a68_is_one_of (p, EQUALS_SYMBOL, COMMA_SYMBOL, STOP))
+       {
+         victal_check_mode_dec (NEXT (p));
+       }
+      else if (IS (p, DECLARER))
+       {
+         if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK))
+           a68_error (p, "Y expected", "actual declarer");
+       }
+    }
+}
+
+/* Check variable declaration. */
+
+static void
+victal_check_variable_dec (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, VARIABLE_DECLARATION))
+       {
+         victal_check_variable_dec (SUB (p));
+         victal_check_variable_dec (NEXT (p));
+       }
+      else
+       {
+         if (IS (p, QUALIFIER))
+           FORWARD (p);
+
+         if (a68_is_one_of (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, STOP)
+             || IS (p, COMMA_SYMBOL))
+           victal_check_variable_dec (NEXT (p));
+         else if (IS (p, UNIT))
+           a68_victal_checker (SUB (p));
+         else if (IS (p, DECLARER))
+           {
+             if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK))
+               a68_error (p, "Y expected", "actual declarer");
+             victal_check_variable_dec (NEXT (p));
+           }
+       }
+    }
+}
+
+/* Check identity declaration.  */
+
+static void
+victal_check_identity_dec (NODE_T * p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, IDENTITY_DECLARATION))
+       {
+         victal_check_identity_dec (SUB (p));
+         victal_check_identity_dec (NEXT (p));
+       }
+      else if (a68_is_one_of (p, DEFINING_IDENTIFIER, EQUALS_SYMBOL, COMMA_SYMBOL, STOP))
+       victal_check_identity_dec (NEXT (p));
+      else if (IS (p, UNIT))
+       a68_victal_checker (SUB (p));
+      else if (IS (p, DECLARER))
+       {
+         if (!victal_check_declarer (p, FORMAL_DECLARER_MARK))
+           a68_error (p, "Y expected", "formal declarer");
+         victal_check_identity_dec (NEXT (p));
+       }
+    }
+}
+
+/* Check routine pack.  */
+
+static void
+victal_check_routine_pack (NODE_T *p, int x, bool *z)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, PARAMETER_PACK))
+       victal_check_routine_pack (SUB (p), x, z);
+      else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP))
+       victal_check_routine_pack (NEXT (p), x, z);
+      else if (a68_is_one_of (p, PARAMETER_LIST, PARAMETER, STOP))
+       {
+         victal_check_routine_pack (NEXT (p), x, z);
+         victal_check_routine_pack (SUB (p), x, z);
+       }
+      else if (IS (p, DECLARER))
+       *z &= victal_check_declarer (SUB (p), x);
+    }
+}
+
+/* Check routine text.  */
+
+static void
+victal_check_routine_text (NODE_T *p)
+{
+  if (IS (p, PARAMETER_PACK))
+    {
+      bool z = true;
+      victal_check_routine_pack (p, FORMAL_DECLARER_MARK, &z);
+      if (!z)
+       a68_error (p, "Y expected", "formal declarers");
+      FORWARD (p);
+    }
+  if (!victal_check_declarer (p, FORMAL_DECLARER_MARK))
+    a68_error (p, "Y expected", "formal declarer");
+  a68_victal_checker (NEXT (p));
+}
+
+/* Check structure pack.  */
+
+static void
+victal_check_structure_pack (NODE_T *p, int x, bool *z)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, STRUCTURE_PACK))
+       victal_check_structure_pack (SUB (p), x, z);
+      else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP))
+       victal_check_structure_pack (NEXT (p), x, z);
+      else if (a68_is_one_of (p, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD, STOP))
+       {
+         victal_check_structure_pack (NEXT (p), x, z);
+         victal_check_structure_pack (SUB (p), x, z);
+       }
+      else if (IS (p, DECLARER))
+       (*z) &= victal_check_declarer (SUB (p), x);
+    }
+}
+
+/* Check union pack.  */
+
+static void
+victal_check_union_pack (NODE_T * p, int x, bool * z)
+{
+  if (p != NO_NODE)
+    {
+    if (IS (p, UNION_PACK))
+      victal_check_union_pack (SUB (p), x, z);
+    else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, VOID_SYMBOL, STOP))
+      victal_check_union_pack (NEXT (p), x, z);
+    else if (IS (p, UNION_DECLARER_LIST))
+      {
+       victal_check_union_pack (NEXT (p), x, z);
+       victal_check_union_pack (SUB (p), x, z);
+      }
+    else if (IS (p, DECLARER))
+      {
+       victal_check_union_pack (NEXT (p), x, z);
+       (*z) &= victal_check_declarer (SUB (p), FORMAL_DECLARER_MARK);
+      }
+    }
+}
+
+/* Check declarer.  */
+
+static bool
+victal_check_declarer (NODE_T *p, int x)
+{
+  if (p == NO_NODE)
+    return false;
+  else if (IS (p, DECLARER))
+    return victal_check_declarer (SUB (p), x);
+  else if (a68_is_one_of (p, LONGETY, SHORTETY, STOP))
+    return true;
+  else if (a68_is_one_of (p, VOID_SYMBOL, INDICANT, STANDARD, STOP))
+    return true;
+  else if (IS_REF (p))
+    return victal_check_declarer (NEXT (p), VIRTUAL_DECLARER_MARK);
+  else if (IS_FLEX (p))
+    return victal_check_declarer (NEXT (p), x);
+  else if (IS (p, BOUNDS))
+    {
+      a68_victal_checker (SUB (p));
+      if (x == FORMAL_DECLARER_MARK)
+       {
+         a68_error (p, "Y expected", "formal bounds");
+         (void) victal_check_declarer (NEXT (p), x);
+         return true;
+       }
+      else if (x == VIRTUAL_DECLARER_MARK)
+       {
+         a68_error (p, "Y expected", "virtual bounds");
+         (void) victal_check_declarer (NEXT (p), x);
+         return true;
+       }
+      else
+       return victal_check_declarer (NEXT (p), x);
+    }
+  else if (IS (p, FORMAL_BOUNDS))
+    {
+      a68_victal_checker (SUB (p));
+      if (x == ACTUAL_DECLARER_MARK)
+       {
+         a68_error (p, "Y expected", "actual bounds");
+         (void) victal_check_declarer (NEXT (p), x);
+         return true;
+       }
+      else
+       return victal_check_declarer (NEXT (p), x);
+    }
+  else if (IS (p, STRUCT_SYMBOL))
+    {
+      bool z = true;
+      victal_check_structure_pack (NEXT (p), x, &z);
+      return z;
+    }
+  else if (IS (p, UNION_SYMBOL))
+    {
+      bool z = true;
+      victal_check_union_pack (NEXT (p), FORMAL_DECLARER_MARK, &z);
+      if (!z)
+       a68_error (p, "Y expected", "formal declarer pack");
+      return true;
+    }
+  else if (IS (p, PROC_SYMBOL))
+    {
+      if (IS (NEXT (p), FORMAL_DECLARERS))
+       {
+         bool z = true;
+         victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z);
+         if (!z)
+           a68_error (p, "Y expected", "formal declarer");
+         FORWARD (p);
+       }
+      if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK))
+       a68_error (p, "Y expected", "formal declarer");
+      return true;
+    }
+  else
+    return false;
+}
+
+/* Check cast.  */
+
+static void
+victal_check_cast (NODE_T *p)
+{
+  if (!victal_check_declarer (p, FORMAL_DECLARER_MARK))
+    {
+      a68_error (p, "Y expected", "formal declarer");
+      a68_victal_checker (NEXT (p));
+    }
+}
+
+/* Driver for checking VICTALITY of declarers.  */
+
+void
+a68_victal_checker (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, MODE_DECLARATION))
+       victal_check_mode_dec (SUB (p));
+      else if (IS (p, VARIABLE_DECLARATION))
+       victal_check_variable_dec (SUB (p));
+      else if (IS (p, IDENTITY_DECLARATION))
+       victal_check_identity_dec (SUB (p));
+      else if (IS (p, GENERATOR))
+       victal_check_generator (SUB (p));
+      else if (IS (p, ROUTINE_TEXT))
+       victal_check_routine_text (SUB (p));
+      else if (IS (p, OPERATOR_PLAN))
+       victal_check_operator_dec (SUB (p));
+      else if (IS (p, CAST))
+       victal_check_cast (SUB (p));
+      else
+       a68_victal_checker (SUB (p));
+    }
+}