Google Git
Sign in
gnu / gcc.git / 7c99de1c439dbb149cc6a33a214f22f2df1c88f3 / . / gcc / m2 / gm2-compiler / M2Range.mod
blob: f1516d3a5e50994a651f8696401dda232f7b78a3 [file] [log] [blame]
(* M2Range.mod exports procedures which maintain the range checking.
Copyright (C) 2008-2025 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. *)
IMPLEMENTATION MODULE M2Range ;
FROM SymbolTable IMPORT NulSym, GetLowestType, PutReadQuad, RemoveReadQuad,
IsVar, IsConst, PushValue, GetSubrange, GetType,
IsSubrange, GetSymName, IsTemporary, IsSet,
IsRecord, IsPointer, IsArray, IsProcType, IsConstLit,
IsAModula2Type, IsUnbounded, IsEnumeration, GetMode,
IsConstString, MakeConstLit, SkipType, IsProcedure,
IsParameter, GetDeclaredMod, IsVarParamAny, GetNthParam,
ModeOfAddr ;
FROM SYSTEM IMPORT ADDRESS ;
FROM m2tree IMPORT debug_tree ;
FROM m2linemap IMPORT ErrorAt, GetFilenameFromLocation, GetColumnNoFromLocation, GetLineNoFromLocation ;
FROM m2type IMPORT GetMinFrom, GetMaxFrom,
GetIntegerType, GetTreeType,
GetPointerType,
AddStatement ;
FROM m2statement IMPORT BuildProcedureCallTree, BuildIfThenElseEnd, BuildIfThenDoEnd ;
FROM m2expr IMPORT CompareTrees, BuildSub, BuildAdd, GetIntegerZero, GetIntegerOne,
BuildAddr, BuildIndirect, BuildGreaterThan, BuildLessThan,
BuildGreaterThanOrEqual,
GetPointerZero, BuildNegate, BuildEqualTo, BuildLessThanOrEqual,
IsTrue, IsFalse, TreeOverflow ;
FROM m2convert IMPORT BuildConvert ;
FROM m2statement IMPORT BuildParam ;
FROM m2decl IMPORT BuildStringConstant, BuildIntegerConstant ;
FROM m2builtins IMPORT BuiltInIsfinite ;
FROM M2Debug IMPORT Assert ;
FROM Indexing IMPORT Index, InitIndex, InBounds, PutIndice, GetIndice ;
FROM Storage IMPORT ALLOCATE ;
FROM M2ALU IMPORT PushIntegerTree, PushInt, ConvertToInt, Equ, Gre, Less, GreEqu ;
FROM M2Options IMPORT VariantValueChecking, CaseEnumChecking, GetPIM, StrictTypeAssignment ;
FROM M2Error IMPORT Error, InternalError, ErrorFormat0, ErrorFormat1, ErrorFormat2, FlushErrors,
GetAnnounceScope ;
FROM M2ColorString IMPORT quoteOpen, quoteClose ;
FROM M2MetaError IMPORT MetaError1, MetaError2, MetaError3,
MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3,
MetaErrorsT1, MetaErrorsT2, MetaErrorsT3, MetaErrorsT4,
MetaErrorStringT1, MetaErrorStringT2, MetaErrorStringT3,
MetaString3 ;
FROM M2LexBuf IMPORT UnknownTokenNo, GetTokenNo, FindFileNameFromToken,
TokenToLineNo, TokenToColumnNo, TokenToLocation, MakeVirtual2Tok ;
FROM StrIO IMPORT WriteString, WriteLn ;
FROM NumberIO IMPORT WriteCard ;
FROM M2GCCDeclare IMPORT TryDeclareConstant, DeclareConstructor ;
FROM M2Quads IMPORT QuadOperator, PutQuad, SubQuad, WriteOperand ;
FROM SymbolConversion IMPORT GccKnowsAbout, Mod2Gcc ;
FROM Lists IMPORT List ;
FROM NameKey IMPORT Name, MakeKey, KeyToCharStar ;
FROM StdIO IMPORT Write ;
FROM DynamicStrings IMPORT String, string, Length, InitString, ConCat, ConCatChar, Mark, InitStringCharStar, KillString ;
FROM M2GenGCC IMPORT GetHighFromUnbounded, StringToChar, LValueToGenericPtr, ZConstToTypedConst ;
FROM M2System IMPORT Address, Word, Loc, Byte, IsWordN, IsRealN, IsComplexN ;
FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2 ;
FROM M2Check IMPORT ParameterTypeCompatible, ExpressionTypeCompatible, AssignmentTypeCompatible ;
FROM M2Base IMPORT Nil, IsRealType, GetBaseTypeMinMax,
Cardinal, Integer, ZType, IsComplexType,
IsExpressionCompatible,
IsParameterCompatible,
ExceptionAssign,
ExceptionReturn,
ExceptionInc, ExceptionDec,
ExceptionIncl, ExceptionExcl,
ExceptionShift, ExceptionRotate,
ExceptionStaticArray, ExceptionDynamicArray,
ExceptionForLoopBegin, ExceptionForLoopTo, ExceptionForLoopEnd,
ExceptionPointerNil, ExceptionNoReturn, ExceptionCase,
ExceptionNonPosDiv, ExceptionNonPosMod,
ExceptionZeroDiv, ExceptionZeroRem,
ExceptionWholeValue, ExceptionRealValue,
ExceptionParameterBounds,
ExceptionNo ;
FROM M2CaseList IMPORT CaseBoundsResolved, OverlappingCaseBounds,
WriteCase, MissingCaseBounds, TypeCaseBounds,
MissingCaseStatementBounds ;
TYPE
TypeOfRange = (assignment, returnassignment, subrangeassignment,
inc, dec, incl, excl, shift, rotate,
typeindrx, typeexpr, typeassign, typeparam,
typereturn,
paramassign,
staticarraysubscript,
dynamicarraysubscript,
forloopbegin, forloopto, forloopend,
pointernil, noreturn, noelse,
casebounds,
wholenonposdiv, wholenonposmod,
wholezerodiv, wholezerorem, none) ;
Range = POINTER TO RECORD
type : TypeOfRange ;
des,
expr, expr2,
byconst,
desLowestType,
exprLowestType: CARDINAL ;
procedure : CARDINAL ;
paramNo : CARDINAL ;
isLeftValue : BOOLEAN ; (* is des an LValue,
only used in pointernil *)
dimension : CARDINAL ;
caseList : CARDINAL ;
destok,
exprtok,
expr2tok,
byconsttok,
tokenNo : CARDINAL ;
incrementquad : CARDINAL ; (* Increment quad used in FOR the loop. *)
errorReported : BOOLEAN ; (* error message reported yet? *)
strict : BOOLEAN ; (* is it a comparison expression? *)
isin : BOOLEAN ; (* expression created by IN operator? *)
cancelled : BOOLEAN ; (* Has this range been cancelled? *)
dependantid : CARDINAL ; (* The associated dependant range test. *)
END ;
VAR
TopOfRange: CARDINAL ;
RangeIndex: Index ;
BreakRange: CARDINAL ;
PROCEDURE gdbhook ;
END gdbhook ;
(*
BreakWhenRangeCreated - to be called interactively by gdb.
*)
PROCEDURE BreakWhenRangeCreated (r: CARDINAL) ;
BEGIN
BreakRange := r
END BreakWhenRangeCreated ;
(*
CheckBreak - if sym = BreakRange then call gdbhook.
*)
PROCEDURE CheckBreak (r: CARDINAL) ;
BEGIN
IF BreakRange = r
THEN
gdbhook
END
END CheckBreak ;
(*
OverlapsRange - returns TRUE if a1..a2 overlaps with b1..b2.
*)
PROCEDURE OverlapsRange (a1, a2, b1, b2: tree) : BOOLEAN ;
BEGIN
(* RETURN( ((a1<=b2) AND (a2>=b1)) ) *)
RETURN( (CompareTrees(a1, b2)<=0) AND (CompareTrees(a2, b1)>=0) )
END OverlapsRange ;
(*
IsGreater - returns TRUE if a>b.
*)
PROCEDURE IsGreater (a, b: tree) : BOOLEAN ;
BEGIN
RETURN( CompareTrees(a, b)>0 )
END IsGreater ;
(*
IsGreaterOrEqual - returns TRUE if a>=b.
*)
PROCEDURE IsGreaterOrEqual (a, b: tree) : BOOLEAN ;
BEGIN
RETURN( CompareTrees(a, b)>=0 )
END IsGreaterOrEqual ;
(*
IsEqual - returns TRUE if a=b.
*)
PROCEDURE IsEqual (a, b: tree) : BOOLEAN ;
BEGIN
RETURN( CompareTrees(a, b)=0 )
END IsEqual ;
(*
IsGreaterOrEqualConversion - tests whether t>=e.
*)
PROCEDURE IsGreaterOrEqualConversion (location: location_t; l: CARDINAL; d, e: CARDINAL) : BOOLEAN ;
BEGIN
IF GetType(d)=NulSym
THEN
IF GetType(e)=NulSym
THEN
RETURN( IsGreaterOrEqual(Mod2Gcc(l), LValueToGenericPtr(location, e)) )
ELSE
RETURN( IsGreaterOrEqual(BuildConvert(location, Mod2Gcc(SkipType(GetType(e))), Mod2Gcc(l), FALSE),
LValueToGenericPtr(location, e)) )
END
ELSE
RETURN( IsGreaterOrEqual(BuildConvert(location, Mod2Gcc(SkipType(GetType(d))), Mod2Gcc(l), FALSE),
LValueToGenericPtr(location, e)) )
END
END IsGreaterOrEqualConversion ;
(*
IsEqualConversion - returns TRUE if a=b.
*)
PROCEDURE IsEqualConversion (l: CARDINAL; d, e: CARDINAL) : BOOLEAN ;
VAR
location: location_t ;
BEGIN
location := TokenToLocation(GetDeclaredMod(l)) ;
IF GetType(d)=NulSym
THEN
IF GetType(e)=NulSym
THEN
RETURN( IsEqual(Mod2Gcc(l), LValueToGenericPtr(location, e)) )
ELSE
RETURN( IsEqual(BuildConvert(location, Mod2Gcc(SkipType(GetType(e))), Mod2Gcc(l), FALSE),
LValueToGenericPtr(location, e)) )
END
ELSE
RETURN( IsEqual(BuildConvert(location, Mod2Gcc(SkipType(GetType(d))), Mod2Gcc(l), FALSE),
LValueToGenericPtr(location, e)) )
END
END IsEqualConversion ;
(*
lookupExceptionHandler -
*)
PROCEDURE lookupExceptionHandler (type: TypeOfRange) : CARDINAL ;
BEGIN
CASE type OF
assignment : RETURN( ExceptionAssign ) |
returnassignment : RETURN( ExceptionReturn ) |
subrangeassignment : InternalError ('not expecting this case value') |
inc : RETURN( ExceptionInc ) |
dec : RETURN( ExceptionDec ) |
incl : RETURN( ExceptionIncl ) |
excl : RETURN( ExceptionExcl ) |
shift : RETURN( ExceptionShift ) |
rotate : RETURN( ExceptionRotate ) |
typeassign,
typeparam,
typeexpr,
typeindrx : InternalError ('not expecting this case value') |
paramassign : RETURN( ExceptionParameterBounds ) |
staticarraysubscript : RETURN( ExceptionStaticArray ) |
dynamicarraysubscript: RETURN( ExceptionDynamicArray ) |
forloopbegin : RETURN( ExceptionForLoopBegin ) |
forloopto : RETURN( ExceptionForLoopTo ) |
forloopend : RETURN( ExceptionForLoopEnd ) |
pointernil : RETURN( ExceptionPointerNil ) |
noreturn : RETURN( ExceptionNoReturn ) |
noelse : RETURN( ExceptionCase ) |
casebounds : InternalError ('not expecting this case value') |
wholenonposdiv : RETURN( ExceptionNonPosDiv ) |
wholenonposmod : RETURN( ExceptionNonPosMod ) |
wholezerodiv : RETURN( ExceptionZeroDiv ) |
wholezerorem : RETURN( ExceptionZeroRem ) |
none : RETURN( ExceptionNo )
ELSE
InternalError ('enumeration value unknown')
END
END lookupExceptionHandler ;
(*
InitRange - returns a new range item.
*)
PROCEDURE InitRange () : CARDINAL ;
VAR
r: CARDINAL ;
p: Range ;
BEGIN
INC(TopOfRange) ;
r := TopOfRange ;
NEW(p) ;
IF p=NIL
THEN
InternalError ('out of memory error')
ELSE
CheckBreak (r) ;
WITH p^ DO
type := none ;
des := NulSym ;
expr := NulSym ;
expr2 := NulSym ;
byconst := NulSym ;
desLowestType := NulSym ;
exprLowestType := NulSym ;
isLeftValue := FALSE ; (* ignored in all cases other *)
dimension := 0 ;
caseList := 0 ;
tokenNo := UnknownTokenNo ; (* than pointernil *)
destok := UnknownTokenNo ;
exprtok := UnknownTokenNo ;
expr2tok := UnknownTokenNo ;
byconsttok := UnknownTokenNo ;
incrementquad := 0 ;
errorReported := FALSE ;
cancelled := FALSE ;
dependantid := 0
END ;
PutIndice(RangeIndex, r, p)
END ;
RETURN( r )
END InitRange ;
(*
reportedError - returns whether this is the first time this error has been
reported.
*)
PROCEDURE reportedError (r: CARDINAL) : BOOLEAN ;
VAR
p: Range ;
BEGIN
p := GetIndice (RangeIndex, r) ;
RETURN p^.errorReported
END reportedError ;
(*
setReported - assigns errorReported to TRUE.
*)
PROCEDURE setReported (r: CARDINAL) ;
VAR
p: Range ;
BEGIN
p := GetIndice (RangeIndex, r) ;
p^.errorReported := TRUE
END setReported ;
(*
PutRangeForIncrement - places incrementquad into the range record.
*)
PROCEDURE PutRangeForIncrement (range: CARDINAL; incrementquad: CARDINAL) ;
VAR
p: Range ;
BEGIN
p := GetIndice (RangeIndex, range) ;
p^.incrementquad := incrementquad
END PutRangeForIncrement ;
(*
PutRange - initializes contents of, p, to
d, e and their lowest types.
It also fills in the current token no
and returns, p.
*)
PROCEDURE PutRange (tokno: CARDINAL; p: Range; t: TypeOfRange; d, e: CARDINAL) : Range ;
BEGIN
WITH p^ DO
type := t ;
des := d ;
expr := e ;
desLowestType := GetLowestType (d) ;
exprLowestType := GetLowestType (e) ;
tokenNo := tokno ;
strict := FALSE ;
isin := FALSE
END ;
RETURN p
END PutRange ;
(*
PutRangeDesExpr2 - initializes contents of, p, to
des, expr1 and their lowest types.
It also fills in the token numbers for
des, expr, expr2 and returns, p.
*)
PROCEDURE PutRangeDesExpr2 (p: Range; t: TypeOfRange;
des, destok,
expr1, expr1tok,
expr2, expr2tok,
byconst, byconsttok: CARDINAL) : Range ;
BEGIN
p^.des := des ;
p^.destok := destok ;
p^.expr := expr1 ;
p^.exprtok := expr1tok ;
p^.expr2 := expr2 ;
p^.expr2tok := expr2tok ;
p^.byconst := byconst ;
p^.byconsttok := byconsttok ;
WITH p^ DO
type := t ;
desLowestType := GetLowestType (des) ;
exprLowestType := GetLowestType (expr1) ;
strict := FALSE ;
isin := FALSE
END ;
RETURN p
END PutRangeDesExpr2 ;
(*
chooseTokenPos - returns, tokenpos, if it is not the unknown location, otherwise
it returns GetTokenNo.
*)
PROCEDURE chooseTokenPos (tokenpos: CARDINAL) : CARDINAL ;
BEGIN
IF tokenpos = UnknownTokenNo
THEN
RETURN GetTokenNo ()
ELSE
RETURN tokenpos
END
END chooseTokenPos ;
(*
PutRangeNoLow - initializes contents of, p. It
does not set lowest types as they may be
unknown at this point.
*)
PROCEDURE PutRangeNoLow (tokpos: CARDINAL; p: Range; t: TypeOfRange; d, e: CARDINAL) : Range ;
BEGIN
WITH p^ DO
type := t ;
des := d ;
expr := e ;
desLowestType := NulSym ;
exprLowestType := NulSym ;
isLeftValue := FALSE ;
tokenNo := chooseTokenPos (tokpos) ;
strict := FALSE ;
isin := FALSE
END ;
RETURN p
END PutRangeNoLow ;
(*
PutRangeExpr - initializes contents of, p. It
does not set lowest types as they may be
unknown at this point.
*)
PROCEDURE PutRangeExpr (tokpos: CARDINAL; p: Range; t: TypeOfRange;
d, e: CARDINAL; strict, isin: BOOLEAN) : Range ;
BEGIN
WITH p^ DO
type := t ;
des := d ;
expr := e ;
desLowestType := NulSym ;
exprLowestType := NulSym ;
isLeftValue := FALSE ;
tokenNo := chooseTokenPos (tokpos) ;
END ;
p^.strict := strict ;
p^.isin := isin ;
RETURN p
END PutRangeExpr ;
(*
PutRangePointer - initializes contents of, p, to
d, isLeft and their lowest types.
It also fills in the current token no
and returns, p.
*)
PROCEDURE PutRangePointer (tokpos: CARDINAL;
p: Range; d: CARDINAL; isLeft: BOOLEAN) : Range ;
BEGIN
WITH p^ DO
type := pointernil ;
des := d ;
expr := NulSym ;
desLowestType := GetLowestType(GetType(d)) ;
exprLowestType := NulSym ;
isLeftValue := isLeft ;
tokenNo := tokpos ;
strict := FALSE ;
isin := FALSE
END ;
RETURN p
END PutRangePointer ;
(*
PutRangeNoEval - initializes contents of, p, to a non evaluation
runtime check such as a no else clause or
no return found in function call.
*)
PROCEDURE PutRangeNoEval (p: Range; t: TypeOfRange) : Range ;
BEGIN
WITH p^ DO
type := t ;
tokenNo := GetTokenNo ()
END ;
RETURN p
END PutRangeNoEval ;
(*
PutRange - initializes contents of, p, to
d, e and its lowest type.
It also fills in the current token no
and returns, p.
*)
PROCEDURE PutRangeUnary (tokno: CARDINAL; p: Range; t: TypeOfRange; d, e: CARDINAL) : Range ;
BEGIN
WITH p^ DO
type := t ;
des := d ;
expr := e ;
desLowestType := GetLowestType(d) ;
exprLowestType := NulSym ;
isLeftValue := FALSE ;
tokenNo := chooseTokenPos (tokno) ;
strict := FALSE ;
isin := FALSE
END ;
RETURN( p )
END PutRangeUnary ;
(*
PutRangeParam - initializes contents of, p, to contain the parameter
type checking information.
It also fills in the current token no
and returns, p.
*)
PROCEDURE PutRangeParam (tokno: CARDINAL; p: Range; t: TypeOfRange; proc: CARDINAL;
paramno: CARDINAL; formal, actual: CARDINAL;
depRangeId: CARDINAL) : Range ;
BEGIN
WITH p^ DO
type := t ;
des := formal ;
expr := actual ;
desLowestType := NulSym ;
exprLowestType := NulSym ;
procedure := proc ;
paramNo := paramno ;
isLeftValue := FALSE ;
tokenNo := tokno ;
strict := FALSE ;
isin := FALSE ;
dependantid := depRangeId
END ;
RETURN p
END PutRangeParam ;
(*
PutRangeArraySubscript - initializes contents of, p, to
d, e and their lowest types. It also
assigns, dim.
It also fills in the current token no
and returns, p.
*)
PROCEDURE PutRangeArraySubscript (p: Range; t: TypeOfRange;
d, e: CARDINAL; dim: CARDINAL) : Range ;
BEGIN
WITH p^ DO
type := t ;
des := d ;
expr := e ;
desLowestType := GetLowestType(d) ;
exprLowestType := GetLowestType(e) ;
dimension := dim ;
tokenNo := GetTokenNo () ;
strict := FALSE ;
isin := FALSE
END ;
RETURN p
END PutRangeArraySubscript ;
(*
InitAssignmentRangeCheck - returns a range check node which
remembers the information necessary
so that a range check for des := expr
can be generated later on.
*)
PROCEDURE InitAssignmentRangeCheck (tokno: CARDINAL;
des, expr: CARDINAL;
destok, exprtok: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
p: Range ;
BEGIN
r := InitRange () ;
p := GetIndice (RangeIndex, r) ;
Assert (PutRange (tokno, p, assignment, des, expr) # NIL) ;
p^.destok := destok ;
p^.exprtok := exprtok ;
RETURN r
END InitAssignmentRangeCheck ;
(*
InitReturnRangeCheck - returns a range check node which
remembers the information necessary
so that a range check for RETURN e
from procedure, d, can be generated later on.
*)
PROCEDURE InitReturnRangeCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRange (tokno, GetIndice (RangeIndex, r), returnassignment, d, e) # NIL) ;
RETURN r
END InitReturnRangeCheck ;
(*
InitSubrangeRangeCheck - returns a range check node which
remembers the information necessary
so that a range check for d := e
can be generated later on.
*)
PROCEDURE InitSubrangeRangeCheck (d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRange (GetTokenNo (), GetIndice (RangeIndex, r), subrangeassignment, d, e) # NIL) ;
RETURN r
END InitSubrangeRangeCheck ;
(*
InitStaticArraySubscriptRangeCheck - returns a range check node which
remembers the information necessary
so that a range check for d[e]
can be generated later on.
*)
PROCEDURE InitStaticArraySubscriptRangeCheck (d, e, dim: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeArraySubscript (GetIndice (RangeIndex, r), staticarraysubscript, d, e, dim) # NIL) ;
RETURN r
END InitStaticArraySubscriptRangeCheck ;
(*
InitDynamicArraySubscriptRangeCheck - returns a range check node which
remembers the information necessary
so that a range check for d[e]
can be generated later on.
*)
PROCEDURE InitDynamicArraySubscriptRangeCheck (d, e, dim: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeArraySubscript (GetIndice (RangeIndex, r), dynamicarraysubscript, d, e, dim) # NIL) ;
RETURN r
END InitDynamicArraySubscriptRangeCheck ;
(*
InitIncRangeCheck - returns a range check node which
remembers the information necessary
so that a range check for INC(d, e)
can be generated later on.
*)
PROCEDURE InitIncRangeCheck (d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRange (GetTokenNo (), GetIndice (RangeIndex, r), inc, d, e) # NIL) ;
RETURN r
END InitIncRangeCheck ;
(*
InitDecRangeCheck - returns a range check node which
remembers the information necessary
so that a range check for DEC(d, e)
can be generated later on.
*)
PROCEDURE InitDecRangeCheck (d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRange (GetTokenNo (), GetIndice (RangeIndex, r), dec, d, e) # NIL) ;
RETURN r
END InitDecRangeCheck ;
(*
InitInclCheck - checks to see that bit, e, is type compatible with
e and also in range.
*)
PROCEDURE InitInclCheck (d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeNoLow (GetTokenNo (), GetIndice (RangeIndex, r), incl, d, e) # NIL) ;
RETURN r
END InitInclCheck ;
(*
InitExclCheck - checks to see that bit, e, is type compatible with
e and also in range.
*)
PROCEDURE InitExclCheck (d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeNoLow (GetTokenNo (), GetIndice (RangeIndex, r), excl, d, e) # NIL) ;
RETURN r
END InitExclCheck ;
(*
InitShiftCheck - checks to see that bit, e, is type compatible with
d and also in range.
*)
PROCEDURE InitShiftCheck (d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeNoLow (GetTokenNo (), GetIndice (RangeIndex, r), shift, d, e) # NIL) ;
RETURN r
END InitShiftCheck ;
(*
InitRotateCheck - checks to see that bit, e, is type compatible with
d and also in range.
*)
PROCEDURE InitRotateCheck (d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeNoLow (GetTokenNo (), GetIndice (RangeIndex, r), rotate, d, e) # NIL) ;
RETURN r
END InitRotateCheck ;
(*
InitTypesAssignmentCheck - checks to see that the types of d and e
are assignment compatible.
*)
PROCEDURE InitTypesAssignmentCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeNoLow (tokno, GetIndice (RangeIndex, r), typeassign, d, e) # NIL) ;
RETURN r
END InitTypesAssignmentCheck ;
(*
InitTypesIndrXCheck - checks to see that the types of d and e
are assignment compatible. The type checking
will dereference *e during the type check.
d = *e.
*)
PROCEDURE InitTypesIndrXCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeNoLow (tokno, GetIndice (RangeIndex, r), typeindrx, d, e) # NIL) ;
RETURN r
END InitTypesIndrXCheck ;
(*
InitTypesReturnTypeCheck - checks to see that the types of des and func
are assignment compatible.
*)
PROCEDURE InitTypesReturnTypeCheck (tokno: CARDINAL; func, val: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeNoLow (tokno, GetIndice (RangeIndex, r), typereturn, func, val) # NIL) ;
RETURN r
END InitTypesReturnTypeCheck ;
(*
InitTypesParameterCheck - checks to see that the types of, d,
and, e, are parameter compatible.
*)
PROCEDURE InitTypesParameterCheck (tokno: CARDINAL;
proc: CARDINAL; paramno: CARDINAL;
formal, actual: CARDINAL;
depRangeId: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeParam (tokno, GetIndice (RangeIndex, r), typeparam, proc,
paramno, formal, actual, depRangeId) # NIL) ;
RETURN r
END InitTypesParameterCheck ;
(*
PutRangeParamAssign - initializes contents of, p, to contain the parameter
type checking information.
It also fills in the current token no
and returns, p.
*)
PROCEDURE PutRangeParamAssign (tokno: CARDINAL; p: Range; t: TypeOfRange; proc: CARDINAL;
i: CARDINAL; formal, actual: CARDINAL; parentRangeId: CARDINAL) : Range ;
BEGIN
WITH p^ DO
type := t ;
des := formal ;
expr := actual ;
desLowestType := GetLowestType (des) ;
exprLowestType := GetLowestType (expr) ;
procedure := proc ;
paramNo := i ;
dimension := i ;
isLeftValue := FALSE ;
tokenNo := tokno ;
dependantid := parentRangeId
END ;
RETURN( p )
END PutRangeParamAssign ;
(*
InitParameterRangeCheck - checks to see that the types of, d, and, e,
are parameter compatible.
*)
PROCEDURE InitParameterRangeCheck (tokno: CARDINAL; proc: CARDINAL; paramno: CARDINAL;
formal, actual: CARDINAL; parentRangeId: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeParamAssign (tokno, GetIndice (RangeIndex, r), paramassign, proc,
paramno, formal, actual, parentRangeId) # NIL) ;
RETURN r
END InitParameterRangeCheck ;
(*
InitTypesExpressionCheck - checks to see that the types of, d, and, e,
are expression compatible.
*)
PROCEDURE InitTypesExpressionCheck (tokno: CARDINAL; d, e: CARDINAL; strict, isin: BOOLEAN) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange() ;
Assert (PutRangeExpr (tokno, GetIndice (RangeIndex, r), typeexpr, d, e, strict, isin) # NIL) ;
RETURN r
END InitTypesExpressionCheck ;
(*
InitForLoopBeginRangeCheck - returns a range check node which
remembers the information necessary
so that a range check for
FOR des := expr1 TO expr2 DO
can be generated later on. expr2 is
only used to type check with des.
*)
PROCEDURE InitForLoopBeginRangeCheck (des, destok,
expr1, expr1tok,
expr2, expr2tok,
byconst, byconsttok: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeDesExpr2 (GetIndice (RangeIndex, r), forloopbegin,
des, destok,
expr1, expr1tok,
expr2, expr2tok,
byconst, byconsttok) # NIL) ;
RETURN r
END InitForLoopBeginRangeCheck ;
(*
InitForLoopToRangeCheck - returns a range check node which
remembers the information necessary
so that a range check for FOR d := e TO .. DO
can be generated later on.
*)
PROCEDURE InitForLoopToRangeCheck (d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRange (GetTokenNo (), GetIndice (RangeIndex, r), forloopto, d, e) # NIL) ;
RETURN r
END InitForLoopToRangeCheck ;
(*
InitForLoopEndRangeCheck - returns a range check node which
remembers the information necessary
so that a range check for
INC or DEC(d, e)
can be generated later on.
*)
PROCEDURE InitForLoopEndRangeCheck (d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRange (GetTokenNo (), GetIndice (RangeIndex, r), forloopend, d, e) # NIL) ;
RETURN r
END InitForLoopEndRangeCheck ;
(*
InitPointerRangeCheck - creates a pointer # NIL check.
*)
PROCEDURE InitPointerRangeCheck (tokno: CARDINAL;
d: CARDINAL; isLeft: BOOLEAN) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangePointer (tokno, GetIndice (RangeIndex, r), d, isLeft) # NIL) ;
RETURN r
END InitPointerRangeCheck ;
(*
InitNoReturnRangeCheck - creates a check held in the function
to detect the absence of a RETURN
statement at runtime.
*)
PROCEDURE InitNoReturnRangeCheck () : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeNoEval (GetIndice(RangeIndex, r), noreturn) # NIL) ;
RETURN r
END InitNoReturnRangeCheck ;
(*
InitNoElseRangeCheck - creates a check held at the end of
a CASE statement without an ELSE
clause to detect its absence
at runtime.
*)
PROCEDURE InitNoElseRangeCheck () : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeNoEval (GetIndice (RangeIndex, r), noelse) # NIL) ;
RETURN r
END InitNoElseRangeCheck ;
(*
InitWholeNonPosDivCheck - creates a check expression for non positive
or zero 2nd operand to division.
*)
PROCEDURE InitWholeNonPosDivCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeUnary (tokno, GetIndice (RangeIndex, r), wholenonposdiv, d, e) # NIL) ;
RETURN r
END InitWholeNonPosDivCheck ;
(*
InitWholeNonPosModCheck - creates a check expression for non positive
or zero 2nd operand to modulus.
*)
PROCEDURE InitWholeNonPosModCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeUnary (tokno, GetIndice (RangeIndex, r), wholenonposmod, d, e) # NIL) ;
RETURN r
END InitWholeNonPosModCheck ;
(*
InitWholeZeroDivisionCheck - creates a check expression for zero 2nd
operand for division.
*)
PROCEDURE InitWholeZeroDivisionCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeUnary (tokno, GetIndice (RangeIndex, r), wholezerodiv, d, e) # NIL) ;
RETURN r
END InitWholeZeroDivisionCheck ;
(*
InitWholeZeroRemainderCheck - creates a check expression for zero 2nd
operand for remainder.
*)
PROCEDURE InitWholeZeroRemainderCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeUnary (tokno, GetIndice (RangeIndex, r), wholezerorem, d, e) # NIL) ;
RETURN r
END InitWholeZeroRemainderCheck ;
(*
FoldNil - attempts to fold the pointer against nil comparison.
*)
PROCEDURE FoldNil (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p: Range ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant (tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
IF GccKnowsAbout (des) AND IsConst (des)
THEN
PushValue (des) ;
PushValue (Nil) ;
IF Equ (tokenno)
THEN
MetaErrorT1 (tokenNo,
'attempting to dereference a pointer {%1Wa} whose value will be NIL',
des) ;
PutQuad (q, ErrorOp, NulSym, NulSym, r)
ELSE
SubQuad (q)
END
END
END
END FoldNil ;
(*
GetMinMax - returns TRUE if we know the max and min of m2type.
*)
PROCEDURE GetMinMax (tokenno: CARDINAL; type: CARDINAL; VAR min, max: tree) : BOOLEAN ;
VAR
minC, maxC: CARDINAL ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
Assert (IsAModula2Type (type)) ;
IF GccKnowsAbout(type) AND (NOT IsPointer(type)) AND
(NOT IsArray(type)) AND (NOT IsRecord(type)) AND
(NOT IsRecord(type)) AND (NOT IsUnbounded(type)) AND
(NOT IsProcType(type)) AND (NOT IsRealType(type)) AND
(NOT IsRealN(type)) AND (NOT IsComplexType(type)) AND
(NOT IsComplexN(type)) AND
(type#Address) AND (NOT IsSet(type)) AND
(type#Word) AND (type#Loc) AND (type#Byte) AND (NOT IsWordN(type))
THEN
IF IsSubrange(type)
THEN
GetSubrange(type, maxC, minC) ;
max := Mod2Gcc(maxC) ;
min := Mod2Gcc(minC)
ELSIF IsEnumeration(type)
THEN
GetBaseTypeMinMax(type, minC, maxC) ;
max := Mod2Gcc(maxC) ;
min := Mod2Gcc(minC)
ELSE
max := GetMaxFrom(location, Mod2Gcc(type)) ;
min := GetMinFrom(location, Mod2Gcc(type))
END ;
max := BuildConvert (location, Mod2Gcc(type), max, FALSE) ;
Assert (NOT TreeOverflow (max)) ;
min := BuildConvert (location, Mod2Gcc(type), min, FALSE) ;
Assert (NOT TreeOverflow (min)) ;
RETURN TRUE
ELSE
RETURN FALSE
END
END GetMinMax ;
(*
OutOfRange - returns TRUE if expr lies outside min..max.
*)
PROCEDURE OutOfRange (tokenno: CARDINAL;
min: tree;
expr: CARDINAL;
max: tree;
type: CARDINAL) : BOOLEAN ;
BEGIN
IF TreeOverflow (min)
THEN
WriteString ("overflow detected in min\n"); WriteLn ;
debug_tree (min)
END ;
IF TreeOverflow (max)
THEN
WriteString ("overflow detected in max\n"); WriteLn ;
debug_tree (max)
END ;
IF TreeOverflow (max)
THEN
WriteString ("overflow detected in expr\n"); WriteLn ;
debug_tree (StringToChar (Mod2Gcc (expr), type, expr));
END ;
PushIntegerTree (StringToChar (Mod2Gcc (expr), type, expr)) ;
PushIntegerTree (min) ;
IF Less (tokenno)
THEN
RETURN TRUE
END ;
PushIntegerTree (StringToChar (Mod2Gcc (expr), type, expr)) ;
PushIntegerTree (max) ;
IF Gre (tokenno)
THEN
RETURN TRUE
END ;
RETURN FALSE
END OutOfRange ;
(*
HandlerExists -
*)
PROCEDURE HandlerExists (r: CARDINAL) : BOOLEAN ;
VAR
p: Range ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
CASE type OF
assignment : RETURN( ExceptionAssign#NulSym ) |
returnassignment : RETURN( ExceptionReturn#NulSym ) |
subrangeassignment : InternalError ('not expecting this case value') |
inc : RETURN( ExceptionInc#NulSym ) |
dec : RETURN( ExceptionDec#NulSym ) |
incl : RETURN( ExceptionIncl#NulSym ) |
excl : RETURN( ExceptionExcl#NulSym ) |
shift : RETURN( ExceptionShift#NulSym ) |
rotate : RETURN( ExceptionRotate#NulSym ) |
typereturn,
typeassign,
typeparam,
typeexpr,
typeindrx : RETURN( FALSE ) |
paramassign : RETURN( ExceptionParameterBounds#NulSym ) |
staticarraysubscript : RETURN( ExceptionStaticArray#NulSym ) |
dynamicarraysubscript: RETURN( ExceptionDynamicArray#NulSym ) |
forloopbegin : RETURN( ExceptionForLoopBegin#NulSym ) |
forloopto : RETURN( ExceptionForLoopTo#NulSym ) |
forloopend : RETURN( ExceptionForLoopEnd#NulSym ) |
pointernil : RETURN( ExceptionPointerNil#NulSym ) |
noreturn : RETURN( ExceptionNoReturn#NulSym ) |
noelse : RETURN( ExceptionCase#NulSym ) |
casebounds : RETURN( FALSE ) |
wholenonposdiv : RETURN( ExceptionNonPosDiv#NulSym ) |
wholenonposmod : RETURN( ExceptionNonPosMod#NulSym ) |
wholezerodiv : RETURN( ExceptionZeroDiv#NulSym ) |
wholezerorem : RETURN( ExceptionZeroRem#NulSym ) |
none : RETURN( FALSE )
ELSE
InternalError ('enumeration value unknown')
END
END
END HandlerExists ;
(*
FoldAssignment - attempts to fold the range violation checks.
It does not issue errors on type violations as that
is performed by FoldTypeAssign.
*)
PROCEDURE FoldAssignment (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
min, max: tree ;
BEGIN
p := GetIndice (RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant (exprtok, expr) ;
IF desLowestType # NulSym
THEN
IF AssignmentTypeCompatible (tokenno, "", des, expr, FALSE)
THEN
IF GccKnowsAbout (expr) AND IsConst (expr) AND
GetMinMax (tokenno, desLowestType, min, max)
THEN
IF OutOfRange (tokenno, min, expr, max, desLowestType)
THEN
MetaErrorT2 (tokenNo,
'attempting to assign a value {%2Wa} to a designator {%1a} which will exceed the range of type {%1tad}',
des, expr) ;
PutQuad (q, ErrorOp, NulSym, NulSym, r)
ELSE
SubQuad (q)
END
END
ELSE
(* We do not issue an error if these types are incompatible here
as this is done by FoldTypeAssign. *)
SubQuad (q)
END
END
END
END FoldAssignment ;
(*
CheckCancelled - check to see if the range has been cancelled and if so remove quad.
*)
(*
PROCEDURE CheckCancelled (range: CARDINAL; quad: CARDINAL) ;
BEGIN
IF IsCancelled (range)
THEN
SubQuad (quad)
END
END CheckCancelled ;
*)
(*
IsCancelled - return the cancelled flag associated with range.
*)
PROCEDURE IsCancelled (range: CARDINAL) : BOOLEAN ;
VAR
p: Range ;
BEGIN
p := GetIndice (RangeIndex, range) ;
WITH p^ DO
IF cancelled
THEN
RETURN TRUE
END ;
IF (dependantid # 0) AND IsCancelled (dependantid)
THEN
cancelled := TRUE
END ;
RETURN cancelled
END
END IsCancelled ;
(*
Cancel - set the cancelled flag in range.
*)
PROCEDURE Cancel (range: CARDINAL) ;
VAR
p: Range ;
BEGIN
IF range # 0
THEN
p := GetIndice (RangeIndex, range) ;
WITH p^ DO
IF NOT cancelled
THEN
cancelled := TRUE ;
Cancel (dependantid)
END
END
END
END Cancel ;
(*
FoldParameterAssign -
*)
PROCEDURE FoldParameterAssign (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
min, max: tree ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant (tokenNo, expr) ;
IF desLowestType#NulSym
THEN
IF GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, desLowestType, min, max)
THEN
IF OutOfRange(tokenno, min, expr, max, desLowestType)
THEN
(* this is safer to treat as an error, rather than a warning
otherwise the paramater might be widened
(if it is a constant). *)
MetaErrorT3(tokenNo,
'the {%3EN} actual parameter {%2a} will exceed the range of formal parameter type {%1tad}',
des, expr, dimension) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSE
SubQuad(q)
END
END
END
END
END FoldParameterAssign ;
(*
FoldReturn - do we know this is reachable, if so generate an error message.
*)
PROCEDURE FoldReturn (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
min, max: tree ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant (tokenNo, expr) ;
IF desLowestType#NulSym
THEN
IF GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, desLowestType, min, max)
THEN
IF OutOfRange(tokenno, min, expr, max, desLowestType)
THEN
MetaErrorT2(tokenNo,
'attempting to return {%2Wa} from a procedure function {%1a} which will exceed exceed the range of type {%1tad}',
des, expr) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSE
SubQuad(q)
END
END
END
END
END FoldReturn ;
(*
FoldInc -
*)
PROCEDURE FoldInc (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
t, min, max: tree ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF desLowestType#NulSym
THEN
IF GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, desLowestType, min, max)
THEN
IF OutOfRange(tokenno, GetIntegerZero(location), expr, max, desLowestType)
THEN
MetaErrorT2(tokenNo,
'operand to INC {%2Wa} exceeds the range of type {%1ts} of the designator {%1a}',
des, expr) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSIF GccKnowsAbout(des) AND IsConst(des) AND GccKnowsAbout(desLowestType)
THEN
t := BuildSub(location,
max,
BuildConvert(location, Mod2Gcc(desLowestType), Mod2Gcc(expr), FALSE),
FALSE) ;
PushIntegerTree(Mod2Gcc(des)) ;
PushIntegerTree(t) ;
IF Gre(tokenNo)
THEN
MetaErrorT1(tokenNo,
'the designator to INC {%1Wa} will exceed the range of type {%1ts}',
des) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSE
(* range check is unnecessary *)
SubQuad(q)
END
END
END
END
END
END FoldInc ;
(*
FoldDec -
*)
PROCEDURE FoldDec (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
t, min, max: tree ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF desLowestType#NulSym
THEN
IF GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, desLowestType, min, max)
THEN
IF OutOfRange(tokenno, GetIntegerZero(location), expr, max, desLowestType)
THEN
MetaErrorT2(tokenNo,
'operand to DEC {%2Wa} exceeds the range of type {%1ts} of the designator {%1a}',
des, expr) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSIF GccKnowsAbout(des) AND IsConst(des) AND GccKnowsAbout(desLowestType)
THEN
t := BuildSub(location,
BuildConvert(location, Mod2Gcc(desLowestType), Mod2Gcc(expr), FALSE),
min,
FALSE) ;
PushIntegerTree(Mod2Gcc(des)) ;
PushIntegerTree(t) ;
IF Less(tokenNo)
THEN
MetaErrorT1(tokenNo,
'the designator to DEC {%1Wa} will exceed the range of type {%1ts}',
des) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSE
(* range check is unnecessary *)
SubQuad(q)
END
END
END
END
END
END FoldDec ;
(*
CheckSetAndBit - returns TRUE if des is a set type and expr is compatible with des.
*)
PROCEDURE CheckSetAndBit (tokenno: CARDINAL;
des, expr: CARDINAL;
name: ARRAY OF CHAR) : BOOLEAN ;
VAR
s: String ;
BEGIN
IF IsSet(des)
THEN
IF IsExpressionCompatible(GetType(des), GetType(expr))
THEN
RETURN( TRUE )
ELSE
s := ConCat(ConCat(InitString('operands to '),
Mark(InitString(name))),
Mark(InitString(' {%1Etsd:{%2tsd:{%1tsd} and {%2tsd}}} are incompatible'))) ;
MetaErrorStringT2(tokenno, s, des, expr) ;
FlushErrors
END
ELSE
s := ConCat(ConCat(InitString('first operand to '),
Mark(InitString(name))),
Mark(InitString(' is not a set {%1Etasd}'))) ;
MetaErrorStringT1(tokenno, s, des) ;
FlushErrors
END ;
RETURN( FALSE )
END CheckSetAndBit ;
(*
CheckSet - returns TRUE if des is a set type and expr is compatible with INTEGER.
*)
PROCEDURE CheckSet (tokenno: CARDINAL;
des, expr: CARDINAL;
name: ARRAY OF CHAR) : BOOLEAN ;
VAR
s: String ;
BEGIN
IF IsSet(des)
THEN
IF IsParameterCompatible(Integer, GetType(expr))
THEN
RETURN( TRUE )
ELSE
s := ConCat(ConCat(InitString('operands to '),
Mark(InitString(name))),
Mark(InitString(' {%1Etsd:{%2tsd:{%1tsd} and {%2tsd}}} are incompatible'))) ;
MetaErrorStringT2(tokenno, s, des, expr) ;
FlushErrors
END
ELSE
s := ConCat(ConCat(InitString('first operand to '),
Mark(InitString(name))),
Mark(InitString(' is not a set {%1Etasd}'))) ;
MetaErrorStringT1(tokenno, s, des) ;
FlushErrors
END ;
RETURN( FALSE )
END CheckSet ;
(*
FoldIncl - folds an INCL statement if the operands are constant.
*)
PROCEDURE FoldIncl (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
min, max: tree ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
desLowestType := SkipType(GetType(des)) ;
IF desLowestType#NulSym
THEN
IF CheckSetAndBit(tokenno, desLowestType, expr, "INCL")
THEN
IF GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, desLowestType, min, max)
THEN
IF OutOfRange(tokenno, min, expr, max, desLowestType)
THEN
MetaErrorT2(tokenNo,
'operand to INCL {%2Wa} exceeds the range of type {%1tasa}',
des, expr) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSE
(* range check is unnecessary *)
SubQuad(q)
END
END
END
END
END
END FoldIncl ;
(*
FoldExcl - folds an EXCL statement if the operands are constant.
*)
PROCEDURE FoldExcl (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
min, max: tree ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
desLowestType := SkipType(GetType(des)) ;
IF desLowestType#NulSym
THEN
IF CheckSetAndBit(tokenno, desLowestType, expr, "EXCL")
THEN
IF GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, desLowestType, min, max)
THEN
IF OutOfRange(tokenno, min, expr, max, desLowestType)
THEN
MetaErrorT2(tokenNo,
'operand to EXCL {%2Wa} exceeds the range of type {%1tasa}',
des, expr) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSE
(* range check is unnecessary *)
SubQuad(q)
END
END
END
END
END
END FoldExcl ;
(*
FoldShift - folds an SHIFT test statement if the operands are constant.
*)
PROCEDURE FoldShift (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
ofType : CARDINAL ;
p : Range ;
shiftMin,
shiftMax,
min, max: tree ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
desLowestType := SkipType(GetType(des)) ;
IF desLowestType#NulSym
THEN
IF CheckSet(tokenno, desLowestType, expr, "SHIFT")
THEN
ofType := SkipType(GetType(desLowestType)) ;
IF GccKnowsAbout(ofType) AND
GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, ofType, min, max)
THEN
min := BuildConvert(location, GetIntegerType(), min, FALSE) ;
max := BuildConvert(location, GetIntegerType(), max, FALSE) ;
shiftMax := BuildAdd(location, BuildSub(location, max, min, FALSE),
GetIntegerOne(location),
FALSE) ;
shiftMin := BuildNegate(location, shiftMax, FALSE) ;
IF OutOfRange(tokenno, shiftMin, expr, shiftMax, desLowestType)
THEN
MetaErrorT2(tokenNo,
'operand to SHIFT {%2Wa} exceeds the range of type {%1tasa}',
des, expr) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSE
(* range check is unnecessary *)
SubQuad(q)
END
END
END
END
END
END FoldShift ;
(*
FoldRotate - folds a ROTATE test statement if the operands are constant.
*)
PROCEDURE FoldRotate (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
ofType : CARDINAL ;
p : Range ;
rotateMin,
rotateMax,
min, max : tree ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
desLowestType := SkipType(GetType(des)) ;
IF desLowestType#NulSym
THEN
IF CheckSet(tokenno, desLowestType, expr, "ROTATE")
THEN
ofType := SkipType(GetType(desLowestType)) ;
IF GccKnowsAbout(ofType) AND
GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, ofType, min, max)
THEN
min := BuildConvert(location, GetIntegerType(), min, FALSE) ;
max := BuildConvert(location, GetIntegerType(), max, FALSE) ;
rotateMax := BuildAdd(location,
BuildSub(location, max, min, FALSE),
GetIntegerOne(location),
FALSE) ;
rotateMin := BuildNegate(location, rotateMax, FALSE) ;
IF OutOfRange(tokenno, rotateMin, expr, rotateMax, desLowestType)
THEN
MetaErrorT2(tokenNo,
'operand to ROTATE {%2Wa} exceeds the range of type {%1tasa}',
des, expr) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSE
(* range check is unnecessary *)
SubQuad(q)
END
END
END
END
END
END FoldRotate ;
(*
FoldTypeReturnFunc - checks to see that val can be returned from func.
*)
PROCEDURE FoldTypeReturnFunc (q: CARDINAL; tokenNo: CARDINAL; func, val: CARDINAL; r: CARDINAL) ;
VAR
valType,
returnType: CARDINAL ;
BEGIN
returnType := GetType (func) ;
IF returnType = NulSym
THEN
IF NOT reportedError (r)
THEN
MetaErrorsT2 (tokenNo,
'procedure {%1Da} is not a procedure function',
'{%2ad} cannot be returned from {%1Da}',
func, val) ;
SubQuad(q)
END
ELSE
valType := val ;
IF IsVar (val) AND (GetMode (val) = LeftValue)
THEN
valType := GetType (val)
END ;
IF AssignmentTypeCompatible (tokenNo, "", returnType, valType, FALSE)
THEN
SubQuad (q)
ELSE
IF NOT reportedError (r)
THEN
MetaErrorsT2 (tokenNo,
'the return type {%1Etad} used in procedure {%1Da}',
'is incompatible with the returned expression {%1ad}}',
func, val) ;
setReported (r) ;
FlushErrors
END
END
END
END FoldTypeReturnFunc ;
(*
FoldTypeAssign -
*)
PROCEDURE FoldTypeAssign (q: CARDINAL; tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ;
BEGIN
IF NOT reportedError (r)
THEN
IF AssignmentTypeCompatible (tokenNo,
'assignment designator {%1Ea} {%1ta:of type {%1ta}}' +
' cannot be assigned with' +
' {%2ad: a {%2td} {%2ad}}{!%2ad: {%2ad} of type {%2tad}}',
des, expr, TRUE)
THEN
SubQuad (q)
ELSE
setReported (r) ;
FlushErrors
END
END
END FoldTypeAssign ;
(*
FoldTypeIndrX - check to see that des = *expr is type compatible.
*)
PROCEDURE FoldTypeIndrX (q: CARDINAL; tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ;
VAR
exprType: CARDINAL ;
BEGIN
(* Need to skip over a variable or temporary in des and expr so
long as expr is not a procedure. In the case of des = *expr,
both expr and des will be variables due to the property of
indirection. *)
IF IsProcedure (expr)
THEN
(* Must not GetType for a procedure as it gives the return type. *)
exprType := expr
ELSE
exprType := GetType (expr)
END ;
IF AssignmentTypeCompatible (tokenNo, "", GetType (des), GetType (expr), FALSE)
THEN
SubQuad(q)
ELSE
IF NOT reportedError (r)
THEN
IF IsProcedure (des)
THEN
MetaErrorsT2 (tokenNo,
'the return type {%1Etad} declared in procedure {%1Da}',
'is incompatible with the returned expression {%2ad}}',
des, expr) ;
ELSE
MetaErrorT3 (tokenNo,
'assignment designator {%1Ea} {%1ta:of type {%1ta}}' +
' {%1d:is a {%1d}} and expression {%2a} {%3ad:of type' +
' {%3ad}} are incompatible',
des, expr, exprType)
END ;
setReported (r) ;
FlushErrors
END
END
END FoldTypeIndrX ;
(*
FoldTypeParam - performs a parameter check between actual and formal.
The quad is removed if the check succeeds.
*)
PROCEDURE FoldTypeParam (q: CARDINAL; tokenNo: CARDINAL;
formal, actual, procedure: CARDINAL;
paramNo: CARDINAL;
depRangeId: CARDINAL) ;
VAR
compatible: BOOLEAN ;
BEGIN
compatible := FALSE ;
IF IsVarParamAny (procedure, paramNo)
THEN
(* Expression type compatibility rules for pass by reference parameters. *)
compatible := ParameterTypeCompatible (tokenNo,
'{%4EN} parameter failure due to expression incompatibility between actual parameter {%3ad} and the {%4N} formal {%2ad} parameter in procedure {%1ad}',
procedure, formal, actual, paramNo, TRUE)
ELSIF GetPIM ()
THEN
(* Assignment type compatibility rules for pass by value PIM parameters. *)
compatible := ParameterTypeCompatible (tokenNo,
'{%4EN} parameter failure due to assignment incompatibility between actual parameter {%3ad} and the {%4N} formal {%2ad} parameter in procedure {%1ad}',
procedure, formal, actual, paramNo, FALSE)
ELSE
compatible := ParameterTypeCompatible (tokenNo,
'{%4EN} parameter failure due to parameter incompatibility between actual parameter {%3ad} and the {%4N} formal {%2ad} parameter in procedure {%1ad}',
procedure, formal, actual, paramNo, FALSE)
END ;
IF compatible
THEN
SubQuad(q)
ELSE
Cancel (depRangeId)
END
END FoldTypeParam ;
(*
FoldTypeExpr -
*)
PROCEDURE FoldTypeExpr (q: CARDINAL; tokenNo: CARDINAL; left, right: CARDINAL; strict, isin: BOOLEAN; r: CARDINAL) ;
BEGIN
IF (left # NulSym) AND (right # NulSym) AND (NOT reportedError (r))
THEN
IF ExpressionTypeCompatible (tokenNo,
'expression of type {%1Etad} is incompatible with type {%2tad}',
left, right, strict, isin)
THEN
SubQuad(q)
ELSE
setReported (r)
END
END
END FoldTypeExpr ;
(*
CodeTypeAssign -
*)
PROCEDURE CodeTypeAssign (tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ;
BEGIN
IF NOT AssignmentTypeCompatible (tokenNo, "", des, expr, FALSE)
THEN
IF NOT reportedError (r)
THEN
MetaErrorT2 (tokenNo,
'assignment designator {%1Ea} {%1ta:of type {%1ta}} {%1d:is a {%1d}} and expression {%2a} {%2tad:of type {%2tad}} are incompatible',
des, expr)
END ;
setReported (r)
END
END CodeTypeAssign ;
(*
CodeTypeReturnFunc -
*)
PROCEDURE CodeTypeReturnFunc (tokenNo: CARDINAL; func, val: CARDINAL; r: CARDINAL) ;
VAR
valType,
returnType: CARDINAL ;
BEGIN
returnType := GetType (func) ;
IF returnType = NulSym
THEN
IF NOT reportedError (r)
THEN
MetaErrorsT2 (tokenNo,
'procedure {%1Da} is not a procedure function',
'{%2ad} cannot be returned from {%1Da}',
func, val) ;
END
ELSE
valType := val ;
IF IsVar (val) AND (GetMode (val) = LeftValue)
THEN
valType := GetType (val)
END ;
IF NOT AssignmentTypeCompatible (tokenNo, "", returnType, valType, FALSE)
THEN
IF NOT reportedError (r)
THEN
MetaErrorsT2 (tokenNo,
'the return type {%1Etad} used in procedure function {%1Da}',
'is incompatible with the returned expression {%2EUa} {%2tad:of type {%2tad}}',
func, val)
END
END
END
END CodeTypeReturnFunc ;
(*
CodeTypeIndrX - checks that des = *expr is type compatible and generates an error if they
are not compatible. It skips over the LValue type so that to allow
the error messages to pick up the source variable name rather than
a temporary name or vague name 'expression'.
*)
PROCEDURE CodeTypeIndrX (tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ;
BEGIN
IF NOT AssignmentTypeCompatible (tokenNo, "", GetType (des), GetType (expr), FALSE)
THEN
IF NOT reportedError (r)
THEN
IF IsProcedure (des)
THEN
MetaErrorsT2 (tokenNo,
'the return type {%1Etad} declared in procedure {%1Da}',
'is incompatible with the returned expression {%2EUa} {%2tad:of type {%2tad}}',
des, expr) ;
ELSE
MetaErrorT2 (tokenNo,
'assignment designator {%1Ea} {%1ta:of type {%1ta}}' +
' {%1d:is a {%1d}} and expression {%2a}' +
' {%2tad:of type {%2tad}} are incompatible',
des, expr)
END ;
setReported (r)
END
(* FlushErrors *)
END
END CodeTypeIndrX ;
(*
CodeTypeParam -
*)
PROCEDURE CodeTypeParam (tokenNo: CARDINAL; formal, actual, procedure: CARDINAL; paramNo: CARDINAL) ;
BEGIN
IF NOT ParameterTypeCompatible (tokenNo,
'{%4EN} type failure between actual {%3ad} and the formal {%2ad}',
procedure, formal, actual, paramNo, IsVarParamAny (procedure, paramNo))
THEN
END
END CodeTypeParam ;
(*
CodeTypeExpr -
*)
PROCEDURE CodeTypeExpr (tokenNo: CARDINAL; left, right: CARDINAL; strict, isin: BOOLEAN; r: CARDINAL) ;
BEGIN
IF NOT reportedError (r)
THEN
IF ExpressionTypeCompatible (tokenNo,
'expression of type {%1Etad} is incompatible with type {%2tad}',
left, right, strict, isin)
THEN
setReported (r)
END
END
END CodeTypeExpr ;
(*
FoldTypeCheck - folds a type check. This is a no-op and it used
for checking types which are resolved post pass 3.
*)
PROCEDURE FoldTypeCheck (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p: Range ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
(* TryDeclareConstructor(q, expr) ; *)
IF (GccKnowsAbout(des) OR (IsParameter(des) AND GccKnowsAbout(GetType(des)))) AND
GccKnowsAbout(expr)
THEN
CASE type OF
typeassign: FoldTypeAssign (q, tokenNo, des, expr, r) |
typeparam : FoldTypeParam (q, tokenNo, des, expr, procedure, paramNo, r) |
typeexpr : FoldTypeExpr (q, tokenNo, des, expr, strict, isin, r) |
typeindrx : FoldTypeIndrX (q, tokenNo, des, expr, r) |
typereturn: FoldTypeReturnFunc (q, tokenNo, des, expr, r)
ELSE
InternalError ('not expecting to reach this point')
END
END
END
END FoldTypeCheck ;
(*
CodeTypeCheck - folds a type check. This is a no-op and it used
for checking types which are resolved post pass 3.
It does assume that both, des, and, expr, have been
resolved at this point.
*)
PROCEDURE CodeTypeCheck (tokenno: CARDINAL; r: CARDINAL) ;
VAR
p: Range ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
(* TryDeclareConstructor(0, expr) ; *)
IF (GccKnowsAbout(des) OR (IsParameter(des) AND GccKnowsAbout(GetType(des)))) AND
GccKnowsAbout(expr)
THEN
CASE type OF
typeassign: CodeTypeAssign (tokenNo, des, expr, r) |
typeparam : CodeTypeParam (tokenNo, des, expr, procedure, paramNo) |
typeexpr : CodeTypeExpr (tokenNo, des, expr, strict, isin, r) |
typeindrx : CodeTypeIndrX (tokenNo, des, expr, r) |
typereturn: CodeTypeReturnFunc (tokenNo, des, expr, r)
ELSE
InternalError ('not expecting to reach this point')
END
ELSE
InternalError ('expecting des and expr to be resolved')
END
END
END CodeTypeCheck ;
(*
ForLoopBeginTypeCompatible - check for designator assignment compatibility with
expr1 and designator expression compatibility with expr2.
FOR des := expr1 TO expr2 BY byconst DO
END
It generates composite tokens if the tokens are on
the same source line.
*)
PROCEDURE ForLoopBeginTypeCompatible (p: Range) : BOOLEAN ;
VAR
combinedtok: CARDINAL ;
success : BOOLEAN ;
BEGIN
success := TRUE ;
WITH p^ DO
combinedtok := MakeVirtual2Tok (destok, exprtok) ;
IF NOT AssignmentTypeCompatible (combinedtok, "", des, expr, TRUE)
THEN
MetaErrorT2 (combinedtok,
'type incompatibility between {%1Et} and {%2t} detected during the assignment of the designator {%1a} to the first expression {%2a} in the {%kFOR} loop',
des, expr) ;
success := FALSE
END ;
combinedtok := MakeVirtual2Tok (destok, expr2tok) ;
IF NOT ExpressionTypeCompatible (combinedtok, "", des, expr2, TRUE, FALSE)
THEN
MetaErrorT2 (combinedtok,
'type expression incompatibility between {%1Et} and {%2t} detected when comparing the designator {%1a} against the second expression {%2a} in the {%kFOR} loop',
des, expr2) ;
success := FALSE
END ;
combinedtok := MakeVirtual2Tok (destok, byconsttok) ;
IF NOT ExpressionTypeCompatible (combinedtok, "", des, byconst, TRUE, FALSE)
THEN
MetaErrorT2 (combinedtok,
'type expression incompatibility between {%1Et} and {%2t} detected between the designator {%1a} and the {%kBY} constant expression {%2a} in the {%kFOR} loop',
des, byconst) ;
success := FALSE
END ;
IF (NOT success) AND (incrementquad # 0)
THEN
(* Avoid a subsequent generic type check error. *)
SubQuad (incrementquad)
END
END ;
RETURN success
END ForLoopBeginTypeCompatible ;
(*
FoldForLoopBegin -
*)
PROCEDURE FoldForLoopBegin (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
min, max: tree ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF desLowestType#NulSym
THEN
IF GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, desLowestType, min, max)
THEN
IF NOT ForLoopBeginTypeCompatible (p)
THEN
SubQuad (q)
ELSIF OutOfRange (tokenno, min, expr, max, desLowestType)
THEN
MetaErrorT2 (tokenNo,
'attempting to assign a value {%2Wa} to a FOR loop designator {%1a} which will exceed the range of type {%1tad}',
des, expr) ;
PutQuad (q, ErrorOp, NulSym, NulSym, r)
ELSE
SubQuad (q)
END
END
END
END
END FoldForLoopBegin ;
(*
FoldForLoopTo -
*)
PROCEDURE FoldForLoopTo (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
min, max: tree ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF desLowestType#NulSym
THEN
IF GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, desLowestType, min, max)
THEN
IF OutOfRange(tokenno, min, expr, max, desLowestType)
THEN
MetaErrorT2(tokenNo,
'final value in FOR loop will exceed type range {%1Wtasa} of designator {%2a}',
des, expr) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSE
SubQuad(q)
END
END
END
END
END FoldForLoopTo ;
(*
FoldStaticArraySubscript -
*)
PROCEDURE FoldStaticArraySubscript (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
min, max: tree ;
BEGIN
p := GetIndice (RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant (tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
TryDeclareConstant (tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF desLowestType#NulSym
THEN
IF GccKnowsAbout (expr) AND IsConst (expr) AND
GetMinMax (tokenno, desLowestType, min, max)
THEN
IF OutOfRange (tokenno, min, expr, max, desLowestType)
THEN
MetaErrorT3 (tokenNo,
'index {%2Wa} out of range found while attempting to access an element of a static array {%1a} in the {%3N} array subscript',
des, expr, dimension) ;
PutQuad (q, ErrorOp, NulSym, NulSym, r)
ELSE
(* range check is unnecessary *)
SubQuad (q)
END
END
END
END
END FoldStaticArraySubscript ;
(*
FoldDynamicArraySubscript -
*)
PROCEDURE FoldDynamicArraySubscript (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
location: location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF desLowestType#NulSym
THEN
IF GccKnowsAbout(expr) AND IsConst(expr)
THEN
IF IsGreater(GetIntegerZero(location), BuildConvert(location, GetIntegerType(), Mod2Gcc(expr), FALSE))
THEN
MetaErrorT3(tokenNo,
'index {%2Wa} out of range found while attempting to access an element of a dynamic array {%1a} in the {%3N} array subscript',
des, expr, dimension) ;
PutQuad(q, ErrorOp, NulSym, NulSym, r)
ELSE
(* cannot fold high bounds, so leave that for the runtime *)
END
END
END
END
END FoldDynamicArraySubscript ;
(*
FoldCaseBounds -
*)
PROCEDURE FoldCaseBounds (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
errorGenerated: BOOLEAN ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
IF CaseBoundsResolved(tokenno, caseList)
THEN
errorGenerated := FALSE ;
IF TypeCaseBounds (caseList)
THEN
(* nothing to do *)
END ;
IF OverlappingCaseBounds(caseList)
THEN
PutQuad(q, ErrorOp, NulSym, NulSym, r) ;
errorGenerated := TRUE
END ;
IF VariantValueChecking AND MissingCaseBounds(tokenno, caseList)
THEN
IF NOT errorGenerated
THEN
PutQuad(q, ErrorOp, NulSym, NulSym, r) ;
errorGenerated := TRUE
END
END ;
IF CaseEnumChecking AND MissingCaseStatementBounds (tokenno, caseList)
THEN
IF NOT errorGenerated
THEN
PutQuad(q, ErrorOp, NulSym, NulSym, r) ;
errorGenerated := TRUE
END
END ;
IF NOT errorGenerated
THEN
SubQuad(q)
END
END
END
END FoldCaseBounds ;
(*
CodeCaseBounds - attempts to resolve whether the case bounds are legal.
This should resolve at compile time as all case bounds
must be constants. We introduce a CodeCaseBounds as it
might be possible that constants have just been declared
during the code generation of this function.
*)
PROCEDURE CodeCaseBounds (tokenno: CARDINAL; caseList: CARDINAL) ;
BEGIN
IF CaseBoundsResolved (tokenno, caseList)
THEN
IF TypeCaseBounds (caseList)
THEN
(* nothing to do *)
END ;
IF OverlappingCaseBounds (caseList)
THEN
(* nothing to do *)
END ;
IF MissingCaseBounds (tokenno, caseList)
THEN
(* nothing to do *)
END ;
IF CaseEnumChecking AND MissingCaseStatementBounds (tokenno, caseList)
THEN
(* nothing to do *)
END
ELSE
MetaErrorT0 (tokenno, '{%E}the CASE statement ranges must be constants')
END
END CodeCaseBounds ;
(*
MakeAndDeclareConstLit - creates a constant of value and declares it to GCC.
*)
PROCEDURE MakeAndDeclareConstLit (tokenno: CARDINAL; value: Name; type: CARDINAL) : CARDINAL ;
VAR
constant: CARDINAL ;
BEGIN
constant := MakeConstLit (tokenno, value, type) ;
TryDeclareConstant (tokenno, constant) ; (* use quad tokenno, rather than the range tokenNo *)
Assert (GccKnowsAbout (constant)) ;
RETURN constant
END MakeAndDeclareConstLit ;
(*
FoldNonPosDiv - attempts to fold the bound checking for a divide expression.
*)
PROCEDURE FoldNonPosDiv (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
zero: CARDINAL ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF GccKnowsAbout(expr) AND IsConst(expr)
THEN
zero := MakeAndDeclareConstLit (tokenno, MakeKey ('0'), ZType) ;
IF IsGreaterOrEqualConversion (TokenToLocation (tokenno), zero, des, expr)
THEN
MetaErrorT2 (tokenNo,
'the divisor {%2Wa} in this division expression is less than or equal to zero, this will cause an exception to be raised before the result is assigned to the designator {%1a}',
des, expr) ;
PutQuad (q, ErrorOp, NulSym, NulSym, r)
END
END
END
END FoldNonPosDiv ;
(*
FoldNonPosMod - attempts to fold the bound checking for a modulus expression.
*)
PROCEDURE FoldNonPosMod (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
zero: CARDINAL ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF GccKnowsAbout(expr) AND IsConst(expr)
THEN
zero := MakeAndDeclareConstLit (tokenno, MakeKey('0'), ZType) ;
IF IsGreaterOrEqualConversion (TokenToLocation(tokenno), zero, des, expr)
THEN
MetaErrorT2 (tokenNo,
'the divisor {%2Wa} in this modulus expression is less than or equal to zero, this will cause an exception to be raised before the result is assigned to the designator {%1a}',
des, expr) ;
PutQuad (q, ErrorOp, NulSym, NulSym, r)
END
END
END
END FoldNonPosMod ;
(*
FoldZeroDiv -
*)
PROCEDURE FoldZeroDiv (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
zero: CARDINAL ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF GccKnowsAbout(expr) AND IsConst(expr)
THEN
zero := MakeAndDeclareConstLit (tokenno, MakeKey ('0'), ZType) ;
IF IsEqualConversion (zero, des, expr)
THEN
MetaErrorT2 (tokenNo,
'the divisor {%2Wa} in this division expression is equal to zero, this will cause an exception to be raised before the result is assigned to the designator {%1a}',
des, expr) ;
PutQuad (q, ErrorOp, NulSym, NulSym, r)
END
END
END
END FoldZeroDiv ;
(*
FoldZeroRem -
*)
PROCEDURE FoldZeroRem (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
p : Range ;
zero: CARDINAL ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF GccKnowsAbout(expr) AND IsConst(expr)
THEN
zero := MakeAndDeclareConstLit (tokenno, MakeKey ('0'), ZType) ;
IF IsEqualConversion (zero, des, expr)
THEN
MetaErrorT2 (tokenNo,
'the divisor {%2Wa} in this remainder expression is equal to zero, this will cause an exception to be raised before the result is assigned to the designator {%1a}',
des, expr) ;
PutQuad (q, ErrorOp, NulSym, NulSym, r)
END
END
END
END FoldZeroRem ;
(*
FoldRangeCheck - attempts to resolve the range check.
If it evaluates to true then
it is replaced by an ErrorOp
elsif it evaluates to false then
it is removed
else
it is left alone
*)
PROCEDURE FoldRangeCheck (tokenno: CARDINAL; quad: CARDINAL; range: CARDINAL) ;
BEGIN
IF IsCancelled (range)
THEN
SubQuad (quad)
ELSE
FoldRangeCheckLower (tokenno, quad, range)
END
END FoldRangeCheck ;
(*
FoldRangeCheckLower - call the appropriate Fold procedure depending upon the type
of range.
*)
PROCEDURE FoldRangeCheckLower (tokenno: CARDINAL; quad: CARDINAL; range: CARDINAL) ;
VAR
p: Range ;
BEGIN
p := GetIndice(RangeIndex, range) ;
WITH p^ DO
CASE type OF
assignment : FoldAssignment(tokenno, quad, range) |
returnassignment : FoldReturn(tokenno, quad, range) |
(* subrangeassignment : | unused currently *)
inc : FoldInc(tokenno, quad, range) |
dec : FoldDec(tokenno, quad, range) |
incl : FoldIncl(tokenno, quad, range) |
excl : FoldExcl(tokenno, quad, range) |
shift : FoldShift(tokenno, quad, range) |
rotate : FoldRotate(tokenno, quad, range) |
typereturn,
typeassign,
typeparam,
typeexpr,
typeindrx : FoldTypeCheck (tokenno, quad, range) |
paramassign : FoldParameterAssign(tokenno, quad, range) |
staticarraysubscript : FoldStaticArraySubscript(tokenno, quad, range) |
dynamicarraysubscript: FoldDynamicArraySubscript(tokenno, quad, range) |
forloopbegin : FoldForLoopBegin(tokenno, quad, range) |
forloopto : FoldForLoopTo(tokenno, quad, range) |
forloopend : RETURN (* unable to fold anything at this point, des, will be variable *) |
pointernil : FoldNil(tokenno, quad, range) |
noreturn : RETURN (* nothing to fold *) |
noelse : RETURN (* nothing to fold *) |
casebounds : FoldCaseBounds(tokenno, quad, range) |
wholenonposdiv : FoldNonPosDiv(tokenno, quad, range) |
wholenonposmod : FoldNonPosMod(tokenno, quad, range) |
wholezerodiv : FoldZeroDiv(tokenno, quad, range) |
wholezerorem : FoldZeroRem(tokenno, quad, range) |
none : SubQuad(quad)
ELSE
InternalError ('unexpected case')
END
END
END FoldRangeCheckLower ;
(*
DeReferenceLValue - returns a Tree which is either ModGcc(expr)
or Mod2Gcc ( *expr) depending whether, expr,
is an LValue.
*)
PROCEDURE DeReferenceLValue (tokenno: CARDINAL; expr: CARDINAL) : tree ;
VAR
e : tree ;
location: location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
e := Mod2Gcc(expr) ;
IF GetMode(expr)=LeftValue
THEN
e := BuildIndirect(location, e, Mod2Gcc(GetType(expr)))
END ;
RETURN( e )
END DeReferenceLValue ;
(*
BuildStringParam - builds a C style string parameter which will be passed
as an ADDRESS type.
*)
PROCEDURE BuildStringParam (tokenno: CARDINAL; s: String) ;
BEGIN
BuildStringParamLoc (TokenToLocation(tokenno), s)
END BuildStringParam ;
(*
BuildStringParamLoc - builds a C style string parameter which will be passed
as an ADDRESS type.
*)
PROCEDURE BuildStringParamLoc (location: location_t; s: String) ;
BEGIN
BuildParam (location,
BuildConvert (location, Mod2Gcc (Address),
BuildAddr (location, BuildStringConstant (string(s), Length(s)),
FALSE), FALSE))
END BuildStringParamLoc ;
(*
CodeErrorCheck - returns a Tree calling the approprate exception handler.
*)
PROCEDURE CodeErrorCheck (r: CARDINAL; function, message: String) : tree ;
VAR
filename: String ;
line,
column : CARDINAL ;
p : Range ;
f : tree ;
location: location_t ;
BEGIN
IF HandlerExists (r)
THEN
IF message = NIL
THEN
message := GetRangeErrorMessage (r)
END ;
message := FillInParameters (r, message) ;
p := GetIndice (RangeIndex, r) ;
WITH p^ DO
filename := FindFileNameFromToken (tokenNo, 0) ;
line := TokenToLineNo (tokenNo, 0) ;
column := TokenToColumnNo (tokenNo, 0) ;
location := TokenToLocation (tokenNo) ;
f := Mod2Gcc (lookupExceptionHandler (type)) ;
BuildStringParam (tokenNo, message) ;
BuildStringParam (tokenNo, function) ;
BuildParam (location, BuildIntegerConstant (column)) ;
BuildParam (location, BuildIntegerConstant (line)) ;
BuildStringParam (tokenNo, filename) ;
RETURN BuildProcedureCallTree (location, f, NIL)
END
ELSE
RETURN NIL
END
END CodeErrorCheck ;
(*
IssueWarning - issue a warning. The compiler knows that this basic block can be reached
and we are in scope, function.
*)
PROCEDURE IssueWarning (function: String; r: CARDINAL) ;
VAR
p: Range ;
s: String ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
CASE type OF
assignment : s := InitString('if the assignment is ever executed then the designator {%1Wa} will exceed the type range {%1ts:of {%1ts}}') |
returnassignment : s := InitString('if the value {%2Wa} is returned from procedure function {%1Wa} then it will exceed the type range {%1ts:of {%1ts}}') |
subrangeassignment : InternalError ('not expecting this case value') |
inc : s := InitString('if the INC is ever executed the expression {%2Wa} will cause an overflow error for the designator {%1a} as it exceeds the type range {%1ts:of {%1ts}}') |
dec : s := InitString('if the DEC is ever executed the expression {%2Wa} will cause an underflow error for the designator {%1a} as it exceeds the type range {%1ts:of {%1ts}}') |
incl : s := InitString('the expression {%2Wa} given in the INCL exceeds the type range {%1ts} of the designator {%1a}') |
excl : s := InitString('the expression {%2Wa} given in the EXCL exceeds the type range {%1ts} of the designator {%1a}') |
shift : s := InitString('the expression {%2Wa} given in the second parameter to SHIFT exceeds the type range {%1ts} of the first parameter {%1a}') |
rotate : s := InitString('the expression {%2Wa} given in the second parameter to ROTATE exceeds the type range {%1ts} of the first parameter {%1a}') |
typeassign : s := InitString('') |
typeparam : s := InitString('') |
typeexpr : s := InitString('') |
paramassign : s := InitString('if this call is executed then the actual parameter {%2Wa} will be out of range of the {%3N} formal parameter {%1a}') |
staticarraysubscript : s := InitString('if this access to the static array {%1Wa:{%2a:{%1a}[{%2a}]}} is ever made then the index will be out of bounds in the {%3N} array subscript') |
dynamicarraysubscript: s := InitString('if this access to the dynamic array {%1Wa:{%2a:{%1a}[{%2a}]}} is ever made then the index will be out of bounds in the {%3N} array subscript') |
forloopbegin : s := InitString('if the assignment in this FOR loop is ever executed then the designator {%1Wa} will be exceed the type range {%1ts:of {%1ts}}') |
forloopto : s := InitString('the final value {%2Wa} in this FOR loop will be out of bounds {%1ts:of type {%1ts}} if ever executed') |
forloopend : s := InitString('the FOR loop will cause the designator {%1Wa} to be out of bounds when the BY value {%2a} is added') |
pointernil : s := InitString('if this pointer value {%1Wa} is ever dereferenced it will cause an exception') |
noreturn : s := InitString('{%1W:}this function will exit without executing a RETURN statement') |
noelse : s := InitString('{%1W:}this CASE statement does not have an ELSE statement') |
casebounds : s := InitString('{%1W:}this CASE statement has overlapping ranges') |
wholenonposdiv : s := InitString('this division expression {%2Wa} will cause an exception as this divisor is less than or equal to zero') |
wholenonposmod : s := InitString('this modulus expression {%2Wa} will cause an exception as this divisor is less than or equal to zero') |
wholezerodiv : s := InitString('this division expression {%2Wa} will cause an exception as the divisor is zero') |
wholezerorem : s := InitString('this remainder expression {%2Wa} will cause an exception as the divisor is zero') |
none : InternalError ('unexpected value')
ELSE
InternalError ('enumeration value unknown')
END ;
s := ConCat (s, Mark (InitString (' in ('))) ;
s := ConCat (s, function) ;
s := ConCatChar (s, ')') ;
MetaErrorStringT3 (tokenNo, s, des, expr, dimension) ;
(* FlushErrors *)
END
END IssueWarning ;
(*
CodeErrorCheckLoc - generate a runtime error message positioned at location
and in function. If function is NIL then the error scope
is used.
*)
PROCEDURE CodeErrorCheckLoc (location: location_t;
function, message: ConstCharStar; func: CARDINAL) : tree ;
VAR
scope,
errorMessage: String ;
t : tree ;
filename : String ;
line,
column : CARDINAL ;
BEGIN
IF func = NulSym
THEN
RETURN NIL
ELSE
t := Mod2Gcc (func) ;
IF t # NIL
THEN
filename := InitStringCharStar (GetFilenameFromLocation (location)) ;
Assert (message # NIL) ;
errorMessage := InitStringCharStar (message) ;
column := GetColumnNoFromLocation (location) ;
line := GetLineNoFromLocation (location) ;
BuildStringParamLoc (location, errorMessage) ;
IF function = NIL
THEN
scope := GetAnnounceScope (filename, NIL)
ELSE
scope := quoteOpen (InitString ('')) ;
scope := ConCat (scope, Mark (InitStringCharStar (function))) ;
scope := ConCat (InitString ("procedure "), quoteClose (scope))
END ;
BuildStringParamLoc (location, scope) ;
BuildParam (location, BuildIntegerConstant (column)) ;
BuildParam (location, BuildIntegerConstant (line)) ;
BuildStringParamLoc (location, filename) ;
t := BuildProcedureCallTree (location, t, NIL) ;
(*
filename := KillString (filename) ;
scope := KillString (scope) ;
errorMessage := KillString (errorMessage)
*)
END ;
RETURN t
END
END CodeErrorCheckLoc ;
(*
IssueWarningLoc -
*)
PROCEDURE IssueWarningLoc (location: location_t; message: ConstCharStar) ;
VAR
s: String ;
BEGIN
s := InitString ("numerical overflow detected when performing ") ;
s := ConCat (s, Mark (InitStringCharStar (message))) ;
ErrorAt (location, string (s)) ;
s := KillString (s)
END IssueWarningLoc ;
(*
BuildIfCallWholeHandlerLoc - return a Tree containing a runtime test whether, condition, is true.
*)
PROCEDURE BuildIfCallWholeHandlerLoc (location: location_t; condition: tree;
scope, message: ConstCharStar) : tree ;
BEGIN
RETURN BuildIfCallHandlerLoc (location, condition, scope, message, ExceptionWholeValue)
END BuildIfCallWholeHandlerLoc ;
(*
BuildIfCallRealHandlerLoc - return a Tree containing a runtime test whether, condition, is true.
*)
PROCEDURE BuildIfCallRealHandlerLoc (location: location_t; condition: tree;
scope, message: ConstCharStar) : tree ;
BEGIN
RETURN BuildIfCallHandlerLoc (location, condition, scope, message, ExceptionRealValue)
END BuildIfCallRealHandlerLoc ;
(*
BuildIfCallHandlerLoc - return a Tree containing a runtime test whether, condition, is true.
*)
PROCEDURE BuildIfCallHandlerLoc (location: location_t; condition: tree;
scope, message: ConstCharStar; func: CARDINAL) : tree ;
BEGIN
IF IsTrue (condition)
THEN
IssueWarningLoc (location, message)
END ;
RETURN BuildIfThenDoEnd (condition, CodeErrorCheckLoc (location, scope, message, func))
END BuildIfCallHandlerLoc ;
(*
BuildIfCallHandler -
*)
PROCEDURE BuildIfCallHandler (condition: tree; r: CARDINAL;
function, message: String; warning: BOOLEAN) : tree ;
BEGIN
IF warning AND IsTrue (condition)
THEN
IssueWarning (function, r)
END ;
RETURN BuildIfThenDoEnd (condition, CodeErrorCheck (r, function, message))
END BuildIfCallHandler ;
(*
RangeCheckReal -
*)
PROCEDURE RangeCheckReal (p: Range; r: CARDINAL; function, message: String) ;
VAR
e,
condition: tree ;
location : location_t ;
BEGIN
WITH p^ DO
location := TokenToLocation (tokenNo) ;
e := DeReferenceLValue (tokenNo, expr) ;
condition := BuildEqualTo (location,
BuiltInIsfinite (location, e),
GetIntegerZero (location)) ;
AddStatement (location, BuildIfCallHandler (condition, r, function, message, TRUE)) ;
END
END RangeCheckReal ;
(*
RangeCheckOrdinal -
*)
PROCEDURE RangeCheckOrdinal (p: Range; r: CARDINAL; function, message: String) ;
VAR
condition,
desMin, desMax,
exprMin, exprMax: tree ;
location : location_t ;
BEGIN
WITH p^ DO
location := TokenToLocation(tokenNo) ;
IF GetMinMax(tokenNo, exprLowestType, exprMin, exprMax) AND
GetMinMax(tokenNo, desLowestType, desMin, desMax)
THEN
IF OverlapsRange(desMin, desMax, exprMin, exprMax)
THEN
IF IsGreater(desMin, exprMin)
THEN
condition := BuildLessThan(location, DeReferenceLValue(tokenNo, expr), BuildConvert(location, Mod2Gcc(exprLowestType), desMin, FALSE)) ;
AddStatement(location, BuildIfCallHandler(condition, r, function, message, TRUE))
END ;
IF IsGreater(exprMax, desMax)
THEN
condition := BuildGreaterThan(location, DeReferenceLValue(tokenNo, expr), BuildConvert(location, Mod2Gcc(exprLowestType), desMax, FALSE)) ;
AddStatement(location, BuildIfCallHandler(condition, r, function, message, TRUE))
END
ELSE
MetaErrorStringT3 (tokenNo, message, des, expr, paramNo)
END
END
END
END RangeCheckOrdinal ;
(*
DoCodeAssignmentExprType -
*)
PROCEDURE DoCodeAssignmentExprType (p: Range;
r: CARDINAL; function, message: String) ;
BEGIN
WITH p^ DO
IF GccKnowsAbout(desLowestType) AND
GccKnowsAbout(exprLowestType)
THEN
IF IsRealType(desLowestType) AND IsRealType(exprLowestType)
THEN
RangeCheckReal (p, r, function, message)
ELSE
RangeCheckOrdinal (p, r, function, message)
END
ELSE
InternalError ('should have resolved these types')
END
END
END DoCodeAssignmentExprType ;
(*
DoCodeAssignmentWithoutExprType -
*)
PROCEDURE DoCodeAssignmentWithoutExprType (p: Range;
r: CARDINAL; function, message: String) ;
VAR
condition,
desMin, desMax: tree ;
location : location_t ;
BEGIN
WITH p^ DO
location := TokenToLocation(tokenNo) ;
IF GccKnowsAbout(desLowestType)
THEN
IF GetMinMax(tokenNo, desLowestType, desMin, desMax)
THEN
condition := BuildLessThan(location,
BuildConvert(location, Mod2Gcc(desLowestType),
DeReferenceLValue(tokenNo, expr), FALSE),
desMin) ;
AddStatement(location, BuildIfCallHandler(condition, r, function, message, TRUE)) ;
condition := BuildGreaterThan(location,
BuildConvert(location, Mod2Gcc(desLowestType),
DeReferenceLValue(tokenNo, expr), FALSE),
desMax) ;
AddStatement(location, BuildIfCallHandler(condition, r, function, message, TRUE))
END
ELSE
InternalError ('should have resolved this type')
END
END
END DoCodeAssignmentWithoutExprType ;
(*
DoCodeAssignment -
*)
PROCEDURE DoCodeAssignment (tokenno: CARDINAL; r: CARDINAL;
function, message: String) ;
VAR
p: Range ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenNo, des) ;
TryDeclareConstant(tokenNo, expr) ;
DeclareConstructor(tokenno, 0, expr) ;
IF desLowestType#NulSym
THEN
Assert(GccKnowsAbout(expr)) ;
IF exprLowestType=NulSym
THEN
DoCodeAssignmentWithoutExprType (p, r, function, message)
ELSE
DoCodeAssignmentExprType (p, r, function, message)
END
END
END
END DoCodeAssignment ;
(*
CodeAssignment -
*)
PROCEDURE CodeAssignment (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
BEGIN
DoCodeAssignment (tokenno, r, function, message)
END CodeAssignment ;
(*
CodeParameterAssign -
*)
PROCEDURE CodeParameterAssign (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
BEGIN
DoCodeAssignment (tokenno, r, function, message)
END CodeParameterAssign ;
(*
CodeReturn -
*)
PROCEDURE CodeReturn (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
BEGIN
DoCodeAssignment (tokenno, r, function, message)
END CodeReturn ;
(*
IfOutsideLimitsDo -
*)
PROCEDURE IfOutsideLimitsDo (tokenno: CARDINAL; min, expr, max: tree; r: CARDINAL;
function, message: String) ;
VAR
condition: tree ;
location : location_t ;
BEGIN
location := TokenToLocation (tokenno) ;
condition := BuildGreaterThan (location, min, expr) ;
AddStatement (location, BuildIfThenDoEnd (condition, CodeErrorCheck (r, function, message))) ;
condition := BuildLessThan (location, max, expr) ;
AddStatement (location, BuildIfThenDoEnd (condition, CodeErrorCheck (r, function, message)))
END IfOutsideLimitsDo ;
(*
CodeInc -
*)
PROCEDURE CodeInc (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
VAR
p : Range ;
t, condition,
e,
desMin, desMax: tree ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenNo, des) ;
TryDeclareConstant(tokenNo, expr) ;
IF desLowestType#NulSym
THEN
IF GccKnowsAbout(expr) AND GccKnowsAbout(desLowestType)
THEN
IF GetMinMax(tokenno, desLowestType, desMin, desMax)
THEN
e := BuildConvert(location, GetTreeType(desMin), DeReferenceLValue(tokenno, expr), FALSE) ;
IfOutsideLimitsDo(tokenNo,
BuildConvert(location, GetTreeType(desMin), GetIntegerZero(location), FALSE),
e, desMax, r, function, message) ;
t := BuildSub(location,
desMax,
BuildConvert(location, Mod2Gcc(desLowestType), e, FALSE),
FALSE) ;
condition := BuildGreaterThan(location, Mod2Gcc(des), t) ;
AddStatement (location, BuildIfThenDoEnd (condition, CodeErrorCheck (r, function, message)))
END
ELSE
InternalError ('should have resolved these types')
END
END
END
END CodeInc ;
(*
CodeDec -
*)
PROCEDURE CodeDec (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
VAR
p : Range ;
t, condition,
e,
desMin, desMax: tree ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenNo, des) ;
TryDeclareConstant(tokenNo, expr) ;
IF desLowestType#NulSym
THEN
IF GccKnowsAbout(expr) AND GccKnowsAbout(desLowestType)
THEN
IF GetMinMax(tokenno, desLowestType, desMin, desMax)
THEN
e := BuildConvert(location, GetTreeType(desMin), DeReferenceLValue(tokenno, expr), FALSE) ;
IfOutsideLimitsDo(tokenNo,
BuildConvert(location, GetTreeType(desMin), GetIntegerZero(location), FALSE),
e, desMax, r, function, message) ;
t := BuildSub(location, BuildConvert(location, Mod2Gcc(desLowestType), e, FALSE),
desMin,
FALSE) ;
condition := BuildLessThan(location, Mod2Gcc(des), t) ;
AddStatement (location, BuildIfThenDoEnd (condition, CodeErrorCheck (r, function, message)))
END
ELSE
InternalError ('should have resolved these types')
END
END
END
END CodeDec ;
(*
CodeInclExcl -
*)
PROCEDURE CodeInclExcl (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
VAR
p : Range ;
e,
desMin, desMax: tree ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenNo, des) ;
TryDeclareConstant(tokenNo, expr) ;
desLowestType := SkipType(GetType(des)) ;
IF desLowestType#NulSym
THEN
IF GccKnowsAbout(expr) AND GccKnowsAbout(desLowestType)
THEN
IF GetMinMax(tokenno, desLowestType, desMin, desMax)
THEN
e := BuildConvert(location, GetTreeType(desMin), DeReferenceLValue(tokenno, expr), FALSE) ;
IfOutsideLimitsDo(tokenNo, desMin, e, desMax, r, function, message)
(* this should not be used for incl/excl as des is a set type
t := BuildSub(location,
desMax,
BuildConvert(location, Mod2Gcc(desLowestType), e, FALSE),
FALSE) ;
condition := BuildGreaterThan(Mod2Gcc(des), t) ;
AddStatement(location, BuildIfThenDoEnd(condition, CodeErrorCheck(r, function, message)))
*)
END
ELSE
InternalError ('should have resolved these types')
END
END
END
END CodeInclExcl ;
(*
CodeShiftRotate - ensure that the bit shift is within the range
-(MAX(set)-MIN(set)+1)..(MAX(set)-MIN(set)+1)
*)
PROCEDURE CodeShiftRotate (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
VAR
ofType : CARDINAL ;
p : Range ;
e,
shiftMin, shiftMax,
desMin, desMax : tree ;
location : location_t ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenNo, des) ;
TryDeclareConstant(tokenNo, expr) ;
desLowestType := SkipType(GetType(des)) ;
IF desLowestType#NulSym
THEN
ofType := SkipType(GetType(desLowestType)) ;
IF GccKnowsAbout(expr) AND GccKnowsAbout(ofType)
THEN
IF GetMinMax(tokenno, ofType, desMin, desMax)
THEN
location := TokenToLocation(tokenNo) ;
desMin := BuildConvert(location, GetIntegerType(), desMin, FALSE) ;
desMax := BuildConvert(location, GetIntegerType(), desMax, FALSE) ;
shiftMax := BuildAdd(location,
BuildSub(location, desMax, desMin, FALSE),
GetIntegerOne(location),
FALSE) ;
shiftMin := BuildNegate(location, shiftMax, FALSE) ;
e := BuildConvert(location, GetIntegerType(), DeReferenceLValue(tokenno, expr), FALSE) ;
IfOutsideLimitsDo(tokenNo, shiftMin, e, shiftMax, r, function, message)
END
ELSE
InternalError ('should have resolved these types')
END
END
END
END CodeShiftRotate ;
(*
CodeStaticArraySubscript -
*)
PROCEDURE CodeStaticArraySubscript (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
VAR
p : Range ;
desMin, desMax: tree ;
location : location_t ;
BEGIN
location := TokenToLocation (tokenno) ;
p := GetIndice (RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant (tokenNo, expr) ;
IF GccKnowsAbout (expr) AND GccKnowsAbout (desLowestType)
THEN
IF GetMinMax (tokenno, desLowestType, desMin, desMax)
THEN
IfOutsideLimitsDo (tokenno, desMin,
BuildConvert (location, GetTreeType (desMin), DeReferenceLValue (tokenno, expr), FALSE),
desMax, r, function, message)
ELSE
InternalError ('should have resolved the bounds of the static array')
END
ELSE
InternalError ('should have resolved these types')
END
END
END CodeStaticArraySubscript ;
(*
CodeDynamicArraySubscript -
*)
PROCEDURE CodeDynamicArraySubscript (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
VAR
UnboundedType: CARDINAL ;
p : Range ;
high, e : tree ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenNo, expr) ;
Assert(IsVar(des)) ;
IF GccKnowsAbout(expr) AND GccKnowsAbout(des)
THEN
UnboundedType := GetType(des) ;
Assert(IsUnbounded(UnboundedType)) ;
high := BuildConvert(location, GetIntegerType(), GetHighFromUnbounded(location, dimension, des), FALSE) ;
e := BuildConvert(location, GetIntegerType(), DeReferenceLValue(tokenno, expr), FALSE) ;
IfOutsideLimitsDo(tokenNo, GetIntegerZero(location), e, high, r, function, message)
ELSE
InternalError ('should have resolved these types')
END
END
END CodeDynamicArraySubscript ;
(*
CodeForLoopBegin -
*)
PROCEDURE CodeForLoopBegin (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
BEGIN
IF ForLoopBeginTypeCompatible (GetIndice (RangeIndex, r))
THEN
DoCodeAssignment(tokenno, r, function, message)
END
END CodeForLoopBegin ;
(*
CodeForLoopTo -
*)
PROCEDURE CodeForLoopTo (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
BEGIN
DoCodeAssignment(tokenno, r, function, message)
END CodeForLoopTo ;
(*
Pseudo template code for CodeLoopEnd:
PROCEDURE CheckCardinalInteger (des: CARDINAL; inc: INTEGER) ;
VAR
room,
lg : CARDINAL ;
BEGIN
IF inc>=0
THEN
IF des>=0
THEN
lg := VAL(CARDINAL, inc) ;
room := MAX(CARDINAL)-des ;
IF lg>room
THEN
printf("increment exceeds range at end of FOR loop\n") ;
exit (2)
END
ELSE
(* inc can never cause an overflow given its type *)
END
ELSE
(* inc < 0 *)
IF des>VAL(CARDINAL, MAX(INTEGER))
THEN
(* inc can never cause an underflow given its range *)
ELSE
(* des <= MAX(INTEGER) *)
IF des=MIN(INTEGER)
THEN
printf("increment exceeds range at end of FOR loop\n") ;
exit (4)
ELSE
IF inc=MIN(INTEGER)
THEN
IF des=0
THEN
printf("increment exceeds range at end of FOR loop\n") ;
exit (5)
END
ELSE
lg := VAL(CARDINAL, -inc) ;
IF lg>des
THEN
printf("increment exceeds range at end of FOR loop\n") ;
exit (5)
END
END
END
END
END
END CheckCardinalInteger ;
PROCEDURE CheckCardinalCardinal (des: CARDINAL; inc: CARDINAL) ;
BEGIN
IF MAX(CARDINAL)-des<inc
THEN
printf("increment exceeds range at end of FOR loop\n") ;
exit (2)
END
END CheckCardinalCardinal ;
*)
(*
SameTypesCodeForLoopEnd - the trivial case.
*)
PROCEDURE SameTypesCodeForLoopEnd (tokenNo: CARDINAL; r: CARDINAL; function, message: String;
p: Range; dmax: tree) ;
VAR
inc,
room,
statement,
condition: tree ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenNo) ;
WITH p^ DO
inc := DeReferenceLValue(tokenNo, expr) ;
room := BuildSub(location, dmax, Mod2Gcc(des), FALSE) ;
condition := BuildLessThan(location, room, inc) ;
statement := BuildIfCallHandler(condition, r, function, message, IsTrue(condition)) ;
AddStatement(location, statement)
END
END SameTypesCodeForLoopEnd ;
(*
DiffTypesSameForLoopEnd - remember that lowestType will map onto an int, or unsigned int
of appropriate size.
*)
PROCEDURE DiffTypesCodeForLoopEnd (tokenNo: CARDINAL; r: CARDINAL; function, message: String;
p: Range; dmax, emin, emax: tree) ;
VAR
location : location_t ;
desoftypee,
inc,
room,
c1, c2, c3,
c4, c5, c6,
c7, c8,
s1, s2, s3,
s4, s5, s6,
s7, s8,
lg1, lg2,
dz, ez : tree ;
BEGIN
location := TokenToLocation(tokenNo) ;
WITH p^ DO
inc := DeReferenceLValue(tokenNo, expr) ;
ez := BuildConvert(location, Mod2Gcc(exprLowestType), GetIntegerZero(location), FALSE) ;
dz := BuildConvert(location, Mod2Gcc(desLowestType), GetIntegerZero(location), FALSE) ;
c1 := BuildGreaterThanOrEqual(location, inc, ez) ;
(* if (inc >= 0) [c1] *)
c2 := BuildGreaterThanOrEqual(location, Mod2Gcc(des), dz) ;
(* if (des >= 0) [c2] *)
lg1 := BuildConvert(location, Mod2Gcc(desLowestType), inc, FALSE) ;
room := BuildSub(location, dmax, Mod2Gcc(des), FALSE) ;
c3 := BuildGreaterThan(location, lg1, room) ; (* [c3] *)
(* WarnIf(IsTrue(c1) AND IsTrue(c2) AND IsTrue(c3), function, message) ; --implement me-- *)
s3 := BuildIfCallHandler(c3, r, function, message, FALSE) ;
s2 := BuildIfThenDoEnd(c2, s3) ;
(* else *)
(* (* inc < 0 *) [s4] *)
(* if (des <= val(desLowestType, emax) [c4] *)
c4 := BuildLessThanOrEqual(location, Mod2Gcc(des), BuildConvert(location, Mod2Gcc(desLowestType), emax, FALSE)) ;
(* (* des <= MAX(exprLowestType) *) *)
desoftypee := BuildConvert(location, Mod2Gcc(exprLowestType), Mod2Gcc(des), FALSE) ;
c5 := BuildEqualTo(location, desoftypee, emin) ; (* [c5] *)
s5 := BuildIfCallHandler(c5, r, function, message, FALSE) ;
(* if des = emin *)
(* error [s5] *)
(* end *)
c6 := BuildEqualTo(location, inc, emin) ; (* [c6] *)
(* if inc = emin *)
(* if des = 0 [c7] *)
c7 := BuildEqualTo(location, Mod2Gcc(des), dz) ;
s7 := BuildIfCallHandler(c7, r, function, message, FALSE) ;
(* end *)
(* else *)
(* lg2 = VAL(desLowestType, -inc) [s8] *)
lg2 := BuildConvert(location, Mod2Gcc(desLowestType), BuildNegate(location, inc, FALSE), FALSE) ;
(* if lg2 > des *)
(* error *)
c8 := BuildGreaterThan(location, lg2, Mod2Gcc(des)) ;
s8 := BuildIfCallHandler(c8, r, function, message, FALSE) ;
(* end *)
(* end *)
(* end *)
(* end *)
(* end *)
END ;
s6 := BuildIfThenElseEnd(c6, s7, s8) ;
s4 := BuildIfThenElseEnd(c4, s5, s6) ;
s1 := BuildIfThenElseEnd(c1, s2, s4) ;
AddStatement(location, s1)
END DiffTypesCodeForLoopEnd ;
(*
CodeForLoopEnd - checks to see that des := des + expr does not overflow.
This is called at the end of the for loop. It is more complex
than it initially seems as des and expr might be different types.
*)
PROCEDURE CodeForLoopEnd (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
VAR
isCard : BOOLEAN ;
p : Range ;
dmin, dmax,
emin, emax: tree ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenno, des) ; (* use quad tokenno, rather than the range tokenNo *)
TryDeclareConstant(tokenno, expr) ; (* use quad tokenno, rather than the range tokenNo *)
IF desLowestType#NulSym
THEN
Assert(GccKnowsAbout(expr)) ;
IF GccKnowsAbout(desLowestType) AND
GetMinMax(tokenno, desLowestType, dmin, dmax) AND
GccKnowsAbout(exprLowestType) AND
GetMinMax(tokenno, exprLowestType, emin, emax)
THEN
PushIntegerTree(dmin) ;
PushInt(0) ;
isCard := GreEqu(tokenno) ;
IF (desLowestType=exprLowestType) AND isCard
THEN
SameTypesCodeForLoopEnd(tokenno, r, function, message, p, dmax)
ELSE
DiffTypesCodeForLoopEnd(tokenno, r, function, message, p, dmax, emin, emax)
END
END
END
END
END CodeForLoopEnd ;
(*
CodeNil -
*)
PROCEDURE CodeNil (r: CARDINAL; function, message: String) ;
VAR
p : Range ;
condition, t: tree ;
location : location_t ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenNo, des) ;
(*
IF GetMode(des)=LeftValue
THEN
(* t := BuildIndirect(Mod2Gcc(des), Mod2Gcc(GetType(des))) *)
ELSE
t := Mod2Gcc(des)
END ;
*)
t := Mod2Gcc(des) ;
location := TokenToLocation(tokenNo) ;
condition := BuildEqualTo(location, BuildConvert(location, GetPointerType(), t, FALSE), GetPointerZero(location)) ;
AddStatement(location, BuildIfCallHandler(condition, r, function, message, TRUE))
END
END CodeNil ;
(*
CodeWholeNonPos - generates range check code for expr<=0.
*)
PROCEDURE CodeWholeNonPos (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
VAR
zero : CARDINAL ;
p : Range ;
condition,
e : tree ;
location : location_t ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant (tokenNo, expr) ;
IF GccKnowsAbout (expr)
THEN
location := TokenToLocation (tokenno) ;
e := ZConstToTypedConst (LValueToGenericPtr(location, expr), expr, des) ;
zero := MakeAndDeclareConstLit (tokenno, MakeKey('0'), ZType) ;
condition := BuildLessThanOrEqual (location, e, Mod2Gcc (zero)) ;
AddStatement (location, BuildIfThenDoEnd (condition, CodeErrorCheck (r, function, message)))
ELSE
InternalError ('should have resolved expr')
END
END
END CodeWholeNonPos ;
(*
CodeWholeZero - generates range check code for expr=0.
*)
PROCEDURE CodeWholeZero (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
VAR
zero : CARDINAL ;
p : Range ;
condition,
e : tree ;
location : location_t ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
TryDeclareConstant(tokenNo, expr) ;
IF GccKnowsAbout(expr)
THEN
location := TokenToLocation(tokenno) ;
e := ZConstToTypedConst(LValueToGenericPtr(location, expr), expr, des) ;
zero := MakeAndDeclareConstLit (tokenno, MakeKey('0'), ZType) ;
condition := BuildEqualTo(location,
e, BuildConvert(location, GetTreeType(e), Mod2Gcc(zero), FALSE)) ;
AddStatement(location, BuildIfThenDoEnd(condition, CodeErrorCheck(r, function, message)))
ELSE
InternalError ('should have resolved expr')
END
END
END CodeWholeZero ;
(*
InitCaseBounds - creates a case bound range check.
*)
PROCEDURE InitCaseBounds (b: CARDINAL) : CARDINAL ;
VAR
p: Range ;
r: CARDINAL ;
BEGIN
r := InitRange() ;
p := PutRangeNoEval(GetIndice(RangeIndex, r), casebounds) ;
p^.caseList := b ;
RETURN( r )
END InitCaseBounds ;
(*
FillInParameters -
*)
PROCEDURE FillInParameters (r: CARDINAL; s: String) : String ;
VAR
p: Range ;
BEGIN
p := GetIndice (RangeIndex, r) ;
WITH p^ DO
CASE type OF
assignment : s := MetaString3 (s, des, expr, dimension) |
returnassignment : s := MetaString3 (s, des, expr, dimension) |
subrangeassignment : InternalError ('unexpected case') |
inc : s := MetaString3 (s, des, expr, dimension) |
dec : s := MetaString3 (s, des, expr, dimension) |
incl : s := MetaString3 (s, des, expr, dimension) |
excl : s := MetaString3 (s, des, expr, dimension) |
shift : s := MetaString3 (s, des, expr, dimension) |
rotate : s := MetaString3 (s, des, expr, dimension) |
typeassign : |
typeparam : |
typeexpr : |
paramassign : s := MetaString3 (s, des, expr, paramNo) |
staticarraysubscript : s := MetaString3 (s, des, expr, dimension) |
dynamicarraysubscript: s := MetaString3 (s, des, expr, dimension) |
forloopbegin : s := MetaString3 (s, des, expr, dimension) |
forloopto : s := MetaString3 (s, des, expr, dimension) |
forloopend : s := MetaString3 (s, des, expr, dimension) |
pointernil : s := MetaString3 (s, des, expr, dimension) |
noreturn : s := MetaString3 (s, des, expr, dimension) |
noelse : s := MetaString3 (s, des, expr, dimension) |
casebounds : s := MetaString3 (s, des, expr, dimension) |
wholenonposdiv : s := MetaString3 (s, des, expr, dimension) |
wholenonposmod : s := MetaString3 (s, des, expr, dimension) |
wholezerodiv : s := MetaString3 (s, des, expr, dimension) |
wholezerorem : s := MetaString3 (s, des, expr, dimension) |
none : |
ELSE
InternalError ('unexpected case')
END
END ;
RETURN s
END FillInParameters ;
(*
GetRangeErrorMessage - returns a specific error message for the range, r.
It assumes the 3 parameters to be supplied on the MetaError
parameter list are: dest, expr, paramNo or dimension.
XYZ
'the initial assignment to {%1a} at the start of the FOR loop will cause a range error, as the type range of {%1taD} does not overlap with {%2tad}')
'the final TO value {%2a} of the FOR loop will cause a range error with the iterator variable {%1a}')
*)
PROCEDURE GetRangeErrorMessage (r: CARDINAL) : String ;
VAR
p: Range ;
s: String ;
BEGIN
p := GetIndice (RangeIndex, r) ;
WITH p^ DO
CASE type OF
assignment : s := InitString ('assignment will cause a range error, as the runtime instance value of {%1tad} does not overlap with the type {%2tad}') |
returnassignment : s := InitString ('attempting to return {%2Wa} from a procedure function {%1a} which will exceed exceed the range of type {%1tad}') |
subrangeassignment : InternalError ('unexpected case') |
inc : s := InitString ('if the INC is ever executed the expression {%2Wa} will cause an overflow error for the designator {%1a} as it exceeds the type range {%1ts:of {%1ts}}') |
dec : s := InitString ('if the DEC is ever executed the expression {%2Wa} will cause an underflow error for the designator {%1a} as it exceeds the type range {%1ts:of {%1ts}}') |
incl : s := InitString ('the expression {%2Wa} given in the INCL exceeds the type range {%1ts} of the designator {%1a}') |
excl : s := InitString ('the expression {%2Wa} given in the EXCL exceeds the type range {%1ts} of the designator {%1a}') |
shift : s := InitString ('the expression {%2Wa} given in the second parameter to SHIFT exceeds the type range {%1ts} of the first parameter {%1a}') |
rotate : s := InitString ('the expression {%2Wa} given in the second parameter to ROTATE exceeds the type range {%1ts} of the first parameter {%1a}') |
typeassign : s := NIL |
typeparam : s := NIL |
typeexpr : s := NIL |
typeindrx : s := InitString ('assignment between designator {%1ad} and {%2ad} is incompatible') |
typereturn : s := InitString ('the value {%2ad} returned from procedure function {%1a} is type incompatible, expecting {%1tad} rather than a {%2tad}') |
paramassign : s := InitString('if this call is executed then the actual parameter {%2Wa} will be out of range of the {%3N} formal parameter {%1a}') |
staticarraysubscript : s := InitString('if this access to the static array {%1Wa:{%2a:{%1a}[{%2a}]}} is ever made then the index will be out of bounds in the {%3N} array subscript') |
dynamicarraysubscript: s := InitString('if this access to the dynamic array {%1Wa:{%2a:{%1a}[{%2a}]}} is ever made then the index will be out of bounds in the {%3N} array subscript') |
forloopbegin : s := InitString('if the assignment in this FOR loop is ever executed then the designator {%1Wa} will be exceed the type range {%1ts:of {%1ts}}') |
forloopto : s := InitString('the final value {%2Wa} in this FOR loop will be out of bounds {%1ts:of type {%1ts}} if ever executed') |
forloopend : s := InitString('the FOR loop will cause the designator {%1Wa} to be out of bounds when the BY value {%2a} is added') |
pointernil : s := InitString('if this pointer value {%1Wa} is ever dereferenced it will cause an exception') |
noreturn : s := InitString('{%1W:}this function will exit without executing a RETURN statement') |
noelse : s := InitString('{%1W:}this CASE statement does not have an ELSE statement') |
casebounds : s := InitString('{%1W:}this CASE statement has overlapping ranges') |
wholenonposdiv : s := InitString('this division expression {%2Wa} will cause an exception as this divisor is less than or equal to zero') |
wholenonposmod : s := InitString('this modulus expression {%2Wa} will cause an exception as this divisor is less than or equal to zero') |
wholezerodiv : s := InitString('this division expression {%2Wa} will cause an exception as the divisor is zero') |
wholezerorem : s := InitString('this remainder expression {%2Wa} will cause an exception as the divisor is zero') |
none : s := NIL
ELSE
InternalError ('unexpected case')
END
END ;
RETURN s
END GetRangeErrorMessage ;
(*
CodeRangeCheck - returns a Tree representing the code for a
range test defined by, r.
*)
PROCEDURE CodeRangeCheck (r: CARDINAL; function: String) ;
VAR
p : Range ;
message: String ;
BEGIN
p := GetIndice (RangeIndex, r) ;
message := GetRangeErrorMessage (r) ;
WITH p^ DO
CASE type OF
assignment : CodeAssignment (tokenNo, r, function, message) |
returnassignment : CodeReturn (tokenNo, r, function, message) |
subrangeassignment : InternalError ('unexpected case') |
inc : CodeInc (tokenNo, r, function, message) |
dec : CodeDec (tokenNo, r, function, message) |
incl,
excl : CodeInclExcl (tokenNo, r, function, message) |
shift,
rotate : CodeShiftRotate (tokenNo, r, function, message) |
typeassign,
typeparam,
typeexpr,
typeindrx,
typereturn : CodeTypeCheck (tokenNo, r) |
staticarraysubscript : CodeStaticArraySubscript (tokenNo, r, function, message) |
dynamicarraysubscript: CodeDynamicArraySubscript (tokenNo, r, function, message) |
forloopbegin : CodeForLoopBegin (tokenNo, r, function, message) |
forloopto : CodeForLoopTo (tokenNo, r, function, message) |
forloopend : CodeForLoopEnd (tokenNo, r, function, message) |
pointernil : CodeNil (r, function, message) |
noreturn : AddStatement (TokenToLocation (tokenNo), CodeErrorCheck (r, function, message)) |
noelse : AddStatement (TokenToLocation (tokenNo), CodeErrorCheck (r, function, message)) |
casebounds : CodeCaseBounds (tokenNo, caseList) |
wholenonposdiv : CodeWholeNonPos (tokenNo, r, function, message) |
wholenonposmod : CodeWholeNonPos (tokenNo, r, function, message) |
wholezerodiv : CodeWholeZero (tokenNo, r, function, message) |
wholezerorem : CodeWholeZero (tokenNo, r, function, message) |
paramassign : CodeParameterAssign (tokenNo, r, function, message) |
none :
ELSE
InternalError ('unexpected case')
END
END
END CodeRangeCheck ;
(*
AddVarRead - checks to see whether symbol, Sym, is
a variable or a parameter and if so it
then adds this quadruple to the variable
list.
*)
(*
PROCEDURE AddVarRead (sym: CARDINAL; quadNo: CARDINAL) ;
BEGIN
IF (sym#NulSym) AND IsVar(sym)
THEN
PutReadQuad(sym, GetMode(sym), quadNo)
END
END AddVarRead ;
*)
(*
SubVarRead - checks to see whether symbol, Sym, is
a variable or a parameter and if so it
then removes this quadruple from the
variable list.
*)
(*
PROCEDURE SubVarRead (sym: CARDINAL; quadNo: CARDINAL) ;
BEGIN
IF (sym#NulSym) AND IsVar(sym)
THEN
RemoveReadQuad(sym, GetMode(sym), quadNo)
END
END SubVarRead ;
*)
(*
CheckRangeAddVariableRead - ensures that any references to reading
variables used by this range check, r,
at this, quadNo, are recorded in the
symbol table.
*)
(*
PROCEDURE CheckRangeAddVariableRead (r: CARDINAL; quadNo: CARDINAL) ;
VAR
p: Range ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
(* AddVarRead(des, quadNo) ; *)
(* AddVarRead(expr, quadNo) *)
END
END CheckRangeAddVariableRead ;
*)
(*
CheckRangeRemoveVariableRead - ensures that any references to reading
variable at this quadNo are removed from
the symbol table.
*)
(*
PROCEDURE CheckRangeRemoveVariableRead (r: CARDINAL; quadNo: CARDINAL) ;
VAR
p: Range ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
(* SubVarRead(des, quadNo) ; *)
(* SubVarRead(expr, quadNo) *)
END
END CheckRangeRemoveVariableRead ;
*)
(*
WriteRangeCheck - displays debugging information about range, r.
*)
PROCEDURE WriteRangeCheck (r: CARDINAL) ;
VAR
p: Range ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
WriteString ('range ') ;
WriteCard (r, 0) ;
WriteString (' ') ;
IF cancelled
THEN
WriteString ('cancelled ')
END ;
IF dependantid # 0
THEN
WriteString ('dep ') ;
WriteCard (dependantid, 0) ;
WriteString (' ')
END ;
CASE type OF
assignment : WriteString('assignment (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
returnassignment : WriteString('returnassignment (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
subrangeassignment : WriteString('subrangeassignment(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
inc : WriteString('inc(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
dec : WriteString('dec(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
incl : WriteString('incl(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
excl : WriteString('excl(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
shift : WriteString('shift(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
rotate : WriteString('rotate(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
typeexpr : WriteString('expr compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
typeassign : WriteString('assignment compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
typeindrx : WriteString('indrx compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
typereturn : WriteString('return compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
typeparam : WriteString('parameter compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
paramassign : WriteString('parameter range (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
staticarraysubscript : WriteString('staticarraysubscript(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
dynamicarraysubscript: WriteString('dynamicarraysubscript(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
forloopbegin : WriteString('forloopbegin(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
forloopto : WriteString('forloopto(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
forloopend : WriteString('forloopend(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |
pointernil : WriteString('pointernil(') ; WriteOperand(des) |
noreturn : WriteString('noreturn(') |
noelse : WriteString('noelse(') |
casebounds : WriteString('casebounds(') ; WriteCase(caseList) |
wholenonposdiv : WriteString('wholenonposdiv(') ; WriteOperand(expr) |
wholenonposmod : WriteString('wholenonposmod(') ; WriteOperand(expr) |
wholezerodiv : WriteString('wholezerodiv(') ; WriteOperand(expr) |
wholezerorem : WriteString('wholezerorem(') ; WriteOperand(expr) |
none : WriteString('none(') |
ELSE
InternalError ('unknown case')
END ;
Write(')')
END
END WriteRangeCheck ;
(*
Init - initializes the modules global variables.
*)
PROCEDURE Init ;
BEGIN
TopOfRange := 0 ;
RangeIndex := InitIndex(1) ;
BreakWhenRangeCreated (0) ; (* Disable the intereactive range watch. *)
(* To examine the range when it is created run cc1gm2 from gdb
and set a break point on gdbhook.
(gdb) break gdbhook
(gdb) run
Now below interactively call BreakWhenRangeCreated with the symbol
under investigation. *)
gdbhook ;
(* Now is the time to interactively call gdb, for example:
(gdb) print BreakWhenRangeCreated (1234)
(gdb) cont
and you will arrive at gdbhook when this symbol is created. *)
END Init ;
BEGIN
Init
END M2Range.