Improvements to binary and unary expression error messages.

This patch improves binary expression error messages and unary expression
error messages.  The location uses the virtual token created
and the description about the error contains more detail.

gcc/m2/ChangeLog:

	* gm2-compiler/M2GCCDeclare.mod: Corrected spacing.
	* gm2-compiler/M2GenGCC.mod (M2MetaError): Import MetaErrorStringT1.
	(DynamicStrings): Import ConCatChar.  (M2Quads) Import
	GetM2OperatorDesc and GetQuadOp.
	(m2except): Import list inserted identifiers GetM2OperatorDesc and
	GetQuadOp.
	(CodeMakeAdr): Corrected grammer of the error message.
	(FoldMakeAdr): Corrected grammer of the error message.
	(CheckBinaryOperand): New procedure function.
        (BinaryOperands): Rewritten.
	(UnaryOperand): New procedure function.
	(FoldAdd): Corrected spacing.
	(CodeAddChecked): Corrected spacing.
	(CodeAddCheck): Corrected spacing.
	(CodeMult): Corrected spacing.
	(CodeModM2Checked): Corrected spacing.
	(CodeModM2Checked): Corrected spacing.
	(FoldDivM2): Corrected spacing.
	(CodeSetShift): Corrected spacing.
	(FoldSetRotate): Corrected spacing.
	(CodeSetRotate): Corrected spacing.
	(CodeUnaryCheck): Corrected spacing.
	(CodeUnaryCheck): Corrected spacing.
	(CheckReferenced): Improved error message grammar.
	(CodeIfLess): Improved error message grammar.
	(CodeIfGre): Improved error message grammar.
	(CodeIfLessEqu): Improved error message grammar.
	(CodeIfSetEqu): Improved error message grammar.
	* gm2-compiler/M2Quads.def (GetQuadOp): New procedure function
	defined and exported.  (GetM2OperatorDesc) New procedure function
	defined and exported.
	* gm2-compiler/M2Quads.mod (GetQuadOp): New procedure function.
	(GetM2OperatorDesc) New procedure function.
	* gm2-compiler/M2Scope.mod (GetGlobalQuads): Added condition
	for InitStartOp, which fixes an error scope bug when resolving
	constant expressions.
	* gm2-gcc/m2statement.def: Improved comment.

Signed-off-by: Gaius Mulley <gaius.mulley@southwales.ac.uk>
This commit is contained in:
Gaius Mulley 2022-08-11 18:13:49 +01:00
parent 82bcda7e2a
commit 06642d296d
6 changed files with 258 additions and 95 deletions

View File

@ -2823,18 +2823,18 @@ BEGIN
IF Debugging IF Debugging
THEN THEN
n := GetSymName(scope) ; n := GetSymName (scope) ;
printf1('declaring symbols in BLOCK %a\n', n) printf1 ('declaring symbols in BLOCK %a\n', n)
END ; END ;
IF IsProcedure(scope) IF IsProcedure (scope)
THEN THEN
StartDeclareProcedureScope(scope) StartDeclareProcedureScope (scope)
ELSE ELSE
StartDeclareModuleScope(scope) StartDeclareModuleScope (scope)
END ; END ;
IF Debugging IF Debugging
THEN THEN
n := GetSymName(scope) ; n := GetSymName (scope) ;
printf1('\nEND declaring symbols in BLOCK %a\n', n) printf1('\nEND declaring symbols in BLOCK %a\n', n)
END END
END StartDeclareScope ; END StartDeclareScope ;

View File

@ -84,7 +84,9 @@ FROM M2LexBuf IMPORT FindFileNameFromToken, TokenToLineNo, TokenToLocation, Make
FROM M2Code IMPORT CodeBlock ; FROM M2Code IMPORT CodeBlock ;
FROM M2Debug IMPORT Assert ; FROM M2Debug IMPORT Assert ;
FROM M2Error IMPORT InternalError, WriteFormat0, WriteFormat1, WriteFormat2, WarnStringAt ; FROM M2Error IMPORT InternalError, WriteFormat0, WriteFormat1, WriteFormat2, WarnStringAt ;
FROM M2MetaError IMPORT MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3, MetaError1, MetaError2 ;
FROM M2MetaError IMPORT MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3,
MetaError1, MetaError2, MetaErrorStringT1 ;
FROM M2Options IMPORT DisplayQuadruples, UnboundedByReference, PedanticCast, FROM M2Options IMPORT DisplayQuadruples, UnboundedByReference, PedanticCast,
VerboseUnbounded, Iso, Pim, DebugBuiltins, WholeProgram, VerboseUnbounded, Iso, Pim, DebugBuiltins, WholeProgram,
@ -105,7 +107,10 @@ FROM M2Base IMPORT MixTypes, NegateType, ActivationPointer, IsMathType,
FROM M2Bitset IMPORT Bitset ; FROM M2Bitset IMPORT Bitset ;
FROM NameKey IMPORT Name, MakeKey, KeyToCharStar, LengthKey, makekey, NulName ; FROM NameKey IMPORT Name, MakeKey, KeyToCharStar, LengthKey, makekey, NulName ;
FROM DynamicStrings IMPORT string, InitString, KillString, String, InitStringCharStar, Mark, Slice, ConCat ;
FROM DynamicStrings IMPORT string, InitString, KillString, String,
InitStringCharStar, Mark, Slice, ConCat, ConCatChar ;
FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3, Sprintf4 ; FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3, Sprintf4 ;
FROM M2System IMPORT Address, Word, System, TBitSize, MakeAdr, IsSystemType, IsGenericSystemType, IsRealN, IsComplexN, IsSetN, IsWordN, Loc, Byte ; FROM M2System IMPORT Address, Word, System, TBitSize, MakeAdr, IsSystemType, IsGenericSystemType, IsRealN, IsComplexN, IsSetN, IsWordN, Loc, Byte ;
FROM M2FileName IMPORT CalculateFileName ; FROM M2FileName IMPORT CalculateFileName ;
@ -242,6 +247,7 @@ FROM m2except IMPORT BuildThrow, BuildTryBegin, BuildTryEnd,
FROM M2Quads IMPORT QuadOperator, GetQuad, IsReferenced, GetNextQuad, FROM M2Quads IMPORT QuadOperator, GetQuad, IsReferenced, GetNextQuad,
SubQuad, PutQuad, MustCheckOverflow, GetQuadOtok, SubQuad, PutQuad, MustCheckOverflow, GetQuadOtok,
QuadToTokenNo, DisplayQuad, GetQuadtok, QuadToTokenNo, DisplayQuad, GetQuadtok,
GetM2OperatorDesc, GetQuadOp,
DisplayQuadList ; DisplayQuadList ;
FROM M2Check IMPORT ParameterTypeCompatible, AssignmentTypeCompatible ; FROM M2Check IMPORT ParameterTypeCompatible, AssignmentTypeCompatible ;
@ -553,7 +559,10 @@ VAR
op : QuadOperator ; op : QuadOperator ;
op1, op1,
op2, op2,
op3 : CARDINAL ; op3,
op1pos,
op2pos,
op3pos : CARDINAL ;
Changed: BOOLEAN ; Changed: BOOLEAN ;
BEGIN BEGIN
Changed := FALSE ; Changed := FALSE ;
@ -566,7 +575,8 @@ BEGIN
THEN THEN
tokenno := QuadToTokenNo (quad) tokenno := QuadToTokenNo (quad)
END ; END ;
GetQuad (quad, op, op1, op2, op3) ; GetQuadtok (quad, op, op1, op2, op3,
op1pos, op2pos, op3pos) ;
CASE op OF CASE op OF
StandardFunctionOp : FoldStandardFunction (tokenno, p, quad, op1, op2, op3) | StandardFunctionOp : FoldStandardFunction (tokenno, p, quad, op1, op2, op3) |
@ -576,18 +586,18 @@ BEGIN
LogicalAndOp : FoldSetAnd (tokenno, p, quad, op1, op2, op3) | LogicalAndOp : FoldSetAnd (tokenno, p, quad, op1, op2, op3) |
LogicalXorOp : FoldSymmetricDifference (tokenno, p, quad, op1, op2, op3) | LogicalXorOp : FoldSymmetricDifference (tokenno, p, quad, op1, op2, op3) |
BecomesOp : FoldBecomes (tokenno, p, quad, op1, op3) | BecomesOp : FoldBecomes (tokenno, p, quad, op1, op3) |
AddOp : FoldAdd (tokenno, p, quad, op1, op2, op3) | AddOp : FoldAdd (op1pos, p, quad, op1, op2, op3) |
SubOp : FoldSub (tokenno, p, quad, op1, op2, op3) | SubOp : FoldSub (op1pos, p, quad, op1, op2, op3) |
MultOp : FoldMult (tokenno, p, quad, op1, op2, op3) | MultOp : FoldMult (op1pos, p, quad, op1, op2, op3) |
DivM2Op : FoldDivM2 (tokenno, p, quad, op1, op2, op3) | DivM2Op : FoldDivM2 (op1pos, p, quad, op1, op2, op3) |
ModM2Op : FoldModM2 (tokenno, p, quad, op1, op2, op3) | ModM2Op : FoldModM2 (op1pos, p, quad, op1, op2, op3) |
DivTruncOp : FoldDivTrunc (tokenno, p, quad, op1, op2, op3) | DivTruncOp : FoldDivTrunc (op1pos, p, quad, op1, op2, op3) |
ModTruncOp : FoldModTrunc (tokenno, p, quad, op1, op2, op3) | ModTruncOp : FoldModTrunc (op1pos, p, quad, op1, op2, op3) |
DivCeilOp : FoldDivCeil (tokenno, p, quad, op1, op2, op3) | DivCeilOp : FoldDivCeil (op1pos, p, quad, op1, op2, op3) |
ModCeilOp : FoldModCeil (tokenno, p, quad, op1, op2, op3) | ModCeilOp : FoldModCeil (op1pos, p, quad, op1, op2, op3) |
DivFloorOp : FoldDivFloor (tokenno, p, quad, op1, op2, op3) | DivFloorOp : FoldDivFloor (op1pos, p, quad, op1, op2, op3) |
ModFloorOp : FoldModFloor (tokenno, p, quad, op1, op2, op3) | ModFloorOp : FoldModFloor (op1pos, p, quad, op1, op2, op3) |
NegateOp : FoldNegate (tokenno, p, quad, op1, op3) | NegateOp : FoldNegate (op1pos, p, quad, op1, op3) |
SizeOp : FoldSize (tokenno, p, quad, op1, op2, op3) | SizeOp : FoldSize (tokenno, p, quad, op1, op2, op3) |
RecordFieldOp : FoldRecordField (tokenno, p, quad, op1, op2, op3) | RecordFieldOp : FoldRecordField (tokenno, p, quad, op1, op2, op3) |
HighOp : FoldHigh (tokenno, p, quad, op1, op2, op3) | HighOp : FoldHigh (tokenno, p, quad, op1, op2, op3) |
@ -2244,7 +2254,7 @@ BEGIN
IF CompareTrees(bits, max)>0 IF CompareTrees(bits, max)>0
THEN THEN
MetaErrorT0 (CurrentQuadToken, MetaErrorT0 (CurrentQuadToken,
'total number of bit specified as parameters to {%kMAKEADR} exceeds address width') 'total number of bits specified as parameters to {%kMAKEADR} exceeds address width')
END ; END ;
SubQuad(n) ; SubQuad(n) ;
BuildAssignmentStatement (location, res, val) BuildAssignmentStatement (location, res, val)
@ -2314,7 +2324,7 @@ BEGIN
IF GetType(op3)=NulSym IF GetType(op3)=NulSym
THEN THEN
MetaErrorT0 (tokenno, MetaErrorT0 (tokenno,
'must supply typed constants to {%kMAKEADR}') 'constants passed to {%kMAKEADR} must be typed')
ELSE ELSE
type := GetType(op3) ; type := GetType(op3) ;
tmp := BuildConvert(location, GetPointerType(), Mod2Gcc(op3), FALSE) ; tmp := BuildConvert(location, GetPointerType(), Mod2Gcc(op3), FALSE) ;
@ -2333,7 +2343,7 @@ BEGIN
IF CompareTrees(bits, max)>0 IF CompareTrees(bits, max)>0
THEN THEN
MetaErrorT0 (tokenno, MetaErrorT0 (tokenno,
'total number of bit specified as parameters to {%kMAKEADR} exceeds address width') 'total number of bits specified as parameters to {%kMAKEADR} exceeds address width')
END ; END ;
PutConst(r, Address) ; PutConst(r, Address) ;
AddModGcc(r, DeclareKnownConstant(location, Mod2Gcc(Address), val)) ; AddModGcc(r, DeclareKnownConstant(location, Mod2Gcc(Address), val)) ;
@ -3480,6 +3490,91 @@ BEGIN
END CodeBinarySet ; END CodeBinarySet ;
(*
CheckUnaryOperand - checks to see whether operand is using a generic type.
*)
PROCEDURE CheckUnaryOperand (quad: CARDINAL; operand: CARDINAL) : BOOLEAN ;
VAR
type : CARDINAL ;
s, op : String ;
BEGIN
type := SkipType (GetType (operand)) ;
IF (Word=type) OR IsWordN (type) OR (Byte=type) OR (Loc=type)
THEN
op := GetM2OperatorDesc (GetQuadOp (quad)) ;
s := InitString ('operand of type {%1Ets} is not allowed in an unary expression') ;
IF op # NIL
THEN
s := ConCatChar (s, ' ') ;
s := ConCat (s, Mark (op))
END ;
MetaErrorStringT1 (CurrentQuadToken, s, operand) ;
RETURN FALSE
END ;
RETURN TRUE
END CheckUnaryOperand ;
(*
UnaryOperand - returns TRUE if operand is acceptable for
unary operator: + -. If FALSE
is returned, an error message will be generated
and the quad is deleted.
*)
PROCEDURE UnaryOperand (quad: CARDINAL; operand: CARDINAL) : BOOLEAN ;
BEGIN
IF NOT CheckUnaryOperand (quad, operand)
THEN
SubQuad (quad) ; (* We do not want multiple copies of the same error. *)
RETURN FALSE
END ;
RETURN TRUE
END UnaryOperand ;
(*
CheckBinaryOperand - checks to see whether operand is using a generic type.
*)
PROCEDURE CheckBinaryOperand (quad: CARDINAL; isleft: BOOLEAN;
operand: CARDINAL; result: BOOLEAN) : BOOLEAN ;
VAR
type : CARDINAL ;
qop : QuadOperator ;
op1,
op2,
op3,
op1pos,
op2pos,
op3pos: CARDINAL ;
s, op : String ;
BEGIN
type := SkipType (GetType (operand)) ;
IF (Word=type) OR IsWordN (type) OR (Byte=type) OR (Loc=type)
THEN
GetQuadtok (quad, qop, op1, op2, op3,
op1pos, op2pos, op3pos) ;
op := GetM2OperatorDesc (GetQuadOp (quad)) ;
IF isleft
THEN
s := InitString ('left operand {%1Ea} of type {%1Ets} is not allowed in binary expression')
ELSE
s := InitString ('right operand {%1Ea} of type {%1Ets} is not allowed in binary expression')
END ;
IF op # NIL
THEN
s := ConCatChar (s, ' ') ;
s := ConCat (s, Mark (op))
END ;
MetaErrorStringT1 (op1pos, s, operand) ;
RETURN FALSE
END ;
RETURN result
END CheckBinaryOperand ;
(* (*
BinaryOperands - returns TRUE if, l, and, r, are acceptable for BinaryOperands - returns TRUE if, l, and, r, are acceptable for
binary operator: + - / * and friends. If FALSE binary operator: + - / * and friends. If FALSE
@ -3489,25 +3584,13 @@ END CodeBinarySet ;
PROCEDURE BinaryOperands (quad: CARDINAL; l, r: CARDINAL) : BOOLEAN ; PROCEDURE BinaryOperands (quad: CARDINAL; l, r: CARDINAL) : BOOLEAN ;
VAR VAR
tl, tr: CARDINAL ;
result: BOOLEAN ; result: BOOLEAN ;
BEGIN BEGIN
result := TRUE ; result := CheckBinaryOperand (quad, TRUE, l, TRUE) ;
tl := SkipType(GetType(l)) ; result := CheckBinaryOperand (quad, FALSE, r, result) ;
tr := SkipType(GetType(r)) ;
IF (Word=tl) OR IsWordN(tl) OR (Byte=tl) OR (Loc=tl)
THEN
MetaErrorT1 (CurrentQuadToken, 'operand of type {%1Ets} is not allowed in a binary expression', l) ;
result := FALSE
END ;
IF (Word=tr) OR IsWordN(tr) OR (Byte=tl) OR (Loc=tl)
THEN
MetaErrorT1 (CurrentQuadToken, 'operand of type {%1Ets} is not allowed in a binary expression', r) ;
result := FALSE
END ;
IF NOT result IF NOT result
THEN THEN
SubQuad (quad) (* we do not want multiple copies of the same error *) SubQuad (quad) (* We do not want multiple copies of the same error. *)
END ; END ;
RETURN result RETURN result
END BinaryOperands ; END BinaryOperands ;
@ -3535,9 +3618,9 @@ BEGIN
SubQuad(quad) ; SubQuad(quad) ;
s := KillString(s) s := KillString(s)
ELSE ELSE
IF BinaryOperands(quad, op2, op3) IF BinaryOperands (quad, op2, op3)
THEN THEN
FoldBinary(tokenno, p, BuildAdd, quad, op1, op2, op3) FoldBinary (tokenno, p, BuildAdd, quad, op1, op2, op3)
END END
END END
END FoldAdd ; END FoldAdd ;
@ -3592,7 +3675,7 @@ END CodeAdd ;
PROCEDURE FoldSub (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldSub (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, op2, op3) IF BinaryOperands (quad, op2, op3)
THEN THEN
FoldBinary(tokenno, p, BuildSub, quad, op1, op2, op3) FoldBinary(tokenno, p, BuildSub, quad, op1, op2, op3)
END END
@ -3621,7 +3704,7 @@ END CodeSubChecked ;
PROCEDURE CodeSubCheck (quad: CARDINAL; left, right: CARDINAL) ; PROCEDURE CodeSubCheck (quad: CARDINAL; left, right: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, left, right) IF BinaryOperands (quad, left, right)
THEN THEN
CodeBinaryCheck (BuildSubCheck, quad) CodeBinaryCheck (BuildSubCheck, quad)
END END
@ -3634,7 +3717,7 @@ END CodeSubCheck ;
PROCEDURE CodeSub (quad: CARDINAL; left, right: CARDINAL) ; PROCEDURE CodeSub (quad: CARDINAL; left, right: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, left, right) IF BinaryOperands (quad, left, right)
THEN THEN
CodeBinary (BuildSub, quad) CodeBinary (BuildSub, quad)
END END
@ -3648,7 +3731,7 @@ END CodeSub ;
PROCEDURE FoldMult (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldMult (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, op2, op3) IF BinaryOperands (quad, op2, op3)
THEN THEN
FoldBinary(tokenno, p, BuildMult, quad, op1, op2, op3) FoldBinary(tokenno, p, BuildMult, quad, op1, op2, op3)
END END
@ -3776,7 +3859,7 @@ END BinaryOperandRealFamily ;
PROCEDURE FoldDivM2 (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldDivM2 (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, op2, op3) IF BinaryOperands (quad, op2, op3)
THEN THEN
IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3) IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3)
THEN THEN
@ -3813,7 +3896,7 @@ END CodeDivM2 ;
PROCEDURE FoldModM2 (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldModM2 (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, op2, op3) IF BinaryOperands (quad, op2, op3)
THEN THEN
FoldBinary(tokenno, p, BuildModM2, quad, op1, op2, op3) FoldBinary(tokenno, p, BuildModM2, quad, op1, op2, op3)
END END
@ -3826,7 +3909,7 @@ END FoldModM2 ;
PROCEDURE CodeModM2 (quad: CARDINAL; left, right: CARDINAL) ; PROCEDURE CodeModM2 (quad: CARDINAL; left, right: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, left, right) IF BinaryOperands (quad, left, right)
THEN THEN
CodeBinary (BuildModM2, quad) CodeBinary (BuildModM2, quad)
END END
@ -3840,7 +3923,7 @@ END CodeModM2 ;
PROCEDURE FoldDivTrunc (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldDivTrunc (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, op2, op3) IF BinaryOperands (quad, op2, op3)
THEN THEN
IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3) IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3)
THEN THEN
@ -3858,7 +3941,7 @@ END FoldDivTrunc ;
PROCEDURE CodeDivTrunc (quad: CARDINAL; left, right: CARDINAL) ; PROCEDURE CodeDivTrunc (quad: CARDINAL; left, right: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, left, right) IF BinaryOperands (quad, left, right)
THEN THEN
IF BinaryOperandRealFamily (left) OR BinaryOperandRealFamily (right) IF BinaryOperandRealFamily (left) OR BinaryOperandRealFamily (right)
THEN THEN
@ -3904,7 +3987,7 @@ END CodeModTrunc ;
PROCEDURE FoldDivCeil (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldDivCeil (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, op2, op3) IF BinaryOperands (quad, op2, op3)
THEN THEN
IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3) IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3)
THEN THEN
@ -3922,7 +4005,7 @@ END FoldDivCeil ;
PROCEDURE CodeDivCeil (quad: CARDINAL; left, right: CARDINAL) ; PROCEDURE CodeDivCeil (quad: CARDINAL; left, right: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, left, right) IF BinaryOperands (quad, left, right)
THEN THEN
IF BinaryOperandRealFamily (left) OR BinaryOperandRealFamily (right) IF BinaryOperandRealFamily (left) OR BinaryOperandRealFamily (right)
THEN THEN
@ -3941,7 +4024,7 @@ END CodeDivCeil ;
PROCEDURE FoldModCeil (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldModCeil (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, op2, op3) IF BinaryOperands (quad, op2, op3)
THEN THEN
FoldBinary(tokenno, p, BuildModCeil, quad, op1, op2, op3) FoldBinary(tokenno, p, BuildModCeil, quad, op1, op2, op3)
END END
@ -3968,7 +4051,7 @@ END CodeModCeil ;
PROCEDURE FoldDivFloor (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldDivFloor (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, op2, op3) IF BinaryOperands (quad, op2, op3)
THEN THEN
IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3) IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3)
THEN THEN
@ -4005,7 +4088,7 @@ END CodeDivFloor ;
PROCEDURE FoldModFloor (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldModFloor (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, op2, op3) IF BinaryOperands (quad, op2, op3)
THEN THEN
FoldBinary(tokenno, p, BuildModFloor, quad, op1, op2, op3) FoldBinary(tokenno, p, BuildModFloor, quad, op1, op2, op3)
END END
@ -4018,7 +4101,7 @@ END FoldModFloor ;
PROCEDURE CodeModFloor (quad: CARDINAL; left, right: CARDINAL) ; PROCEDURE CodeModFloor (quad: CARDINAL; left, right: CARDINAL) ;
BEGIN BEGIN
IF BinaryOperands(quad, left, right) IF BinaryOperands (quad, left, right)
THEN THEN
CodeBinary (BuildModFloor, quad) CodeBinary (BuildModFloor, quad)
END END
@ -4437,7 +4520,7 @@ END FoldBinarySet ;
PROCEDURE FoldSetOr (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldSetOr (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
FoldBinarySet(tokenno, p, SetOr, quad, op1, op2, op3) FoldBinarySet (tokenno, p, SetOr, quad, op1, op2, op3)
END FoldSetOr ; END FoldSetOr ;
@ -4447,7 +4530,7 @@ END FoldSetOr ;
PROCEDURE CodeSetOr (quad: CARDINAL; op1, op2, op3: CARDINAL) ; PROCEDURE CodeSetOr (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
CodeBinarySet(BuildLogicalOr, SetOr, quad, op1, op2, op3) CodeBinarySet (BuildLogicalOr, SetOr, quad, op1, op2, op3)
END CodeSetOr ; END CodeSetOr ;
@ -4468,7 +4551,7 @@ END FoldSetAnd ;
PROCEDURE CodeSetAnd (quad: CARDINAL; op1, op2, op3: CARDINAL) ; PROCEDURE CodeSetAnd (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
CodeBinarySet(BuildLogicalAnd, SetAnd, quad, op1, op2, op3) CodeBinarySet (BuildLogicalAnd, SetAnd, quad, op1, op2, op3)
END CodeSetAnd ; END CodeSetAnd ;
@ -4566,12 +4649,12 @@ END FoldSetShift ;
PROCEDURE CodeSetShift (quad: CARDINAL; op1, op2, op3: CARDINAL) ; PROCEDURE CodeSetShift (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
CodeBinarySetShift(BuildLogicalShift, CodeBinarySetShift (BuildLogicalShift,
SetShift, SetShift,
MakeKey('ShiftVal'), MakeKey('ShiftVal'),
MakeKey('ShiftLeft'), MakeKey('ShiftLeft'),
MakeKey('ShiftRight'), MakeKey('ShiftRight'),
quad, op1, op2, op3) quad, op1, op2, op3)
END CodeSetShift ; END CodeSetShift ;
@ -4592,12 +4675,12 @@ END FoldSetRotate ;
PROCEDURE CodeSetRotate (quad: CARDINAL; op1, op2, op3: CARDINAL) ; PROCEDURE CodeSetRotate (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
CodeBinarySetShift(BuildLogicalRotate, CodeBinarySetShift (BuildLogicalRotate,
SetRotate, SetRotate,
MakeKey('RotateVal'), MakeKey ('RotateVal'),
MakeKey('RotateLeft'), MakeKey ('RotateLeft'),
MakeKey('RotateRight'), MakeKey ('RotateRight'),
quad, op1, op2, op3) quad, op1, op2, op3)
END CodeSetRotate ; END CodeSetRotate ;
@ -4620,8 +4703,8 @@ END FoldSetLogicalDifference ;
PROCEDURE CodeSetLogicalDifference (quad: CARDINAL; op1, op2, op3: CARDINAL) ; PROCEDURE CodeSetLogicalDifference (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
CodeBinarySet(BuildLogicalDifference, SetDifference, CodeBinarySet (BuildLogicalDifference, SetDifference,
quad, op1, op2, op3) quad, op1, op2, op3)
END CodeSetLogicalDifference ; END CodeSetLogicalDifference ;
@ -4632,7 +4715,7 @@ END CodeSetLogicalDifference ;
PROCEDURE FoldSymmetricDifference (tokenno: CARDINAL; p: WalkAction; PROCEDURE FoldSymmetricDifference (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
FoldBinarySet(tokenno, p, SetSymmetricDifference, quad, op1, op2, op3) FoldBinarySet (tokenno, p, SetSymmetricDifference, quad, op1, op2, op3)
END FoldSymmetricDifference ; END FoldSymmetricDifference ;
@ -4642,8 +4725,8 @@ END FoldSymmetricDifference ;
PROCEDURE CodeSetSymmetricDifference (quad: CARDINAL; op1, op2, op3: CARDINAL) ; PROCEDURE CodeSetSymmetricDifference (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN BEGIN
CodeBinarySet(BuildSymmetricDifference, SetSymmetricDifference, CodeBinarySet (BuildSymmetricDifference, SetSymmetricDifference,
quad, op1, op2, op3) quad, op1, op2, op3)
END CodeSetSymmetricDifference ; END CodeSetSymmetricDifference ;
@ -4652,7 +4735,7 @@ END CodeSetSymmetricDifference ;
Set operands may be longer than a word. Set operands may be longer than a word.
*) *)
PROCEDURE CodeUnarySet (unop: BuildUnarySetFunction; doOp: DoUnaryProcedure; PROCEDURE CodeUnarySet (unop: BuildUnarySetFunction; constop: DoUnaryProcedure;
quad: CARDINAL; result, expr: CARDINAL) ; quad: CARDINAL; result, expr: CARDINAL) ;
VAR VAR
location: location_t ; location: location_t ;
@ -4669,7 +4752,7 @@ BEGIN
Assert (FindType (expr) # NulSym) ; Assert (FindType (expr) # NulSym) ;
PutConst (result, FindType (expr)) ; PutConst (result, FindType (expr)) ;
PushValue (expr) ; PushValue (expr) ;
doOp (CurrentQuadToken) ; constop (CurrentQuadToken) ;
PopValue (result) ; PopValue (result) ;
PushValue (result) ; PushValue (result) ;
PutConstSet (result) ; PutConstSet (result) ;
@ -4683,10 +4766,10 @@ BEGIN
END END
ELSE ELSE
checkDeclare (result) ; checkDeclare (result) ;
BuildUnaryForeachWordDo(location, BuildUnaryForeachWordDo (location,
Mod2Gcc (GetType (result)), Mod2Gcc (result), Mod2Gcc (expr), unop, Mod2Gcc (GetType (result)), Mod2Gcc (result), Mod2Gcc (expr), unop,
GetMode(result) = LeftValue, GetMode(expr) = LeftValue, GetMode(result) = LeftValue, GetMode(expr) = LeftValue,
IsConst (result), IsConst (expr)) IsConst (result), IsConst (expr))
END END
END CodeUnarySet ; END CodeUnarySet ;
@ -5195,7 +5278,7 @@ PROCEDURE FoldNegate (tokenno: CARDINAL; p: WalkAction;
BEGIN BEGIN
IF IsConstSet (expr) IF IsConstSet (expr)
THEN THEN
FoldUnarySet(tokenno, p, SetNegate, quad, result, expr) FoldUnarySet (tokenno, p, SetNegate, quad, result, expr)
ELSE ELSE
FoldUnary (tokenno, p, BuildNegate, NIL, quad, result, expr) FoldUnary (tokenno, p, BuildNegate, NIL, quad, result, expr)
END END
@ -5212,11 +5295,14 @@ BEGIN
IF IsConstSet (op3) OR IsSet (GetType (op3)) IF IsConstSet (op3) OR IsSet (GetType (op3))
THEN THEN
CodeUnarySet (BuildSetNegate, SetNegate, quad, op1, op3) CodeUnarySet (BuildSetNegate, SetNegate, quad, op1, op3)
ELSIF MustCheckOverflow (quad) ELSIF UnaryOperand (quad, op3)
THEN THEN
CodeUnaryCheck (BuildNegateCheck, NIL, quad, op1, op3) IF MustCheckOverflow (quad)
ELSE THEN
CodeUnary (BuildNegate, NIL, quad, op1, op3) CodeUnaryCheck (BuildNegateCheck, NIL, quad, op1, op3)
ELSE
CodeUnary (BuildNegate, NIL, quad, op1, op3)
END
END END
END CodeNegateChecked ; END CodeNegateChecked ;
@ -6288,7 +6374,7 @@ BEGIN
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2)) IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
THEN THEN
MetaErrorT2 (CurrentQuadToken, MetaErrorT2 (CurrentQuadToken,
'comparison tests between are composite types not allowed {%1Eatd} and {%2atd}', 'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
op1, op2) op1, op2)
ELSE ELSE
ConvertBinaryOperands(location, ConvertBinaryOperands(location,
@ -6385,7 +6471,7 @@ BEGIN
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2)) IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
THEN THEN
MetaErrorT2 (CurrentQuadToken, MetaErrorT2 (CurrentQuadToken,
'comparison tests between are composite types not allowed {%1Eatd} and {%2atd}', 'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
op1, op2) op1, op2)
ELSE ELSE
ConvertBinaryOperands(location, ConvertBinaryOperands(location,
@ -6481,7 +6567,7 @@ BEGIN
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2)) IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
THEN THEN
MetaErrorT2 (CurrentQuadToken, MetaErrorT2 (CurrentQuadToken,
'comparison tests between are composite types not allowed {%1Eatd} and {%2atd}', 'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
op1, op2) op1, op2)
ELSE ELSE
ConvertBinaryOperands(location, ConvertBinaryOperands(location,
@ -6577,7 +6663,7 @@ BEGIN
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2)) IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
THEN THEN
MetaErrorT2 (CurrentQuadToken, MetaErrorT2 (CurrentQuadToken,
'comparison tests between are composite types not allowed {%1Eatd} and {%2atd}', 'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
op1, op2) op1, op2)
ELSE ELSE
ConvertBinaryOperands(location, ConvertBinaryOperands(location,
@ -6731,7 +6817,7 @@ BEGIN
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2)) IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
THEN THEN
MetaErrorT2 (CurrentQuadToken, MetaErrorT2 (CurrentQuadToken,
'equality tests between are composite types not allowed {%1Eatd} and {%2atd}', 'equality tests between composite types not allowed {%1Eatd} and {%2atd}',
op1, op2) op1, op2)
ELSE ELSE
ConvertBinaryOperands(location, ConvertBinaryOperands(location,
@ -6780,7 +6866,7 @@ BEGIN
IF IsComposite(op1) OR IsComposite(op2) IF IsComposite(op1) OR IsComposite(op2)
THEN THEN
MetaErrorT2 (CurrentQuadToken, MetaErrorT2 (CurrentQuadToken,
'inequality tests between are composite types not allowed {%1Eatd} and {%2atd}', 'inequality tests between composite types not allowed {%1Eatd} and {%2atd}',
op1, op2) op1, op2)
ELSE ELSE
ConvertBinaryOperands(location, ConvertBinaryOperands(location,

View File

@ -128,6 +128,7 @@ EXPORT QUALIFIED StartBuildDefFile, StartBuildModFile, EndBuildFile,
GetQuad, GetFirstQuad, GetNextQuad, PutQuad, GetQuad, GetFirstQuad, GetNextQuad, PutQuad,
SubQuad, EraseQuad, GetRealQuad, SubQuad, EraseQuad, GetRealQuad,
GetQuadtok, GetQuadOtok, GetQuadtok, GetQuadOtok,
GetQuadOp, GetM2OperatorDesc,
CountQuads, CountQuads,
GetLastFileQuad, GetLastFileQuad,
GetLastQuadNo, GetLastQuadNo,
@ -437,6 +438,24 @@ PROCEDURE GetQuad (QuadNo: CARDINAL;
VAR Oper1, Oper2, Oper3: CARDINAL) ; VAR Oper1, Oper2, Oper3: CARDINAL) ;
(*
GetQuadOp - returns the operator for quad.
*)
PROCEDURE GetQuadOp (quad: CARDINAL) : QuadOperator ;
(*
GetM2OperatorDesc - returns the Modula-2 string associated with the quad operator
(if possible). It returns NIL if no there is not an obvious match
in Modula-2. It is assummed that the string will be used during
construction of error messages and therefore keywords are
wrapped with a format specifier.
*)
PROCEDURE GetM2OperatorDesc (op: QuadOperator) : String ;
(* (*
GetQuadtok - returns the Quadruple QuadNo. GetQuadtok - returns the Quadruple QuadNo.
*) *)

View File

@ -13381,6 +13381,55 @@ BEGIN
END WriteMode ; END WriteMode ;
(*
GetQuadOp - returns the operator for quad.
*)
PROCEDURE GetQuadOp (quad: CARDINAL) : QuadOperator ;
VAR
f: QuadFrame ;
BEGIN
f := GetQF (quad) ;
RETURN f^.Operator
END GetQuadOp ;
(*
GetM2OperatorDesc - returns the Modula-2 string associated with the quad operator
(if possible). It returns NIL if no there is not an obvious match
in Modula-2. It is assummed that the string will be used during
construction of error messages and therefore keywords are
wrapped with a format specifier.
*)
PROCEDURE GetM2OperatorDesc (op: QuadOperator) : String ;
BEGIN
CASE op OF
NegateOp : RETURN InitString ('-') |
AddOp : RETURN InitString ('+') |
SubOp : RETURN InitString ('-') |
MultOp : RETURN InitString ('*') |
DivM2Op,
DivCeilOp,
DivFloorOp,
DivTruncOp : RETURN InitString ('{%kDIV}') |
ModM2Op,
ModCeilOp,
ModFloorOp : RETURN InitString ('{%kMOD}') |
ModTruncOp : RETURN InitString ('{%kREM}') |
LogicalOrOp : RETURN InitString ('{%kOR}') |
LogicalAndOp: RETURN InitString ('{%kAND}') |
InclOp : RETURN InitString ('{%kINCL}') |
ExclOp : RETURN InitString ('{%kEXCL}')
ELSE
RETURN NIL
END
END GetM2OperatorDesc ;
(* (*
PushExit - pushes the exit value onto the EXIT stack. PushExit - pushes the exit value onto the EXIT stack.
*) *)

View File

@ -186,6 +186,15 @@ BEGIN
nb := AddToRange (nb, TRUE, i) ; nb := AddToRange (nb, TRUE, i) ;
SetScope (nb, op3, definitionscope) SetScope (nb, op3, definitionscope)
ELSIF op=StartModFileOp ELSIF op=StartModFileOp
THEN
nb := AddToRange (nb, TRUE, i) ;
IF IsDefImp (op3)
THEN
SetScope (nb, op3, implementationscope)
ELSE
SetScope (nb, op3, programscope)
END
ELSIF op=InitStartOp
THEN THEN
nb := AddToRange (nb, TRUE, i) ; nb := AddToRange (nb, TRUE, i) ;
IF IsDefImp (op3) IF IsDefImp (op3)

View File

@ -227,7 +227,7 @@ PROCEDURE BuildAsm (location: location_t; instr: Tree;
BuildUnaryForeachWordDo - provides the large set operators. BuildUnaryForeachWordDo - provides the large set operators.
Each word (or less) of the set can be Each word (or less) of the set can be
calculated by unop. calculated by unop.
This procedure runs along each word This procedure iterates over each word
of the large set invoking the unop. of the large set invoking the unop.
*) *)