PR modula2/109496 Fix constant char parameter passing to an array of char

This patch fixes PR modula2/109496 and PR modula2/109497.  The fix for
PR modula2/109496 promotes a char constant to a string.  The PR
modula2/109497 allows for constant chars to be added to form a string.
The fixes for both PR's occur in M2GenGCC.mod and M2GCCDeclare.mod
after the resolving of constant declarations.

gcc/m2/ChangeLog:

	* gm2-compiler/M2ALU.def (PopChar): New procedure function.
	* gm2-compiler/M2ALU.mod (PopChar): New procedure function.
	* gm2-compiler/M2GCCDeclare.mod (PromoteToString): Detect
	a single constant char and build a C string.
	* gm2-compiler/M2GenGCC.mod (IsConstStr): New procedure
	function.
	(GetStr): New procedure function.
	(FoldAdd): Use IsConstStr.
	* gm2-compiler/M2Quads.mod: Formatting changes.
	* gm2-gcc/m2expr.cc (m2expr_GetCstInteger): New function.
	* gm2-gcc/m2expr.def (GetCstInteger): New procedure function.
	* gm2-gcc/m2expr.h (m2expr_GetCstInteger): New prototype.

gcc/testsuite/ChangeLog:

	PR modula2/109497
	* gm2/pim/run/pass/addcharconst.mod: New test.
	PR modula2/109496
	* gm2/pim/run/pass/singlechar.mod: New test.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>

gcc/m2/gm2-compiler/M2ALU.def

@@ -51,6 +51,7 @@ EXPORT QUALIFIED PtrToValue,
                  PushRealTree, PopRealTree,
                  PushComplexTree, PopComplexTree,
                  PopConstructorTree,
+                 PopChar,
                  PushCard,
                  PushInt,
                  PushChar,
@@ -260,6 +261,13 @@ PROCEDURE PushInt (i: INTEGER) ;
 PROCEDURE PushChar (c: CHAR) ;
 
 
+(*
+   PopChar - returns the value from the stack in a character.
+*)
+
+PROCEDURE PopChar (tokenno: CARDINAL) : CHAR ;
+
+
 (*
    PushString - pushes the numerical value of the string onto the stack.
 *)

gcc/m2/gm2-compiler/M2ALU.mod

@@ -67,7 +67,8 @@ FROM m2expr IMPORT BuildAdd, BuildSub, BuildMult,
                    BuildDivTrunc, BuildModTrunc, BuildDivFloor, BuildModFloor,
                    BuildLSL, BuildLSR,
                    BuildLogicalOr, BuildLogicalAnd, BuildSymmetricDifference,
-                   GetWordOne, GetCardinalZero, TreeOverflow, RemoveOverflow ;
+                   GetWordOne, GetCardinalZero, TreeOverflow, RemoveOverflow,
+                   GetCstInteger ;
 
 FROM m2decl IMPORT GetBitsPerBitset, BuildIntegerConstant, BuildConstLiteralNumber ;
 FROM m2misc IMPORT DebugTree ;
@@ -1157,6 +1158,30 @@ BEGIN
 END PushChar ;
 
 
+(*
+   PopChar - pops a char from the stack.
+*)
+
+PROCEDURE PopChar (tokenno: CARDINAL) : CHAR ;
+VAR
+   v : PtrToValue ;
+   ch: CHAR ;
+BEGIN
+   v := Pop () ;
+   ch := 0C ;
+   WITH v^ DO
+      IF type = integer
+      THEN
+         ch := VAL (CHAR, GetCstInteger (numberValue))
+      ELSE
+         MetaErrorT0 (tokenno, '{%E}cannot convert constant to a CHAR')
+      END
+   END ;
+   Push (v) ;
+   RETURN ch
+END PopChar ;
+
+
 (*
    IsReal - returns TRUE if a is a REAL number.
 *)

gcc/m2/gm2-compiler/M2GCCDeclare.mod

@@ -47,7 +47,7 @@ FROM M2AsmUtil IMPORT GetFullSymName, GetFullScopeAsmName ;
 FROM M2Batch IMPORT MakeDefinitionSource ;
 FROM NameKey IMPORT Name, MakeKey, NulName, KeyToCharStar, makekey ;
 FROM M2FileName IMPORT CalculateFileName ;
-FROM DynamicStrings IMPORT String, string, InitString, KillString, InitStringCharStar, Mark ;
+FROM DynamicStrings IMPORT String, string, InitString, KillString, InitStringCharStar, InitStringChar, Mark ;
 FROM FormatStrings IMPORT Sprintf1 ;
 FROM M2LexBuf IMPORT TokenToLineNo, FindFileNameFromToken, TokenToLocation, UnknownTokenNo, BuiltinTokenNo ;
 FROM M2MetaError IMPORT MetaError1, MetaError3 ;
@@ -143,6 +143,7 @@ FROM M2Scope IMPORT ScopeBlock, InitScopeBlock, KillScopeBlock, ForeachScopeBloc
 
 FROM M2ALU IMPORT Addn, Sub, Equ, GreEqu, Gre, Less, PushInt, PushCard, ConvertToType,
                   PushIntegerTree, PopIntegerTree, PopRealTree, ConvertToInt, PopSetTree,
+                  PopChar,
                   IsConstructorDependants, WalkConstructorDependants,
                   PopConstructorTree, PopComplexTree, PutConstructorSolved,
                   ChangeToConstructor, EvaluateValue, TryEvaluateValue ;
@@ -1562,16 +1563,24 @@ END DeclareStringConstant ;
 PROCEDURE PromoteToString (tokenno: CARDINAL; sym: CARDINAL) : Tree ;
 VAR
    size: CARDINAL ;
+   ch  : CHAR ;
 BEGIN
    DeclareConstant (tokenno, sym) ;
-   size := GetStringLength (sym) ;
-   IF size > 1
+   IF IsConst (sym) AND (GetSType (sym) = Char)
    THEN
-      (* will be a string anyway *)
-      RETURN Tree (Mod2Gcc (sym))
+      PushValue (sym) ;
+      ch := PopChar (tokenno) ;
+      RETURN BuildCStringConstant (string (InitStringChar (ch)), 1)
    ELSE
-      RETURN BuildStringConstant (KeyToCharStar (GetString (sym)),
-                                  GetStringLength (sym))
+      size := GetStringLength (sym) ;
+      IF size > 1
+      THEN
+         (* will be a string anyway *)
+         RETURN Tree (Mod2Gcc (sym))
+      ELSE
+         RETURN BuildStringConstant (KeyToCharStar (GetString (sym)),
+                                     GetStringLength (sym))
+      END
    END
 END PromoteToString ;
 

gcc/m2/gm2-compiler/M2GenGCC.mod

@@ -109,7 +109,8 @@ FROM M2Bitset IMPORT Bitset ;
 FROM NameKey IMPORT Name, MakeKey, KeyToCharStar, LengthKey, makekey, NulName ;
 
 FROM DynamicStrings IMPORT string, InitString, KillString, String,
-                           InitStringCharStar, Mark, Slice, ConCat, ConCatChar ;
+                           InitStringCharStar, Mark, Slice, ConCat, ConCatChar,
+                           InitStringChar, Dup ;
 
 FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3, Sprintf4 ;
 FROM M2System IMPORT Address, Word, System, TBitSize, MakeAdr, IsSystemType, IsGenericSystemType, IsRealN, IsComplexN, IsSetN, IsWordN, Loc, Byte ;
@@ -132,7 +133,7 @@ FROM M2ALU IMPORT PtrToValue,
                   PushSetTree, PopSetTree,
                   PopRealTree, PushCard,
                   PushRealTree,
-                  PopComplexTree,
+                  PopComplexTree, PopChar,
                   Gre, Sub, Equ, NotEqu, LessEqu,
                   BuildRange, SetOr, SetAnd, SetNegate,
                   SetSymmetricDifference, SetDifference,
@@ -3589,6 +3590,38 @@ BEGIN
 END BinaryOperands ;
 
 
+(*
+   IsConstStr - returns TRUE if sym is a constant string or a char constant.
+*)
+
+PROCEDURE IsConstStr (sym: CARDINAL) : BOOLEAN ;
+BEGIN
+   RETURN IsConstString (sym) OR (IsConst (sym) AND (GetSType (sym) = Char))
+END IsConstStr ;
+
+
+(*
+   GetStr - return a string containing a constant string value associated with sym.
+            A nul char constant will return an empty string.
+*)
+
+PROCEDURE GetStr (tokenno: CARDINAL; sym: CARDINAL) : String ;
+VAR
+   ch: CHAR ;
+BEGIN
+   Assert (IsConst (sym)) ;
+   IF IsConstString (sym)
+   THEN
+      RETURN InitStringCharStar (KeyToCharStar (GetString (sym)))
+   ELSE
+      Assert (GetSType (sym) = Char) ;
+      PushValue (sym) ;
+      ch := PopChar (tokenno) ;
+      RETURN InitStringChar (ch)
+   END
+END GetStr ;
+
+
 (*
    FoldAdd - check addition for constant folding.
 *)
@@ -3598,18 +3631,17 @@ PROCEDURE FoldAdd (tokenno: CARDINAL; p: WalkAction;
 VAR
    s: String ;
 BEGIN
-   IF IsConst(op2) AND IsConst(op3) AND IsConst(op3) AND
-      IsConstString(op2) AND IsConstString(op3)
+   IF IsConstStr (op2) AND IsConstStr (op3)
    THEN
-      (* handle special addition for constant strings *)
-      s := InitStringCharStar(KeyToCharStar(GetString(op2))) ;
-      s := ConCat(s, Mark(InitStringCharStar(KeyToCharStar(GetString(op3))))) ;
-      PutConstString(tokenno, op1, makekey(string(s))) ;
-      TryDeclareConstant(tokenno, op1) ;
-      p(op1) ;
+      (* Handle special addition for constant strings.  *)
+      s := Dup (GetStr (tokenno, op2)) ;
+      s := ConCat (s, GetStr (tokenno, op3)) ;
+      PutConstString (tokenno, op1, makekey (string (s))) ;
+      TryDeclareConstant (tokenno, op1) ;
+      p (op1) ;
       NoChange := FALSE ;
-      SubQuad(quad) ;
-      s := KillString(s)
+      SubQuad (quad) ;
+      s := KillString (s)
    ELSE
       IF BinaryOperands (quad, op2, op3)
       THEN
@@ -5675,11 +5707,11 @@ VAR
 BEGIN
    location := TokenToLocation (CurrentQuadToken) ;
 
-   DeclareConstant(CurrentQuadToken, array) ;
-   IF IsConstString(array)
+   DeclareConstant (CurrentQuadToken, array) ;
+   IF IsConstString (array) OR (IsConst (array) AND (GetSType (array) = Char))
    THEN
       BuildAssignmentStatement (location, Mod2Gcc (result), BuildAddr (location, PromoteToString (CurrentQuadToken, array), FALSE))
-   ELSIF IsConstructor(array)
+   ELSIF IsConstructor (array)
    THEN
       BuildAssignmentStatement (location, Mod2Gcc (result), BuildAddr (location, Mod2Gcc (array), TRUE))
    ELSIF IsUnbounded (GetType (array))

gcc/m2/gm2-compiler/M2Quads.mod

@@ -585,7 +585,7 @@ BEGIN
                        END
 
       END ;
-      i := GetNextQuad(i)
+      i := GetNextQuad (i)
    END ;
    InternalError ('fix this for the sake of efficiency..')
 END IsBackReference ;
@@ -686,7 +686,7 @@ BEGIN
                        END
 
       END ;
-      i := GetNextQuad(i)
+      i := GetNextQuad (i)
    END ;
    InternalError ('fix this for the sake of efficiency..')
 END IsBackReferenceConditional ;

gcc/m2/gm2-gcc/m2expr.cc

@@ -4283,6 +4283,16 @@ build_set_full_complement (location_t location)
   return value;
 }
 
+
+/* GetCstInteger return the integer value of the cst tree.  */
+
+int
+m2expr_GetCstInteger (tree cst)
+{
+  return TREE_INT_CST_LOW (cst);
+}
+
+
 /* init initialise this module.  */
 
 void

gcc/m2/gm2-gcc/m2expr.def

@@ -583,6 +583,13 @@ PROCEDURE IsTrue (t: Tree) : BOOLEAN ;
 PROCEDURE IsFalse (t: Tree) : BOOLEAN ;
 
 
+(*
+    GetCstInteger - return the integer value of the cst tree.
+*)
+
+PROCEDURE GetCstInteger (cst: Tree) : INTEGER ;
+
+
 (*
     AreConstantsEqual - maps onto tree.c (tree_int_cst_equal). It returns
                         TRUE if the value of e1 is the same as e2.

gcc/m2/gm2-gcc/m2expr.h

@@ -234,6 +234,7 @@ EXTERN void m2expr_ConstantExpressionWarning (tree value);
 EXTERN tree m2expr_BuildAddAddress (location_t location, tree op1, tree op2);
 EXTERN tree m2expr_BuildRDiv (location_t location, tree op1, tree op2,
                               bool needconvert);
+EXTERN int m2expr_GetCstInteger (tree cst);
 
 EXTERN void m2expr_init (location_t location);
 

gcc/testsuite/gm2/pim/run/pass/addcharconst.mod

@@ -0,0 +1,20 @@
+MODULE addcharconst ;
+
+FROM libc IMPORT printf, exit ;
+FROM StrLib IMPORT StrLen ;
+
+
+PROCEDURE input (a: ARRAY OF CHAR) ;
+BEGIN
+   IF StrLen (a) # 2
+   THEN
+      printf ("string length is not 2, but %d\n", StrLen (a)) ;
+      exit (1)
+   END
+END input ;
+
+
+BEGIN
+   input (015C + 012C) ;
+   printf ("successful test, finishing\n")
+END addcharconst.

gcc/testsuite/gm2/pim/run/pass/singlechar.mod

@@ -0,0 +1,20 @@
+MODULE singlechar ;
+
+FROM libc IMPORT printf, exit ;
+FROM StrLib IMPORT StrLen ;
+
+
+PROCEDURE input (a: ARRAY OF CHAR) ;
+BEGIN
+   IF StrLen (a) # 1
+   THEN
+      printf ("string length is not 1, but %d\n", StrLen (a)) ;
+      exit (1)
+   END
+END input ;
+
+
+BEGIN
+   input (015C) ;
+   printf ("successful test, finishing\n")
+END singlechar.