*)
FROM M2System IMPORT IsSystemType, IsGenericSystemType, IsSameSize, IsComplexN ;
-FROM M2Base IMPORT IsParameterCompatible, IsAssignmentCompatible, IsExpressionCompatible, IsComparisonCompatible, IsBaseType, IsMathType, ZType, CType, RType, IsComplexType ;
-FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, KillIndex, HighIndice, LowIndice, IncludeIndiceIntoIndex ;
+FROM M2Base IMPORT IsParameterCompatible, IsAssignmentCompatible, IsExpressionCompatible, IsComparisonCompatible, IsBaseType, IsMathType, ZType, CType, RType, IsComplexType, Char ;
+FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, KillIndex, HighIndice, LowIndice, IncludeIndiceIntoIndex, ForeachIndiceInIndexDo ;
FROM M2Error IMPORT Error, InternalError, NewError, ErrorString, ChainError ;
FROM M2MetaError IMPORT MetaErrorStringT2, MetaErrorStringT3, MetaErrorStringT4, MetaString2, MetaString3, MetaString4 ;
FROM StrLib IMPORT StrEqual ;
FROM DynamicStrings IMPORT String, InitString, KillString ;
FROM M2LexBuf IMPORT GetTokenNo ;
FROM Storage IMPORT ALLOCATE ;
+FROM SYSTEM IMPORT ADR ;
FROM libc IMPORT printf ;
errors : Index ;
+(*
+ dumpIndice -
+*)
+
+PROCEDURE dumpIndice (ptr: pair) ;
+BEGIN
+ printf (" left (%d), right (%d), status ",
+ ptr^.left, ptr^.right);
+ CASE ptr^.pairStatus OF
+
+ true : printf ("true") |
+ false : printf ("false") |
+ unknown: printf ("unknown") |
+ visited: printf ("visited") |
+ unused : printf ("unused")
+
+ END ;
+ printf ("\n")
+END dumpIndice ;
+
+
+(*
+ dumpIndex -
+*)
+
+PROCEDURE dumpIndex (name: ARRAY OF CHAR; index: Index) ;
+BEGIN
+ printf ("status: %s\n", ADR (name)) ;
+ ForeachIndiceInIndexDo (index, dumpIndice)
+END dumpIndex ;
+
+
+(*
+ dumptInfo -
+*)
+
+PROCEDURE dumptInfo (t: tInfo) ;
+BEGIN
+ printf ("actual (%d), formal (%d), left (%d), right (%d), procedure (%d)\n",
+ t^.actual, t^.formal, t^.left, t^.right, t^.procedure) ;
+ dumpIndex ('visited', t^.visited) ;
+ dumpIndex ('resolved', t^.resolved) ;
+ dumpIndex ('unresolved', t^.unresolved)
+END dumptInfo ;
+
+
(*
isKnown - returns BOOLEAN:TRUE if result is status:true or status:false.
*)
(*
- buildError4 -
+ buildError4 - generate a MetaString4 error. This is only used when checking
+ parameter compatibility.
*)
PROCEDURE buildError4 (tinfo: tInfo; left, right: CARDINAL) ;
of paramters passed to ParameterTypeCompatible. *)
s := MetaString4 (tinfo^.format,
tinfo^.procedure,
- tinfo^.left, tinfo^.right,
+ tinfo^.formal, tinfo^.actual,
tinfo^.nth) ;
ErrorString (tinfo^.error, s)
END ;
IF (left # tinfo^.left) OR (right # tinfo^.right)
THEN
tinfo^.error := ChainError (tinfo^.token, tinfo^.error) ;
- s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible in this context"), left, right) ;
+ s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible as formal and actual procedure parameters"),
+ left, right) ;
ErrorString (tinfo^.error, s)
END
END
(*
- buildError2 -
+ buildError2 - generate a MetaString2 error. This is called by all three kinds of errors.
*)
PROCEDURE buildError2 (tinfo: tInfo; left, right: CARDINAL) ;
THEN
IF tinfo^.error = NIL
THEN
- (* need to create top level error message first. *)
+ (* Need to create top level error message first. *)
tinfo^.error := NewError (tinfo^.token) ;
s := MetaString2 (tinfo^.format,
tinfo^.left, tinfo^.right) ;
ErrorString (tinfo^.error, s)
END ;
- (* and also generate a sub error containing detail. *)
+ (* Also generate a sub error containing detail. *)
IF (left # tinfo^.left) OR (right # tinfo^.right)
THEN
tinfo^.error := ChainError (tinfo^.token, tinfo^.error) ;
- s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible in this context"), left, right) ;
+ CASE tinfo^.kind OF
+
+ parameter: s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible as formal and actual procedure parameters"),
+ left, right) |
+ assignment: s := MetaString2 (InitString ("{%1Ead} and {%2ad} are assignment incompatible"),
+ left, right) |
+ expression: s := MetaString2 (InitString ("{%1Ead} and {%2ad} are expression incompatible"),
+ left, right)
+
+ END ;
ErrorString (tinfo^.error, s)
END
END
(*
- checkConstMeta -
+ checkConstMeta - performs a very course grained check against
+ obviously incompatible type kinds.
+ If left is a const string then it checks right against char.
*)
-PROCEDURE checkConstMeta (result: status;
- left, right: CARDINAL) : status ;
+PROCEDURE checkConstMeta (result: status; tinfo: tInfo;
+ left, right: CARDINAL) : status ;
VAR
typeRight: CARDINAL ;
BEGIN
IF typeRight = NulSym
THEN
RETURN result
- ELSIF IsSet (typeRight) OR IsEnumeration (typeRight)
+ ELSIF IsSet (typeRight) OR IsEnumeration (typeRight) OR IsProcedure (typeRight) OR
+ IsRecord (typeRight)
THEN
RETURN false
+ ELSE
+ RETURN doCheckPair (result, tinfo, Char, typeRight)
END
END ;
RETURN result
early on. For example adding a string to an enum or set.
*)
-PROCEDURE checkConstEquivalence (result: status;
+PROCEDURE checkConstEquivalence (result: status; tinfo: tInfo;
left, right: CARDINAL) : status ;
BEGIN
IF isFalse (result)
RETURN true
ELSIF IsConst (left)
THEN
- RETURN checkConstMeta (result, left, right)
+ RETURN checkConstMeta (result, tinfo, left, right)
ELSIF IsConst (right)
THEN
- RETURN checkConstMeta (result, right, left)
+ RETURN checkConstMeta (result, tinfo, right, left)
END ;
RETURN result
END checkConstEquivalence ;
THEN
RETURN return (true, tinfo, left, right)
ELSE
- result := checkConstEquivalence (unknown, left, right) ;
+ result := checkConstEquivalence (unknown, tinfo, left, right) ;
IF NOT isKnown (result)
THEN
result := checkVarEquivalence (unknown, tinfo, left, right) ;
result : status ;
left, right: CARDINAL ;
BEGIN
+ IF debugging
+ THEN
+ dumptInfo (tinfo)
+ END ;
WHILE get (tinfo^.unresolved, left, right, unknown) DO
IF debugging
THEN
- printf ("doCheck (%d, %d)\n", left, right)
+ printf ("doCheck (%d, %d)\n", left, right) ;
+ dumptInfo (tinfo)
END ;
(*
IF in (tinfo^.visited, left, right)
tinfo^.strict := FALSE ;
tinfo^.isin := FALSE ;
include (tinfo^.unresolved, actual, formal, unknown) ;
+ IF debugging
+ THEN
+ dumptInfo (tinfo)
+ END ;
IF doCheck (tinfo)
THEN
deconstruct (tinfo) ;
PROCEDURE PrintVerboseFromList (l: List; i: CARDINAL) ;
VAR
+ len,
type,
low,
high,
ELSIF IsConstStringCnul (sym)
THEN
printf0(' a nul terminated C string')
- END
+ END ;
+ len := GetStringLength (sym) ;
+ printf1(' length %d', len)
ELSIF IsConstructor(sym)
THEN
printf0(' constant constructor ') ;
IndrXOp : CodeIndrX (q, op1, op2, op3) |
XIndrOp : CodeXIndr (q) |
CallOp : CodeCall (CurrentQuadToken, op3) |
- ParamOp : CodeParam (q, op1, op2, op3) |
+ ParamOp : CodeParam (q) |
FunctValueOp : CodeFunctValue (location, op1) |
AddrOp : CodeAddr (q, op1, op3) |
SizeOp : CodeSize (op1, op3) |
procedure, op2. The number of the parameter is op1.
*)
-PROCEDURE doParam (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE doParam (quad: CARDINAL; paramtok: CARDINAL; op1, op2, op3: CARDINAL) ;
VAR
location: location_t ;
BEGIN
- location := TokenToLocation (CurrentQuadToken) ;
- DeclareConstant (CurrentQuadToken, op3) ;
- DeclareConstructor (CurrentQuadToken, quad, op3) ;
- BuildParam (location, CheckConvertCoerceParameter (CurrentQuadToken, op1, op2, op3))
+ location := TokenToLocation (paramtok) ;
+ DeclareConstant (paramtok, op3) ;
+ DeclareConstructor (paramtok, quad, op3) ;
+ BuildParam (location, CheckConvertCoerceParameter (paramtok, op1, op2, op3))
END doParam ;
REPEAT
IF (op=ParamOp) AND (op1>0)
THEN
- doParam(n, op1, op2, op3)
+ doParam (tokenno, n, op1, op2, op3)
ELSIF op=CallOp
THEN
procedure := op3
NOTE that we CAN ignore ModeOfAddr though
*)
-PROCEDURE CodeParam (quad: CARDINAL; nth, procedure, parameter: CARDINAL) ;
+PROCEDURE CodeParam (quad: CARDINAL) ;
+VAR
+ nopos,
+ procedure,
+ parameter,
+ parampos : CARDINAL ;
+ nth : CARDINAL ;
+ compatible,
+ overflow : BOOLEAN ;
+ op : QuadOperator ;
BEGIN
+ GetQuadOtok (quad, parampos, op,
+ nth, procedure, parameter, overflow,
+ nopos, nopos, nopos) ;
+ compatible := TRUE ;
IF nth=0
THEN
CodeBuiltinFunction (quad, nth, procedure, parameter)
THEN
IF (nth <= NoOfParam (procedure))
THEN
- IF IsVarParam (procedure, nth) AND
- (NOT ParameterTypeCompatible (CurrentQuadToken,
- 'parameter incompatibility when attempting to pass actual parameter {%2ad} to a {%kVAR} formal parameter {%3Ead} during call to procedure {%1ad}',
- procedure, GetNthParam (procedure, nth), parameter, nth, TRUE))
- THEN
-
- ELSIF (NOT IsVarParam (procedure, nth)) AND
- (NOT ParameterTypeCompatible (CurrentQuadToken,
- 'parameter incompatibility when attempting to pass actual parameter {%3Ead} to the {%4EN} formal parameter {%2ad} during call to procedure {%1ad}',
- procedure, GetNthParam (procedure, nth), parameter, nth, FALSE))
- THEN
- (* use the AssignmentTypeCompatible as the rules are for assignment for non var parameters. *)
- ELSE
- (* doParam (quad, nth, procedure, parameter) *) (* --fixme-- enable when M2Check works. *)
- END
+ compatible := ParameterTypeCompatible (parampos,
+ 'parameter incompatibility when attempting to pass actual parameter {%2ad} to a {%kVAR} formal parameter {%3Ead} during call to procedure {%1ad}',
+ procedure, GetNthParam (procedure, nth),
+ parameter, nth, IsVarParam (procedure, nth))
END
- ELSE
- (* doParam (quad, nth, procedure, parameter) *) (* --fixme-- enable when M2Check works. *)
END ;
- (* --fixme remove B EGIN *)
IF (nth <= NoOfParam (procedure)) AND
IsVarParam (procedure, nth) AND IsConst (parameter)
THEN
- MetaErrorT1 (CurrentQuadToken,
+ MetaErrorT1 (parampos,
'cannot pass a constant {%1Ead} as a VAR parameter', parameter)
ELSIF IsAModula2Type (parameter)
THEN
- MetaErrorT2 (CurrentQuadToken,
+ MetaErrorT2 (parampos,
'cannot pass a type {%1Ead} as a parameter to procedure {%2ad}',
parameter, procedure)
- ELSE
- doParam (quad, nth, procedure, parameter)
+ ELSIF compatible
+ THEN
+ doParam (quad, parampos, nth, procedure, parameter)
END
- (* --fixme remove E ND once M2Check works. *)
END
END CodeParam ;
PopTrwtok (Des, w, destok) ;
MarkAsWrite (w) ;
CheckCompatibleWithBecomes (Des, Exp, destok, exptok) ;
- combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
IF DebugTokPos
THEN
MetaErrorT1 (becomesTokNo, 'becomestok {%1Oad}', Des) ;
CheckBecomesMeta (Des, Exp, combinedtok, destok, exptok)
END ;
(* Simple assignment. *)
- MoveWithMode (becomesTokNo, Des, Exp, Array, destok, exptok, checkOverflow) ;
+ MoveWithMode (combinedtok, Des, Exp, Array, destok, exptok, checkOverflow) ;
IF checkTypes
THEN
(*
Actual, FormalI, Proc, i)
ELSIF IsConstString (Actual)
THEN
- IF (GetStringLength (Actual) = 0) (* if = 0 then it maybe unknown at this time *)
+ IF (GetStringLength (Actual) = 0) (* If = 0 then it maybe unknown at this time. *)
THEN
- (* dont check this yet *)
+ (* We dont check this yet, it is checked in M2GenGCC.mod:CodeParam
+ after the string has been created. *)
ELSIF IsArray(GetDType(FormalI)) AND (GetSType(GetDType(FormalI))=Char)
THEN
- (* allow string literals to be passed to ARRAY [0..n] OF CHAR *)
- ELSIF (GetStringLength(Actual) = 1) (* if = 1 then it maybe treated as a char *)
+ (* Allow string literals to be passed to ARRAY [0..n] OF CHAR. *)
+ ELSIF (GetStringLength(Actual) = 1) (* If = 1 then it maybe treated as a char. *)
THEN
CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
ELSIF NOT IsUnboundedParam(Proc, i)
ExpectType: CARDINAL ;
s, s1, s2 : String ;
BEGIN
- MetaError2 ('parameter mismatch between the {%2N} parameter of procedure {%1Ead}',
- ProcedureSym, ParameterNo) ;
+ MetaErrorT2 (tokpos,
+ 'parameter mismatch between the {%2N} parameter of procedure {%1Ead}',
+ ProcedureSym, ParameterNo) ;
s := InitString ('{%kPROCEDURE} {%1Eau} (') ;
IF NoOfParam(ProcedureSym)>=ParameterNo
THEN
s := ConCat (s, Mark (InitString ('){%1Tau:% : {%1Tau}} ;'))) ;
MetaErrorStringT1 (First, Dup (s), ProcedureSym) ;
MetaErrorStringT1 (tokpos, s, ProcedureSym) ;
- MetaError1 ('item being passed is {%1EDda} {%1Dad} of type {%1Dtsd}', Given)
+ IF GetLType (Given) = NulSym
+ THEN
+ MetaError1 ('item being passed is {%1EDda} {%1Dad}', Given)
+ ELSE
+ MetaError1 ('item being passed is {%1EDda} {%1Dad} of type {%1Dts}',
+ Given)
+ END
END FailParameter ;
ELSE
(* CheckForGenericNulSet(e1, e2, t1, t2) *)
END ;
+ OldPos := OperatorPos ;
+ OperatorPos := MakeVirtualTok (OperatorPos, leftpos, rightpos) ;
IF (Operator = PlusTok) AND IsConstString(left) AND IsConstString(right)
THEN
(* handle special addition for constant strings *)
value := MakeConstLitString (OperatorPos, makekey (string (s))) ;
s := KillString (s)
ELSE
- OldPos := OperatorPos ;
- OperatorPos := MakeVirtualTok (OperatorPos, leftpos, rightpos) ;
IF checkTypes
THEN
BuildRange (InitTypesExpressionCheck (OperatorPos, left, right, FALSE, FALSE))
ConstStringSym: ConstString.Length := LengthKey (contents) ;
ConstString.Contents := contents ;
+ InitWhereDeclaredTok (tok, ConstString.At) ;
InitWhereFirstUsedTok (tok, ConstString.At) |
ConstVarSym : (* ok altering this to ConstString *)
--- /dev/null
+MODULE badpointer4 ;
+
+FROM DynamicStrings IMPORT String ;
+FROM strconst IMPORT Hello ;
+
+
+PROCEDURE testproc (s: String) ;
+BEGIN
+END testproc ;
+
+
+PROCEDURE foo ;
+BEGIN
+ testproc (Hello)
+END foo ;
+
+
+BEGIN
+ foo
+END badpointer4.
--- /dev/null
+DEFINITION MODULE strconst ;
+
+CONST
+ Hello = "hello world" ;
+
+END strconst.
git://gcc.gnu.org / gcc.git / commitdiff