diff options
| author | Gaius Mulley <gaiusmod2@gmail.com> | 2023-05-12 00:15:28 +0100 |
|---|---|---|
| committer | Gaius Mulley <gaiusmod2@gmail.com> | 2023-05-12 00:15:28 +0100 |
| commit | c787f593e62869ae0b230949b4791f4f3a26e50e (patch) | |
| tree | 55bb404358049d4fcc0fea6c5a72ab8bdf671a12 /gcc/m2 | |
| parent | 02777f20be4f40160f1b4ed34fa59ba75245b5b7 (diff) | |
| download | gcc-c787f593e62869ae0b230949b4791f4f3a26e50e.zip gcc-c787f593e62869ae0b230949b4791f4f3a26e50e.tar.gz gcc-c787f593e62869ae0b230949b4791f4f3a26e50e.tar.bz2 | |
PR modula2/109810 ICE fix when an array is assigned by a larger string
This patch fixes an ICE when an array variable is assigned with
a string which exceeds the array size. It improves the accuracy
of the virtual token used to indicate the error message.
gcc/m2/ChangeLog:
PR modula2/109810
* gm2-compiler/M2ALU.mod (ConvertConstToType): Use
PrepareCopyString in place of DoCopyString.
* gm2-compiler/M2GenGCC.def (DoCopyString): Rename to ...
(PrepareCopyString): ... this.
* gm2-compiler/M2GenGCC.mod (CodeStatement): Call CodeReturnValue
with a single parameter. Call CodeXIndr with a single parameter.
(CodeReturnValue): Remove parameters and replace with a single
quadno. Reimplement using PrepareCopyString. Issue error
if the string exceeds designator space.
(DoCopyString): Reimplement and rename to ...
(PrepareCopyString): ... this.
(CodeXIndr): Remove parameters and replace with a single
quadno. Reimplement using PrepareCopyString. Issue error
if the string exceeds designator space.
(CodeBecomes): Remove parameters and replace with a single
quadno. Reimplement using PrepareCopyString. Issue error
if the string exceeds designator space.
* gm2-compiler/M2Quads.def (BuildReturn): Rename parameter to
tokreturn.
* gm2-compiler/M2Quads.mod (BuildReturn): Rename parameter to
tokreturn. Rename tokno to tokcombined.
gcc/testsuite/ChangeLog:
PR modula2/109810
* gm2/pim/fail/highice.mod: New test.
Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
Diffstat (limited to 'gcc/m2')
| -rw-r--r-- | gcc/m2/gm2-compiler/M2ALU.mod | 11 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/M2GenGCC.def | 21 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/M2GenGCC.mod | 208 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/M2Quads.def | 2 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/M2Quads.mod | 73 |
5 files changed, 176 insertions, 139 deletions
diff --git a/gcc/m2/gm2-compiler/M2ALU.mod b/gcc/m2/gm2-compiler/M2ALU.mod index ef3b934..5cad874 100644 --- a/gcc/m2/gm2-compiler/M2ALU.mod +++ b/gcc/m2/gm2-compiler/M2ALU.mod @@ -40,7 +40,7 @@ FROM M2Debug IMPORT Assert ; FROM Storage IMPORT ALLOCATE ; FROM StringConvert IMPORT ostoi, bstoi, stoi, hstoi ; FROM M2GCCDeclare IMPORT GetTypeMin, GetTypeMax, CompletelyResolved, DeclareConstant ; -FROM M2GenGCC IMPORT DoCopyString, StringToChar ; +FROM M2GenGCC IMPORT PrepareCopyString, StringToChar ; FROM M2Bitset IMPORT Bitset ; FROM SymbolConversion IMPORT Mod2Gcc, GccKnowsAbout ; FROM M2Printf IMPORT printf0, printf2 ; @@ -4528,8 +4528,13 @@ BEGIN IF IsConstString(init) AND IsArray(SkipType(GetType(field))) AND (SkipTypeAndSubrange(GetType(GetType(field)))=Char) THEN - DoCopyString(tokenno, nBytes, initT, GetType(field), init) ; - RETURN( initT ) + IF NOT PrepareCopyString (tokenno, nBytes, initT, init, GetType (field)) + THEN + MetaErrorT2 (tokenno, + 'string constant {%1Ea} is too large to be assigned to the {%2d} {%2a}', + init, field) + END ; + RETURN initT ELSE RETURN( ConvertConstantAndCheck(TokenToLocation(tokenno), Mod2Gcc(GetType(field)), Mod2Gcc(init)) ) END diff --git a/gcc/m2/gm2-compiler/M2GenGCC.def b/gcc/m2/gm2-compiler/M2GenGCC.def index e29649d..646e09e 100644 --- a/gcc/m2/gm2-compiler/M2GenGCC.def +++ b/gcc/m2/gm2-compiler/M2GenGCC.def @@ -37,7 +37,7 @@ FROM m2linemap IMPORT location_t ; EXPORT QUALIFIED ConvertQuadsToTree, ResolveConstantExpressions, GetHighFromUnbounded, StringToChar, LValueToGenericPtr, ZConstToTypedConst, - DoCopyString ; + PrepareCopyString ; (* @@ -91,13 +91,22 @@ PROCEDURE ZConstToTypedConst (t: Tree; op1, op2: CARDINAL) : Tree ; (* - DoCopyString - returns trees: - t number of bytes to be copied (including the nul) - op3t the string with the extra nul character - providing it fits. + PrepareCopyString - returns two trees: + length number of bytes to be copied (including the nul if room) + srcTreeType the new string type (with the extra nul character). + + Pre condition: destStrType the dest type string. + src is the original string (without a nul) + to be copied. + Post condition: TRUE or FALSE is returned. + if true length and srcTreeType will be assigned + else length is set to the maximum length to be + copied and srcTree is set to the max length + which fits in dest. *) -PROCEDURE DoCopyString (tokenno: CARDINAL; VAR length, op3t: Tree; op1t, op3: CARDINAL) ; +PROCEDURE PrepareCopyString (tokenno: CARDINAL; VAR length, srcTree: Tree; + src, destStrType: CARDINAL) : BOOLEAN ; END M2GenGCC. diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod index 15fb929..9e975ba 100644 --- a/gcc/m2/gm2-compiler/M2GenGCC.mod +++ b/gcc/m2/gm2-compiler/M2GenGCC.mod @@ -80,7 +80,10 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue, NulSym ; FROM M2Batch IMPORT MakeDefinitionSource ; -FROM M2LexBuf IMPORT FindFileNameFromToken, TokenToLineNo, TokenToLocation, MakeVirtualTok ; + +FROM M2LexBuf IMPORT FindFileNameFromToken, TokenToLineNo, TokenToLocation, + MakeVirtualTok, UnknownTokenNo ; + FROM M2Code IMPORT CodeBlock ; FROM M2Debug IMPORT Assert ; FROM M2Error IMPORT InternalError, WriteFormat0, WriteFormat1, WriteFormat2, WarnStringAt ; @@ -167,6 +170,7 @@ FROM m2expr IMPORT GetIntegerZero, GetIntegerOne, CompareTrees, StringLength, AreConstantsEqual, + GetCstInteger, BuildForeachWordInSetDoIfExpr, BuildIfConstInVar, BuildIfVarInVar, @@ -467,7 +471,7 @@ BEGIN KillLocalVarOp : CodeKillLocalVar (op3) | ProcedureScopeOp : CodeProcedureScope (op3) | ReturnOp : (* Not used as return is achieved by KillLocalVar. *) | - ReturnValueOp : CodeReturnValue (op1, op3) | + ReturnValueOp : CodeReturnValue (q) | TryOp : CodeTry | ThrowOp : CodeThrow (op3) | CatchBeginOp : CodeCatchBegin | @@ -507,7 +511,7 @@ BEGIN IfInOp : CodeIfIn (q, op1, op2, op3) | IfNotInOp : CodeIfNotIn (q, op1, op2, op3) | IndrXOp : CodeIndrX (q, op1, op2, op3) | - XIndrOp : CodeXIndr (q, op1, op2, op3) | + XIndrOp : CodeXIndr (q) | CallOp : CodeCall (CurrentQuadToken, op3) | ParamOp : CodeParam (q, op1, op2, op3) | FunctValueOp : CodeFunctValue (location, op1) | @@ -1832,68 +1836,39 @@ END CodeProcedureScope ; allocated by the function call. *) -PROCEDURE CodeReturnValue (res, Procedure: CARDINAL) ; +PROCEDURE CodeReturnValue (quad: CARDINAL) ; VAR - value, length, op3t : Tree ; - location: location_t ; + op : QuadOperator ; + expr, none, procedure : CARDINAL ; + combinedpos, + returnpos, exprpos, nonepos, procpos: CARDINAL ; + value, length : Tree ; + location : location_t ; BEGIN - location := TokenToLocation (CurrentQuadToken) ; - TryDeclareConstant (CurrentQuadToken, res) ; (* checks to see whether it is a constant and declares it *) - TryDeclareConstructor (CurrentQuadToken, res) ; - IF IsConstString (res) AND (SkipTypeAndSubrange (GetType (Procedure)) # Char) + GetQuadOtok (quad, returnpos, op, expr, none, procedure, + exprpos, nonepos, procpos) ; + combinedpos := MakeVirtualTok (returnpos, returnpos, exprpos) ; + location := TokenToLocation (combinedpos) ; + TryDeclareConstant (exprpos, expr) ; (* checks to see whether it is a constant and declares it *) + TryDeclareConstructor (exprpos, expr) ; + IF IsConstString (expr) AND (SkipTypeAndSubrange (GetType (procedure)) # Char) THEN - DoCopyString (CurrentQuadToken, length, op3t, GetType (Procedure), res) ; + IF NOT PrepareCopyString (returnpos, length, value, expr, GetType (procedure)) + THEN + MetaErrorT3 (MakeVirtualTok (returnpos, returnpos, exprpos), + 'string constant {%1Ea} is too large to be returned from procedure {%2a} via the {%3d} {%3a}', + expr, procedure, GetType (procedure)) + END ; value := BuildArrayStringConstructor (location, - Mod2Gcc (GetType (Procedure)), op3t, length) + Mod2Gcc (GetType (procedure)), + value, length) ELSE - value := Mod2Gcc (res) + value := Mod2Gcc (expr) END ; - BuildReturnValueCode (location, Mod2Gcc (Procedure), value) + BuildReturnValueCode (location, Mod2Gcc (procedure), value) END CodeReturnValue ; -(* ******************************* -(* - GenerateCleanup - generates a try/catch/clobber tree containing the call to ptree -*) - -PROCEDURE GenerateCleanup (location: location_t; procedure: CARDINAL; p, call: Tree) : Tree ; -VAR - i, n: CARDINAL ; - t : Tree ; -BEGIN - t := push_statement_list (begin_statement_list ()) ; - i := 1 ; - n := NoOfParam (procedure) ; - WHILE i<=n DO - IF IsParameterVar (GetNthParam (procedure, i)) - THEN - AddStatement (location, BuildCleanUp (GetParamTree (call, i-1))) - END ; - INC(i) - END ; - RETURN BuildTryFinally (location, p, pop_statement_list ()) -END GenerateCleanup ; - - -(* - CheckCleanup - checks whether a cleanup is required for a procedure with - VAR parameters. The final tree is returned. -*) - -PROCEDURE CheckCleanup (location: location_t; procedure: CARDINAL; tree, call: Tree) : Tree ; -BEGIN - IF HasVarParameters(procedure) - THEN - RETURN tree ; - (* RETURN GenerateCleanup(location, procedure, tree, call) *) - ELSE - RETURN tree - END -END CheckCleanup ; -************************************** *) - - (* CodeCall - determines whether the procedure call is a direct call or an indirect procedure call. @@ -1920,7 +1895,6 @@ BEGIN THEN location := TokenToLocation (tokenno) ; AddStatement (location, tree) - (* was AddStatement(location, CheckCleanup(location, procedure, tree, tree)) *) ELSE (* leave tree alone - as it will be picked up when processing FunctValue *) END @@ -2882,57 +2856,67 @@ END FoldConstBecomes ; (* - DoCopyString - returns trees: - length number of bytes to be copied (including the nul) - op1t the new string _type_ (with the extra nul character). - op3t the actual string with the extra nul character. + PrepareCopyString - returns two trees: + length number of bytes to be copied (including the nul if room) + srcTreeType the new string type (with the extra nul character). + + Pre condition: destStrType the dest type string. + src is the original string (without a nul) + to be copied. + Post condition: TRUE or FALSE is returned. + if true length and srcTreeType will be assigned + else length is set to the maximum length to be + copied and srcTree is set to the max length + which fits in dest. *) -PROCEDURE DoCopyString (tokenno: CARDINAL; VAR length, op3t: Tree; op1t, op3: CARDINAL) ; +PROCEDURE PrepareCopyString (tokenno: CARDINAL; VAR length, srcTree: Tree; + src, destStrType: CARDINAL) : BOOLEAN ; VAR - location: location_t ; + location : location_t ; + intLength: INTEGER ; BEGIN - location := TokenToLocation(tokenno) ; - Assert(IsArray(SkipType(op1t))) ; - (* handle string assignments: + location := TokenToLocation (tokenno) ; + Assert (IsArray (SkipType (destStrType))) ; + (* Handle string assignments: VAR str: ARRAY [0..10] OF CHAR ; ch : CHAR ; str := 'abcde' but not ch := 'a' *) - IF GetType (op3) = Char + IF GetType (src) = Char THEN (* - * create string from char and add nul to the end, nul is + * Create string from char and add nul to the end, nul is * added by BuildStringConstant *) - op3t := BuildStringConstant (KeyToCharStar (GetString (op3)), 1) + srcTree := BuildStringConstant (KeyToCharStar (GetString (src)), 1) ELSE - op3t := Mod2Gcc (op3) + srcTree := Mod2Gcc (src) END ; - op3t := ConvertString (Mod2Gcc (op1t), op3t) ; - - PushIntegerTree(FindSize(tokenno, op3)) ; - PushIntegerTree(FindSize(tokenno, op1t)) ; - IF Less(tokenno) - THEN - (* there is room for the extra <nul> character *) - length := BuildAdd(location, FindSize(tokenno, op3), GetIntegerOne(location), FALSE) + 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) ELSE - PushIntegerTree(FindSize(tokenno, op3)) ; - PushIntegerTree(FindSize(tokenno, op1t)) ; + length := FindSize (tokenno, destStrType) ; + PushIntegerTree (FindSize (tokenno, src)) ; + PushIntegerTree (length) ; + (* Greater or Equal so return max characters in the array. *) IF Gre (tokenno) THEN - WarnStringAt (InitString('string constant is too large to be assigned to the array'), - tokenno) ; - length := FindSize (tokenno, op1t) - ELSE - (* equal so return max characters in the array *) - length := FindSize (tokenno, op1t) + intLength := GetCstInteger (length) ; + srcTree := BuildStringConstant (KeyToCharStar (GetString (src)), intLength) ; + RETURN FALSE END - END -END DoCopyString ; + END ; + RETURN TRUE +END PrepareCopyString ; (* @@ -3104,7 +3088,8 @@ VAR location : location_t ; BEGIN GetQuadOtok (quad, becomespos, op, op1, op2, op3, op1pos, op2pos, op3pos) ; - DeclareConstant (CurrentQuadToken, op3) ; (* checks to see whether it is a constant and declares it *) + Assert (op2pos = UnknownTokenNo) ; + DeclareConstant (CurrentQuadToken, op3) ; (* Check to see whether op3 is a constant and declare it. *) DeclareConstructor (CurrentQuadToken, quad, op3) ; location := TokenToLocation (CurrentQuadToken) ; @@ -3121,7 +3106,12 @@ BEGIN ELSIF IsConstString (op3) AND (SkipTypeAndSubrange (GetType (op1)) # Char) THEN checkDeclare (op1) ; - DoCopyString (CurrentQuadToken, length, op3t, SkipType (GetType (op1)), op3) ; + IF NOT PrepareCopyString (becomespos, length, op3t, op3, SkipType (GetType (op1))) + THEN + MetaErrorT2 (MakeVirtualTok (becomespos, op1pos, op3pos), + 'string constant {%1Ea} is too large to be assigned to the array {%2ad}', + op3, op1) + END ; AddStatement (location, MaybeDebugBuiltinMemcpy (location, CurrentQuadToken, BuildAddr (location, Mod2Gcc (op1), FALSE), @@ -7177,17 +7167,28 @@ END CodeIndrX ; (op2 is the type of the data being indirectly copied) *) -PROCEDURE CodeXIndr (quad: CARDINAL; op1, type, op3: CARDINAL) ; +PROCEDURE CodeXIndr (quad: CARDINAL) ; VAR + op : QuadOperator ; + tokenno, + op1, + type, + op3, + op1pos, + op3pos, + typepos, + xindrpos: CARDINAL ; length, newstr : Tree ; location: location_t ; BEGIN - location := TokenToLocation(CurrentQuadToken) ; + GetQuadOtok (quad, xindrpos, op, op1, type, op3, op1pos, typepos, op3pos) ; + tokenno := MakeVirtualTok (xindrpos, op1pos, op3pos) ; + location := TokenToLocation (tokenno) ; type := SkipType (type) ; - DeclareConstant(CurrentQuadToken, op3) ; - DeclareConstructor(CurrentQuadToken, quad, op3) ; + DeclareConstant (op3pos, op3) ; + DeclareConstructor (op3pos, quad, op3) ; (* Follow the Quadruple rule: @@ -7195,8 +7196,8 @@ BEGIN *) 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 (op1), GetPointerType ()), Mod2Gcc (op3)) + ELSIF IsConstString (op3) AND (GetStringLength (op3) = 0) AND (GetMode (op1) = LeftValue) THEN (* no need to check for type errors, @@ -7205,13 +7206,18 @@ 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, op1), Mod2Gcc (Char)), + StringToChar (Mod2Gcc (op3), Char, op3)) + ELSIF IsConstString (op3) AND (SkipTypeAndSubrange (GetType (op1)) # Char) THEN - DoCopyString (CurrentQuadToken, length, newstr, type, op3) ; + IF NOT PrepareCopyString (tokenno, length, newstr, op3, type) + THEN + MetaErrorT2 (MakeVirtualTok (xindrpos, op1pos, op3pos), + 'string constant {%1Ea} is too large to be assigned to the array {%2ad}', + op3, op1) + END ; AddStatement (location, - MaybeDebugBuiltinMemcpy (location, CurrentQuadToken, + MaybeDebugBuiltinMemcpy (location, tokenno, Mod2Gcc (op1), BuildAddr (location, newstr, FALSE), length)) diff --git a/gcc/m2/gm2-compiler/M2Quads.def b/gcc/m2/gm2-compiler/M2Quads.def index 84c01e2..582daeb 100644 --- a/gcc/m2/gm2-compiler/M2Quads.def +++ b/gcc/m2/gm2-compiler/M2Quads.def @@ -1705,7 +1705,7 @@ PROCEDURE BuildProcedureEnd ; |------------| *) -PROCEDURE BuildReturn (tokno: CARDINAL) ; +PROCEDURE BuildReturn (tokreturn: CARDINAL) ; (* diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod index 57f272f..65e3c49 100644 --- a/gcc/m2/gm2-compiler/M2Quads.mod +++ b/gcc/m2/gm2-compiler/M2Quads.mod @@ -260,7 +260,7 @@ IMPORT M2Error ; CONST DebugStackOn = TRUE ; DebugVarients = FALSE ; - BreakAtQuad = 4423 ; + BreakAtQuad = 133 ; DebugTokPos = FALSE ; TYPE @@ -301,8 +301,8 @@ TYPE RecordSym : CARDINAL ; RecordType : CARDINAL ; RecordRef : CARDINAL ; - rw : CARDINAL ; (* The record variable. *) - RecordTokPos: CARDINAL ; (* Token of the record. *) + rw : CARDINAL ; (* The record variable. *) + RecordTokPos: CARDINAL ; (* Token of the record. *) END ; ForLoopInfo = POINTER TO RECORD @@ -333,8 +333,9 @@ VAR WhileStack, ForStack, ExitStack, - ReturnStack : StackOfWord ; (* Return quadruple of the procedure. *) - PriorityStack : StackOfWord ; (* Temporary variable holding old priority. *) + ReturnStack : StackOfWord ; (* Return quadruple of the procedure. *) + PriorityStack : StackOfWord ; (* Temporary variable holding old *) + (* priority. *) SuppressWith : BOOLEAN ; QuadArray : Index ; NextQuad : CARDINAL ; (* Next quadruple number to be created. *) @@ -3195,7 +3196,7 @@ BEGIN IF IsConstString(Exp) AND IsConst(Des) THEN GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE, - tokno, destok, exptok) ; + destok, UnknownTokenNo, exptok) ; PutConstString (tokno, Des, GetString (Exp)) ELSE IF GetMode(Des)=RightValue @@ -3206,7 +3207,7 @@ BEGIN doIndrX (tokno, Des, Exp) ELSE GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE, - tokno, destok, exptok) + destok, UnknownTokenNo, exptok) END ELSIF GetMode(Des)=LeftValue THEN @@ -3227,7 +3228,7 @@ BEGIN END ELSE GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE, - tokno, destok, exptok) + destok, UnknownTokenNo, exptok) END END END MoveWithMode ; @@ -3542,6 +3543,17 @@ BEGIN MarkAsWrite (w) ; CheckCompatibleWithBecomes (Des, Exp, destok, exptok) ; combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ; + IF DebugTokPos + THEN + MetaErrorT1 (becomesTokNo, 'becomestok {%1Oad}', Des) ; + MetaErrorT1 (destok, 'destok {%1Oad}', Des) ; + MetaErrorT1 (exptok, 'exptok {%1Oad}', Exp) + END ; + combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ; + IF DebugTokPos + THEN + MetaErrorT1 (combinedtok, 'combined {%1Oad}', Des) + END ; IF (GetSType (Des) # NulSym) AND (NOT IsSet (GetDType (Des))) THEN (* Tell code generator to test runtime values of assignment so ensure we @@ -3552,7 +3564,7 @@ BEGIN THEN CheckBecomesMeta (Des, Exp, combinedtok, destok, exptok) END ; - (* Traditional Assignment. *) + (* Simple assignment. *) MoveWithMode (becomesTokNo, Des, Exp, Array, destok, exptok, checkOverflow) ; IF checkTypes THEN @@ -10925,7 +10937,7 @@ END CheckReturnType ; (* BuildReturn - Builds the Return part of the procedure. - tokno is the location of the RETURN keyword. + tokreturn is the location of the RETURN keyword. The Stack is expected to contain: @@ -10938,48 +10950,53 @@ END CheckReturnType ; |------------| *) -PROCEDURE BuildReturn (tokno: CARDINAL) ; +PROCEDURE BuildReturn (tokreturn: CARDINAL) ; VAR + tokcombined, + tokexpr : CARDINAL ; e2, t2, e1, t1, t, f, - Des : CARDINAL ; + Des : CARDINAL ; BEGIN IF IsBoolean (1) THEN - PopBool(t, f) ; + PopBooltok (t, f, tokexpr) ; (* Des will be a boolean type *) - Des := MakeTemporary (tokno, RightValue) ; + Des := MakeTemporary (tokexpr, RightValue) ; PutVar (Des, Boolean) ; - PushTF (Des, Boolean) ; - PushBool (t, f) ; - BuildAssignmentWithoutBounds (tokno, FALSE, TRUE) ; - PushTF (Des, Boolean) + PushTFtok (Des, Boolean, tokexpr) ; + PushBooltok (t, f, tokexpr) ; + BuildAssignmentWithoutBounds (tokreturn, FALSE, TRUE) ; + PushTFtok (Des, Boolean, tokexpr) END ; - PopTF (e1, t1) ; + PopTFtok (e1, t1, tokexpr) ; + tokcombined := MakeVirtualTok (tokreturn, tokreturn, tokexpr) ; IF e1 # NulSym THEN (* this will check that the type returned is compatible with the formal return type of the procedure. *) - CheckReturnType (tokno, CurrentProc, e1, t1) ; + CheckReturnType (tokcombined, CurrentProc, e1, t1) ; (* dereference LeftValue if necessary *) IF GetMode (e1) = LeftValue THEN t2 := GetSType (CurrentProc) ; - e2 := MakeTemporary (tokno, RightValue) ; + e2 := MakeTemporary (tokexpr, RightValue) ; PutVar(e2, t2) ; - CheckPointerThroughNil (tokno, e1) ; - doIndrX (tokno, e2, e1) ; + CheckPointerThroughNil (tokexpr, e1) ; + doIndrX (tokexpr, e2, e1) ; (* here we check the data contents to ensure no overflow. *) - BuildRange (InitReturnRangeCheck (tokno, CurrentProc, e2)) ; - GenQuadO (tokno, ReturnValueOp, e2, NulSym, CurrentProc, FALSE) + BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e2)) ; + GenQuadOtok (tokcombined, ReturnValueOp, e2, NulSym, CurrentProc, FALSE, + tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) ELSE (* here we check the data contents to ensure no overflow. *) - BuildRange (InitReturnRangeCheck (tokno, CurrentProc, e1)) ; - GenQuadO (tokno, ReturnValueOp, e1, NulSym, CurrentProc, FALSE) + BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e1)) ; + GenQuadOtok (tokcombined, ReturnValueOp, e1, NulSym, CurrentProc, FALSE, + tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) END END ; - GenQuadO (tokno, GotoOp, NulSym, NulSym, PopWord(ReturnStack), FALSE) ; + GenQuadO (tokcombined, GotoOp, NulSym, NulSym, PopWord (ReturnStack), FALSE) ; PushWord (ReturnStack, NextQuad-1) END BuildReturn ; |