From 78b72ee5a80f45bd761a55006e2b3fc2cbe749bc Mon Sep 17 00:00:00 2001 From: Gaius Mulley Date: Mon, 19 Feb 2024 12:59:36 +0000 Subject: 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 --- 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 +++++++++--------------------- 11 files changed, 621 insertions(+), 951 deletions(-) (limited to 'gcc/m2') diff --git a/gcc/m2/gm2-compiler/M2ALU.mod b/gcc/m2/gm2-compiler/M2ALU.mod index 938124a..58d4b5c 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 d72924d..b50b591 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 dae5a6b..6f0a749 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 @@ -1972,6 +1976,29 @@ 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 todolist. @@ -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 @@ -4055,12 +4072,44 @@ 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 25bfbf8..c7581f8 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 Addr Sym2 meaning Mem[Sym1] := Sym2 +(* + 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 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 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 character. *) + length := BuildAdd (location, FindSize (tokenno, src), + GetIntegerOne (location), FALSE) ; + srcTree := Mod2Gcc (src) + ELSE + (* We need to truncate the 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)) @@ -3913,6 +4034,18 @@ 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 XIndr Sym2 Meaning Mem[constant] := Mem[Sym3] - Sym1 XIndr Sym2 Meaning Mem[Mem[Sym1]] := Mem[Sym3] - - (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 acc49c8..e9fd122 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 a23fa32..e40e07d 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 ; @@ -2582,6 +2585,34 @@ 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 ca0f300..0b23e53 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 7811672..e2260a4 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 5021203..17a6e1b 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 6cbc5c2..508b818 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 ; (* @@ -1432,47 +1163,6 @@ 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. *) @@ -2911,38 +2601,6 @@ 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. *) @@ -2951,33 +2609,6 @@ 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 7cef7ee..6fe36da 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') -- cgit v1.1