public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-9063] PR modula2/113889 Incorrect constant string value if declared in a definition module
@ 2024-02-19 13:02 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2024-02-19 13:02 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:78b72ee5a80f45bd761a55006e2b3fc2cbe749bc
commit r14-9063-g78b72ee5a80f45bd761a55006e2b3fc2cbe749bc
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date: Mon Feb 19 12:59:36 2024 +0000
PR modula2/113889 Incorrect constant string value if declared in a definition module
This patch fixes a bug exposed when a constant string is declared in a
definition module and imported by a program module. The bug fix
was to defer the string assignment and concatenation until quadruples
were generated. The conststring symbol has a known field which
must be checked prior to retrieving the string contents.
gcc/m2/ChangeLog:
PR modula2/113889
* gm2-compiler/M2ALU.mod (StringFitsArray): Add tokeno parameter
to GetStringLength.
(InitialiseArrayOfCharWithString): Add tokeno parameter to
GetStringLength.
(CheckGetCharFromString): Add tokeno parameter to GetStringLength.
* gm2-compiler/M2Const.mod (constResolveViaMeta): Replace
PutConstString with PutConstStringKnown.
* gm2-compiler/M2GCCDeclare.mod (DeclareCharConstant): Add tokenno
parameter and add assert. Use tokenno to generate location.
(DeclareStringConstant): Add tokenno and add asserts.
Add tokenno parameter to calls to GetStringLength.
(PromoteToString): Add assert and add tokenno parameter to
GetStringLength.
(PromoteToCString): Add assert and add tokenno parameter to
GetStringLength.
(DeclareConstString): New procedure function.
(TryDeclareConst): Remove size local variable.
Check IsConstStringKnown.
Call DeclareConstString.
(PrintString): New procedure.
(PrintVerboseFromList): Call PrintString.
(CheckResolveSubrange): Check IsConstStringKnown before creating
subrange for char or issuing an error.
* gm2-compiler/M2GenGCC.mod (ResolveConstantExpressions): Add
StringLengthOp, StringConvertM2nulOp, StringConvertCnulOp case
clauses.
(FindSize): Add assert IsConstStringKnown.
(StringToChar): New variable tokenno.
Add tokenno parameter to GetStringLength.
(FoldStringLength): New procedure.
(FoldStringConvertM2nul): New procedure.
(FoldStringConvertCnul): New procedure.
(CodeAddr): Add tokenno parameter.
Replace CurrentQuadToken with tokenno.
Add tokenno parameter to GetStringLength.
(PrepareCopyString): Rewrite.
(IsConstStrKnown): New procedure function.
(FoldAdd): Detect conststring op2 and op3 which are known and
concat. Place result into op1.
(FoldStandardFunction): Pass tokenno as a parameter to
GetStringLength.
(CodeXIndr): Rewrite comment.
Rename op1 to left, op3 to right.
Pass rightpos to GetStringLength.
* gm2-compiler/M2Quads.def (QuadrupleOp): Add
StringConvertCnulOp, StringConvertM2nulOp and StringLengthOp.
* gm2-compiler/M2Quads.mod (import): Remove MakeConstLitString.
Add CopyConstString and PutConstStringKnown.
(IsInitialisingConst): Add StringConvertCnulOp,
StringConvertM2nulOp and StringLengthOp.
(callRequestDependant): Replace MakeConstLitString with
MakeConstString.
(DeferMakeConstStringCnul): New procedure function.
(DeferMakeConstStringM2nul): New procedure function.
(CheckParameter): Add early return if the string const is unknown.
(DescribeType): Add token parameter to GetStringLength.
Check for IsConstStringKnown.
(ManipulateParameters): Use DeferMakeConstStringCnul and
DeferMakeConstStringM2nul.
(MakeLengthConst): Remove and replace with...
(DeferMakeLengthConst): ... this.
(doBuildBinaryOp): Create ConstString and set it to contents
unknown.
Check IsConstStringKnown before generating error message.
(WriteQuad): Add StringConvertCnulOp, StringConvertM2nulOp and
StringLengthOp.
(WriteOperator): Add StringConvertCnulOp, StringConvertM2nulOp and
StringLengthOp.
* gm2-compiler/M2SymInit.mod (CheckReadBeforeInitQuad): Add
StringConvertCnulOp, StringConvertM2nulOp and StringLengthOp.
* gm2-compiler/NameKey.mod (LengthKey): Allow NulName to return 0.
* gm2-compiler/P2SymBuild.mod (BuildString): Replace
MakeConstLitString with MakeConstString.
(DetermineType): Replace PutConstString with PutConstStringKnown.
* gm2-compiler/SymbolTable.def (MakeConstVar): Tidy up comment.
(MakeConstLitString): Remove.
(MakeConstString): New procedure function.
(MakeConstStringCnul): New procedure function.
(MakeConstStringM2nul): New procedure function.
(PutConstStringKnown): New procedure.
(CopyConstString): New procedure.
(IsConstStringKnown): New procedure function.
(IsConstStringM2): New procedure function.
(IsConstStringC): New procedure function.
(IsConstStringM2nul): New procedure function.
(IsConstStringCnul): New procedure function.
(GetStringLength): Add token parameter.
(PutConstString): Remove.
(GetConstStringM2): Remove.
(GetConstStringC): Remove.
(GetConstStringM2nul): Remove.
(GetConstStringCnul): Remove.
(MakeConstStringC): Remove.
* gm2-compiler/SymbolTable.mod (SymConstString): Remove
M2Variant, NulM2Variant, CVariant, NulCVariant.
Add Known.
(CheckAnonymous): Replace $$ with __anon.
(IsNameAnonymous): Replace $$ with __anon.
(MakeConstVar): Detect whether the name is nul and treat as
a temporary constant.
(MakeConstLitString): Remove.
(BackFillString): Remove.
(InitConstString): Rewrite.
(GetConstStringM2): Remove.
(GetConstStringC): Remove.
(GetConstStringContent): New procedure function.
(GetConstStringM2nul): Remove.
(GetConstStringCnul): Remove.
(MakeConstStringCnul): Rewrite.
(MakeConstStringM2nul): Rewrite.
(MakeConstStringC): Remove.
(MakeConstString): Rewrite.
(PutConstStringKnown): New procedure.
(CopyConstString): New procedure.
(PutConstString): Remove.
(IsConstStringKnown): New procedure function.
(IsConstStringM2): New procedure function.
(IsConstStringC): Rewrite.
(IsConstStringM2nul): Rewrite.
(IsConstStringCnul): Rewrite.
(GetConstStringKind): New procedure function.
(GetString): Check Known.
(GetStringLength): Add token parameter and check Known.
gcc/testsuite/ChangeLog:
PR modula2/113889
* gm2/pim/run/pass/pim-run-pass.exp: Add filter for
constdef.mod.
* gm2/extensions/run/pass/callingc2.mod: New test.
* gm2/extensions/run/pass/callingc3.mod: New test.
* gm2/extensions/run/pass/callingc4.mod: New test.
* gm2/extensions/run/pass/callingc5.mod: New test.
* gm2/extensions/run/pass/callingc6.mod: New test.
* gm2/extensions/run/pass/callingc7.mod: New test.
* gm2/extensions/run/pass/callingc8.mod: New test.
* gm2/extensions/run/pass/fixedarray.mod: New test.
* gm2/extensions/run/pass/fixedarray2.mod: New test.
* gm2/pim/run/pass/constdef.def: New test.
* gm2/pim/run/pass/constdef.mod: New test.
* gm2/pim/run/pass/testimportconst.mod: New test.
Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2ALU.mod | 6 +-
gcc/m2/gm2-compiler/M2Const.mod | 2 +-
gcc/m2/gm2-compiler/M2GCCDeclare.mod | 129 +++--
gcc/m2/gm2-compiler/M2GenGCC.mod | 303 ++++++++----
gcc/m2/gm2-compiler/M2Quads.def | 3 +
gcc/m2/gm2-compiler/M2Quads.mod | 130 +++--
gcc/m2/gm2-compiler/M2SymInit.mod | 3 +
gcc/m2/gm2-compiler/NameKey.mod | 13 +-
gcc/m2/gm2-compiler/P2SymBuild.mod | 8 +-
gcc/m2/gm2-compiler/SymbolTable.def | 525 +++------------------
gcc/m2/gm2-compiler/SymbolTable.mod | 450 ++++++------------
.../gm2/extensions/run/pass/callingc2.mod | 7 +
.../gm2/extensions/run/pass/callingc3.mod | 13 +
.../gm2/extensions/run/pass/callingc4.mod | 10 +
.../gm2/extensions/run/pass/callingc5.mod | 10 +
.../gm2/extensions/run/pass/callingc6.mod | 10 +
.../gm2/extensions/run/pass/callingc7.mod | 10 +
.../gm2/extensions/run/pass/callingc8.mod | 10 +
.../gm2/extensions/run/pass/fixedarray.mod | 7 +
.../gm2/extensions/run/pass/fixedarray2.mod | 7 +
gcc/testsuite/gm2/pim/run/pass/constdef.def | 6 +
gcc/testsuite/gm2/pim/run/pass/constdef.mod | 3 +
gcc/testsuite/gm2/pim/run/pass/pim-run-pass.exp | 6 +-
gcc/testsuite/gm2/pim/run/pass/testimportconst.mod | 26 +
24 files changed, 744 insertions(+), 953 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2ALU.mod b/gcc/m2/gm2-compiler/M2ALU.mod
index 938124abaa7d..58d4b5c24ed7 100644
--- a/gcc/m2/gm2-compiler/M2ALU.mod
+++ b/gcc/m2/gm2-compiler/M2ALU.mod
@@ -4700,7 +4700,7 @@ BEGIN
PushIntegerTree(BuildNumberOfArrayElements(location, Mod2Gcc(arrayType))) ;
IF IsConstString(el)
THEN
- PushCard(GetStringLength(el))
+ PushCard(GetStringLength(tokenno, el))
ELSIF IsConst(el) AND (SkipType(GetType(el))=Char) AND IsValueSolved(el)
THEN
PushCard(1)
@@ -4755,7 +4755,7 @@ BEGIN
THEN
isChar := FALSE ;
s := InitStringCharStar(KeyToCharStar(GetString(el))) ;
- l := GetStringLength(el)
+ l := GetStringLength(tokenno, el)
ELSIF IsConst(el) AND (SkipType(GetType(el))=Char) AND IsValueSolved(el)
THEN
isChar := TRUE
@@ -4905,7 +4905,7 @@ BEGIN
offset := totalLength ;
IF IsConstString (element)
THEN
- INC (totalLength, GetStringLength (element)) ;
+ INC (totalLength, GetStringLength (tokenno, element)) ;
IF totalLength > arrayIndex
THEN
key := GetString (element) ;
diff --git a/gcc/m2/gm2-compiler/M2Const.mod b/gcc/m2/gm2-compiler/M2Const.mod
index d72924d404f5..b50b591220ae 100644
--- a/gcc/m2/gm2-compiler/M2Const.mod
+++ b/gcc/m2/gm2-compiler/M2Const.mod
@@ -373,7 +373,7 @@ BEGIN
WITH h^ DO
IF findConstMetaExpr(h)=str
THEN
- PutConstString(constsym, MakeKey('')) ;
+ PutConstStringKnown (constsym, MakeKey(''), FALSE, FALSE) ;
IF DebugConsts
THEN
n := GetSymName(constsym) ;
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index dae5a6b34bd2..6f0a749c5263 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -98,7 +98,7 @@ FROM SymbolTable IMPORT NulSym,
IsGnuAsm, IsGnuAsmVolatile, IsObject, IsTuple,
IsError, IsHiddenType, IsVarHeap,
IsComponent, IsPublic, IsExtern, IsCtor,
- IsImport, IsImportStatement,
+ IsImport, IsImportStatement, IsConstStringKnown,
GetMainModule, GetBaseModule, GetModule, GetLocalSym,
PutModuleFinallyFunction,
GetProcedureScope, GetProcedureQuads,
@@ -1677,11 +1677,12 @@ END DeclareConstantFromTree ;
DeclareCharConstant - declares a character constant.
*)
-PROCEDURE DeclareCharConstant (sym: CARDINAL) ;
+PROCEDURE DeclareCharConstant (tokenno: CARDINAL; sym: CARDINAL) ;
VAR
location: location_t ;
BEGIN
- location := TokenToLocation(GetDeclaredMod(sym)) ;
+ Assert (IsConstStringKnown (sym)) ;
+ location := TokenToLocation(tokenno) ;
PreAddModGcc(sym, BuildCharConstant(location, KeyToCharStar(GetString(sym)))) ;
WatchRemoveList(sym, todolist) ;
WatchIncludeList(sym, fullydeclared)
@@ -1689,23 +1690,24 @@ END DeclareCharConstant ;
(*
- DeclareStringConstant - declares a string constant.
+ DeclareStringConstant - declares a string constant the sym will be known.
*)
-PROCEDURE DeclareStringConstant (sym: CARDINAL) ;
+PROCEDURE DeclareStringConstant (tokenno: CARDINAL; sym: CARDINAL) ;
VAR
symtree : Tree ;
BEGIN
+ Assert (IsConstStringKnown (sym)) ;
IF IsConstStringM2nul (sym) OR IsConstStringCnul (sym)
THEN
(* in either case the string needs a nul terminator. If the string
is a C variant it will already have had any escape characters applied.
The BuildCStringConstant only adds the nul terminator. *)
symtree := BuildCStringConstant (KeyToCharStar (GetString (sym)),
- GetStringLength (sym))
+ GetStringLength (tokenno, sym))
ELSE
symtree := BuildStringConstant (KeyToCharStar (GetString (sym)),
- GetStringLength (sym))
+ GetStringLength (tokenno, sym))
END ;
PreAddModGcc (sym, symtree) ;
WatchRemoveList (sym, todolist) ;
@@ -1733,14 +1735,15 @@ BEGIN
ch := PopChar (tokenno) ;
RETURN BuildCStringConstant (string (InitStringChar (ch)), 1)
ELSE
- size := GetStringLength (sym) ;
+ Assert (IsConstStringKnown (sym)) ;
+ size := GetStringLength (tokenno, sym) ;
IF size > 1
THEN
- (* will be a string anyway *)
+ (* It will be already be declared as a string, so return it. *)
RETURN Tree (Mod2Gcc (sym))
ELSE
RETURN BuildStringConstant (KeyToCharStar (GetString (sym)),
- GetStringLength (sym))
+ GetStringLength (tokenno, sym))
END
END
END PromoteToString ;
@@ -1760,13 +1763,14 @@ VAR
ch : CHAR ;
BEGIN
DeclareConstant (tokenno, sym) ;
+ Assert (IsConstStringKnown (sym)) ;
IF IsConst (sym) AND (GetSType (sym) = Char)
THEN
PushValue (sym) ;
ch := PopChar (tokenno) ;
RETURN BuildCStringConstant (string (InitStringChar (ch)), 1)
ELSE
- size := GetStringLength (sym) ;
+ size := GetStringLength (tokenno, sym) ;
RETURN BuildCStringConstant (KeyToCharStar (GetString (sym)),
size)
END
@@ -1971,6 +1975,29 @@ BEGIN
END DeclareConstant ;
+(*
+ DeclareConstString -
+*)
+
+PROCEDURE DeclareConstString (tokenno: CARDINAL; sym: CARDINAL) : BOOLEAN ;
+VAR
+ size: CARDINAL ;
+BEGIN
+ IF IsConstStringKnown (sym)
+ THEN
+ size := GetStringLength (tokenno, sym) ;
+ IF size=1
+ THEN
+ DeclareCharConstant (tokenno, sym)
+ ELSE
+ DeclareStringConstant (tokenno, sym)
+ END ;
+ RETURN TRUE
+ END ;
+ RETURN FALSE
+END DeclareConstString ;
+
+
(*
TryDeclareConst - try to declare a const to gcc. If it cannot
declare the symbol it places it into the
@@ -1979,8 +2006,7 @@ END DeclareConstant ;
PROCEDURE TryDeclareConst (tokenno: CARDINAL; sym: CARDINAL) ;
VAR
- type,
- size: CARDINAL ;
+ type: CARDINAL ;
BEGIN
IF NOT GccKnowsAbout(sym)
THEN
@@ -2001,14 +2027,10 @@ BEGIN
RETURN
END
END ;
- IF IsConstString(sym)
+ IF IsConstString(sym) AND IsConstStringKnown (sym)
THEN
- size := GetStringLength(sym) ;
- IF size=1
+ IF DeclareConstString (tokenno, sym)
THEN
- DeclareCharConstant(sym)
- ELSE
- DeclareStringConstant (sym)
END
ELSIF IsValueSolved(sym)
THEN
@@ -2050,7 +2072,6 @@ END TryDeclareConst ;
PROCEDURE DeclareConst (tokenno: CARDINAL; sym: CARDINAL) : Tree ;
VAR
type: CARDINAL ;
- size: CARDINAL ;
BEGIN
IF GccKnowsAbout(sym)
THEN
@@ -2062,12 +2083,8 @@ BEGIN
END ;
IF IsConstString(sym)
THEN
- size := GetStringLength(sym) ;
- IF size=1
+ IF DeclareConstString (tokenno, sym)
THEN
- DeclareCharConstant(sym)
- ELSE
- DeclareStringConstant (sym)
END
ELSIF IsValueSolved(sym)
THEN
@@ -4054,13 +4071,45 @@ BEGIN
END PrintProcedure ;
+(*
+ PrintString -
+*)
+
+PROCEDURE PrintString (sym: CARDINAL) ;
+VAR
+ len : CARDINAL ;
+ tokenno: CARDINAL ;
+BEGIN
+ IF IsConstStringKnown (sym)
+ THEN
+ IF IsConstStringM2 (sym)
+ THEN
+ printf0 ('a Modula-2 string')
+ ELSIF IsConstStringC (sym)
+ THEN
+ printf0 (' a C string')
+ ELSIF IsConstStringM2nul (sym)
+ THEN
+ printf0 (' a nul terminated Modula-2 string')
+ ELSIF IsConstStringCnul (sym)
+ THEN
+ printf0 (' a nul terminated C string')
+ END ;
+ tokenno := GetDeclaredMod (sym) ;
+ len := GetStringLength (tokenno, sym) ;
+ printf1 (' length %d', len)
+ ELSE
+ printf0 ('is not currently known')
+ END
+END PrintString ;
+
+
(*
PrintVerboseFromList - prints the, i, th element in the list, l.
*)
PROCEDURE PrintVerboseFromList (l: List; i: CARDINAL) ;
VAR
- len,
type,
low,
high,
@@ -4215,22 +4264,8 @@ BEGIN
printf2('sym %d IsConst (%a)', sym, n) ;
IF IsConstString(sym)
THEN
- printf1(' also IsConstString (%a)', n) ;
- IF IsConstStringM2 (sym)
- THEN
- printf0(' a Modula-2 string')
- ELSIF IsConstStringC (sym)
- THEN
- printf0(' a C string')
- ELSIF IsConstStringM2nul (sym)
- THEN
- printf0(' a nul terminated Modula-2 string')
- ELSIF IsConstStringCnul (sym)
- THEN
- printf0(' a nul terminated C string')
- END ;
- len := GetStringLength (sym) ;
- printf1(' length %d', len)
+ printf1 (' also IsConstString (%a) ', n) ;
+ PrintString (sym)
ELSIF IsConstructor(sym)
THEN
printf0(' constant constructor ') ;
@@ -5419,23 +5454,25 @@ END DeclareSet ;
PROCEDURE CheckResolveSubrange (sym: CARDINAL) ;
VAR
+ tokenno : CARDINAL;
size, high, low, type: CARDINAL ;
BEGIN
GetSubrange(sym, high, low) ;
+ tokenno := GetDeclaredMod (sym) ;
type := GetSType(sym) ;
IF type=NulSym
THEN
IF GccKnowsAbout(low) AND GccKnowsAbout(high)
THEN
- IF IsConstString(low)
+ IF IsConstString (low) AND IsConstStringKnown (low)
THEN
- size := GetStringLength(low) ;
+ size := GetStringLength (tokenno, low) ;
IF size=1
THEN
PutSubrange(sym, low, high, Char)
ELSE
- MetaError1('cannot have a subrange of a string type {%1Uad}',
- sym)
+ MetaError1 ('cannot have a subrange of a string type {%1Uad}',
+ sym)
END
ELSIF IsFieldEnumeration(low)
THEN
diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index 25bfbf894aa7..c7581f859374 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -27,7 +27,7 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue,
PushVarSize,
PushSumOfLocalVarSize,
PushSumOfParamSize,
- MakeConstLit, MakeConstLitString,
+ MakeConstLit,
RequestSym, FromModuleGetSym,
StartScope, EndScope, GetScope,
GetMainModule, GetModuleScope,
@@ -57,6 +57,7 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue,
IsValueSolved, IsSizeSolved,
IsProcedureNested, IsInnerModule, IsArrayLarge,
IsComposite, IsVariableSSA, IsPublic, IsCtor,
+ IsConstStringKnown,
ForeachExportedDo,
ForeachImportedDo,
ForeachProcedureDo,
@@ -74,10 +75,10 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue,
GetProcedureQuads,
GetProcedureBuiltin,
GetPriority, GetNeedSavePriority,
- PutConstString,
+ PutConstStringKnown,
PutConst, PutConstSet, PutConstructor,
GetSType, GetTypeMode,
- HasVarParameters,
+ HasVarParameters, CopyConstString,
NulSym ;
FROM M2Batch IMPORT MakeDefinitionSource ;
@@ -522,7 +523,7 @@ BEGIN
CallOp : CodeCall (CurrentQuadToken, op3) |
ParamOp : CodeParam (q) |
FunctValueOp : CodeFunctValue (location, op1) |
- AddrOp : CodeAddr (q, op1, op3) |
+ AddrOp : CodeAddr (CurrentQuadToken, q, op1, op3) |
SizeOp : CodeSize (op1, op3) |
UnboundedOp : CodeUnbounded (op1, op3) |
RecordFieldOp : CodeRecordField (op1, op2, op3) |
@@ -628,7 +629,10 @@ BEGIN
LogicalRotateOp : FoldSetRotate (tokenno, p, quad, op1, op2, op3) |
ParamOp : FoldBuiltinFunction (tokenno, p, quad, op1, op2, op3) |
RangeCheckOp : FoldRange (tokenno, quad, op3) |
- StatementNoteOp : FoldStatementNote (op3)
+ StatementNoteOp : FoldStatementNote (op3) |
+ StringLengthOp : FoldStringLength (quad, p) |
+ StringConvertM2nulOp: FoldStringConvertM2nul (quad, p) |
+ StringConvertCnulOp : FoldStringConvertCnul (quad, p)
ELSE
(* ignore quadruple as it is not associated with a constant expression *)
@@ -650,8 +654,8 @@ END ResolveConstantExpressions ;
(*
- FindSize - given a Modula-2 symbol, sym, return the GCC Tree
- (constant) representing the storage size in bytes.
+ FindSize - given a Modula-2 symbol sym return a gcc tree
+ constant representing the storage size in bytes.
*)
PROCEDURE FindSize (tokenno: CARDINAL; sym: CARDINAL) : Tree ;
@@ -661,7 +665,8 @@ BEGIN
location := TokenToLocation (tokenno) ;
IF IsConstString (sym)
THEN
- PushCard (GetStringLength (sym)) ;
+ Assert (IsConstStringKnown (sym)) ;
+ PushCard (GetStringLength (tokenno, sym)) ;
RETURN PopIntegerTree ()
ELSIF IsSizeSolved (sym)
THEN
@@ -2040,18 +2045,21 @@ PROCEDURE StringToChar (t: Tree; type, str: CARDINAL) : Tree ;
VAR
s: String ;
n: Name ;
+ tokenno : CARDINAL ;
location: location_t ;
BEGIN
- location := TokenToLocation(GetDeclaredMod(str)) ;
- type := SkipType(type) ;
+ tokenno := GetDeclaredMod(str) ;
+ location := TokenToLocation(tokenno) ;
+ type := SkipType (type) ;
IF (type=Char) AND IsConstString(str)
THEN
- IF GetStringLength(str)=0
+ Assert (IsConstStringKnown (str)) ;
+ IF GetStringLength (tokenno, str) = 0
THEN
s := InitString('') ;
t := BuildCharConstant(location, s) ;
s := KillString(s) ;
- ELSIF GetStringLength(str)>1
+ ELSIF GetStringLength (tokenno, str)>1
THEN
n := GetSymName(str) ;
WriteFormat1("type incompatibility, attempting to use a string ('%a') when a CHAR is expected", n) ;
@@ -2590,15 +2598,99 @@ END CodeFunctValue ;
(*
- Addr Operator - contains the address of a variable.
+ FoldStringLength -
+*)
+
+PROCEDURE FoldStringLength (quad: CARDINAL; p: WalkAction) ;
+VAR
+ op : QuadOperator ;
+ des, none, expr : CARDINAL ;
+ stroppos,
+ despos, nonepos,
+ exprpos : CARDINAL ;
+ overflowChecking: BOOLEAN ;
+ location : location_t ;
+BEGIN
+ GetQuadOtok (quad, stroppos, op, des, none, expr, overflowChecking,
+ despos, nonepos, exprpos) ;
+ IF IsConstStr (expr) AND IsConstStrKnown (expr)
+ THEN
+ location := TokenToLocation (stroppos) ;
+ PushCard (GetStringLength (exprpos, expr)) ;
+ AddModGcc (des, BuildConvert (location, Mod2Gcc (GetType (des)), PopIntegerTree (), FALSE)) ;
+ RemoveQuad (p, des, quad)
+ END
+END FoldStringLength ;
+
+
+(*
+ FoldStringConvertM2nul - attempt to assign the des with the string contents from expr.
+ It also marks the des as a m2 string which must be nul terminated.
+ The front end uses double book keeping and it is easier to have
+ different m2 string symbols each of which map onto a slightly different
+ gcc string tree.
+*)
+
+PROCEDURE FoldStringConvertM2nul (quad: CARDINAL; p: WalkAction) ;
+VAR
+ op : QuadOperator ;
+ des, none, expr : CARDINAL ;
+ stroppos,
+ despos, nonepos,
+ exprpos : CARDINAL ;
+ s : String ;
+ overflowChecking: BOOLEAN ;
+BEGIN
+ GetQuadOtok (quad, stroppos, op, des, none, expr, overflowChecking,
+ despos, nonepos, exprpos) ;
+ IF IsConstStr (expr) AND IsConstStrKnown (expr)
+ THEN
+ s := GetStr (exprpos, expr) ;
+ PutConstStringKnown (stroppos, des, makekey (string (s)), FALSE, TRUE) ;
+ TryDeclareConstant (despos, des) ;
+ p (des) ;
+ NoChange := FALSE ;
+ SubQuad (quad) ;
+ s := KillString (s)
+ END
+END FoldStringConvertM2nul ;
+
+
+(*
+ FoldStringConvertCnul -attempt to assign the des with the string contents from expr.
+ It also marks the des as a C string which must be nul terminated.
+*)
+
+PROCEDURE FoldStringConvertCnul (quad: CARDINAL; p: WalkAction) ;
+VAR
+ op : QuadOperator ;
+ des, none, expr : CARDINAL ;
+ stroppos,
+ despos, nonepos,
+ exprpos : CARDINAL ;
+ s : String ;
+ overflowChecking: BOOLEAN ;
+BEGIN
+ GetQuadOtok (quad, stroppos, op, des, none, expr, overflowChecking,
+ despos, nonepos, exprpos) ;
+ IF IsConstStr (expr) AND IsConstStrKnown (expr)
+ THEN
+ s := GetStr (exprpos, expr) ;
+ PutConstStringKnown (stroppos, des, makekey (string (s)), TRUE, TRUE) ;
+ TryDeclareConstant (despos, des) ;
+ p (des) ;
+ NoChange := FALSE ;
+ SubQuad (quad) ;
+ s := KillString (s)
+ END
+END FoldStringConvertCnul ;
- Yields the address of a variable - need to add the frame pointer if
- a variable is local to a procedure.
- Sym1<X> Addr Sym2<X> meaning Mem[Sym1<I>] := Sym2<I>
+(*
+ Addr Operator - generates the address of a variable (op1 = &op3).
*)
-PROCEDURE CodeAddr (quad: CARDINAL; op1, op3: CARDINAL) ;
+PROCEDURE CodeAddr (tokenno: CARDINAL; quad: CARDINAL; op1, op3: CARDINAL) ;
VAR
value : Tree ;
type : CARDINAL ;
@@ -2606,15 +2698,19 @@ VAR
BEGIN
IF IsConst(op3) AND (NOT IsConstString(op3))
THEN
- MetaErrorT1 (CurrentQuadToken, 'error in expression, trying to find the address of a constant {%1Ead}', op3)
+ MetaErrorT1 (tokenno, 'error in expression, trying to find the address of a constant {%1Ead}', op3)
ELSE
- location := TokenToLocation (CurrentQuadToken) ;
+ IF IsConstString (op3) AND (NOT IsConstStringKnown (op3))
+ THEN
+ printf1 ("failure in quad: %d\n", quad)
+ END ;
+ location := TokenToLocation (tokenno) ;
type := SkipType (GetType (op3)) ;
- DeclareConstant (CurrentQuadToken, op3) ; (* we might be asked to find the address of a constant string *)
- DeclareConstructor (CurrentQuadToken, quad, op3) ;
+ DeclareConstant (tokenno, op3) ; (* we might be asked to find the address of a constant string *)
+ DeclareConstructor (tokenno, quad, op3) ;
IF (IsConst (op3) AND (type=Char)) OR IsConstString (op3)
THEN
- value := BuildStringConstant (KeyToCharStar (GetString (op3)), GetStringLength (op3))
+ value := BuildStringConstant (KeyToCharStar (GetString (op3)), GetStringLength (tokenno, op3))
ELSE
value := Mod2Gcc (op3)
END ;
@@ -2754,7 +2850,9 @@ END TypeCheckBecomes ;
(*
- PerformFoldBecomes -
+ PerformFoldBecomes - attempts to fold quad. It propagates constant strings
+ and attempts to declare des providing it is a constant
+ and expr is resolved.
*)
PROCEDURE PerformFoldBecomes (p: WalkAction; quad: CARDINAL) ;
@@ -2770,9 +2868,12 @@ BEGIN
des, op2, expr, overflowChecking,
despos, op2pos, exprpos) ;
Assert (op2pos = UnknownTokenNo) ;
- IF IsConstString (expr)
+ IF IsConst (des) AND IsConstString (expr)
THEN
- PutConstString (exprpos, des, GetString (expr))
+ IF IsConstStringKnown (expr) AND (NOT IsConstStringKnown (des))
+ THEN
+ CopyConstString (exprpos, des, expr)
+ END
ELSIF GetType (des) = NulSym
THEN
Assert (GetType (expr) # NulSym) ;
@@ -3033,32 +3134,47 @@ BEGIN
THEN
(*
* Create string from char and add nul to the end, nul is
- * added by BuildStringConstant
+ * added by BuildStringConstant. In modula-2 an array must
+ * have at least one element.
*)
- srcTree := BuildStringConstant (KeyToCharStar (GetString (src)), 1)
- ELSE
- srcTree := Mod2Gcc (src)
- END ;
- srcTree := ConvertString (Mod2Gcc (destStrType), srcTree) ;
- PushIntegerTree (FindSize (tokenno, src)) ;
- PushIntegerTree (FindSize (tokenno, destStrType)) ;
- IF Less (tokenno)
- THEN
- (* There is room for the extra <nul> character. *)
- length := BuildAdd (location, FindSize (tokenno, src),
- GetIntegerOne (location), FALSE)
+ length := GetIntegerOne (location) ;
+ PushIntegerTree (FindSize (tokenno, src)) ;
+ PushIntegerTree (FindSize (tokenno, destStrType)) ;
+ IF Less (tokenno)
+ THEN
+ (* There is room for the extra <nul> character. *)
+ length := BuildAdd (location, length,
+ GetIntegerOne (location), FALSE)
+ END
ELSE
- length := FindSize (tokenno, destStrType) ;
PushIntegerTree (FindSize (tokenno, src)) ;
- PushIntegerTree (length) ;
- (* Greater or Equal so return max characters in the array. *)
- IF Gre (tokenno)
+ PushIntegerTree (FindSize (tokenno, destStrType)) ;
+ IF Less (tokenno)
THEN
- intLength := GetCstInteger (length) ;
- srcTree := BuildStringConstant (KeyToCharStar (GetString (src)), intLength) ;
- RETURN FALSE
+ (* There is room for the extra <nul> character. *)
+ length := BuildAdd (location, FindSize (tokenno, src),
+ GetIntegerOne (location), FALSE) ;
+ srcTree := Mod2Gcc (src)
+ ELSE
+ (* We need to truncate the <nul> at least. *)
+ length := FindSize (tokenno, destStrType) ;
+ PushIntegerTree (FindSize (tokenno, src)) ;
+ PushIntegerTree (length) ;
+ (* Greater or Equal so return max characters in the array. *)
+ IF Gre (tokenno)
+ THEN
+ (* Create a new string without non nul characters to be gimple safe.
+ But return FALSE indicating an overflow. *)
+ intLength := GetCstInteger (length) ;
+ srcTree := BuildStringConstant (KeyToCharStar (GetString (src)), intLength) ;
+ srcTree := ConvertString (Mod2Gcc (destStrType), srcTree) ;
+ RETURN FALSE
+ END
END
END ;
+ intLength := GetCstInteger (length) ;
+ srcTree := BuildStringConstant (KeyToCharStar (GetString (src)), intLength) ;
+ srcTree := ConvertString (Mod2Gcc (destStrType), srcTree) ;
RETURN TRUE
END PrepareCopyString ;
@@ -3255,6 +3371,11 @@ BEGIN
'assignment check caught mismatch between {%1Ead} and {%2ad}',
des, expr)
END ;
+ IF IsConstString (expr) AND (NOT IsConstStringKnown (expr))
+ THEN
+ MetaErrorT2 (virtpos,
+ 'internal error: CodeBecomes {%1Aad} in quad {%2n}', des, quad)
+ END ;
IF IsConst (des) AND (NOT GccKnowsAbout (des))
THEN
ConstantKnownAndUsed (des, CheckConstant (virtpos, des, expr))
@@ -3912,6 +4033,18 @@ BEGIN
END IsConstStr ;
+(*
+ IsConstStrKnown - returns TRUE if sym is a constant string or a char constant
+ which is known.
+*)
+
+PROCEDURE IsConstStrKnown (sym: CARDINAL) : BOOLEAN ;
+BEGIN
+ RETURN (IsConstString (sym) AND IsConstStringKnown (sym)) OR
+ (IsConst (sym) AND (GetSType (sym) = Char))
+END IsConstStrKnown ;
+
+
(*
GetStr - return a string containing a constant string value associated with sym.
A nul char constant will return an empty string.
@@ -3946,15 +4079,18 @@ VAR
BEGIN
IF IsConstStr (op2) AND IsConstStr (op3)
THEN
- (* 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)
+ IF IsConstStrKnown (op2) AND IsConstStrKnown (op3)
+ THEN
+ (* Handle special addition for constant strings. *)
+ s := Dup (GetStr (tokenno, op2)) ;
+ s := ConCat (s, GetStr (tokenno, op3)) ;
+ PutConstStringKnown (tokenno, op1, makekey (string (s)), FALSE, TRUE) ;
+ TryDeclareConstant (tokenno, op1) ;
+ p (op1) ;
+ NoChange := FALSE ;
+ SubQuad (quad) ;
+ s := KillString (s)
+ END
ELSE
FoldArithAdd (tokenno, p, quad, op1, op2, op3)
END
@@ -4539,7 +4675,7 @@ BEGIN
END
ELSE
(* rewrite the quad to use becomes. *)
- d := GetStringLength (op3) ;
+ d := GetStringLength (tokenno, op3) ;
s := Sprintf1 (Mark (InitString ("%d")), d) ;
result := MakeConstLit (tokenno, makekey (string (s)), Cardinal) ;
s := KillString (s) ;
@@ -4555,7 +4691,7 @@ BEGIN
(* fine, we can take advantage of this and fold constants *)
IF IsConst(op1)
THEN
- IF (IsConstString(op3) AND (GetStringLength(op3)=1)) OR
+ IF (IsConstString(op3) AND (GetStringLength (tokenno, op3) = 1)) OR
(GetType(op3)=Char)
THEN
AddModGcc(op1, BuildCap(location, Mod2Gcc(op3))) ;
@@ -7514,13 +7650,9 @@ END CodeIndrX ;
(*
-------------------------------------------------------------------------------
- XIndr Operator *a = b
-------------------------------------------------------------------------------
- Sym1<I> XIndr Sym2<X> Meaning Mem[constant] := Mem[Sym3<I>]
- Sym1<X> XIndr Sym2<X> Meaning Mem[Mem[Sym1<I>]] := Mem[Sym3<I>]
-
- (op2 is the type of the data being indirectly copied)
+ CodeXIndr - operands for XIndrOp are: left type right.
+ *left = right. The second operand is the type of the data being
+ indirectly copied.
*)
PROCEDURE CodeXIndr (quad: CARDINAL) ;
@@ -7528,34 +7660,29 @@ VAR
overflowChecking: BOOLEAN ;
op : QuadOperator ;
tokenno,
- op1,
+ left,
type,
- op3,
- op1pos,
- op3pos,
+ right,
+ leftpos,
+ rightpos,
typepos,
xindrpos : CARDINAL ;
length,
newstr : Tree ;
location : location_t ;
BEGIN
- GetQuadOtok (quad, xindrpos, op, op1, type, op3, overflowChecking,
- op1pos, typepos, op3pos) ;
- tokenno := MakeVirtualTok (xindrpos, op1pos, op3pos) ;
+ GetQuadOtok (quad, xindrpos, op, left, type, right, overflowChecking,
+ leftpos, typepos, rightpos) ;
+ tokenno := MakeVirtualTok (xindrpos, leftpos, rightpos) ;
location := TokenToLocation (tokenno) ;
type := SkipType (type) ;
- DeclareConstant (op3pos, op3) ;
- DeclareConstructor (op3pos, quad, op3) ;
- (*
- Follow the Quadruple rule:
-
- Mem[Mem[Op1]] := Mem[Op3]
- *)
+ DeclareConstant (rightpos, right) ;
+ DeclareConstructor (rightpos, quad, right) ;
IF IsProcType(SkipType(type))
THEN
- BuildAssignmentStatement (location, BuildIndirect (location, Mod2Gcc (op1), GetPointerType ()), Mod2Gcc (op3))
- ELSIF IsConstString (op3) AND (GetStringLength (op3) = 0) AND (GetMode (op1) = LeftValue)
+ BuildAssignmentStatement (location, BuildIndirect (location, Mod2Gcc (left), GetPointerType ()), Mod2Gcc (right))
+ ELSIF IsConstString (right) AND (GetStringLength (rightpos, right) = 0) AND (GetMode (left) = LeftValue)
THEN
(*
no need to check for type errors,
@@ -7564,25 +7691,25 @@ BEGIN
contents.
*)
BuildAssignmentStatement (location,
- BuildIndirect (location, LValueToGenericPtr (location, op1), Mod2Gcc (Char)),
- StringToChar (Mod2Gcc (op3), Char, op3))
- ELSIF IsConstString (op3) AND (SkipTypeAndSubrange (GetType (op1)) # Char)
+ BuildIndirect (location, LValueToGenericPtr (location, left), Mod2Gcc (Char)),
+ StringToChar (Mod2Gcc (right), Char, right))
+ ELSIF IsConstString (right) AND (SkipTypeAndSubrange (GetType (left)) # Char)
THEN
- IF NOT PrepareCopyString (tokenno, length, newstr, op3, type)
+ IF NOT PrepareCopyString (tokenno, length, newstr, right, type)
THEN
- MetaErrorT2 (MakeVirtualTok (xindrpos, op1pos, op3pos),
+ MetaErrorT2 (MakeVirtualTok (xindrpos, leftpos, rightpos),
'string constant {%1Ea} is too large to be assigned to the array {%2ad}',
- op3, op1)
+ right, left)
END ;
AddStatement (location,
MaybeDebugBuiltinMemcpy (location,
- Mod2Gcc (op1),
+ Mod2Gcc (left),
BuildAddr (location, newstr, FALSE),
length))
ELSE
BuildAssignmentStatement (location,
- BuildIndirect (location, Mod2Gcc (op1), Mod2Gcc (type)),
- ConvertRHS (Mod2Gcc (op3), type, op3))
+ BuildIndirect (location, Mod2Gcc (left), Mod2Gcc (type)),
+ ConvertRHS (Mod2Gcc (right), type, right))
END
END CodeXIndr ;
diff --git a/gcc/m2/gm2-compiler/M2Quads.def b/gcc/m2/gm2-compiler/M2Quads.def
index acc49c84b435..e9fd1224d860 100644
--- a/gcc/m2/gm2-compiler/M2Quads.def
+++ b/gcc/m2/gm2-compiler/M2Quads.def
@@ -233,6 +233,9 @@ TYPE
SubOp,
SubrangeHighOp,
SubrangeLowOp,
+ StringConvertCnulOp,
+ StringConvertM2nulOp,
+ StringLengthOp,
ThrowOp,
TryOp,
UnboundedOp,
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index a23fa32906e4..e40e07d55c58 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -50,8 +50,9 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
MakeTemporary,
MakeTemporaryFromExpression,
MakeTemporaryFromExpressions,
- MakeConstLit, MakeConstLitString,
- MakeConstString, MakeConstant,
+ MakeConstLit,
+ MakeConstString, MakeConstant, MakeConstVar,
+ MakeConstStringM2nul, MakeConstStringCnul,
Make2Tuple,
RequestSym, MakePointer, PutPointer,
SkipType,
@@ -71,8 +72,7 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
GetModuleQuads, GetProcedureQuads,
GetModuleCtors,
MakeProcedure,
- MakeConstStringCnul, MakeConstStringM2nul,
- PutConstString,
+ CopyConstString, PutConstStringKnown,
PutModuleStartQuad, PutModuleEndQuad,
PutModuleFinallyStartQuad, PutModuleFinallyEndQuad,
PutProcedureStartQuad, PutProcedureEndQuad,
@@ -110,7 +110,7 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
PutConstructor, PutConstructorFrom,
PutDeclared,
MakeComponentRecord, MakeComponentRef,
- IsSubscript, IsComponent,
+ IsSubscript, IsComponent, IsConstStringKnown,
IsTemporary,
IsAModula2Type,
PutLeftValueFrontBackType,
@@ -852,6 +852,9 @@ BEGIN
GetQuad (QuadNo, op, op1, op2, op3) ;
CASE op OF
+ StringConvertCnulOp,
+ StringConvertM2nulOp,
+ StringLengthOp,
InclOp,
ExclOp,
UnboundedOp,
@@ -2334,12 +2337,12 @@ BEGIN
Assert (requestDep # NulSym) ;
PushTtok (requestDep, tokno) ;
PushTF (Adr, Address) ;
- PushTtok (MakeConstLitString (tokno, GetSymName (moduleSym)), tokno) ;
+ PushTtok (MakeConstString (tokno, GetSymName (moduleSym)), tokno) ;
PushT (1) ;
BuildAdrFunction ;
PushTF (Adr, Address) ;
- PushTtok (MakeConstLitString (tokno, GetLibName (moduleSym)), tokno) ;
+ PushTtok (MakeConstString (tokno, GetLibName (moduleSym)), tokno) ;
PushT (1) ;
BuildAdrFunction ;
@@ -2349,12 +2352,12 @@ BEGIN
PushTF (Nil, Address)
ELSE
PushTF (Adr, Address) ;
- PushTtok (MakeConstLitString (tokno, GetSymName (depModuleSym)), tokno) ;
+ PushTtok (MakeConstString (tokno, GetSymName (depModuleSym)), tokno) ;
PushT (1) ;
BuildAdrFunction ;
PushTF (Adr, Address) ;
- PushTtok (MakeConstLitString (tokno, GetLibName (depModuleSym)), tokno) ;
+ PushTtok (MakeConstString (tokno, GetLibName (depModuleSym)), tokno) ;
PushT (1) ;
BuildAdrFunction
END ;
@@ -2581,6 +2584,34 @@ BEGIN
END BuildM2MainFunction ;
+(*
+ DeferMakeConstStringCnul - return a C const string which will be nul terminated.
+*)
+
+PROCEDURE DeferMakeConstStringCnul (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
+VAR
+ const: CARDINAL ;
+BEGIN
+ const := MakeConstStringCnul (tok, NulName, FALSE) ;
+ GenQuadO (tok, StringConvertCnulOp, const, 0, sym, FALSE) ;
+ RETURN const
+END DeferMakeConstStringCnul ;
+
+
+(*
+ DeferMakeConstStringM2nul - return a const string which will be nul terminated.
+*)
+
+PROCEDURE DeferMakeConstStringM2nul (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
+VAR
+ const: CARDINAL ;
+BEGIN
+ const := MakeConstStringM2nul (tok, NulName, FALSE) ;
+ GenQuadO (tok, StringConvertM2nulOp, const, 0, sym, FALSE) ;
+ RETURN const
+END DeferMakeConstStringM2nul ;
+
+
(*
BuildStringAdrParam - push the address of a nul terminated string onto the quad stack.
*)
@@ -2590,8 +2621,9 @@ VAR
str, m2strnul: CARDINAL ;
BEGIN
PushTF (Adr, Address) ;
- str := MakeConstLitString (tok, name) ;
- m2strnul := MakeConstStringM2nul (tok, str) ;
+ str := MakeConstString (tok, name) ;
+ PutConstStringKnown (tok, str, name, FALSE, TRUE) ;
+ m2strnul := DeferMakeConstStringM2nul (tok, str) ;
PushTtok (m2strnul, tok) ;
PushT (1) ;
BuildAdrFunction
@@ -2693,12 +2725,12 @@ BEGIN
PushTtok (deconstructModules, tok) ;
PushTF(Adr, Address) ;
- PushTtok (MakeConstLitString (tok, GetSymName (moduleSym)), tok) ;
+ PushTtok (MakeConstString (tok, GetSymName (moduleSym)), tok) ;
PushT(1) ;
BuildAdrFunction ;
PushTF(Adr, Address) ;
- PushTtok (MakeConstLitString (tok, GetLibName (moduleSym)), tok) ;
+ PushTtok (MakeConstString (tok, GetLibName (moduleSym)), tok) ;
PushT(1) ;
BuildAdrFunction ;
@@ -2757,12 +2789,12 @@ BEGIN
PushTtok (RegisterModule, tok) ;
PushTF (Adr, Address) ;
- PushTtok (MakeConstLitString (tok, GetSymName (moduleSym)), tok) ;
+ PushTtok (MakeConstString (tok, GetSymName (moduleSym)), tok) ;
PushT (1) ;
BuildAdrFunction ;
PushTF (Adr, Address) ;
- PushTtok (MakeConstLitString (tok, GetLibName (moduleSym)), tok) ;
+ PushTtok (MakeConstString (tok, GetLibName (moduleSym)), tok) ;
PushT (1) ;
BuildAdrFunction ;
@@ -3262,7 +3294,7 @@ BEGIN
THEN
GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
destok, UnknownTokenNo, exptok) ;
- PutConstString (tokno, Des, GetString (Exp))
+ CopyConstString (tokno, Des, Exp)
ELSE
IF GetMode(Des)=RightValue
THEN
@@ -5431,14 +5463,14 @@ BEGIN
Actual, FormalI, Proc, i)
ELSIF IsConstString (Actual)
THEN
- IF (GetStringLength (Actual) = 0) (* If = 0 then it maybe unknown at this time. *)
+ IF (NOT IsConstStringKnown (Actual))
THEN
(* We dont check this yet, it is checked in M2GenGCC.mod:CodeParam
after the string has been created. *)
ELSIF IsArray(GetDType(FormalI)) AND (GetSType(GetDType(FormalI))=Char)
THEN
(* Allow string literals to be passed to ARRAY [0..n] OF CHAR. *)
- ELSIF (GetStringLength(Actual) = 1) (* If = 1 then it maybe treated as a char. *)
+ ELSIF (GetStringLength(paramtok, Actual) = 1) (* If = 1 then it maybe treated as a char. *)
THEN
CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
ELSIF NOT IsUnboundedParam(Proc, i)
@@ -5650,8 +5682,13 @@ VAR
NewList : BOOLEAN ;
ActualType, FormalType: CARDINAL ;
BEGIN
+ IF IsConstString(Actual) AND (NOT IsConstStringKnown (Actual))
+ THEN
+ (* Cannot check if the string content is not yet known. *)
+ RETURN
+ END ;
FormalType := GetDType(Formal) ;
- IF IsConstString(Actual) AND (GetStringLength(Actual) = 1) (* if = 1 then it maybe treated as a char *)
+ IF IsConstString(Actual) AND (GetStringLength(tokpos, Actual) = 1) (* if = 1 then it maybe treated as a char *)
THEN
ActualType := Char
ELSIF Actual=Boolean
@@ -5784,7 +5821,8 @@ BEGIN
s := NIL ;
IF IsConstString(Sym)
THEN
- IF (GetStringLength(Sym) = 1) (* if = 1 then it maybe treated as a char *)
+ (* If = 1 then it maybe treated as a char. *)
+ IF IsConstStringKnown (Sym) AND (GetStringLength (GetDeclaredMod (Sym), Sym) = 1)
THEN
s := InitString('(constant string) or {%kCHAR}')
ELSE
@@ -6316,7 +6354,7 @@ BEGIN
ELSIF IsConstString (OperandT (pi))
THEN
f^.TrueExit := MakeLeftValue (OperandTok (pi),
- MakeConstStringCnul (OperandTok (pi), OperandT (pi)), RightValue, Address) ;
+ DeferMakeConstStringCnul (OperandTok (pi), OperandT (pi)), RightValue, Address) ;
MarkAsReadWrite(rw)
ELSIF (GetSType(OperandT(pi))#NulSym) AND IsUnbounded(GetSType(OperandT(pi)))
THEN
@@ -6361,7 +6399,7 @@ BEGIN
(IsUnboundedParam(Proc, i) OR (GetDType(GetParam(Proc, i))=Address))
THEN
f^.TrueExit := MakeLeftValue (OperandTok (pi),
- MakeConstStringCnul (OperandTok (pi), OperandT (pi)),
+ DeferMakeConstStringCnul (OperandTok (pi), OperandT (pi)),
RightValue, Address) ;
MarkAsReadWrite (rw)
ELSIF IsUnboundedParam(Proc, i)
@@ -6370,7 +6408,7 @@ BEGIN
IF IsConstString (OperandT(pi))
THEN
(* this is a Modula-2 string which must be nul terminated. *)
- f^.TrueExit := MakeConstStringM2nul (OperandTok (pi), OperandT (pi))
+ f^.TrueExit := DeferMakeConstStringM2nul (OperandTok (pi), OperandT (pi))
END ;
t := MakeTemporary (OperandTok (pi), RightValue) ;
UnboundedType := GetSType(GetParam(Proc, i)) ;
@@ -6627,7 +6665,7 @@ BEGIN
THEN
IF IsConstString (Sym)
THEN
- PushTtok (MakeLengthConst (tok, Sym), tok)
+ PushTtok (DeferMakeLengthConst (tok, Sym), tok)
ELSE
ArrayType := GetSType (Sym) ;
IF IsUnbounded (ArrayType)
@@ -7687,7 +7725,7 @@ END BuildConstFunctionCall ;
(*
BuildTypeCoercion - builds the type coersion.
- MODULA-2 allows types to be coersed with no runtime
+ Modula-2 allows types to be coersed with no runtime
penility.
It insists that the TSIZE(t1)=TSIZE(t2) where
t2 variable := t2(variable of type t1).
@@ -8379,13 +8417,18 @@ END GetQualidentImport ;
(*
- MakeLengthConst - creates a constant which contains the length of string, sym.
+ DeferMakeLengthConst - creates a constant which contains the length of string, sym.
*)
-PROCEDURE MakeLengthConst (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
+PROCEDURE DeferMakeLengthConst (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
+VAR
+ const: CARDINAL ;
BEGIN
- RETURN MakeConstant (tok, GetStringLength (sym))
-END MakeLengthConst ;
+ const := MakeTemporary (tok, ImmediateValue) ;
+ PutVar (const, ZType) ;
+ GenQuadO (tok, StringLengthOp, const, 0, sym, FALSE) ;
+ RETURN const
+END DeferMakeLengthConst ;
(*
@@ -8422,9 +8465,9 @@ BEGIN
Param := OperandT (1) ;
paramtok := OperandTok (1) ;
functok := OperandTok (NoOfParam + 1) ;
- (* Restore stack to origional form *)
+ (* Restore stack to origional form. *)
PushT (NoOfParam) ;
- Type := GetSType (Param) ; (* get the type from the symbol, not the stack *)
+ Type := GetSType (Param) ; (* Get the type from the symbol, not the stack. *)
IF NoOfParam # 1
THEN
MetaErrorT1 (functok, 'base procedure {%1EkLENGTH} expects 1 parameter, seen {%1n} parameters', NoOfParam)
@@ -8441,7 +8484,7 @@ BEGIN
ELSIF IsConstString (Param)
THEN
PopT (NoOfParam) ;
- ReturnVar := MakeLengthConst (combinedtok, OperandT (1)) ;
+ ReturnVar := DeferMakeLengthConst (combinedtok, OperandT (1)) ;
PopN (NoOfParam + 1) ;
PushTtok (ReturnVar, combinedtok)
ELSE
@@ -12522,11 +12565,10 @@ BEGIN
OperatorPos := MakeVirtualTok (OperatorPos, leftpos, rightpos) ;
IF (Operator = PlusTok) AND IsConstString(left) AND IsConstString(right)
THEN
- (* handle special addition for constant strings *)
- s := InitStringCharStar (KeyToCharStar (GetString (left))) ;
- s := ConCat (s, Mark (InitStringCharStar (KeyToCharStar (GetString (right))))) ;
- value := MakeConstLitString (OperatorPos, makekey (string (s))) ;
- s := KillString (s)
+ value := MakeConstString (OperatorPos, NulName) ;
+ PutConstStringKnown (OperatorPos, value, NulName, FALSE, FALSE) ;
+ GenQuadOtok (OperatorPos, MakeOp (PlusTok), value, left, right, FALSE,
+ OperatorPos, leftpos, rightpos)
ELSE
IF checkTypes
THEN
@@ -12840,7 +12882,7 @@ BEGIN
MetaErrorsT1 (tokpos,
'{%1EU} not expecting an array variable as an operand for either comparison or binary operation',
'it was declared as a {%1Dd}', sym)
- ELSIF IsConstString(sym) AND (GetStringLength(sym)>1)
+ ELSIF IsConstString (sym) AND IsConstStringKnown (sym) AND (GetStringLength (tokpos, sym) > 1)
THEN
MetaErrorT1 (tokpos,
'{%1EU} not expecting a string constant as an operand for either comparison or binary operation',
@@ -13403,7 +13445,10 @@ BEGIN
ReturnValueOp,
FunctValueOp,
NegateOp,
- AddrOp : WriteOperand(Operand1) ;
+ AddrOp,
+ StringConvertCnulOp,
+ StringConvertM2nulOp,
+ StringLengthOp : WriteOperand(Operand1) ;
printf0(' ') ;
WriteOperand(Operand3) |
ElementSizeOp,
@@ -13617,7 +13662,12 @@ BEGIN
RangeCheckOp : printf0('RangeCheck ') |
ErrorOp : printf0('Error ') |
SaveExceptionOp : printf0('SaveException ') |
- RestoreExceptionOp : printf0('RestoreException ')
+ RestoreExceptionOp : printf0('RestoreException ') |
+ StringConvertCnulOp : printf0('StringConvertCnul ') |
+ StringConvertM2nulOp : printf0('StringConvertM2nul') |
+ StringLengthOp : printf0('StringLength ') |
+ SubrangeHighOp : printf0('SubrangeHigh ') |
+ SubrangeLowOp : printf0('SubrangeLow ')
ELSE
InternalError ('operator not expected')
diff --git a/gcc/m2/gm2-compiler/M2SymInit.mod b/gcc/m2/gm2-compiler/M2SymInit.mod
index ca0f3001a0fc..0b23e53a4a91 100644
--- a/gcc/m2/gm2-compiler/M2SymInit.mod
+++ b/gcc/m2/gm2-compiler/M2SymInit.mod
@@ -1342,6 +1342,9 @@ BEGIN
ElementSizeOp,
BuiltinConstOp, (* Nothing to do, it is assigning a constant to op1 (also a const). *)
BuiltinTypeInfoOp, (* Likewise assigning op1 (const) with a type. *)
+ StringConvertCnulOp,
+ StringConvertM2nulOp,
+ StringLengthOp,
ProcedureScopeOp,
InitEndOp,
InitStartOp,
diff --git a/gcc/m2/gm2-compiler/NameKey.mod b/gcc/m2/gm2-compiler/NameKey.mod
index 78116722a719..e2260a413426 100644
--- a/gcc/m2/gm2-compiler/NameKey.mod
+++ b/gcc/m2/gm2-compiler/NameKey.mod
@@ -251,13 +251,16 @@ VAR
i: CARDINAL ;
p: PtrToChar ;
BEGIN
- p := KeyToCharStar(Key) ;
i := 0 ;
- WHILE p^#nul DO
- INC(i) ;
- INC(p)
+ IF Key # NulName
+ THEN
+ p := KeyToCharStar (Key) ;
+ WHILE p^ # nul DO
+ INC (i) ;
+ INC (p)
+ END
END ;
- RETURN( i )
+ RETURN i
END LengthKey ;
diff --git a/gcc/m2/gm2-compiler/P2SymBuild.mod b/gcc/m2/gm2-compiler/P2SymBuild.mod
index 502120346e19..17a6e1b71ca3 100644
--- a/gcc/m2/gm2-compiler/P2SymBuild.mod
+++ b/gcc/m2/gm2-compiler/P2SymBuild.mod
@@ -55,7 +55,7 @@ FROM SymbolTable IMPORT NulSym,
GetCurrentModule, GetMainModule,
MakeTemporary, CheckAnonymous, IsNameAnonymous,
MakeConstLit,
- MakeConstLitString,
+ MakeConstString,
MakeSubrange,
MakeVar, MakeType, PutType,
MakeModuleCtor,
@@ -87,7 +87,7 @@ FROM SymbolTable IMPORT NulSym,
MakeVarient, MakeFieldVarient,
MakeArray, PutArraySubscript,
MakeSubscript, PutSubscript,
- PutConstString, GetString,
+ PutConstStringKnown, GetString,
PutArray, IsArray,
GetType, SkipType,
IsProcType, MakeProcType,
@@ -790,7 +790,7 @@ BEGIN
THEN
stop
END ;
- Sym := MakeConstLitString (tok, makekey (string (Mark (Slice (Mark (InitStringCharStar (KeyToCharStar (name))), 1, -1))))) ;
+ Sym := MakeConstString (tok, makekey (string (Mark (Slice (Mark (InitStringCharStar (KeyToCharStar (name))), 1, -1))))) ;
PushTFtok (Sym, NulSym, tok) ;
Annotate ("%1s(%1d)|%3d||constant string")
END BuildString ;
@@ -3050,7 +3050,7 @@ BEGIN
CASE type OF
set : PutConstSet(Sym) |
- str : PutConstString(GetTokenNo(), Sym, MakeKey('')) |
+ str : PutConstStringKnown (GetTokenNo(), Sym, MakeKey(''), FALSE, FALSE) |
array,
constructor: PutConstructor(Sym) |
cast : PutConst(Sym, castType) |
diff --git a/gcc/m2/gm2-compiler/SymbolTable.def b/gcc/m2/gm2-compiler/SymbolTable.def
index 6cbc5c29fe42..508b818767ee 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.def
+++ b/gcc/m2/gm2-compiler/SymbolTable.def
@@ -37,335 +37,6 @@ FROM DynamicStrings IMPORT String ;
FROM M2Error IMPORT ErrorScope ;
FROM Lists IMPORT List ;
-EXPORT QUALIFIED NulSym,
- FinalSymbol,
-
- ModeOfAddr,
- GetMode, PutMode,
-
- AppendModuleOnImportStatement,
- AppendModuleImportStatement,
-
- StartScope, EndScope, PseudoScope,
- GetCurrentScope,
- IsDeclaredIn,
- CheckAnonymous, IsNameAnonymous,
-
- SetCurrentModule,
- SetMainModule,
- SetFileModule,
- MakeModule, MakeDefImp,
- MakeInnerModule, MakeModuleCtor, PutModuleCtorExtern,
- MakeProcedure,
- MakeProcedureCtorExtern,
- MakeConstant,
- MakeConstLit,
- MakeConstVar,
- MakeConstLitString,
- MakeConstString,
- MakeConstStringC, MakeConstStringCnul, MakeConstStringM2nul,
- MakeType,
- MakeHiddenType,
- MakeVar,
- MakeRecord,
- MakeVarient,
- MakeFieldVarient,
- MakeEnumeration,
- MakeSubrange,
- MakeSet,
- MakeArray,
- MakeTemporary,
- MakeComponentRecord,
- MakeComponentRef,
- IsComponent,
- MakePointer,
- MakeSubscript,
- MakeUnbounded,
- MakeOAFamily,
- MakeProcType,
- MakeImport, MakeImportStatement,
- Make2Tuple,
- MakeGnuAsm,
- MakeRegInterface,
- MakeError, MakeErrorS,
-
- ForeachModuleDo,
- ForeachInnerModuleDo,
- ForeachLocalSymDo,
- ForeachParamSymDo,
-
- ForeachFieldEnumerationDo,
- GetModule,
- GetCurrentModule,
- GetFileModule,
- GetMainModule,
- GetBaseModule,
- GetCurrentModuleScope,
- GetLastModuleScope,
- AddSymToModuleScope,
- GetType, GetLType, GetSType, GetDType,
- SkipType, SkipTypeAndSubrange,
- GetLowestType, GetTypeMode,
- GetSym, GetLocalSym, GetDeclareSym, GetRecord,
- FromModuleGetSym,
- GetOAFamily,
- GetDimension,
- GetNth,
- GetVarScope,
- GetSubrange,
- GetParam,
- GetString,
- GetStringLength,
- GetProcedureBuiltin,
- GetNthParam,
- GetNthProcedure,
- GetParameterShadowVar,
- GetUnbounded,
- GetUnboundedRecordType,
- GetUnboundedAddressOffset,
- GetUnboundedHighOffset,
- GetModuleQuads,
- PutModuleFinallyFunction, GetModuleFinallyFunction,
- PutExceptionBlock, HasExceptionBlock,
- PutExceptionFinally, HasExceptionFinally,
- GetProcedureQuads,
- GetQuads,
- GetReadQuads, GetWriteQuads,
- GetReadLimitQuads, GetWriteLimitQuads,
- GetDeclaredDef, GetDeclaredMod, PutDeclared,
- GetDeclaredDefinition, GetDeclaredModule,
- GetFirstUsed,
- PutProcedureBegin, PutProcedureEnd, GetProcedureBeginEnd,
- GetGnuAsmInput, GetGnuAsmOutput, GetGnuAsmTrash, GetGnuAsm,
- GetRegInterface,
- GetVariableAtAddress,
- GetAlignment, GetDefaultRecordFieldAlignment,
- PutDeclaredPacked, IsDeclaredPacked, IsDeclaredPackedResolved,
- GetPackedEquivalent, GetNonPackedEquivalent,
- GetConstStringM2, GetConstStringC, GetConstStringM2nul, GetConstStringCnul,
- GetModuleCtors,
- GetImportModule, GetImportDeclared,
- GetImportStatementList, GetModuleDefImportStatementList, GetModuleModImportStatementList,
-
- PutVar,
- PutVarConst,
- PutLeftValueFrontBackType,
- GetVarBackEndType,
- PutVarPointerCheck,
- GetVarPointerCheck,
- PutVarWritten,
- GetVarWritten,
- PutConst,
- PutConstString,
- PutDefLink,
- PutModLink,
- PutModuleBuiltin,
- PutVarArrayRef, IsVarArrayRef,
-
- PutConstSet,
- PutConstructor,
- PutConstructorFrom,
- PutFieldRecord,
- PutFieldVarient,
- GetVarient,
- GetVarientTag,
-
- PutVarientTag,
- IsRecordFieldAVarientTag,
- IsEmptyFieldVarient,
- PutFieldEnumeration,
- PutSubrange,
- PutSet, IsSetPacked,
- PutArraySubscript, GetArraySubscript,
- PutArray,
- PutArrayLarge, IsArrayLarge,
- PutType,
- PutFunction, PutOptFunction,
- PutParam, PutVarParam, PutParamName,
- PutProcTypeParam, PutProcTypeVarParam,
- PutPointer,
- PutSubscript,
- PutProcedureBuiltin, PutProcedureInline,
- PutModuleStartQuad,
- PutModuleEndQuad,
- PutModuleFinallyStartQuad,
- PutModuleFinallyEndQuad,
- PutProcedureStartQuad,
- PutProcedureEndQuad,
- PutProcedureScopeQuad,
- PutProcedureReachable,
- PutProcedureNoReturn, IsProcedureNoReturn,
- PutReadQuad, RemoveReadQuad,
- PutWriteQuad, RemoveWriteQuad,
- PutGnuAsm, PutGnuAsmOutput, PutGnuAsmInput, PutGnuAsmTrash,
- PutGnuAsmVolatile, PutGnuAsmSimple,
- PutRegInterface,
- PutVariableAtAddress,
- PutAlignment, PutDefaultRecordFieldAlignment,
- PutUnused, IsUnused,
- PutVariableSSA, IsVariableSSA,
- PutPublic, IsPublic, PutCtor, IsCtor, PutExtern, IsExtern,
- PutMonoName, IsMonoName,
- PutVarHeap, IsVarHeap,
-
- IsDefImp,
- IsModule,
- IsInnerModule,
- IsUnknown,
- IsPartialUnbounded,
- IsType,
- IsProcedure,
- IsParameter,
- IsParameterUnbounded,
- IsParameterVar,
- IsVarParam,
- IsUnboundedParam,
- IsPointer,
- IsRecord,
- IsVarient,
- IsFieldVarient,
- IsEnumeration,
- IsFieldEnumeration,
- IsUnbounded,
- IsArray,
- IsRecordField,
- IsProcType,
- IsImport,
- IsImportStatement,
- IsVar,
- IsVarConst,
- IsConst,
- IsConstString,
- IsConstStringM2, IsConstStringC, IsConstStringM2nul, IsConstStringCnul,
- IsConstLit,
- IsConstSet,
- IsConstructor,
- IsDummy,
- IsTemporary, IsVarAParam,
- IsSubscript,
- IsSubrange,
- IsSet,
- IsHiddenType,
- IsAModula2Type,
- IsGnuAsmVolatile, IsGnuAsmSimple, IsGnuAsm, IsRegInterface,
- IsError,
- IsObject,
- IsTuple,
- IsComposite,
-
- IsReallyPointer,
- IsLegal,
-
- IsProcedureReachable,
- IsProcedureVariable,
- IsProcedureNested,
- IsProcedureBuiltin, IsProcedureInline,
- IsModuleWithinProcedure,
- IsVariableAtAddress,
- IsReturnOptional,
- IsDefLink,
- IsModLink,
- IsModuleBuiltin,
- IsProcedureBuiltinAvailable,
-
- ForeachProcedureDo,
- ProcedureParametersDefined,
- AreProcedureParametersDefined,
- ParametersDefinedInDefinition,
- AreParametersDefinedInDefinition,
- ParametersDefinedInImplementation,
- AreParametersDefinedInImplementation,
-
- PutUseVarArgs,
- UsesVarArgs,
- PutUseOptArg,
- UsesOptArg,
- PutOptArgInit,
- GetOptArgInit,
- PutPriority,
- GetPriority,
- PutNeedSavePriority,
- GetNeedSavePriority,
-
- NoOfVariables,
- NoOfElements,
- NoOfParam,
- AddNameToImportList,
- AddNameToScope, ResolveImports,
- GetScope, GetModuleScope, GetProcedureScope,
- GetParent,
-
- GetSymName,
- RenameSym,
-
- RequestSym,
-
- GetExported,
- PutImported,
- PutIncluded,
- PutExported,
- PutExportQualified,
- PutExportUnQualified,
- PutExportUnImplemented,
- GetFromOuterModule,
- IsExportQualified,
- IsExportUnQualified,
- IsExported,
- IsImplicityExported,
- IsImported,
- PutIncludedByDefinition, IsIncludedByDefinition,
- TryMoveUndeclaredSymToInnerModule,
- ForeachImportedDo,
- ForeachExportedDo,
- ForeachOAFamily,
-
- CheckForExportedImplementation,
- CheckForUnImplementedExports,
- CheckForUndeclaredExports,
- CheckForUnknownInModule, UnknownReported,
- CheckHiddenTypeAreAddress,
-
- CheckForEnumerationInCurrentModule,
- PutHiddenTypeDeclared,
- IsHiddenTypeDeclared,
-
- PutDefinitionForC,
- IsDefinitionForC,
-
- PutDoesNeedExportList, PutDoesNotNeedExportList,
- DoesNotNeedExportList,
- ResolveConstructorTypes,
- MakeTemporaryFromExpression, MakeTemporaryFromExpressions,
- SanityCheckConstants,
-
- PutModuleContainsBuiltin, IsBuiltinInModule,
- HasVarParameters,
- GetErrorScope,
- GetLibName, PutLibName,
-
- IsSizeSolved,
- IsOffsetSolved,
- IsValueSolved,
- IsConstructorConstant,
- IsSumOfParamSizeSolved,
- PushSize,
- PushOffset,
- PushValue,
- PushParamSize,
- PushVarSize,
- PushSumOfLocalVarSize,
- PushSumOfParamSize,
- PopValue,
- PopSize,
- PopOffset,
- PopSumOfParamSize,
- DisplayTrees,
- DebugLineNumbers,
- VarCheckReadInit, VarInitState, PutVarInitialized,
- PutVarFieldInitialized, GetVarFieldInitialized,
- PrintInitialized,
- GetParameterHeapVar, PutProcedureParameterHeapVars ;
-
(*
Throughout this module any SymKey value of 0 is deemed to be a
@@ -787,35 +458,95 @@ PROCEDURE MakeConstLit (tok: CARDINAL; constName: Name; constType: CARDINAL) : C
(*
- MakeConstVar - makes a ConstVar type with
- name ConstVarName.
+ MakeConstVar - makes a ConstVar type with name ConstVarName.
*)
PROCEDURE MakeConstVar (tok: CARDINAL; ConstVarName: Name) : CARDINAL ;
(*
- MakeConstLitString - put a constant which has the string described by
- ConstName into the ConstantTree and return a symbol.
- This symbol is known as a String Constant rather than a
- ConstLit which indicates a number.
- If the constant already exits
- then a duplicate constant is not entered in the tree.
- All values of constant strings
- are ignored in Pass 1 and evaluated in Pass 2 via
- character manipulation.
+ MakeConstString - create a string constant in the symboltable.
*)
-PROCEDURE MakeConstLitString (tok: CARDINAL; ConstName: Name) : CARDINAL ;
+PROCEDURE MakeConstString (tok: CARDINAL; ConstName: Name) : CARDINAL ;
(*
- MakeConstString - puts a constant into the symboltable which is a string.
- The string value is unknown at this time and will be
- filled in later by PutString.
+ MakeConstStringCnul - creates a constant string nul terminated string suitable for C.
+ If known is TRUE then name is assigned to the contents
+ and the escape sequences will be converted into characters.
*)
-PROCEDURE MakeConstString (tok: CARDINAL; ConstName: Name) : CARDINAL ;
+PROCEDURE MakeConstStringCnul (tok: CARDINAL; name: Name; known: BOOLEAN) : CARDINAL ;
+
+
+(*
+ MakeConstStringM2nul - creates a constant string nul terminated string suitable for M2.
+ If known is TRUE then name is assigned to the contents
+ however the escape sequences are not converted into characters.
+*)
+
+PROCEDURE MakeConstStringM2nul (tok: CARDINAL; name: Name; known: BOOLEAN) : CARDINAL ;
+
+
+(*
+ PutConstStringKnown - if sym is a constvar then convert it into a conststring.
+ If known is FALSE then contents is ignored and NulName is
+ stored. If escape is TRUE then the contents will have
+ any escape sequences converted into single characters.
+*)
+
+PROCEDURE PutConstStringKnown (tok: CARDINAL; sym: CARDINAL;
+ contents: Name; escape, known: BOOLEAN) ;
+
+
+(*
+ CopyConstString - copies string contents from expr to des
+ and retain the kind of string.
+*)
+
+PROCEDURE CopyConstString (tok: CARDINAL; des, expr: CARDINAL) ;
+
+
+(*
+ IsConstStringKnown - returns TRUE if sym is a const string
+ and the contents are known.
+*)
+
+PROCEDURE IsConstStringKnown (sym: CARDINAL) : BOOLEAN ;
+
+
+(*
+ IsConstStringM2 - returns whether this conststring is a
+ Modula-2 string.
+*)
+
+PROCEDURE IsConstStringM2 (sym: CARDINAL) : BOOLEAN ;
+
+
+(*
+ IsConstStringC - returns whether this conststring is a C style string
+ which will have any escape translated.
+*)
+
+PROCEDURE IsConstStringC (sym: CARDINAL) : BOOLEAN ;
+
+
+(*
+ IsConstStringM2nul - returns whether this conststring is a Modula-2 string which
+ contains a nul terminator.
+*)
+
+PROCEDURE IsConstStringM2nul (sym: CARDINAL) : BOOLEAN ;
+
+
+(*
+ IsConstStringCnul - returns whether this conststring is a C style string
+ which will have any escape translated and also contains
+ a nul terminator.
+*)
+
+PROCEDURE IsConstStringCnul (sym: CARDINAL) : BOOLEAN ;
(*
@@ -1292,10 +1023,10 @@ PROCEDURE GetString (Sym: CARDINAL) : Name ;
(*
GetStringLength - returns the actual string length for ConstString
- symbol Sym.
+ symbol sym.
*)
-PROCEDURE GetStringLength (Sym: CARDINAL) : CARDINAL ;
+PROCEDURE GetStringLength (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
(*
@@ -1431,47 +1162,6 @@ PROCEDURE GetVarWritten (sym: CARDINAL) : BOOLEAN ;
PROCEDURE PutConst (Sym: CARDINAL; ConstType: CARDINAL) ;
-(*
- PutConstString - places contents into a constant symbol, sym.
- sym maybe a ConstString or a ConstVar. If the later is
- true then the ConstVar is converted to a ConstString.
-*)
-
-PROCEDURE PutConstString (tok: CARDINAL; sym: CARDINAL; contents: Name) ;
-
-
-(*
- GetConstStringM2 - returns the Modula-2 variant of a string
- (with no added nul terminator).
-*)
-
-PROCEDURE GetConstStringM2 (sym: CARDINAL) : CARDINAL ;
-
-
-(*
- GetConstStringC - returns the C variant of a string
- (with no added nul terminator).
-*)
-
-PROCEDURE GetConstStringC (sym: CARDINAL) : CARDINAL ;
-
-
-(*
- GetConstStringM2nul - returns the Modula-2 variant of a string
- (with added nul terminator).
-*)
-
-PROCEDURE GetConstStringM2nul (sym: CARDINAL) : CARDINAL ;
-
-
-(*
- GetConstStringCnul - returns the C variant of a string
- (with no added nul terminator).
-*)
-
-PROCEDURE GetConstStringCnul (sym: CARDINAL) : CARDINAL ;
-
-
(*
PutConstSet - informs the constant symbol, sym, that it is or will contain
a set value.
@@ -2910,38 +2600,6 @@ PROCEDURE IsConst (Sym: CARDINAL) : BOOLEAN ;
PROCEDURE IsConstString (sym: CARDINAL) : BOOLEAN ;
-(*
- IsConstStringM2 - returns whether this conststring is an unaltered Modula-2 string.
-*)
-
-PROCEDURE IsConstStringM2 (sym: CARDINAL) : BOOLEAN ;
-
-
-(*
- IsConstStringC - returns whether this conststring is a C style string
- which will have any escape translated.
-*)
-
-PROCEDURE IsConstStringC (sym: CARDINAL) : BOOLEAN ;
-
-
-(*
- IsConstStringM2nul - returns whether this conststring is a Modula-2 string which
- contains a nul terminator.
-*)
-
-PROCEDURE IsConstStringM2nul (sym: CARDINAL) : BOOLEAN ;
-
-
-(*
- IsConstStringCnul - returns whether this conststring is a C style string
- which will have any escape translated and also contains
- a nul terminator.
-*)
-
-PROCEDURE IsConstStringCnul (sym: CARDINAL) : BOOLEAN ;
-
-
(*
IsConstStringNulTerminated - returns TRUE if the constant string, sym,
should be created with a nul terminator.
@@ -2950,33 +2608,6 @@ PROCEDURE IsConstStringCnul (sym: CARDINAL) : BOOLEAN ;
PROCEDURE IsConstStringNulTerminated (sym: CARDINAL) : BOOLEAN ;
-(*
- MakeConstStringCnul - creates a constant string nul terminated string suitable for C.
- sym is a ConstString and a new symbol is returned
- with the escape sequences converted into characters.
-*)
-
-PROCEDURE MakeConstStringCnul (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
-
-
-(*
- MakeConstStringM2nul - creates a constant string nul terminated string.
- sym is a ConstString and a new symbol is returned.
-*)
-
-PROCEDURE MakeConstStringM2nul (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
-
-
-(*
- MakeConstStringC - creates a constant string suitable for C.
- sym is a Modula-2 ConstString and a new symbol is returned
- with the escape sequences converted into characters.
- It is not nul terminated.
-*)
-
-PROCEDURE MakeConstStringC (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
-
-
(*
IsConstLit - returns true if Sym is a literal constant.
*)
diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod
index 7cef7ee1e438..6fe36da0bbca 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.mod
+++ b/gcc/m2/gm2-compiler/SymbolTable.mod
@@ -112,7 +112,7 @@ CONST
UnboundedAddressName = "_m2_contents" ;
UnboundedHighName = "_m2_high_%d" ;
- BreakSym = 5293 ;
+ BreakSym = 8496 ;
TYPE
ConstLitPoolEntry = POINTER TO RECORD
@@ -475,11 +475,8 @@ TYPE
(* of const. *)
Contents : Name ; (* Contents of the string. *)
Length : CARDINAL ; (* StrLen (Contents) *)
- M2Variant,
- NulM2Variant,
- CVariant,
- NulCVariant : CARDINAL ; (* variants of the same string *)
StringVariant : ConstStringVariant ;
+ Known : BOOLEAN ; (* Is Contents known? *)
Scope : CARDINAL ; (* Scope of declaration. *)
At : Where ; (* Where was sym declared/used *)
END ;
@@ -875,9 +872,6 @@ VAR
FreeSymbol : CARDINAL ; (* The next free symbol indice. *)
DefModuleTree : SymbolTree ;
ModuleTree : SymbolTree ; (* Tree of all modules ever used. *)
- ConstLitStringTree
- : SymbolTree ; (* String Literal Constants only need *)
- (* to be declared once. *)
CurrentModule : CARDINAL ; (* Index into symbols determining the *)
(* current module being compiled. *)
(* This maybe an inner module. *)
@@ -924,12 +918,12 @@ VAR
PROCEDURE CheckAnonymous (name: Name) : Name ;
BEGIN
- IF name=NulName
+ IF name = NulName
THEN
- INC(AnonymousName) ;
- name := makekey(string(Mark(Sprintf1(Mark(InitString('$$%d')), AnonymousName))))
+ INC (AnonymousName) ;
+ name := makekey (string (Mark (Sprintf1 (Mark (InitString ('__anon%d')), AnonymousName))))
END ;
- RETURN( name )
+ RETURN name
END CheckAnonymous ;
@@ -940,7 +934,7 @@ END CheckAnonymous ;
PROCEDURE IsNameAnonymous (sym: CARDINAL) : BOOLEAN ;
VAR
- a: ARRAY [0..1] OF CHAR ;
+ a: ARRAY [0..5] OF CHAR ;
n: Name ;
BEGIN
n := GetSymName(sym) ;
@@ -949,7 +943,7 @@ BEGIN
RETURN( TRUE )
ELSE
GetKey(n, a) ;
- RETURN( StrEqual(a, '$$') )
+ RETURN( StrEqual(a, '__anon') )
END
END IsNameAnonymous ;
@@ -1647,7 +1641,6 @@ BEGIN
AnonymousName := 0 ;
CurrentError := NIL ;
InitTree (ConstLitPoolTree) ;
- InitTree (ConstLitStringTree) ;
InitTree (DefModuleTree) ;
InitTree (ModuleTree) ;
Symbols := InitIndex (1) ;
@@ -4990,7 +4983,10 @@ PROCEDURE MakeConstVar (tok: CARDINAL; ConstVarName: Name) : CARDINAL ;
VAR
pSym: PtrToSymbol ;
Sym : CARDINAL ;
+ temp: BOOLEAN ;
BEGIN
+ temp := (ConstVarName = NulName) ;
+ ConstVarName := CheckAnonymous (ConstVarName) ;
Sym := DeclareSym (tok, ConstVarName) ;
IF NOT IsError(Sym)
THEN
@@ -5005,7 +5001,7 @@ BEGIN
IsConstructor := FALSE ;
FromType := NulSym ; (* type is determined FromType *)
UnresFromType := FALSE ; (* is Type resolved? *)
- IsTemp := FALSE ;
+ IsTemp := temp ;
Scope := GetCurrentScope () ;
InitWhereDeclaredTok (tok, At)
END
@@ -5018,82 +5014,11 @@ END MakeConstVar ;
(*
- MakeConstLitString - put a constant which has the string described by
- ConstName into the ConstantTree.
- The symbol number is returned.
- This symbol is known as a String Constant rather than a
- ConstLit which indicates a number.
- If the constant already exits
- then a duplicate constant is not entered in the tree.
- All values of constant strings
- are ignored in Pass 1 and evaluated in Pass 2 via
- character manipulation.
- In this procedure ConstName is the string.
-*)
-
-PROCEDURE MakeConstLitString (tok: CARDINAL; ConstName: Name) : CARDINAL ;
-VAR
- pSym: PtrToSymbol ;
- sym : CARDINAL ;
-BEGIN
- sym := GetSymKey (ConstLitStringTree, ConstName) ;
- IF sym=NulSym
- THEN
- NewSym (sym) ;
- PutSymKey (ConstLitStringTree, ConstName, sym) ;
- pSym := GetPsym (sym) ;
- WITH pSym^ DO
- SymbolType := ConstStringSym ;
- CASE SymbolType OF
-
- ConstStringSym: InitConstString (tok, sym, ConstName, ConstName,
- m2str,
- sym, NulSym, NulSym, NulSym)
-
- ELSE
- InternalError ('expecting ConstString symbol')
- END
- END
- END ;
- RETURN sym
-END MakeConstLitString ;
-
-
-(*
- BackFillString -
-*)
-
-PROCEDURE BackFillString (sym, m2sym, m2nulsym, csym, cnulsym: CARDINAL) ;
-VAR
- pSym: PtrToSymbol ;
-BEGIN
- IF sym # NulSym
- THEN
- pSym := GetPsym (sym) ;
- WITH pSym^ DO
- CASE SymbolType OF
-
- ConstStringSym: ConstString.M2Variant := m2sym ;
- ConstString.NulM2Variant := m2nulsym ;
- ConstString.CVariant := csym ;
- ConstString.NulCVariant := cnulsym
-
- ELSE
- InternalError ('expecting ConstStringSym')
- END
- END
- END
-END BackFillString ;
-
-
-(*
- InitConstString - initialize the constant string and back fill any
- previous string variants.
+ InitConstString - initialize the constant string.
*)
PROCEDURE InitConstString (tok: CARDINAL; sym: CARDINAL; name, contents: Name;
- kind: ConstStringVariant;
- m2sym, m2nulsym, csym, cnulsym: CARDINAL) ;
+ kind: ConstStringVariant; escape, known: BOOLEAN) ;
VAR
pSym: PtrToSymbol ;
BEGIN
@@ -5104,19 +5029,9 @@ BEGIN
ConstStringSym: ConstString.name := name ;
ConstString.StringVariant := kind ;
- PutConstString (tok, sym, contents) ;
- BackFillString (sym,
- m2sym, m2nulsym, csym, cnulsym) ;
- BackFillString (m2sym,
- m2sym, m2nulsym, csym, cnulsym) ;
- BackFillString (m2nulsym,
- m2sym, m2nulsym, csym, cnulsym) ;
- BackFillString (csym,
- m2sym, m2nulsym, csym, cnulsym) ;
- BackFillString (cnulsym,
- m2sym, m2nulsym, csym, cnulsym) ;
ConstString.Scope := GetCurrentScope() ;
- InitWhereDeclaredTok (tok, ConstString.At)
+ InitWhereDeclaredTok (tok, ConstString.At) ;
+ PutConstStringKnown (tok, sym, contents, escape, known)
ELSE
InternalError ('expecting ConstStringSym')
@@ -5126,33 +5041,10 @@ END InitConstString ;
(*
- GetConstStringM2 - returns the Modula-2 variant of a string
- (with no added nul terminator).
-*)
-
-PROCEDURE GetConstStringM2 (sym: CARDINAL) : CARDINAL ;
-VAR
- pSym: PtrToSymbol ;
-BEGIN
- pSym := GetPsym (sym) ;
- WITH pSym^ DO
- CASE SymbolType OF
-
- ConstStringSym: RETURN ConstString.M2Variant
-
- ELSE
- InternalError ('expecting ConstStringSym')
- END
- END
-END GetConstStringM2 ;
-
-
-(*
- GetConstStringC - returns the C variant of a string
- (with no added nul terminator).
+ GetConstString - returns the contents of a string constant.
*)
-PROCEDURE GetConstStringC (sym: CARDINAL) : CARDINAL ;
+PROCEDURE GetConstStringContent (sym: CARDINAL) : Name ;
VAR
pSym: PtrToSymbol ;
BEGIN
@@ -5160,57 +5052,13 @@ BEGIN
WITH pSym^ DO
CASE SymbolType OF
- ConstStringSym: RETURN ConstString.CVariant
+ ConstStringSym: RETURN ConstString.Contents
ELSE
InternalError ('expecting ConstStringSym')
END
END
-END GetConstStringC ;
-
-
-(*
- GetConstStringM2nul - returns the Modula-2 variant of a string
- (with added nul terminator).
-*)
-
-PROCEDURE GetConstStringM2nul (sym: CARDINAL) : CARDINAL ;
-VAR
- pSym: PtrToSymbol ;
-BEGIN
- pSym := GetPsym (sym) ;
- WITH pSym^ DO
- CASE SymbolType OF
-
- ConstStringSym: RETURN ConstString.NulM2Variant
-
- ELSE
- InternalError ('expecting ConstStringSym')
- END
- END
-END GetConstStringM2nul ;
-
-
-(*
- GetConstStringCnul - returns the C variant of a string
- (with no added nul terminator).
-*)
-
-PROCEDURE GetConstStringCnul (sym: CARDINAL) : CARDINAL ;
-VAR
- pSym: PtrToSymbol ;
-BEGIN
- pSym := GetPsym (sym) ;
- WITH pSym^ DO
- CASE SymbolType OF
-
- ConstStringSym: RETURN ConstString.NulCVariant
-
- ELSE
- InternalError ('expecting ConstStringSym')
- END
- END
-END GetConstStringCnul ;
+END GetConstStringContent ;
(*
@@ -5238,176 +5086,133 @@ END IsConstStringNulTerminated ;
(*
MakeConstStringCnul - creates a constant string nul terminated string suitable for C.
- sym is a ConstString and a new symbol is returned
- with the escape sequences converted into characters.
+ If known is TRUE then name is assigned to the contents
+ and the escape sequences will be converted into characters.
*)
-PROCEDURE MakeConstStringCnul (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
+PROCEDURE MakeConstStringCnul (tok: CARDINAL; name: Name; known: BOOLEAN) : CARDINAL ;
VAR
- pSym : PtrToSymbol ;
newstr: CARDINAL ;
BEGIN
- pSym := GetPsym (GetConstStringM2 (sym)) ;
- WITH pSym^ DO
- CASE SymbolType OF
-
- ConstStringSym: Assert (ConstString.StringVariant = m2str) ;
- ConstString.CVariant := MakeConstStringC (tok, sym) ;
- IF ConstString.NulCVariant = NulSym
- THEN
- NewSym (newstr) ;
- ConstString.NulCVariant := newstr ;
- InitConstString (tok, newstr, ConstString.name, GetString (ConstString.CVariant),
- cnulstr,
- ConstString.M2Variant, ConstString.NulM2Variant, ConstString.CVariant, ConstString.NulCVariant)
- END ;
- RETURN ConstString.NulCVariant
-
- ELSE
- InternalError ('expecting ConstStringSym')
- END
- END
+ NewSym (newstr) ;
+ InitConstString (tok, newstr, name, name, cnulstr, TRUE, known) ;
+ RETURN newstr
END MakeConstStringCnul ;
(*
- MakeConstStringM2nul - creates a constant string nul terminated string.
- sym is a ConstString and a new symbol is returned.
+ MakeConstStringM2nul - creates a constant string nul terminated string suitable for M2.
+ If known is TRUE then name is assigned to the contents
+ however the escape sequences are not converted into characters.
*)
-PROCEDURE MakeConstStringM2nul (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
+PROCEDURE MakeConstStringM2nul (tok: CARDINAL; name: Name; known: BOOLEAN) : CARDINAL ;
VAR
- pSym: PtrToSymbol ;
+ newstr: CARDINAL ;
BEGIN
- pSym := GetPsym (GetConstStringM2 (sym)) ;
- WITH pSym^ DO
- CASE SymbolType OF
-
- ConstStringSym: Assert (ConstString.StringVariant = m2str) ;
- IF ConstString.NulM2Variant = NulSym
- THEN
- NewSym (ConstString.NulM2Variant) ;
- InitConstString (tok, ConstString.NulM2Variant,
- ConstString.name, ConstString.Contents,
- m2nulstr,
- ConstString.M2Variant, ConstString.NulM2Variant,
- ConstString.CVariant, ConstString.NulCVariant)
- END ;
- RETURN ConstString.NulM2Variant
-
- ELSE
- InternalError ('expecting ConstStringSym')
- END
- END
+ NewSym (newstr) ;
+ InitConstString (tok, newstr, name, name, m2nulstr, FALSE, known) ;
+ RETURN newstr
END MakeConstStringM2nul ;
(*
- MakeConstStringC - creates a constant string suitable for C.
- sym is a Modula-2 ConstString and a new symbol is returned
- with the escape sequences converted into characters.
- It is not nul terminated.
+ MakeConstString - create a string constant in the symboltable.
*)
-PROCEDURE MakeConstStringC (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
+PROCEDURE MakeConstString (tok: CARDINAL; ConstName: Name) : CARDINAL ;
VAR
- pSym : PtrToSymbol ;
- s : String ;
+ newstr: CARDINAL ;
BEGIN
- pSym := GetPsym (sym) ;
- WITH pSym^ DO
- CASE SymbolType OF
-
- ConstStringSym: IF ConstString.StringVariant = cstr
- THEN
- RETURN sym (* this is already the C variant. *)
- ELSIF ConstString.CVariant = NulSym
- THEN
- Assert (ConstString.StringVariant = m2str) ; (* we can only derive string variants from Modula-2 strings. *)
- Assert (sym = ConstString.M2Variant) ;
- (* we need to create a new one and return the new symbol. *)
- s := HandleEscape (InitStringCharStar (KeyToCharStar (GetString (ConstString.M2Variant)))) ;
- NewSym (ConstString.CVariant) ;
- InitConstString (tok, ConstString.CVariant, ConstString.name, makekey (string (s)),
- cstr,
- ConstString.M2Variant, ConstString.NulM2Variant, ConstString.CVariant, ConstString.NulCVariant) ;
- s := KillString (s)
- END ;
- RETURN ConstString.CVariant
-
- ELSE
- InternalError ('expecting ConstStringSym')
- END
- END
-END MakeConstStringC ;
+ NewSym (newstr) ;
+ InitConstString (tok, newstr, ConstName, ConstName, m2nulstr, FALSE, TRUE) ;
+ RETURN newstr
+END MakeConstString ;
(*
- MakeConstString - puts a constant into the symboltable which is a string.
- The string value is unknown at this time and will be
- filled in later by PutString.
+ PutConstStringKnown - if sym is a constvar then convert it into a conststring.
+ If known is FALSE then contents is ignored and NulName is
+ stored. If escape is TRUE then the contents will have
+ any escape sequences converted into single characters.
*)
-PROCEDURE MakeConstString (tok: CARDINAL; ConstName: Name) : CARDINAL ;
+PROCEDURE PutConstStringKnown (tok: CARDINAL; sym: CARDINAL;
+ contents: Name; escape, known: BOOLEAN) ;
VAR
pSym: PtrToSymbol ;
- sym : CARDINAL ;
+ s : String ;
BEGIN
- NewSym (sym) ;
- PutSymKey (ConstLitStringTree, ConstName, sym) ;
pSym := GetPsym (sym) ;
WITH pSym^ DO
- SymbolType := ConstStringSym ;
CASE SymbolType OF
- ConstStringSym : InitConstString (tok, sym, ConstName, NulName,
- m2str, sym, NulSym, NulSym, NulSym)
+ ConstStringSym: IF known
+ THEN
+ IF escape
+ THEN
+ s := HandleEscape (InitStringCharStar (KeyToCharStar (contents))) ;
+ contents := makekey (string (s)) ;
+ s := KillString (s)
+ END ;
+ ConstString.Length := LengthKey (contents) ;
+ ConstString.Contents := contents
+ ELSE
+ ConstString.Length := 0 ;
+ ConstString.Contents := NulName
+ END ;
+ ConstString.Known := known ;
+ InitWhereDeclaredTok (tok, ConstString.At) ;
+ InitWhereFirstUsedTok (tok, ConstString.At) |
+
+ ConstVarSym : (* Change a ConstVar to a ConstString copy name
+ and alter symboltype. *)
+ InitConstString (tok, sym, ConstVar.name, contents,
+ m2str, escape, known)
ELSE
InternalError ('expecting ConstString symbol')
END
- END ;
- RETURN sym
-END MakeConstString ;
+ END
+END PutConstStringKnown ;
(*
- PutConstString - places a string, String, into a constant symbol, Sym.
- Sym maybe a ConstString or a ConstVar. If the later is
- true then the ConstVar is converted to a ConstString.
+ CopyConstString - copies string contents from expr to des
+ and retain the kind of string.
*)
-PROCEDURE PutConstString (tok: CARDINAL; sym: CARDINAL; contents: Name) ;
+PROCEDURE CopyConstString (tok: CARDINAL; des, expr: CARDINAL) ;
VAR
pSym: PtrToSymbol ;
BEGIN
- pSym := GetPsym (sym) ;
+ Assert (IsConstStringKnown (expr)) ;
+ pSym := GetPsym (des) ;
WITH pSym^ DO
CASE SymbolType OF
- ConstStringSym: ConstString.Length := LengthKey (contents) ;
- ConstString.Contents := contents ;
- InitWhereDeclaredTok (tok, ConstString.At) ;
- InitWhereFirstUsedTok (tok, ConstString.At) |
-
- ConstVarSym : (* ok altering this to ConstString *)
- (* copy name and alter symbol. *)
- InitConstString (tok, sym, ConstVar.name, contents,
- m2str,
- sym, NulSym, NulSym, NulSym)
+ ConstStringSym: InitConstString (tok, des, ConstString.name,
+ GetString (expr),
+ GetConstStringKind (expr), FALSE, TRUE) |
+ ConstVarSym : (* Change a ConstVar to a ConstString copy name
+ and alter symboltype. *)
+ InitConstString (tok, des, ConstVar.name,
+ GetString (expr),
+ GetConstStringKind (expr), FALSE, TRUE)
ELSE
- InternalError ('expecting ConstString or ConstVar symbol')
+ InternalError ('expecting ConstString symbol')
END
END
-END PutConstString ;
+END CopyConstString ;
(*
- IsConstStringM2 - returns whether this conststring is an unaltered Modula-2 string.
+ IsConstStringKnown - returns TRUE if sym is a const string
+ and the contents are known.
*)
-PROCEDURE IsConstStringM2 (sym: CARDINAL) : BOOLEAN ;
+PROCEDURE IsConstStringKnown (sym: CARDINAL) : BOOLEAN ;
VAR
pSym: PtrToSymbol ;
BEGIN
@@ -5415,12 +5220,23 @@ BEGIN
WITH pSym^ DO
CASE SymbolType OF
- ConstStringSym: RETURN ConstString.StringVariant = m2str
+ ConstStringSym: RETURN ConstString.Known
ELSE
- InternalError ('expecting ConstString symbol')
+ RETURN FALSE
END
END
+END IsConstStringKnown ;
+
+
+(*
+ IsConstStringM2 - returns whether this conststring is a
+ Modula-2 string.
+*)
+
+PROCEDURE IsConstStringM2 (sym: CARDINAL) : BOOLEAN ;
+BEGIN
+ RETURN GetConstStringKind (sym) = m2str
END IsConstStringM2 ;
@@ -5430,19 +5246,8 @@ END IsConstStringM2 ;
*)
PROCEDURE IsConstStringC (sym: CARDINAL) : BOOLEAN ;
-VAR
- pSym: PtrToSymbol ;
BEGIN
- pSym := GetPsym (sym) ;
- WITH pSym^ DO
- CASE SymbolType OF
-
- ConstStringSym: RETURN ConstString.StringVariant = cstr
-
- ELSE
- InternalError ('expecting ConstString symbol')
- END
- END
+ RETURN GetConstStringKind (sym) = cstr
END IsConstStringC ;
@@ -5452,19 +5257,8 @@ END IsConstStringC ;
*)
PROCEDURE IsConstStringM2nul (sym: CARDINAL) : BOOLEAN ;
-VAR
- pSym: PtrToSymbol ;
BEGIN
- pSym := GetPsym (sym) ;
- WITH pSym^ DO
- CASE SymbolType OF
-
- ConstStringSym: RETURN ConstString.StringVariant = m2nulstr
-
- ELSE
- InternalError ('expecting ConstString symbol')
- END
- END
+ RETURN GetConstStringKind (sym) = m2nulstr
END IsConstStringM2nul ;
@@ -5475,6 +5269,16 @@ END IsConstStringM2nul ;
*)
PROCEDURE IsConstStringCnul (sym: CARDINAL) : BOOLEAN ;
+BEGIN
+ RETURN GetConstStringKind (sym) = cnulstr
+END IsConstStringCnul ;
+
+
+(*
+ GetConstStringKind - return the StringVariant field associated with sym.
+*)
+
+PROCEDURE GetConstStringKind (sym: CARDINAL) : ConstStringVariant ;
VAR
pSym: PtrToSymbol ;
BEGIN
@@ -5482,13 +5286,14 @@ BEGIN
WITH pSym^ DO
CASE SymbolType OF
- ConstStringSym: RETURN ConstString.StringVariant = cnulstr
+ ConstStringSym: RETURN ConstString.StringVariant
ELSE
InternalError ('expecting ConstString symbol')
END
END
-END IsConstStringCnul ;
+END GetConstStringKind ;
+
(*
@@ -5504,7 +5309,12 @@ BEGIN
WITH pSym^ DO
CASE SymbolType OF
- ConstStringSym: RETURN ConstString.Contents
+ ConstStringSym: IF ConstString.Known
+ THEN
+ RETURN ConstString.Contents
+ ELSE
+ InternalError ('const string contents are unknown')
+ END
ELSE
InternalError ('expecting ConstString symbol')
@@ -5517,15 +5327,21 @@ END GetString ;
GetStringLength - returns the length of the string symbol Sym.
*)
-PROCEDURE GetStringLength (Sym: CARDINAL) : CARDINAL ;
+PROCEDURE GetStringLength (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
VAR
pSym: PtrToSymbol ;
BEGIN
- pSym := GetPsym (Sym) ;
+ pSym := GetPsym (sym) ;
WITH pSym^ DO
CASE SymbolType OF
- ConstStringSym: RETURN ConstString.Length
+ ConstStringSym: IF ConstString.Known
+ THEN
+ RETURN ConstString.Length
+ ELSE
+ MetaErrorT0 (tok, 'const string contents are unknown') ;
+ RETURN 0
+ END
ELSE
InternalError ('expecting ConstString symbol')
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc2.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc2.mod
new file mode 100644
index 000000000000..c408b2d6ffc9
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc2.mod
@@ -0,0 +1,7 @@
+MODULE callingc2 ;
+
+FROM libc IMPORT printf ;
+
+BEGIN
+ printf ("\n") ;
+END callingc2.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc3.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc3.mod
new file mode 100644
index 000000000000..48081ba3108a
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc3.mod
@@ -0,0 +1,13 @@
+MODULE callingc3 ;
+
+FROM libc IMPORT exit ;
+FROM StrLib IMPORT StrLen ;
+
+VAR
+ a: ARRAY [0..1] OF CHAR ;
+BEGIN
+ IF StrLen ("\n") # 2
+ THEN
+ exit (1)
+ END
+END callingc3.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc4.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc4.mod
new file mode 100644
index 000000000000..4ab3471f7633
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc4.mod
@@ -0,0 +1,10 @@
+MODULE callingc4 ;
+
+FROM libc IMPORT printf, exit ;
+FROM StrLib IMPORT StrLen ;
+
+VAR
+ a: ARRAY [0..1] OF CHAR ;
+BEGIN
+ a := "\n"
+END callingc4.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc5.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc5.mod
new file mode 100644
index 000000000000..a331970505ed
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc5.mod
@@ -0,0 +1,10 @@
+MODULE callingc5 ;
+
+FROM libc IMPORT printf, exit ;
+FROM StrLib IMPORT StrLen ;
+
+VAR
+ a: ARRAY [0..1] OF CHAR ;
+BEGIN
+ a := "a"
+END callingc5.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc6.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc6.mod
new file mode 100644
index 000000000000..850bd6c81341
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc6.mod
@@ -0,0 +1,10 @@
+MODULE callingc6 ;
+
+FROM libc IMPORT printf, exit ;
+FROM StrLib IMPORT StrLen ;
+
+VAR
+ tinyarray: ARRAY [0..1] OF CHAR ;
+BEGIN
+ tinyarray := "ab"
+END callingc6.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc7.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc7.mod
new file mode 100644
index 000000000000..029df6a7a2c5
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc7.mod
@@ -0,0 +1,10 @@
+MODULE callingc7 ;
+
+FROM libc IMPORT printf, exit ;
+FROM StrLib IMPORT StrLen ;
+
+VAR
+ tinyarray: ARRAY [0..1] OF CHAR ;
+BEGIN
+ tinyarray := "b"
+END callingc7.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc8.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc8.mod
new file mode 100644
index 000000000000..98a2df0f8319
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc8.mod
@@ -0,0 +1,10 @@
+MODULE callingc8 ;
+
+FROM libc IMPORT printf, exit ;
+FROM StrLib IMPORT StrLen ;
+
+VAR
+ tinyarray: ARRAY [0..1] OF CHAR ;
+BEGIN
+ tinyarray := "ab"
+END callingc8.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/fixedarray.mod b/gcc/testsuite/gm2/extensions/run/pass/fixedarray.mod
new file mode 100644
index 000000000000..d3155ff1a94b
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/fixedarray.mod
@@ -0,0 +1,7 @@
+MODULE fixedarray ;
+
+VAR
+ array: ARRAY [0..9] OF CHAR ;
+BEGIN
+ array := "0123456789"
+END fixedarray.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/fixedarray2.mod b/gcc/testsuite/gm2/extensions/run/pass/fixedarray2.mod
new file mode 100644
index 000000000000..7067a5a90ce5
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/fixedarray2.mod
@@ -0,0 +1,7 @@
+MODULE fixedarray2 ;
+
+VAR
+ array: ARRAY [0..9] OF CHAR ;
+BEGIN
+ array := "012345678"
+END fixedarray2.
diff --git a/gcc/testsuite/gm2/pim/run/pass/constdef.def b/gcc/testsuite/gm2/pim/run/pass/constdef.def
new file mode 100644
index 000000000000..7c00390381b7
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/run/pass/constdef.def
@@ -0,0 +1,6 @@
+DEFINITION MODULE constdef ; (*!m2iso+gm2*)
+
+CONST
+ StrConst = 'hello' ;
+
+END constdef.
diff --git a/gcc/testsuite/gm2/pim/run/pass/constdef.mod b/gcc/testsuite/gm2/pim/run/pass/constdef.mod
new file mode 100644
index 000000000000..cfdcb86f9b58
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/run/pass/constdef.mod
@@ -0,0 +1,3 @@
+IMPLEMENTATION MODULE constdef ; (*!m2iso+gm2*)
+
+END constdef.
diff --git a/gcc/testsuite/gm2/pim/run/pass/pim-run-pass.exp b/gcc/testsuite/gm2/pim/run/pass/pim-run-pass.exp
index 00e9ab622bb1..a2369f28730d 100644
--- a/gcc/testsuite/gm2/pim/run/pass/pim-run-pass.exp
+++ b/gcc/testsuite/gm2/pim/run/pass/pim-run-pass.exp
@@ -27,18 +27,20 @@ load_lib gm2-torture.exp
set gm2src ${srcdir}/../m2
gm2_init_pim "${srcdir}/gm2/pim/run/pass"
-gm2_link_obj "sys.o"
+gm2_link_obj "sys.o constdef.o"
foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.mod]] {
set output [gm2_target_compile $srcdir/$subdir/sys.mod sys.o object "-g -I$srcdir/../m2/gm2-libs -I$srcdir/$subdir -I$srcdir/../m2/gm2-compiler -I../m2/gm2-libs -I../m2/gm2-compiler -fpim"]
+ set output [gm2_target_compile $srcdir/$subdir/constdef.mod constdef.o object "-g -I$srcdir/../m2/gm2-libs -I$srcdir/$subdir -I$srcdir/../m2/gm2-compiler -I../m2/gm2-libs -I../m2/gm2-compiler -fpim"]
# If we're only testing specific files and this isn't one of them, skip it.
if ![runtest_file_p $runtests $testcase] then {
continue
}
- if { $testcase != "$srcdir/$subdir/sys.mod" } {
+ if { $testcase != "$srcdir/$subdir/sys.mod"
+ && $testcase != "$srcdir/$subdir/constdef.mod" } {
gm2-torture-execute $testcase "" "pass"
}
}
diff --git a/gcc/testsuite/gm2/pim/run/pass/testimportconst.mod b/gcc/testsuite/gm2/pim/run/pass/testimportconst.mod
new file mode 100644
index 000000000000..8abe8878b5f5
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/run/pass/testimportconst.mod
@@ -0,0 +1,26 @@
+MODULE testimportconst ; (*!m2iso+gm2*)
+
+FROM StrLib IMPORT StrEqual ;
+FROM libc IMPORT printf ;
+FROM constdef IMPORT StrConst ;
+IMPORT constdef ;
+
+
+PROCEDURE init ;
+BEGIN
+ IF NOT StrEqual (StrConst, 'hello')
+ THEN
+ printf ("failed to import 'hello' from constdef\n");
+ HALT (1)
+ END ;
+ IF NOT StrEqual (constdef.StrConst, 'hello')
+ THEN
+ printf ("failed constdef.StrConst does not equal 'hello'\n");
+ HALT (2)
+ END
+END init ;
+
+
+BEGIN
+ init
+END testimportconst.
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2024-02-19 13:02 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-02-19 13:02 [gcc r14-9063] PR modula2/113889 Incorrect constant string value if declared in a definition module Gaius Mulley
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).