FROM Lists IMPORT InitList, IncludeItemIntoList, RemoveItemFromList, NoOfItemsInList, GetItemFromList ;
FROM NameKey IMPORT KeyToCharStar ;
FROM SymbolConversion IMPORT GccKnowsAbout, Mod2Gcc, AddModGcc ;
-FROM DynamicStrings IMPORT InitString, InitStringCharStar, ConCat, Mark, KillString ;
+FROM DynamicStrings IMPORT InitString, InitStringCharStar, InitStringChar, ConCat, Mark, KillString ;
FROM m2tree IMPORT Tree ;
FROM m2block IMPORT RememberType ;
FROM m2type IMPORT GetMinFrom ;
-FROM m2expr IMPORT GetIntegerOne ;
+FROM m2expr IMPORT GetIntegerOne, CSTIntToString, CSTIntToChar ;
FROM Storage IMPORT ALLOCATE ;
-FROM M2Base IMPORT IsExpressionCompatible ;
+FROM M2Base IMPORT IsExpressionCompatible, Char ;
FROM M2Printf IMPORT printf1 ;
FROM M2LexBuf IMPORT TokenToLocation ;
FROM SymbolTable IMPORT NulSym, IsConst, IsFieldVarient, IsRecord, IsRecordField, GetVarientTag, GetType,
- ForeachLocalSymDo, GetSymName, IsEnumeration, SkipType, NoOfElements, GetNth ;
+ ForeachLocalSymDo, GetSymName, IsEnumeration, SkipType, NoOfElements, GetNth,
+ IsSubrange ;
TYPE
RangePair = POINTER TO RECORD
END ErrorRanges ;
+(*
+ appendString -
+*)
+
+PROCEDURE appendString (str: String) ;
+BEGIN
+ errorString := ConCat (errorString, str)
+END appendString ;
+
+
(*
appendEnum -
*)
PROCEDURE appendEnum (enum: CARDINAL) ;
BEGIN
- errorString := ConCat (errorString,
- Mark (InitStringCharStar (KeyToCharStar (GetSymName (enum)))))
+ appendString (Mark (InitStringCharStar (KeyToCharStar (GetSymName (enum)))))
END appendEnum ;
PROCEDURE appendStr (str: ARRAY OF CHAR) ;
BEGIN
- errorString := ConCat (errorString, Mark (InitString (str)))
+ appendString (Mark (InitString (str)))
END appendStr ;
END EnumerateErrors ;
+(*
+ NoOfSetElements - return the number of set elements.
+*)
+
+PROCEDURE NoOfSetElements (set: SetRange) : Tree ;
+BEGIN
+ PushInt (0) ;
+ WHILE set # NIL DO
+ IF ((set^.low # NIL) AND (set^.high = NIL)) OR
+ ((set^.low = NIL) AND (set^.high # NIL))
+ THEN
+ PushInt (1) ;
+ Addn
+ ELSIF (set^.low # NIL) AND (set^.high # NIL)
+ THEN
+ PushIntegerTree (set^.high) ;
+ PushIntegerTree (set^.low) ;
+ Sub ;
+ PushInt (1) ;
+ Addn ;
+ Addn
+ END ;
+ set := set^.next
+ END ;
+ RETURN PopIntegerTree ()
+END NoOfSetElements ;
+
+
+(*
+ isPrintableChar - a cautious isprint.
+*)
+
+PROCEDURE isPrintableChar (value: Tree) : BOOLEAN ;
+BEGIN
+ CASE CSTIntToChar (value) OF
+
+ 'a'..'z': RETURN TRUE |
+ 'A'..'Z': RETURN TRUE |
+ '0'..'9': RETURN TRUE |
+ '!', '@': RETURN TRUE |
+ '#', '$': RETURN TRUE |
+ '%', '^': RETURN TRUE |
+ '&', '*': RETURN TRUE |
+ '(', ')': RETURN TRUE |
+ '[', ']': RETURN TRUE |
+ '{', '}': RETURN TRUE |
+ '-', '+': RETURN TRUE |
+ '_', '=': RETURN TRUE |
+ ':', ';': RETURN TRUE |
+ "'", '"': RETURN TRUE |
+ ',', '.': RETURN TRUE |
+ '<', '>': RETURN TRUE |
+ '/', '?': RETURN TRUE |
+ '\', '|': RETURN TRUE |
+ '~', '`': RETURN TRUE |
+ ' ' : RETURN TRUE
+
+ ELSE
+ RETURN FALSE
+ END
+END isPrintableChar ;
+
+
+(*
+ appendTree -
+*)
+
+PROCEDURE appendTree (value: Tree; type: CARDINAL) ;
+BEGIN
+ IF SkipType (GetType (type)) = Char
+ THEN
+ IF isPrintableChar (value)
+ THEN
+ IF CSTIntToChar (value) = "'"
+ THEN
+ appendString (InitStringChar ('"')) ;
+ appendString (InitStringChar (CSTIntToChar (value))) ;
+ appendString (InitStringChar ('"'))
+ ELSE
+ appendString (InitStringChar ("'")) ;
+ appendString (InitStringChar (CSTIntToChar (value))) ;
+ appendString (InitStringChar ("'"))
+ END
+ ELSE
+ appendString (InitStringCharStar ('CHR (')) ;
+ appendString (InitStringCharStar (CSTIntToString (value))) ;
+ appendString (InitStringChar (')'))
+ END
+ ELSE
+ appendString (InitStringCharStar (CSTIntToString (value)))
+ END
+END appendTree ;
+
+
+(*
+ SubrangeErrors -
+*)
+
+PROCEDURE SubrangeErrors (subrangetype: CARDINAL; set: SetRange) ;
+VAR
+ sr : SetRange ;
+ rangeNo : CARDINAL ;
+ nMissing,
+ zero, one: Tree ;
+BEGIN
+ nMissing := NoOfSetElements (set) ;
+ PushInt (0) ;
+ zero := PopIntegerTree () ;
+ IF IsGreater (nMissing, zero)
+ THEN
+ PushInt (1) ;
+ one := PopIntegerTree () ;
+ IF IsGreater (nMissing, one)
+ THEN
+ errorString := InitString ('{%W}there are a total of ')
+ ELSE
+ errorString := InitString ('{%W}there is a total of ')
+ END ;
+ appendString (InitStringCharStar (CSTIntToString (nMissing))) ;
+ appendStr (' missing values in the subrange, the {%kCASE} statement needs labels (or an {%kELSE} statement)') ;
+ appendStr (' for the following values: ') ;
+ sr := set ;
+ rangeNo := 0 ;
+ WHILE sr # NIL DO
+ INC (rangeNo) ;
+ IF rangeNo > 1
+ THEN
+ IF sr^.next = NIL
+ THEN
+ appendStr (' and ')
+ ELSE
+ appendStr (', ')
+ END
+ END ;
+ IF sr^.low = NIL
+ THEN
+ appendTree (sr^.high, subrangetype)
+ ELSIF (sr^.high = NIL) OR IsEqual (sr^.low, sr^.high)
+ THEN
+ appendTree (sr^.low, subrangetype)
+ ELSE
+ appendTree (sr^.low, subrangetype) ;
+ appendStr ('..') ;
+ appendTree (sr^.high, subrangetype)
+ END ;
+ sr := sr^.next
+ END
+ END
+END SubrangeErrors ;
+
+
(*
EmitMissingRangeErrors - emits a singular/plural error message for an enumeration type.
*)
IF IsEnumeration (type)
THEN
EnumerateErrors (ErrorRanges (type, set))
+ ELSIF IsSubrange (type)
+ THEN
+ SubrangeErrors (type, set)
END ;
IF errorString # NIL
THEN
IF expression # NulSym
THEN
type := SkipType (GetType (expression)) ;
- IF (type # NulSym) AND IsEnumeration (type)
+ IF type # NulSym
THEN
- (* A case statement sequence without an else clause but
- selecting using an enumeration type. *)
- set := NewSet (type) ;
- set := ExcludeCaseRanges (set, p) ;
- IF set # NIL
+ IF IsEnumeration (type) OR IsSubrange (type)
THEN
- missing := TRUE ;
- MetaErrorT1 (tokenno,
- 'not all enumeration values in the {%kCASE} statements are specified, hint you either need to specify each value of {%1Wad} or use an {%kELSE} clause',
- type) ;
- EmitMissingRangeErrors (tokenno, type, set)
- END ;
- set := DisposeRanges (set)
+ (* A case statement sequence without an else clause but
+ selecting using an enumeration type. *)
+ set := NewSet (type) ;
+ set := ExcludeCaseRanges (set, p) ;
+ IF set # NIL
+ THEN
+ missing := TRUE ;
+ MetaErrorT1 (tokenno,
+ 'not all {%1Wd} values in the {%kCASE} statements are specified, hint you either need to specify each value of {%1ad} or use an {%kELSE} clause',
+ type) ;
+ EmitMissingRangeErrors (tokenno, type, set)
+ END ;
+ set := DisposeRanges (set)
+ END
END
END
END
PROCEDURE SetFieldInitializedNo (desc: InitDesc;
fieldlist: List; level: CARDINAL) : BOOLEAN ;
VAR
- init : BOOLEAN ;
nsym : CARDINAL ;
fdesc: InitDesc ;
BEGIN
TrySetInitialized (desc) ;
RETURN desc^.initialized
ELSE
- init := SetFieldInitializedNo (fdesc, fieldlist, level + 1) ;
+ IF SetFieldInitializedNo (fdesc, fieldlist, level + 1)
+ THEN
+ END ;
TrySetInitialized (desc) ;
RETURN desc^.initialized
END
(*
IsLocalVar -
-*)
PROCEDURE IsLocalVar (procsym, varsym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN IsVar (varsym) AND (GetVarScope (varsym) = procsym)
END IsLocalVar ;
+*)
(*
PROCEDURE RecordContainsVarient (sym: CARDINAL; visited: List) : BOOLEAN ;
VAR
i,
- fieldsym,
- fieldtype: CARDINAL ;
+ fieldsym: CARDINAL ;
BEGIN
Assert (IsRecord (sym)) ;
i := 1 ;
GenerateNoteFlow -
*)
-PROCEDURE GenerateNoteFlow (lst: List; n: CARDINAL; warning: BOOLEAN) ;
+PROCEDURE GenerateNoteFlow (n: CARDINAL; warning: BOOLEAN) ;
VAR
i : CARDINAL ;
ip1Ptr,
CheckDeferredRecordAccess -
*)
-PROCEDURE CheckDeferredRecordAccess (procsym: CARDINAL; tok: CARDINAL;
+PROCEDURE CheckDeferredRecordAccess (tok: CARDINAL;
sym: CARDINAL;
canDereference, warning: BOOLEAN;
- lst: List; i: CARDINAL) ;
+ i: CARDINAL) ;
VAR
unique: BOOLEAN ;
BEGIN
Trace ("checkReadInit IsComponent (%d) is true)", sym) ;
IF (NOT GetVarComponentInitialized (sym, tok)) AND IsUniqueWarning (tok)
THEN
- GenerateNoteFlow (lst, i, warning) ;
+ GenerateNoteFlow (i, warning) ;
IssueWarning (tok,
'attempting to access ',
' before it has been initialized',
unique := IsUniqueWarning (tok) ;
IF unique
THEN
- GenerateNoteFlow (lst, i, warning) ;
+ GenerateNoteFlow (i, warning) ;
IssueWarning (tok,
'attempting to access the address of ',
' before it has been initialized',
THEN
IF unique
THEN
- GenerateNoteFlow (lst, i, warning) ;
+ GenerateNoteFlow (i, warning) ;
IssueWarning (tok,
'attempting to access ', ' before it has been initialized',
sym, warning)
Trace ("checkReadInit call VarCheckReadInit using GetMode (%d)", sym) ;
IF (NOT VarCheckReadInit (sym, GetMode (sym))) AND IsUniqueWarning (tok)
THEN
- GenerateNoteFlow (lst, i, warning) ;
+ GenerateNoteFlow (i, warning) ;
IssueWarning (tok,
'attempting to access ',
' before it has been initialized',
CheckBinary -
*)
-PROCEDURE CheckBinary (procSym,
- op1tok, op1,
+PROCEDURE CheckBinary (op1tok, op1,
op2tok, op2,
op3tok, op3: CARDINAL; warning: BOOLEAN;
- lst: List; i: CARDINAL) ;
+ i: CARDINAL) ;
BEGIN
- CheckDeferredRecordAccess (procSym, op2tok, op2, FALSE, warning, lst, i) ;
- CheckDeferredRecordAccess (procSym, op3tok, op3, FALSE, warning, lst, i) ;
+ CheckDeferredRecordAccess (op2tok, op2, FALSE, warning, i) ;
+ CheckDeferredRecordAccess (op3tok, op3, FALSE, warning, i) ;
SetVarInitialized (op1, FALSE, op1tok)
END CheckBinary ;
CheckUnary -
*)
-PROCEDURE CheckUnary (procSym,
- lhstok, lhs,
+PROCEDURE CheckUnary (lhstok, lhs,
rhstok, rhs: CARDINAL; warning: BOOLEAN;
- lst: List; i: CARDINAL) ;
+ i: CARDINAL) ;
BEGIN
- CheckDeferredRecordAccess (procSym, rhstok, rhs, FALSE, warning, lst, i) ;
+ CheckDeferredRecordAccess (rhstok, rhs, FALSE, warning, i) ;
SetVarInitialized (lhs, FALSE, lhstok)
END CheckUnary ;
CheckXIndr -
*)
-PROCEDURE CheckXIndr (procSym, lhstok, lhs, type,
+PROCEDURE CheckXIndr (lhstok, lhs, type,
rhstok, rhs: CARDINAL; warning: BOOLEAN;
- bblst: List; i: CARDINAL) ;
+ i: CARDINAL) ;
VAR
lst : List ;
content: CARDINAL ;
BEGIN
- CheckDeferredRecordAccess (procSym, rhstok, rhs, FALSE, warning, bblst, i) ;
- CheckDeferredRecordAccess (procSym, lhstok, lhs, FALSE, warning, bblst, i) ;
+ CheckDeferredRecordAccess (rhstok, rhs, FALSE, warning, i) ;
+ CheckDeferredRecordAccess (lhstok, lhs, FALSE, warning, i) ;
(* Now see if we know what lhs is pointing to and set fields if necessary. *)
content := getContent (getLAlias (lhs), lhs, lhstok) ;
IF (content # NulSym) AND (content # lhs) AND (GetSType (content) = type)
CheckIndrX -
*)
-PROCEDURE CheckIndrX (procSym, lhstok, lhs, type, rhstok, rhs: CARDINAL;
+PROCEDURE CheckIndrX (lhstok, lhs, rhstok, rhs: CARDINAL;
warning: BOOLEAN;
- lst: List; i: CARDINAL) ;
+ i: CARDINAL) ;
VAR
content: CARDINAL ;
BEGIN
- CheckDeferredRecordAccess (procSym, rhstok, rhs, FALSE, warning, lst, i) ;
+ CheckDeferredRecordAccess (rhstok, rhs, FALSE, warning, i) ;
content := getContent (getLAlias (rhs), rhs, rhstok) ;
IF content = NulSym
THEN
IncludeItemIntoList (ignoreList, lhs)
ELSE
- CheckDeferredRecordAccess (procSym, rhstok, content, TRUE, warning, lst, i) ;
+ CheckDeferredRecordAccess (rhstok, content, TRUE, warning, i) ;
SetVarInitialized (lhs, VarCheckReadInit (content, RightValue), lhstok) ;
IF IsReallyPointer (content)
THEN
CheckRecordField -
*)
-PROCEDURE CheckRecordField (procSym, op1tok, op1, op2tok, op2: CARDINAL) ;
+PROCEDURE CheckRecordField (op1: CARDINAL) ;
BEGIN
PutVarInitialized (op1, LeftValue)
END CheckRecordField ;
CheckBecomes -
*)
-PROCEDURE CheckBecomes (procSym, destok, des, exprtok, expr: CARDINAL;
- warning: BOOLEAN; bblst: List; i: CARDINAL) ;
+PROCEDURE CheckBecomes (destok, des, exprtok, expr: CARDINAL;
+ warning: BOOLEAN; i: CARDINAL) ;
VAR
lvalue: BOOLEAN ;
lst : List ;
vsym : CARDINAL ;
BEGIN
- CheckDeferredRecordAccess (procSym, exprtok, expr, FALSE, warning, bblst, i) ;
+ CheckDeferredRecordAccess (exprtok, expr, FALSE, warning, i) ;
SetupLAlias (des, expr) ;
SetVarInitialized (des, FALSE, destok) ;
(* Now see if we know what lhs is pointing to and set fields if necessary. *)
CheckComparison -
*)
-PROCEDURE CheckComparison (procSym, op1tok, op1, op2tok, op2: CARDINAL;
- warning: BOOLEAN; lst: List; i: CARDINAL) ;
+PROCEDURE CheckComparison (op1tok, op1, op2tok, op2: CARDINAL;
+ warning: BOOLEAN; i: CARDINAL) ;
BEGIN
- CheckDeferredRecordAccess (procSym, op1tok, op1, FALSE, warning, lst, i) ;
- CheckDeferredRecordAccess (procSym, op2tok, op2, FALSE, warning, lst, i)
+ CheckDeferredRecordAccess (op1tok, op1, FALSE, warning, i) ;
+ CheckDeferredRecordAccess (op2tok, op2, FALSE, warning, i)
END CheckComparison ;
CheckAddr -
*)
-PROCEDURE CheckAddr (procSym, ptrtok, ptr, contenttok, content: CARDINAL) ;
+PROCEDURE CheckAddr (ptrtok, ptr, contenttok, content: CARDINAL) ;
BEGIN
SetVarInitialized (ptr, GetVarInitialized (content, contenttok), ptrtok) ;
SetupIndr (ptr, content)
IfLessOp,
IfLessEquOp,
IfGreOp,
- IfGreEquOp : CheckComparison (procSym, op1tok, op1, op2tok, op2, warning, lst, i) |
+ IfGreEquOp : CheckComparison (op1tok, op1, op2tok, op2, warning, i) |
TryOp,
ReturnOp,
CallOp,
(* Variable references. *)
InclOp,
- ExclOp : CheckDeferredRecordAccess (procSym, op1tok, op1, FALSE, warning, lst, i) ;
- CheckDeferredRecordAccess (procSym, op1tok, op1, TRUE, warning, lst, i) ;
- CheckDeferredRecordAccess (procSym, op3tok, op3, FALSE, warning, lst, i) |
- NegateOp : CheckUnary (procSym, op1tok, op1, op3tok, op3, warning, lst, i) |
- BecomesOp : CheckBecomes (procSym, op1tok, op1, op3tok, op3, warning, lst, i) |
+ ExclOp : CheckDeferredRecordAccess (op1tok, op1, FALSE, warning, i) ;
+ CheckDeferredRecordAccess (op1tok, op1, TRUE, warning, i) ;
+ CheckDeferredRecordAccess (op3tok, op3, FALSE, warning, i) |
+ NegateOp : CheckUnary (op1tok, op1, op3tok, op3, warning, i) |
+ BecomesOp : CheckBecomes (op1tok, op1, op3tok, op3, warning, i) |
UnboundedOp,
FunctValueOp,
StandardFunctionOp,
HighOp,
SizeOp : SetVarInitialized (op1, FALSE, op1tok) |
- AddrOp : CheckAddr (procSym, op1tok, op1, op3tok, op3) |
+ AddrOp : CheckAddr (op1tok, op1, op3tok, op3) |
ReturnValueOp : SetVarInitialized (op1, FALSE, op1tok) |
NewLocalVarOp : |
- ParamOp : CheckDeferredRecordAccess (procSym, op2tok, op2, FALSE, warning, lst, i) ;
- CheckDeferredRecordAccess (procSym, op3tok, op3, FALSE, warning, lst, i) ;
+ ParamOp : CheckDeferredRecordAccess (op2tok, op2, FALSE, warning, i) ;
+ CheckDeferredRecordAccess (op3tok, op3, FALSE, warning, i) ;
IF (op1 > 0) AND (op1 <= NoOfParam (op2)) AND
IsVarParam (op2, op1)
THEN
SetVarInitialized (op3, TRUE, op3tok)
END |
- ArrayOp : CheckDeferredRecordAccess (procSym, op3tok, op3, FALSE, warning, lst, i) ;
+ ArrayOp : CheckDeferredRecordAccess (op3tok, op3, FALSE, warning, i) ;
SetVarInitialized (op1, TRUE, op1tok) |
- RecordFieldOp : CheckRecordField (procSym, op1tok, op1, op2tok, op2) |
+ RecordFieldOp : CheckRecordField (op1) |
LogicalShiftOp,
LogicalRotateOp,
LogicalOrOp,
ModCeilOp,
DivFloorOp,
ModTruncOp,
- DivTruncOp : CheckBinary (procSym,
- op1tok, op1, op2tok, op2, op3tok, op3, warning, lst, i) |
- XIndrOp : CheckXIndr (procSym, op1tok, op1, op2, op3tok, op3, warning, lst, i) |
- IndrXOp : CheckIndrX (procSym, op1tok, op1, op2, op3tok, op3, warning, lst, i) |
+ DivTruncOp : CheckBinary (op1tok, op1, op2tok, op2, op3tok, op3, warning, i) |
+ XIndrOp : CheckXIndr (op1tok, op1, op2, op3tok, op3, warning, i) |
+ IndrXOp : CheckIndrX (op1tok, op1, op3tok, op3, warning, i) |
SaveExceptionOp : SetVarInitialized (op1, FALSE, op1tok) |
- RestoreExceptionOp: CheckDeferredRecordAccess (procSym, op1tok, op1, FALSE, warning, lst, i) |
+ RestoreExceptionOp: CheckDeferredRecordAccess (op1tok, op1, FALSE, warning, i) |
SubrangeLowOp,
SubrangeHighOp : InternalError ('quadruples should have been resolved') |
DumpBBSequence -
*)
-PROCEDURE DumpBBSequence (procSym: CARDINAL; lst: List) ;
+PROCEDURE DumpBBSequence (lst: List) ;
VAR
arrayindex,
listindex, n: CARDINAL ;
printf0 (" checking sequence:");
WHILE listindex <= n DO
arrayindex := GetItemFromList (lst, listindex) ;
- printf1 (" [%d]", listindex) ;
+ printf2 (" lst[%d] -> %d", listindex, arrayindex) ;
INC (listindex)
END ;
printf0 ("\n")
BEGIN
IF Debugging
THEN
- DumpBBSequence (procSym, lst)
+ DumpBBSequence (lst)
END ;
initBlock ;
ForeachLocalSymDo (procSym, SetVarUninitialized) ;
projects / thirdparty / gcc.git / commitdiff
