7192 lines
221 KiB
Modula-2
7192 lines
221 KiB
Modula-2
(* M2GenGCC.mod convert the quadruples into GCC trees.
|
|
|
|
Copyright (C) 2001-2022 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 M2GenGCC ;
|
|
|
|
FROM SYSTEM IMPORT ADDRESS, WORD ;
|
|
|
|
FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue,
|
|
PushVarSize,
|
|
PushSumOfLocalVarSize,
|
|
PushSumOfParamSize,
|
|
MakeConstLit, MakeConstLitString,
|
|
RequestSym, FromModuleGetSym,
|
|
StartScope, EndScope, GetScope,
|
|
GetMainModule, GetModuleScope,
|
|
GetSymName, ModeOfAddr, GetMode,
|
|
GetGnuAsm, IsGnuAsmVolatile, IsGnuAsmSimple,
|
|
GetGnuAsmInput, GetGnuAsmOutput, GetGnuAsmTrash,
|
|
GetLowestType,
|
|
GetLocalSym, GetVarWritten,
|
|
GetVarient, GetVarBackEndType, GetModuleCtors,
|
|
NoOfVariables,
|
|
NoOfParam, GetParent, GetDimension, IsAModula2Type,
|
|
IsModule, IsDefImp, IsType, IsModuleWithinProcedure,
|
|
IsConstString, GetString, GetStringLength,
|
|
IsConst, IsConstSet, IsProcedure, IsProcType,
|
|
IsVar, IsVarParam, IsTemporary,
|
|
IsEnumeration,
|
|
IsUnbounded, IsArray, IsSet, IsConstructor,
|
|
IsProcedureVariable,
|
|
IsUnboundedParam,
|
|
IsRecordField, IsFieldVarient, IsVarient, IsRecord,
|
|
IsExportQualified,
|
|
IsExported,
|
|
IsSubrange, IsPointer,
|
|
IsProcedureBuiltin, IsProcedureInline,
|
|
IsParameter, IsParameterVar,
|
|
IsValueSolved, IsSizeSolved,
|
|
IsProcedureNested, IsInnerModule, IsArrayLarge,
|
|
IsComposite, IsVariableSSA, IsPublic, IsCtor,
|
|
ForeachExportedDo,
|
|
ForeachImportedDo,
|
|
ForeachProcedureDo,
|
|
ForeachInnerModuleDo,
|
|
ForeachLocalSymDo,
|
|
GetLType,
|
|
GetType, GetNth, GetNthParam,
|
|
SkipType, SkipTypeAndSubrange,
|
|
GetUnboundedHighOffset,
|
|
GetUnboundedAddressOffset,
|
|
GetSubrange, NoOfElements, GetArraySubscript,
|
|
GetFirstUsed, GetDeclaredMod,
|
|
GetProcedureBeginEnd,
|
|
GetRegInterface,
|
|
GetProcedureQuads,
|
|
GetProcedureBuiltin,
|
|
GetPriority, GetNeedSavePriority,
|
|
PutConstString,
|
|
PutConst, PutConstSet, PutConstructor,
|
|
GetSType,
|
|
HasVarParameters,
|
|
NulSym ;
|
|
|
|
FROM M2Batch IMPORT MakeDefinitionSource ;
|
|
FROM M2LexBuf IMPORT FindFileNameFromToken, TokenToLineNo, TokenToLocation, MakeVirtualTok ;
|
|
FROM M2Code IMPORT CodeBlock ;
|
|
FROM M2Debug IMPORT Assert ;
|
|
FROM M2Error IMPORT InternalError, WriteFormat0, WriteFormat1, WriteFormat2, WarnStringAt ;
|
|
|
|
FROM M2MetaError IMPORT MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3,
|
|
MetaError1, MetaError2, MetaErrorStringT1 ;
|
|
|
|
FROM M2Options IMPORT DisplayQuadruples, UnboundedByReference, PedanticCast,
|
|
VerboseUnbounded, Iso, Pim, DebugBuiltins, WholeProgram,
|
|
StrictTypeChecking, AutoInit, cflag, ScaffoldMain,
|
|
ScaffoldDynamic, ScaffoldStatic, GetRuntimeModuleOverride,
|
|
DebugTraceQuad, DebugTraceAPI ;
|
|
|
|
FROM M2Printf IMPORT printf0, printf1, printf2, printf4 ;
|
|
FROM M2Quiet IMPORT qprintf0 ;
|
|
|
|
FROM M2Base IMPORT MixTypes, NegateType, ActivationPointer, IsMathType,
|
|
IsRealType, IsComplexType, IsBaseType,
|
|
IsOrdinalType,
|
|
Cardinal, Char, Integer, IsTrunc,
|
|
Boolean, True,
|
|
Im, Re, Cmplx, GetCmplxReturnType, GetBaseTypeMinMax,
|
|
CheckAssignmentCompatible, IsAssignmentCompatible ;
|
|
|
|
FROM M2Bitset IMPORT Bitset ;
|
|
FROM NameKey IMPORT Name, MakeKey, KeyToCharStar, LengthKey, makekey, NulName ;
|
|
|
|
FROM DynamicStrings IMPORT string, InitString, KillString, String,
|
|
InitStringCharStar, Mark, Slice, ConCat, ConCatChar ;
|
|
|
|
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 M2FileName IMPORT CalculateFileName ;
|
|
FROM M2AsmUtil IMPORT GetModuleInitName, GetModuleFinallyName ;
|
|
FROM SymbolConversion IMPORT AddModGcc, Mod2Gcc, GccKnowsAbout, RemoveMod2Gcc ;
|
|
|
|
FROM M2StackWord IMPORT InitStackWord, StackOfWord, PeepWord, ReduceWord,
|
|
PushWord, PopWord, IsEmptyWord ;
|
|
|
|
FROM Lists IMPORT List, InitList, KillList,
|
|
PutItemIntoList,
|
|
RemoveItemFromList, IncludeItemIntoList,
|
|
NoOfItemsInList, GetItemFromList ;
|
|
|
|
FROM M2ALU IMPORT PtrToValue,
|
|
IsValueTypeReal, IsValueTypeSet,
|
|
IsValueTypeConstructor, IsValueTypeArray,
|
|
IsValueTypeRecord, IsValueTypeComplex,
|
|
PushIntegerTree, PopIntegerTree,
|
|
PushSetTree, PopSetTree,
|
|
PopRealTree, PushCard,
|
|
PushRealTree,
|
|
PopComplexTree,
|
|
Gre, Sub, Equ, NotEqu, LessEqu,
|
|
BuildRange, SetOr, SetAnd, SetNegate,
|
|
SetSymmetricDifference, SetDifference,
|
|
SetShift, SetRotate,
|
|
AddBit, SubBit, Less, Addn, GreEqu, SetIn,
|
|
CheckOrResetOverflow, GetRange, GetValue,
|
|
ConvertToType ;
|
|
|
|
FROM M2GCCDeclare IMPORT WalkAction,
|
|
DeclareConstant, TryDeclareConstant,
|
|
DeclareConstructor, TryDeclareConstructor,
|
|
StartDeclareScope, EndDeclareScope,
|
|
PromoteToString, DeclareLocalVariable,
|
|
CompletelyResolved,
|
|
PoisonSymbols, GetTypeMin, GetTypeMax,
|
|
IsProcedureGccNested, DeclareParameters,
|
|
ConstantKnownAndUsed, PrintSym ;
|
|
|
|
FROM M2Range IMPORT CodeRangeCheck, FoldRangeCheck, CodeErrorCheck, GetMinMax ;
|
|
|
|
FROM m2builtins IMPORT BuiltInMemCopy, BuiltInAlloca,
|
|
GetBuiltinConst, GetBuiltinTypeInfo,
|
|
BuiltinExists, BuildBuiltinTree ;
|
|
|
|
FROM m2expr IMPORT GetIntegerZero, GetIntegerOne,
|
|
GetCardinalOne,
|
|
GetPointerZero,
|
|
GetCardinalZero,
|
|
GetSizeOfInBits,
|
|
FoldAndStrip,
|
|
CompareTrees,
|
|
StringLength,
|
|
AreConstantsEqual,
|
|
BuildForeachWordInSetDoIfExpr,
|
|
BuildIfConstInVar,
|
|
BuildIfVarInVar,
|
|
BuildIfNotConstInVar,
|
|
BuildIfNotVarInVar,
|
|
BuildBinCheckProcedure, BuildUnaryCheckProcedure,
|
|
BuildBinProcedure, BuildUnaryProcedure,
|
|
BuildSetProcedure, BuildUnarySetFunction,
|
|
BuildAddCheck, BuildSubCheck, BuildMultCheck, BuildDivTruncCheck,
|
|
BuildDivM2Check, BuildModM2Check,
|
|
BuildAdd, BuildSub, BuildMult, BuildLSL,
|
|
BuildDivCeil, BuildModCeil,
|
|
BuildDivTrunc, BuildModTrunc, BuildDivFloor, BuildModFloor,
|
|
BuildDivM2, BuildModM2,
|
|
BuildRDiv,
|
|
BuildLogicalOrAddress,
|
|
BuildLogicalOr, BuildLogicalAnd, BuildSymmetricDifference,
|
|
BuildLogicalDifference,
|
|
BuildLogicalShift, BuildLogicalRotate,
|
|
BuildNegate, BuildNegateCheck, BuildAddr, BuildSize, BuildTBitSize,
|
|
BuildOffset, BuildOffset1,
|
|
BuildLessThan, BuildGreaterThan,
|
|
BuildLessThanOrEqual, BuildGreaterThanOrEqual,
|
|
BuildEqualTo, BuildNotEqualTo,
|
|
BuildIsSuperset, BuildIsNotSuperset,
|
|
BuildIsSubset, BuildIsNotSubset,
|
|
BuildIndirect, BuildArray,
|
|
BuildTrunc, BuildCoerce,
|
|
BuildBinaryForeachWordDo,
|
|
BuildBinarySetDo,
|
|
BuildSetNegate,
|
|
BuildComponentRef,
|
|
BuildCap, BuildAbs, BuildIm, BuildRe, BuildCmplx,
|
|
BuildAddAddress,
|
|
BuildIfInRangeGoto, BuildIfNotInRangeGoto ;
|
|
|
|
FROM m2tree IMPORT Tree, debug_tree ;
|
|
FROM m2linemap IMPORT location_t ;
|
|
|
|
FROM m2decl IMPORT BuildStringConstant, DeclareKnownConstant, GetBitsPerBitset,
|
|
BuildIntegerConstant, DeclareM2linkGlobals,
|
|
BuildModuleCtor, DeclareModuleCtor ;
|
|
|
|
FROM m2statement IMPORT BuildAsm, BuildProcedureCallTree, BuildParam, BuildFunctValue,
|
|
DoJump, BuildUnaryForeachWordDo, BuildGoto, BuildCall2, BuildCall3,
|
|
BuildStart, BuildEnd, BuildCallInner, BuildStartFunctionCode,
|
|
BuildEndFunctionCode,
|
|
BuildAssignmentTree, DeclareLabel,
|
|
BuildFunctionCallTree,
|
|
BuildAssignmentStatement,
|
|
BuildIndirectProcedureCallTree,
|
|
BuildPushFunctionContext, BuildPopFunctionContext,
|
|
BuildReturnValueCode, SetLastFunction,
|
|
BuildIncludeVarConst, BuildIncludeVarVar,
|
|
BuildExcludeVarConst, BuildExcludeVarVar,
|
|
GetParamTree, BuildCleanUp,
|
|
BuildTryFinally,
|
|
GetLastFunction, SetLastFunction,
|
|
SetBeginLocation, SetEndLocation ;
|
|
|
|
FROM m2type IMPORT ChainOnParamValue, GetPointerType, GetIntegerType, AddStatement,
|
|
GetCardinalType, GetWordType, GetM2ZType, GetM2RType, GetM2CType,
|
|
BuildCharConstant, AddStringToTreeList, BuildArrayStringConstructor,
|
|
GetArrayNoOfElements ;
|
|
|
|
FROM m2block IMPORT RememberConstant, pushGlobalScope, popGlobalScope, finishFunctionDecl,
|
|
pushFunctionScope, popFunctionScope,
|
|
push_statement_list, pop_statement_list, begin_statement_list,
|
|
addStmtNote, removeStmtNote ;
|
|
|
|
FROM m2misc IMPORT DebugTree ;
|
|
|
|
FROM m2convert IMPORT BuildConvert, ConvertConstantAndCheck, ToCardinal, ConvertString ;
|
|
|
|
FROM m2except IMPORT BuildThrow, BuildTryBegin, BuildTryEnd,
|
|
BuildCatchBegin, BuildCatchEnd ;
|
|
|
|
FROM M2Quads IMPORT QuadOperator, GetQuad, IsReferenced, GetNextQuad,
|
|
SubQuad, PutQuad, MustCheckOverflow, GetQuadOtok,
|
|
QuadToTokenNo, DisplayQuad, GetQuadtok,
|
|
GetM2OperatorDesc, GetQuadOp,
|
|
DisplayQuadList ;
|
|
|
|
FROM M2Check IMPORT ParameterTypeCompatible, AssignmentTypeCompatible ;
|
|
FROM M2SSA IMPORT EnableSSA ;
|
|
|
|
|
|
CONST
|
|
Debugging = FALSE ;
|
|
PriorityDebugging = FALSE ;
|
|
CascadedDebugging = FALSE ;
|
|
|
|
TYPE
|
|
DoProcedure = PROCEDURE (CARDINAL) ;
|
|
DoUnaryProcedure = PROCEDURE (CARDINAL) ;
|
|
|
|
VAR
|
|
CurrentQuadToken : CARDINAL ;
|
|
UnboundedLabelNo : CARDINAL ;
|
|
LastLine : CARDINAL ;(* The Last Line number emitted with the *)
|
|
(* generated code. *)
|
|
LastOperator : QuadOperator ; (* The last operator processed. *)
|
|
ScopeStack : StackOfWord ; (* keeps track of the current scope *)
|
|
(* under translation. *)
|
|
NoChange : BOOLEAN ; (* has any constant been resolved? *)
|
|
|
|
|
|
(*
|
|
Rules for Quadruples
|
|
====================
|
|
|
|
Rules
|
|
=====
|
|
|
|
All program declared variables are given the mode, Offset.
|
|
All constants have mode, Immediate.
|
|
|
|
Operators
|
|
=========
|
|
|
|
------------------------------------------------------------------------------
|
|
Array Operators
|
|
------------------------------------------------------------------------------
|
|
Sym<I> Base a Delivers a constant result if a is a
|
|
Global variable. If a is a local variable
|
|
then the Frame pointer needs to be added.
|
|
Base yields the effective location in memory
|
|
of, a, array [0,0, .. ,0] address.
|
|
Sym<I> ElementSize 1 Always delivers a constant. The number
|
|
indicates which specified element is chosen.
|
|
ElementSize is the TypeSize for that element.
|
|
Unbounded Op1 Op3 Initializes the op1 StartAddress of the array
|
|
op3. Op3 can be a normal array or unbounded array.
|
|
op1 (is the Unbounded.ArrayAddress) := ADR(op3).
|
|
In GNU Modula-2 the callee saves non var unbounded
|
|
arrays. This is direct contrast to the M2F native
|
|
code generators.
|
|
------------------------------------------------------------------------------
|
|
:= Operator
|
|
------------------------------------------------------------------------------
|
|
Sym1<I> := Sym3<I> := produces a constant
|
|
Sym1<O> := Sym3<O> := has the effect Mem[Sym1<I>] := Mem[Sym3<I>]
|
|
------------------------------------------------------------------------------
|
|
Addr Operator - contains the address of a variable - may need to add
|
|
------------------------------------------------------------------------------
|
|
Yields the address of a variable - need to add the frame pointer if
|
|
a variable is local to a procedure.
|
|
|
|
Sym1<O> Addr Sym2<O> meaning Mem[Sym1<I>] := Sym2<I>
|
|
Sym1<V> Addr Sym2<O> meaning Mem[Sym1<I>] := Sym2<I>
|
|
Sym1<O> Addr Sym2<V> meaning Mem[Sym1<I>] := Mem[Sym2<I>]
|
|
Sym1<V> Addr Sym2<V> meaning Mem[Sym1<I>] := Mem[Sym2<I>]
|
|
------------------------------------------------------------------------------
|
|
Xindr Operator ( *a = b)
|
|
------------------------------------------------------------------------------
|
|
Sym1<O> Copy Sym2<I> Meaning Mem[Sym1<I>] := constant
|
|
Sym1<V> Copy Sym2<I> Meaning Mem[Sym1<I>] := constant
|
|
Sym1<O> Copy Sym2<O> meaning Mem[Sym1<I>] := Mem[Sym2<I>]
|
|
Sym1<V> Copy Sym2<O> meaning Mem[Sym1<I>] := Mem[Sym2<I>]
|
|
Sym1<O> Copy Sym2<V> meaning Mem[Sym1<I>] := Mem[Mem[Sym2<I>]]
|
|
Sym1<V> Copy Sym2<V> meaning Mem[Sym1<I>] := Mem[Mem[Sym2<I>]]
|
|
------------------------------------------------------------------------------
|
|
IndrX Operator (a = *b) where <X> means any value
|
|
------------------------------------------------------------------------------
|
|
Sym1<X> IndrX Sym2<I> meaning Mem[Sym1<I>] := Mem[constant]
|
|
Sym1<X> IndrX Sym2<I> meaning Mem[Sym1<I>] := Mem[constant]
|
|
|
|
Sym1<X> IndrX Sym2<X> meaning Mem[Sym1<I>] := Mem[Mem[Sym2<I>]]
|
|
Sym1<X> IndrX Sym2<X> meaning Mem[Sym1<I>] := Mem[Mem[Sym2<I>]]
|
|
------------------------------------------------------------------------------
|
|
+ - / * Operators
|
|
------------------------------------------------------------------------------
|
|
Sym1<I> + Sym2<I> Sym3<I> meaning Sym1<I> := Sym2<I> + Sym3<I>
|
|
Sym1<O> + Sym2<O> Sym3<I> meaning Mem[Sym1<I>] :=
|
|
Mem[Sym2<I>] + Sym3<I>
|
|
Sym1<O> + Sym2<O> Sym3<O> meaning Mem[Sym1<I>] :=
|
|
Mem[Sym2<I>] + Mem[Sym3<I>]
|
|
Sym1<O> + Sym2<O> Sym3<V> meaning Mem[Sym1<I>] :=
|
|
Mem[Sym2<I>] + Mem[Sym3<I>]
|
|
Sym1<V> + Sym2<O> Sym3<V> meaning Mem[Sym1<I>] :=
|
|
Mem[Sym2<I>] + Mem[Sym3<I>]
|
|
Sym1<V> + Sym2<V> Sym3<V> meaning Mem[Sym1<I>] :=
|
|
Mem[Sym2<I>] + Mem[Sym3<I>]
|
|
------------------------------------------------------------------------------
|
|
Base Operator
|
|
------------------------------------------------------------------------------
|
|
Sym1<O> Base Sym2 Sym3<O> meaning Mem[Sym1<I>] := Sym3<I>
|
|
Sym1<V> Base Sym2 Sym3<O> meaning Should Never Occur But If it did..
|
|
Mem[Mem[Sym1<I>]] := Sym3<I>
|
|
Sym1<O> Base Sym2 Sym3<V> meaning Mem[Sym1<I>] := Mem[Sym3<I>]
|
|
Sym1<V> Base Sym2 Sym3<V> meaning Should Never Occur But If it did..
|
|
Mem[Mem[Sym1<I>]] := Mem[Sym3<I>]
|
|
Sym2 is the array type
|
|
------------------------------------------------------------------------------
|
|
*)
|
|
|
|
|
|
(*
|
|
IsExportedGcc - returns TRUE if this symbol should be (as far as the middle/backend of GCC)
|
|
is concerned, exported.
|
|
*)
|
|
|
|
PROCEDURE IsExportedGcc (sym: CARDINAL) : BOOLEAN ;
|
|
VAR
|
|
scope: CARDINAL ;
|
|
BEGIN
|
|
(* Has a procedure been overridden as public? *)
|
|
IF IsProcedure (sym) AND IsPublic (sym)
|
|
THEN
|
|
RETURN TRUE
|
|
END ;
|
|
(* Check for whole program. *)
|
|
IF WholeProgram
|
|
THEN
|
|
scope := GetScope (sym) ;
|
|
WHILE scope#NulSym DO
|
|
IF IsDefImp (scope)
|
|
THEN
|
|
RETURN IsExported (scope, sym)
|
|
ELSIF IsModule (scope)
|
|
THEN
|
|
RETURN FALSE
|
|
END ;
|
|
scope := GetScope(scope)
|
|
END ;
|
|
Assert (FALSE)
|
|
ELSE
|
|
(* Otherwise it is public if it were exported. *)
|
|
RETURN IsExported (GetMainModule (), sym)
|
|
END
|
|
END IsExportedGcc ;
|
|
|
|
|
|
(*
|
|
ConvertQuadsToTree - runs through the quadruple list and converts it into
|
|
the GCC tree structure.
|
|
*)
|
|
|
|
PROCEDURE ConvertQuadsToTree (Start, End: CARDINAL) ;
|
|
BEGIN
|
|
REPEAT
|
|
CodeStatement (Start) ;
|
|
Start := GetNextQuad (Start)
|
|
UNTIL (Start > End) OR (Start = 0) ;
|
|
END ConvertQuadsToTree ;
|
|
|
|
|
|
(*
|
|
IsCompilingMainModule -
|
|
*)
|
|
|
|
PROCEDURE IsCompilingMainModule (sym: CARDINAL) : BOOLEAN ;
|
|
BEGIN
|
|
WHILE (sym # NulSym) AND (GetMainModule () # sym) DO
|
|
sym := GetModuleScope (sym)
|
|
END ;
|
|
RETURN sym # NulSym
|
|
END IsCompilingMainModule ;
|
|
|
|
|
|
(*
|
|
CodeStatement - A multi-way decision call depending on the current
|
|
quadruple.
|
|
*)
|
|
|
|
PROCEDURE CodeStatement (q: CARDINAL) ;
|
|
VAR
|
|
op : QuadOperator ;
|
|
op1, op2, op3: CARDINAL ;
|
|
location : location_t ;
|
|
BEGIN
|
|
GetQuad(q, op, op1, op2, op3) ;
|
|
IF op=StatementNoteOp
|
|
THEN
|
|
FoldStatementNote (op3) (* will change CurrentQuadToken using op3 *)
|
|
ELSE
|
|
CurrentQuadToken := QuadToTokenNo (q)
|
|
END ;
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
CheckReferenced(q, op) ;
|
|
IF DebugTraceQuad
|
|
THEN
|
|
printf0('building: ') ;
|
|
DisplayQuad(q)
|
|
END ;
|
|
|
|
CASE op OF
|
|
|
|
StartDefFileOp : CodeStartDefFile (op3) |
|
|
StartModFileOp : CodeStartModFile (op3) |
|
|
ModuleScopeOp : CodeModuleScope (op3) |
|
|
EndFileOp : CodeEndFile |
|
|
InitStartOp : CodeInitStart (op2, op3, IsCompilingMainModule (op3)) |
|
|
InitEndOp : CodeInitEnd (op3, IsCompilingMainModule (op3)) |
|
|
FinallyStartOp : CodeFinallyStart (op2, op3, IsCompilingMainModule (op3)) |
|
|
FinallyEndOp : CodeFinallyEnd (op3, IsCompilingMainModule (op3)) |
|
|
NewLocalVarOp : CodeNewLocalVar (op1, op3) |
|
|
KillLocalVarOp : CodeKillLocalVar (op3) |
|
|
ProcedureScopeOp : CodeProcedureScope (op3) |
|
|
ReturnOp : (* Not used as return is achieved by KillLocalVar. *) |
|
|
ReturnValueOp : CodeReturnValue (op1, op3) |
|
|
TryOp : CodeTry |
|
|
ThrowOp : CodeThrow (op3) |
|
|
CatchBeginOp : CodeCatchBegin |
|
|
CatchEndOp : CodeCatchEnd |
|
|
RetryOp : CodeRetry (op3) |
|
|
DummyOp : |
|
|
InitAddressOp : CodeInitAddress(q, op1, op2, op3) |
|
|
BecomesOp : CodeBecomes(q) |
|
|
AddOp : CodeAddChecked (q, op2, op3) |
|
|
SubOp : CodeSubChecked (q, op2, op3) |
|
|
MultOp : CodeMultChecked (q, op2, op3) |
|
|
DivM2Op : CodeDivM2Checked (q, op2, op3) |
|
|
ModM2Op : CodeModM2Checked (q, op2, op3) |
|
|
DivTruncOp : CodeDivTrunc (q, op2, op3) |
|
|
ModTruncOp : CodeModTrunc (q, op2, op3) |
|
|
DivCeilOp : CodeDivCeil (q, op2, op3) |
|
|
ModCeilOp : CodeModCeil (q, op2, op3) |
|
|
DivFloorOp : CodeDivFloor (q, op2, op3) |
|
|
ModFloorOp : CodeModFloor (q, op2, op3) |
|
|
GotoOp : CodeGoto (op3) |
|
|
InclOp : CodeIncl (op1, op3) |
|
|
ExclOp : CodeExcl (op1, op3) |
|
|
NegateOp : CodeNegateChecked (q, op1, op3) |
|
|
LogicalShiftOp : CodeSetShift (q, op1, op2, op3) |
|
|
LogicalRotateOp : CodeSetRotate (q, op1, op2, op3) |
|
|
LogicalOrOp : CodeSetOr (q, op1, op2, op3) |
|
|
LogicalAndOp : CodeSetAnd (q, op1, op2, op3) |
|
|
LogicalXorOp : CodeSetSymmetricDifference (q, op1, op2, op3) |
|
|
LogicalDiffOp : CodeSetLogicalDifference (q, op1, op2, op3) |
|
|
IfLessOp : CodeIfLess (q, op1, op2, op3) |
|
|
IfEquOp : CodeIfEqu (q, op1, op2, op3) |
|
|
IfNotEquOp : CodeIfNotEqu (q, op1, op2, op3) |
|
|
IfGreEquOp : CodeIfGreEqu (q, op1, op2, op3) |
|
|
IfLessEquOp : CodeIfLessEqu (q, op1, op2, op3) |
|
|
IfGreOp : CodeIfGre (q, op1, op2, op3) |
|
|
IfInOp : CodeIfIn (q, op1, op2, op3) |
|
|
IfNotInOp : CodeIfNotIn (q, op1, op2, op3) |
|
|
IndrXOp : CodeIndrX (q, op1, op2, op3) |
|
|
XIndrOp : CodeXIndr (q, op1, op2, op3) |
|
|
CallOp : CodeCall (CurrentQuadToken, op3) |
|
|
ParamOp : CodeParam (q, op1, op2, op3) |
|
|
FunctValueOp : CodeFunctValue (location, op1) |
|
|
AddrOp : CodeAddr (q, op1, op3) |
|
|
SizeOp : CodeSize (op1, op3) |
|
|
UnboundedOp : CodeUnbounded (op1, op3) |
|
|
RecordFieldOp : CodeRecordField (op1, op2, op3) |
|
|
HighOp : CodeHigh (op1, op2, op3) |
|
|
ArrayOp : CodeArray (op1, op2, op3) |
|
|
ElementSizeOp : InternalError ('ElementSizeOp is expected to have been folded via constant evaluation') |
|
|
ConvertOp : CodeConvert (q, op1, op2, op3) |
|
|
CoerceOp : CodeCoerce (q, op1, op2, op3) |
|
|
CastOp : CodeCast (q, op1, op2, op3) |
|
|
StandardFunctionOp : CodeStandardFunction (q, op1, op2, op3) |
|
|
SavePriorityOp : CodeSavePriority (op1, op2, op3) |
|
|
RestorePriorityOp : CodeRestorePriority (op1, op2, op3) |
|
|
|
|
InlineOp : CodeInline (location, CurrentQuadToken, op3) |
|
|
StatementNoteOp : CodeStatementNote (op3) |
|
|
CodeOnOp : | (* the following make no sense with gcc *)
|
|
CodeOffOp : |
|
|
ProfileOnOp : |
|
|
ProfileOffOp : |
|
|
OptimizeOnOp : |
|
|
OptimizeOffOp : |
|
|
RangeCheckOp : CodeRange (op3) |
|
|
ErrorOp : CodeError (op3) |
|
|
SaveExceptionOp : CodeSaveException (op1, op3) |
|
|
RestoreExceptionOp : CodeRestoreException (op1, op3)
|
|
|
|
ELSE
|
|
WriteFormat1 ('quadruple %d not yet implemented', q) ;
|
|
InternalError ('quadruple not implemented yet')
|
|
END ;
|
|
LastOperator := op
|
|
END CodeStatement ;
|
|
|
|
|
|
(*
|
|
ResolveConstantExpressions - resolves constant expressions from the quadruple list.
|
|
It returns TRUE if one or more constants were folded.
|
|
When a constant symbol value is solved, the call back
|
|
p(sym) is invoked.
|
|
*)
|
|
|
|
PROCEDURE ResolveConstantExpressions (p: WalkAction; start, end: CARDINAL) : BOOLEAN ;
|
|
VAR
|
|
tokenno: CARDINAL ;
|
|
quad : CARDINAL ;
|
|
op : QuadOperator ;
|
|
op1,
|
|
op2,
|
|
op3,
|
|
op1pos,
|
|
op2pos,
|
|
op3pos : CARDINAL ;
|
|
Changed: BOOLEAN ;
|
|
BEGIN
|
|
Changed := FALSE ;
|
|
REPEAT
|
|
NoChange := TRUE ;
|
|
quad := start ;
|
|
WHILE (quad<=end) AND (quad#0) DO
|
|
tokenno := CurrentQuadToken ;
|
|
IF tokenno=0
|
|
THEN
|
|
tokenno := QuadToTokenNo (quad)
|
|
END ;
|
|
GetQuadtok (quad, op, op1, op2, op3,
|
|
op1pos, op2pos, op3pos) ;
|
|
CASE op OF
|
|
|
|
StandardFunctionOp : FoldStandardFunction (tokenno, p, quad, op1, op2, op3) |
|
|
BuiltinConstOp : FoldBuiltinConst (tokenno, p, quad, op1, op3) |
|
|
BuiltinTypeInfoOp : FoldBuiltinTypeInfo (tokenno, p, quad, op1, op2, op3) |
|
|
LogicalOrOp : FoldSetOr (tokenno, p, quad, op1, op2, op3) |
|
|
LogicalAndOp : FoldSetAnd (tokenno, p, quad, op1, op2, op3) |
|
|
LogicalXorOp : FoldSymmetricDifference (tokenno, p, quad, op1, op2, op3) |
|
|
BecomesOp : FoldBecomes (tokenno, p, quad, op1, op3) |
|
|
AddOp : FoldAdd (op1pos, p, quad, op1, op2, op3) |
|
|
SubOp : FoldSub (op1pos, p, quad, op1, op2, op3) |
|
|
MultOp : FoldMult (op1pos, p, quad, op1, op2, op3) |
|
|
DivM2Op : FoldDivM2 (op1pos, p, quad, op1, op2, op3) |
|
|
ModM2Op : FoldModM2 (op1pos, p, quad, op1, op2, op3) |
|
|
DivTruncOp : FoldDivTrunc (op1pos, p, quad, op1, op2, op3) |
|
|
ModTruncOp : FoldModTrunc (op1pos, p, quad, op1, op2, op3) |
|
|
DivCeilOp : FoldDivCeil (op1pos, p, quad, op1, op2, op3) |
|
|
ModCeilOp : FoldModCeil (op1pos, p, quad, op1, op2, op3) |
|
|
DivFloorOp : FoldDivFloor (op1pos, p, quad, op1, op2, op3) |
|
|
ModFloorOp : FoldModFloor (op1pos, p, quad, op1, op2, op3) |
|
|
NegateOp : FoldNegate (op1pos, p, quad, op1, op3) |
|
|
SizeOp : FoldSize (tokenno, p, quad, op1, op2, op3) |
|
|
RecordFieldOp : FoldRecordField (tokenno, p, quad, op1, op2, op3) |
|
|
HighOp : FoldHigh (tokenno, p, quad, op1, op2, op3) |
|
|
ElementSizeOp : FoldElementSize (tokenno, p, quad, op1, op2) |
|
|
ConvertOp : FoldConvert (tokenno, p, quad, op1, op2, op3) |
|
|
CoerceOp : FoldCoerce (tokenno, p, quad, op1, op2, op3) |
|
|
CastOp : FoldCast (tokenno, p, quad, op1, op2, op3) |
|
|
InclOp : FoldIncl (tokenno, p, quad, op1, op3) |
|
|
ExclOp : FoldExcl (tokenno, p, quad, op1, op3) |
|
|
IfLessOp : FoldIfLess (tokenno, quad, op1, op2, op3) |
|
|
IfInOp : FoldIfIn (tokenno, quad, op1, op2, op3) |
|
|
IfNotInOp : FoldIfNotIn (tokenno, quad, op1, op2, op3) |
|
|
LogicalShiftOp : FoldSetShift(tokenno, p, quad, op1, op2, op3) |
|
|
LogicalRotateOp : FoldSetRotate (tokenno, p, quad, op1, op2, op3) |
|
|
ParamOp : FoldBuiltinFunction (tokenno, p, quad, op1, op2, op3) |
|
|
RangeCheckOp : FoldRange (tokenno, quad, op3) |
|
|
StatementNoteOp : FoldStatementNote (op3)
|
|
|
|
ELSE
|
|
(* ignore quadruple as it is not associated with a constant expression *)
|
|
END ;
|
|
quad := GetNextQuad(quad)
|
|
END ;
|
|
IF NOT NoChange
|
|
THEN
|
|
Changed := TRUE
|
|
END
|
|
UNTIL NoChange ;
|
|
IF Debugging AND DisplayQuadruples AND FALSE
|
|
THEN
|
|
printf0('after resolving expressions with gcc\n') ;
|
|
DisplayQuadList
|
|
END ;
|
|
RETURN Changed
|
|
END ResolveConstantExpressions ;
|
|
|
|
|
|
(*
|
|
FindSize - given a Modula-2 symbol, sym, return the GCC Tree
|
|
(constant) representing the storage size in bytes.
|
|
*)
|
|
|
|
PROCEDURE FindSize (tokenno: CARDINAL; sym: CARDINAL) : Tree ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (tokenno) ;
|
|
IF IsConstString (sym)
|
|
THEN
|
|
PushCard (GetStringLength (sym)) ;
|
|
RETURN PopIntegerTree ()
|
|
ELSIF IsSizeSolved (sym)
|
|
THEN
|
|
PushSize (sym) ;
|
|
RETURN PopIntegerTree ()
|
|
ELSE
|
|
IF GccKnowsAbout (sym)
|
|
THEN
|
|
IF IsVar (sym) AND IsVariableSSA (sym)
|
|
THEN
|
|
sym := GetType (sym)
|
|
END ;
|
|
PushIntegerTree (BuildSize (location, Mod2Gcc (sym), FALSE)) ;
|
|
PopSize (sym) ;
|
|
PushSize (sym) ;
|
|
RETURN PopIntegerTree ()
|
|
ELSIF IsVar (sym) AND GccKnowsAbout (GetType (sym))
|
|
THEN
|
|
PushIntegerTree (BuildSize (location, Mod2Gcc (GetType (sym)), FALSE)) ;
|
|
RETURN PopIntegerTree ()
|
|
ELSE
|
|
InternalError ('expecting gcc to already know about this symbol')
|
|
END
|
|
END
|
|
END FindSize ;
|
|
|
|
|
|
(*
|
|
FindType - returns the type of, Sym, if Sym is a TYPE then return Sym otherwise return GetType(Sym)
|
|
*)
|
|
|
|
PROCEDURE FindType (Sym: CARDINAL) : CARDINAL ;
|
|
BEGIN
|
|
IF IsType (Sym)
|
|
THEN
|
|
RETURN Sym
|
|
ELSE
|
|
RETURN GetType (Sym)
|
|
END
|
|
END FindType ;
|
|
|
|
|
|
(*
|
|
BuildTreeFromInterface - generates a GCC tree from an interface definition.
|
|
*)
|
|
|
|
PROCEDURE BuildTreeFromInterface (tokenno: CARDINAL; sym: CARDINAL) : Tree ;
|
|
VAR
|
|
i : CARDINAL ;
|
|
name : Name ;
|
|
str,
|
|
obj : CARDINAL ;
|
|
gccName,
|
|
tree : Tree ;
|
|
location: location_t;
|
|
BEGIN
|
|
tree := Tree (NIL) ;
|
|
IF sym#NulSym
|
|
THEN
|
|
location := TokenToLocation (tokenno) ;
|
|
i := 1 ;
|
|
REPEAT
|
|
GetRegInterface (sym, i, name, str, obj) ;
|
|
IF str#NulSym
|
|
THEN
|
|
IF IsConstString (str)
|
|
THEN
|
|
DeclareConstant (tokenno, obj) ;
|
|
IF name = NulName
|
|
THEN
|
|
gccName := NIL
|
|
ELSE
|
|
gccName := BuildStringConstant (location, KeyToCharStar (name), LengthKey (name))
|
|
END ;
|
|
tree := ChainOnParamValue (tree, gccName, PromoteToString (tokenno, str), Mod2Gcc (obj))
|
|
ELSE
|
|
WriteFormat0 ('a constraint to the GNU ASM statement must be a constant string')
|
|
END
|
|
END ;
|
|
INC(i)
|
|
UNTIL (str = NulSym) AND (obj = NulSym) ;
|
|
END ;
|
|
RETURN tree
|
|
END BuildTreeFromInterface ;
|
|
|
|
|
|
(*
|
|
BuildTrashTreeFromInterface - generates a GCC string tree from an interface definition.
|
|
*)
|
|
|
|
PROCEDURE BuildTrashTreeFromInterface (sym: CARDINAL) : Tree ;
|
|
VAR
|
|
i : CARDINAL ;
|
|
str,
|
|
obj : CARDINAL ;
|
|
name: Name ;
|
|
tree: Tree ;
|
|
BEGIN
|
|
tree := Tree(NIL) ;
|
|
IF sym#NulSym
|
|
THEN
|
|
i := 1 ;
|
|
REPEAT
|
|
GetRegInterface(sym, i, name, str, obj) ;
|
|
IF str#NulSym
|
|
THEN
|
|
IF IsConstString(str)
|
|
THEN
|
|
tree := AddStringToTreeList(tree, PromoteToString(GetDeclaredMod(str), str))
|
|
ELSE
|
|
WriteFormat0('a constraint to the GNU ASM statement must be a constant string')
|
|
END
|
|
END ;
|
|
(*
|
|
IF obj#NulSym
|
|
THEN
|
|
InternalError ('not expecting the object to be non null in the trash list')
|
|
END ;
|
|
*)
|
|
INC(i)
|
|
UNTIL (str=NulSym) AND (obj=NulSym)
|
|
END ;
|
|
RETURN( tree )
|
|
END BuildTrashTreeFromInterface ;
|
|
|
|
|
|
(*
|
|
CodeInline - InlineOp is a quadruple which has the following format:
|
|
|
|
InlineOp NulSym NulSym Sym
|
|
|
|
The inline asm statement, Sym, is written to standard output.
|
|
*)
|
|
|
|
PROCEDURE CodeInline (location: location_t; tokenno: CARDINAL; GnuAsm: CARDINAL) ;
|
|
VAR
|
|
string : CARDINAL ;
|
|
inputs,
|
|
outputs,
|
|
trash,
|
|
labels : Tree ;
|
|
BEGIN
|
|
(*
|
|
no need to explicity flush the outstanding instructions as
|
|
per M2GenDyn486 and M2GenAPU. The GNU ASM statements in GCC
|
|
can handle the register dependency providing the user
|
|
specifies VOLATILE and input/output/trash sets correctly.
|
|
*)
|
|
inputs := BuildTreeFromInterface (tokenno, GetGnuAsmInput(GnuAsm)) ;
|
|
outputs := BuildTreeFromInterface (tokenno, GetGnuAsmOutput(GnuAsm)) ;
|
|
trash := BuildTrashTreeFromInterface (GetGnuAsmTrash(GnuAsm)) ;
|
|
labels := NIL ; (* at present it makes no sence for Modula-2 to jump to a label,
|
|
given that labels are not allowed in Modula-2. *)
|
|
string := GetGnuAsm (GnuAsm) ;
|
|
DeclareConstant (tokenno, string) ;
|
|
BuildAsm (location,
|
|
Mod2Gcc (string), IsGnuAsmVolatile (GnuAsm), IsGnuAsmSimple (GnuAsm),
|
|
inputs, outputs, trash, labels)
|
|
END CodeInline ;
|
|
|
|
|
|
(*
|
|
FoldStatementNote -
|
|
*)
|
|
|
|
PROCEDURE FoldStatementNote (tokenno: CARDINAL) ;
|
|
BEGIN
|
|
CurrentQuadToken := tokenno
|
|
END FoldStatementNote ;
|
|
|
|
|
|
(*
|
|
CodeStatementNote -
|
|
*)
|
|
|
|
PROCEDURE CodeStatementNote (tokenno: CARDINAL) ;
|
|
BEGIN
|
|
CurrentQuadToken := tokenno ;
|
|
addStmtNote (TokenToLocation (tokenno))
|
|
END CodeStatementNote ;
|
|
|
|
|
|
(*
|
|
FoldRange - attempts to fold the range test.
|
|
--fixme-- complete this
|
|
*)
|
|
|
|
PROCEDURE FoldRange (tokenno: CARDINAL; (* p: WalkAction; *)
|
|
quad: CARDINAL; rangeno: CARDINAL) ;
|
|
BEGIN
|
|
FoldRangeCheck (tokenno, quad, rangeno)
|
|
END FoldRange ;
|
|
|
|
|
|
(*
|
|
CodeSaveException - op1 := op3(TRUE)
|
|
*)
|
|
|
|
PROCEDURE CodeSaveException (des, exceptionProcedure: CARDINAL) ;
|
|
VAR
|
|
functValue: Tree ;
|
|
location : location_t;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
BuildParam (location, Mod2Gcc (True)) ;
|
|
BuildFunctionCallTree (location,
|
|
Mod2Gcc (exceptionProcedure),
|
|
Mod2Gcc (GetType (exceptionProcedure))) ;
|
|
functValue := BuildFunctValue (location, Mod2Gcc (des)) ;
|
|
AddStatement (location, functValue)
|
|
END CodeSaveException ;
|
|
|
|
|
|
(*
|
|
CodeRestoreException - op1 := op3(op1)
|
|
*)
|
|
|
|
PROCEDURE CodeRestoreException (des, exceptionProcedure: CARDINAL) ;
|
|
VAR
|
|
functValue: Tree ;
|
|
location : location_t;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
BuildParam (location, Mod2Gcc (des)) ;
|
|
BuildFunctionCallTree (location,
|
|
Mod2Gcc (exceptionProcedure),
|
|
Mod2Gcc (GetType (exceptionProcedure))) ;
|
|
functValue := BuildFunctValue (location, Mod2Gcc (des)) ;
|
|
AddStatement (location, functValue)
|
|
END CodeRestoreException ;
|
|
|
|
|
|
(*
|
|
PushScope -
|
|
*)
|
|
|
|
PROCEDURE PushScope (sym: CARDINAL) ;
|
|
BEGIN
|
|
PushWord (ScopeStack, sym)
|
|
END PushScope ;
|
|
|
|
|
|
(*
|
|
PopScope -
|
|
*)
|
|
|
|
PROCEDURE PopScope ;
|
|
VAR
|
|
sym: CARDINAL ;
|
|
BEGIN
|
|
sym := PopWord (ScopeStack) ;
|
|
Assert (sym # NulSym)
|
|
END PopScope ;
|
|
|
|
|
|
(*
|
|
GetCurrentScopeDescription - returns a description of the current scope.
|
|
*)
|
|
|
|
PROCEDURE GetCurrentScopeDescription () : String ;
|
|
VAR
|
|
sym : CARDINAL ;
|
|
n : String ;
|
|
BEGIN
|
|
IF IsEmptyWord(ScopeStack)
|
|
THEN
|
|
InternalError ('not expecting scope stack to be empty')
|
|
ELSE
|
|
sym := PeepWord(ScopeStack, 1) ;
|
|
n := Mark(InitStringCharStar(KeyToCharStar(GetSymName(sym)))) ;
|
|
IF IsDefImp(sym)
|
|
THEN
|
|
RETURN( Sprintf1(Mark(InitString('implementation module %s')), n) )
|
|
ELSIF IsModule(sym)
|
|
THEN
|
|
IF IsInnerModule(sym)
|
|
THEN
|
|
RETURN( Sprintf1(Mark(InitString('inner module %s')), n) )
|
|
ELSE
|
|
RETURN( Sprintf1(Mark(InitString('program module %s')), n) )
|
|
END
|
|
ELSIF IsProcedure(sym)
|
|
THEN
|
|
IF IsProcedureNested(sym)
|
|
THEN
|
|
RETURN( Sprintf1(Mark(InitString('nested procedure %s')), n) )
|
|
ELSE
|
|
RETURN( Sprintf1(Mark(InitString('procedure %s')), n) )
|
|
END
|
|
ELSE
|
|
InternalError ('unexpected scope symbol')
|
|
END
|
|
END
|
|
END GetCurrentScopeDescription ;
|
|
|
|
|
|
(*
|
|
CodeRange - encode the range test associated with op3.
|
|
*)
|
|
|
|
PROCEDURE CodeRange (rangeId: CARDINAL) ;
|
|
BEGIN
|
|
CodeRangeCheck (rangeId, GetCurrentScopeDescription ())
|
|
END CodeRange ;
|
|
|
|
|
|
(*
|
|
CodeError - encode the error test associated with op3.
|
|
*)
|
|
|
|
PROCEDURE CodeError (errorId: CARDINAL) ;
|
|
BEGIN
|
|
(* would like to test whether this position is in the same basicblock
|
|
as any known entry point. If so we could emit an error message.
|
|
*)
|
|
AddStatement (TokenToLocation (CurrentQuadToken),
|
|
CodeErrorCheck (errorId, GetCurrentScopeDescription (), NIL))
|
|
END CodeError ;
|
|
|
|
|
|
(*
|
|
CodeModuleScope - ModuleScopeOp is a quadruple which has the following
|
|
format:
|
|
|
|
ModuleScopeOp _ _ moduleSym
|
|
|
|
Its purpose is to reset the source file to another
|
|
file, hence all line numbers emitted with the
|
|
generated code will be relative to this source file.
|
|
*)
|
|
|
|
PROCEDURE CodeModuleScope (moduleSym: CARDINAL) ;
|
|
BEGIN
|
|
PushScope (moduleSym)
|
|
END CodeModuleScope ;
|
|
|
|
|
|
(*
|
|
CodeStartModFile - StartModFileOp is a quadruple which has the following
|
|
format:
|
|
|
|
StartModFileOp _ _ moduleSym
|
|
|
|
A new source file has been encountered therefore
|
|
set LastLine to 1.
|
|
Call pushGlobalScope.
|
|
*)
|
|
|
|
PROCEDURE CodeStartModFile (moduleSym: CARDINAL) ;
|
|
BEGIN
|
|
pushGlobalScope ;
|
|
LastLine := 1 ;
|
|
PushScope (moduleSym)
|
|
END CodeStartModFile ;
|
|
|
|
|
|
(*
|
|
CodeStartDefFile - StartDefFileOp is a quadruple with the following
|
|
format:
|
|
|
|
StartDefFileOp _ _ moduleSym
|
|
|
|
A new source file has been encountered therefore
|
|
set LastLine to 1.
|
|
Call pushGlobalScope.
|
|
*)
|
|
|
|
PROCEDURE CodeStartDefFile (moduleSym: CARDINAL) ;
|
|
BEGIN
|
|
pushGlobalScope ;
|
|
PushScope (moduleSym) ;
|
|
LastLine := 1
|
|
END CodeStartDefFile ;
|
|
|
|
|
|
(*
|
|
CodeEndFile - pops the GlobalScope.
|
|
*)
|
|
|
|
PROCEDURE CodeEndFile ;
|
|
BEGIN
|
|
popGlobalScope
|
|
END CodeEndFile ;
|
|
|
|
|
|
(*
|
|
CallInnerInit - produce a call to inner module initialization routine.
|
|
*)
|
|
|
|
PROCEDURE CallInnerInit (moduleSym: WORD) ;
|
|
VAR
|
|
location : location_t;
|
|
ctor, init, fini, dep: CARDINAL ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
|
|
BuildCallInner (location, Mod2Gcc (init))
|
|
END CallInnerInit ;
|
|
|
|
|
|
(*
|
|
CallInnerFinally - produce a call to inner module finalization routine.
|
|
*)
|
|
|
|
PROCEDURE CallInnerFinally (moduleSym: WORD) ;
|
|
VAR
|
|
location : location_t;
|
|
ctor, init, fini, dep: CARDINAL ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
|
|
BuildCallInner (location, Mod2Gcc (fini))
|
|
END CallInnerFinally ;
|
|
|
|
|
|
(*
|
|
CodeInitStart - emits starting code before the main BEGIN END of the
|
|
current module.
|
|
*)
|
|
|
|
PROCEDURE CodeInitStart (currentScope, moduleSym: CARDINAL;
|
|
CompilingMainModule: BOOLEAN) ;
|
|
VAR
|
|
location : location_t;
|
|
ctor, init,
|
|
fini, dep : CARDINAL ;
|
|
BEGIN
|
|
IF CompilingMainModule OR WholeProgram
|
|
THEN
|
|
(* SetFileNameAndLineNo (string (FileName), op1) ; *)
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
|
|
BuildStartFunctionCode (location, Mod2Gcc (init),
|
|
IsExportedGcc (init), FALSE) ;
|
|
ForeachInnerModuleDo (moduleSym, CallInnerInit)
|
|
END
|
|
END CodeInitStart ;
|
|
|
|
|
|
(*
|
|
CodeInitEnd - emits terminating code after the main BEGIN END of the
|
|
current module.
|
|
*)
|
|
|
|
PROCEDURE CodeInitEnd (moduleSym: CARDINAL;
|
|
CompilingMainModule: BOOLEAN) ;
|
|
VAR
|
|
location : location_t;
|
|
ctor, init,
|
|
fini, dep : CARDINAL ;
|
|
BEGIN
|
|
IF CompilingMainModule OR WholeProgram
|
|
THEN
|
|
(*
|
|
SetFileNameAndLineNo(string(FileName), op1) ;
|
|
EmitLineNote(string(FileName), op1) ;
|
|
*)
|
|
|
|
location := TokenToLocation (GetDeclaredMod (moduleSym)) ;
|
|
GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
|
|
finishFunctionDecl (location, Mod2Gcc (init)) ;
|
|
BuildEndFunctionCode (location, Mod2Gcc (init),
|
|
IsModuleWithinProcedure (moduleSym))
|
|
END
|
|
END CodeInitEnd ;
|
|
|
|
|
|
(*
|
|
CodeFinallyStart - emits starting code before the main BEGIN END of the
|
|
current module.
|
|
*)
|
|
|
|
PROCEDURE CodeFinallyStart (outerModule, moduleSym: CARDINAL;
|
|
CompilingMainModule: BOOLEAN) ;
|
|
VAR
|
|
location : location_t;
|
|
ctor, init,
|
|
fini, dep : CARDINAL ;
|
|
BEGIN
|
|
IF CompilingMainModule OR WholeProgram
|
|
THEN
|
|
(* SetFileNameAndLineNo (string (FileName), op1) ; *)
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
|
|
BuildStartFunctionCode (location, Mod2Gcc (fini),
|
|
IsExportedGcc (fini), FALSE) ;
|
|
ForeachInnerModuleDo (moduleSym, CallInnerFinally)
|
|
END
|
|
END CodeFinallyStart ;
|
|
|
|
|
|
(*
|
|
CodeFinallyEnd - emits terminating code after the main BEGIN END of the
|
|
current module. It also creates the scaffold if the
|
|
cflag was not present.
|
|
*)
|
|
|
|
PROCEDURE CodeFinallyEnd (moduleSym: CARDINAL;
|
|
CompilingMainModule: BOOLEAN) ;
|
|
VAR
|
|
location : location_t;
|
|
ctor, init,
|
|
fini, dep : CARDINAL ;
|
|
BEGIN
|
|
IF CompilingMainModule OR WholeProgram
|
|
THEN
|
|
(*
|
|
SetFileNameAndLineNo(string(FileName), op1) ;
|
|
EmitLineNote(string(FileName), op1) ;
|
|
*)
|
|
|
|
location := TokenToLocation (GetDeclaredMod (moduleSym)) ;
|
|
GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
|
|
finishFunctionDecl (location, Mod2Gcc (fini)) ;
|
|
BuildEndFunctionCode (location, Mod2Gcc (fini),
|
|
IsModuleWithinProcedure (moduleSym)) ;
|
|
IF ScaffoldMain OR (NOT cflag)
|
|
THEN
|
|
IF CompilingMainModule AND
|
|
(ScaffoldDynamic OR ScaffoldStatic OR ScaffoldMain) AND
|
|
(moduleSym = GetMainModule ())
|
|
THEN
|
|
qprintf0 (" generating scaffold m2link information\n");
|
|
DeclareM2linkGlobals (location, VAL (INTEGER, ScaffoldStatic), GetRuntimeModuleOverride ())
|
|
END
|
|
END
|
|
END
|
|
END CodeFinallyEnd ;
|
|
|
|
|
|
(*
|
|
GetAddressOfUnbounded - returns the address of the unbounded array contents.
|
|
*)
|
|
|
|
PROCEDURE GetAddressOfUnbounded (location: location_t; param: CARDINAL) : Tree ;
|
|
VAR
|
|
UnboundedType: CARDINAL ;
|
|
BEGIN
|
|
UnboundedType := GetType (param) ;
|
|
Assert (IsUnbounded (UnboundedType)) ;
|
|
|
|
RETURN BuildConvert (TokenToLocation (GetDeclaredMod (param)),
|
|
GetPointerType (),
|
|
BuildComponentRef (location, Mod2Gcc (param), Mod2Gcc (GetUnboundedAddressOffset (UnboundedType))),
|
|
FALSE)
|
|
END GetAddressOfUnbounded ;
|
|
|
|
|
|
(*
|
|
GetHighFromUnbounded - returns a Tree containing the value of
|
|
param.HIGH.
|
|
*)
|
|
|
|
PROCEDURE GetHighFromUnbounded (location: location_t; dim, param: CARDINAL) : Tree ;
|
|
VAR
|
|
UnboundedType,
|
|
ArrayType,
|
|
HighField : CARDINAL ;
|
|
HighTree : Tree ;
|
|
accessibleDim: CARDINAL ;
|
|
(* remainingDim : CARDINAL ; *)
|
|
BEGIN
|
|
UnboundedType := GetType (param) ;
|
|
Assert (IsUnbounded (UnboundedType)) ;
|
|
ArrayType := GetType (UnboundedType) ;
|
|
HighField := GetUnboundedHighOffset (UnboundedType, dim) ;
|
|
IF HighField = NulSym
|
|
THEN
|
|
(* it might be a dynamic array of static arrays,
|
|
so lets see if there is an earlier dimension available. *)
|
|
accessibleDim := dim ;
|
|
WHILE (HighField = NulSym) AND (accessibleDim > 1) DO
|
|
DEC (accessibleDim) ;
|
|
HighField := GetUnboundedHighOffset(UnboundedType, accessibleDim)
|
|
END ;
|
|
IF HighField = NulSym
|
|
THEN
|
|
MetaError1 ('{%EkHIGH} dimension number {%1N} for array does not exist', dim)
|
|
ELSE
|
|
(* remainingDim := dim - accessibleDim ; --fixme-- write tests to stress this code. *)
|
|
HighTree := BuildHighFromStaticArray (location, (* remainingDim, *) ArrayType) ;
|
|
IF HighTree = NIL
|
|
THEN
|
|
MetaError1 ('{%EkHIGH} dimension number {%1N} for array does not exist', dim)
|
|
END ;
|
|
RETURN HighTree
|
|
END
|
|
ELSE
|
|
RETURN BuildComponentRef (location, Mod2Gcc (param), Mod2Gcc (HighField))
|
|
END
|
|
END GetHighFromUnbounded ;
|
|
|
|
|
|
(*
|
|
GetSizeOfHighFromUnbounded - returns a Tree containing the value of
|
|
param.HIGH * sizeof(unboundedType).
|
|
The number of legal bytes this array
|
|
occupies.
|
|
*)
|
|
|
|
PROCEDURE GetSizeOfHighFromUnbounded (tokenno: CARDINAL; param: CARDINAL) : Tree ;
|
|
VAR
|
|
t : Tree ;
|
|
UnboundedType,
|
|
ArrayType : CARDINAL ;
|
|
i, n : CARDINAL ;
|
|
location : location_t;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
UnboundedType := GetType(param) ;
|
|
Assert(IsUnbounded(UnboundedType)) ;
|
|
ArrayType := GetType(UnboundedType) ;
|
|
|
|
i := 1 ;
|
|
n := GetDimension(UnboundedType) ;
|
|
t := GetCardinalOne(location) ;
|
|
WHILE i<=n DO
|
|
t := BuildMult(location,
|
|
BuildAdd(location,
|
|
GetHighFromUnbounded(location, i, param),
|
|
GetCardinalOne(location),
|
|
FALSE),
|
|
t, FALSE) ;
|
|
(* remember we must add one as HIGH(a) means we can legally reference a[HIGH(a)]. *)
|
|
INC(i)
|
|
END ;
|
|
RETURN( BuildConvert(location,
|
|
GetCardinalType(),
|
|
BuildMult(location,
|
|
t, BuildConvert(location,
|
|
GetCardinalType(),
|
|
FindSize(tokenno, ArrayType), FALSE), FALSE),
|
|
FALSE) )
|
|
END GetSizeOfHighFromUnbounded ;
|
|
|
|
|
|
(*
|
|
MaybeDebugBuiltinAlloca -
|
|
*)
|
|
|
|
PROCEDURE MaybeDebugBuiltinAlloca (location: location_t; tok: CARDINAL; high: Tree) : Tree ;
|
|
VAR
|
|
func: Tree ;
|
|
BEGIN
|
|
IF DebugBuiltins
|
|
THEN
|
|
func := Mod2Gcc(FromModuleGetSym(tok,
|
|
MakeKey('alloca_trace'),
|
|
MakeDefinitionSource(tok,
|
|
MakeKey('Builtins')))) ;
|
|
RETURN( BuildCall2(location, func, GetPointerType(), BuiltInAlloca(location, high), high) )
|
|
ELSE
|
|
RETURN( BuiltInAlloca(location, high) )
|
|
END
|
|
END MaybeDebugBuiltinAlloca ;
|
|
|
|
|
|
(*
|
|
MaybeDebugBuiltinMemcpy -
|
|
*)
|
|
|
|
PROCEDURE MaybeDebugBuiltinMemcpy (location: location_t; tok: CARDINAL; src, dest, nbytes: Tree) : Tree ;
|
|
VAR
|
|
func: Tree ;
|
|
BEGIN
|
|
IF DebugBuiltins
|
|
THEN
|
|
func := Mod2Gcc(FromModuleGetSym(tok,
|
|
MakeKey('memcpy'),
|
|
MakeDefinitionSource(tok,
|
|
MakeKey('Builtins')))) ;
|
|
RETURN( BuildCall3(location, func, GetPointerType(), src, dest, nbytes) )
|
|
ELSE
|
|
RETURN( BuiltInMemCopy(location, src, dest, nbytes) )
|
|
END
|
|
END MaybeDebugBuiltinMemcpy ;
|
|
|
|
|
|
(*
|
|
MakeCopyUse - make a copy of the unbounded array and alter all references
|
|
from the old unbounded array to the new unbounded array.
|
|
The parameter, param, contains a RECORD
|
|
ArrayAddress: ADDRESS ;
|
|
ArrayHigh : CARDINAL ;
|
|
END
|
|
we simply declare a new array of size, ArrayHigh
|
|
and set ArrayAddress to the address of the copy.
|
|
|
|
Remember ArrayHigh == sizeof(Array)-sizeof(typeof(array))
|
|
so we add 1 for the size and add 1 for a possible <nul>
|
|
*)
|
|
|
|
PROCEDURE MakeCopyUse (tokenno: CARDINAL; param: CARDINAL) ;
|
|
VAR
|
|
location : location_t;
|
|
UnboundedType: CARDINAL ;
|
|
Addr,
|
|
High,
|
|
NewArray : Tree ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
UnboundedType := GetType (param) ;
|
|
Assert (IsUnbounded (UnboundedType)) ;
|
|
|
|
High := GetSizeOfHighFromUnbounded (tokenno, param) ;
|
|
Addr := GetAddressOfUnbounded (location, param) ;
|
|
|
|
NewArray := MaybeDebugBuiltinAlloca (location, tokenno, High) ;
|
|
NewArray := MaybeDebugBuiltinMemcpy (location, tokenno, NewArray, Addr, High) ;
|
|
|
|
(* now assign param.Addr := ADR(NewArray) *)
|
|
|
|
BuildAssignmentStatement (location,
|
|
BuildComponentRef (location, Mod2Gcc (param), Mod2Gcc (GetUnboundedAddressOffset (UnboundedType))),
|
|
NewArray)
|
|
END MakeCopyUse ;
|
|
|
|
|
|
(*
|
|
GetParamAddress - returns the address of parameter, param.
|
|
*)
|
|
|
|
PROCEDURE GetParamAddress (location: location_t; proc, param: CARDINAL) : Tree ;
|
|
VAR
|
|
sym,
|
|
type: CARDINAL ;
|
|
BEGIN
|
|
IF IsParameter(param)
|
|
THEN
|
|
type := GetType(param) ;
|
|
sym := GetLocalSym(proc, GetSymName(param)) ;
|
|
IF IsUnbounded(type)
|
|
THEN
|
|
RETURN( GetAddressOfUnbounded(location, sym) )
|
|
ELSE
|
|
Assert(GetMode(sym)=LeftValue) ;
|
|
RETURN( Mod2Gcc(sym) )
|
|
END
|
|
ELSE
|
|
Assert(IsVar(param)) ;
|
|
Assert(GetMode(param)=LeftValue) ;
|
|
RETURN( Mod2Gcc(param) )
|
|
END
|
|
END GetParamAddress ;
|
|
|
|
|
|
(*
|
|
IsUnboundedWrittenTo - returns TRUE if the unbounded parameter
|
|
might be written to, or if -funbounded-by-reference
|
|
was _not_ specified.
|
|
*)
|
|
|
|
PROCEDURE IsUnboundedWrittenTo (proc, param: CARDINAL) : BOOLEAN ;
|
|
VAR
|
|
f : String ;
|
|
l : CARDINAL ;
|
|
sym : CARDINAL ;
|
|
n1, n2: Name ;
|
|
BEGIN
|
|
sym := GetLocalSym(proc, GetSymName(param)) ;
|
|
IF sym=NulSym
|
|
THEN
|
|
InternalError ('should find symbol in table')
|
|
ELSE
|
|
IF UnboundedByReference
|
|
THEN
|
|
IF (NOT GetVarWritten(sym)) AND VerboseUnbounded
|
|
THEN
|
|
n1 := GetSymName(sym) ;
|
|
n2 := GetSymName(proc) ;
|
|
f := FindFileNameFromToken(GetDeclaredMod(sym), 0) ;
|
|
l := TokenToLineNo(GetDeclaredMod(sym), 0) ;
|
|
printf4('%s:%d:non VAR unbounded parameter %a in procedure %a does not need to be copied\n',
|
|
f, l, n1, n2)
|
|
END ;
|
|
RETURN( GetVarWritten(sym) )
|
|
ELSE
|
|
RETURN( TRUE )
|
|
END
|
|
END
|
|
END IsUnboundedWrittenTo ;
|
|
|
|
|
|
(*
|
|
GetParamSize - returns the size in bytes of, param.
|
|
*)
|
|
|
|
PROCEDURE GetParamSize (tokenno: CARDINAL; param: CARDINAL) : Tree ;
|
|
BEGIN
|
|
Assert(IsVar(param) OR IsParameter(param)) ;
|
|
IF IsUnbounded(param)
|
|
THEN
|
|
RETURN GetSizeOfHighFromUnbounded(tokenno, param)
|
|
ELSE
|
|
RETURN BuildSize(tokenno, Mod2Gcc(GetType(param)), FALSE)
|
|
END
|
|
END GetParamSize ;
|
|
|
|
|
|
(*
|
|
DoIsIntersection - jumps to, tLabel, if the ranges i1..i2 j1..j2 overlap
|
|
else jump to, fLabel.
|
|
*)
|
|
|
|
PROCEDURE DoIsIntersection (tokenno: CARDINAL; ta, tb, tc, td: Tree; tLabel, fLabel: String) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
(*
|
|
if (ta>td) OR (tb<tc)
|
|
then
|
|
goto fLabel
|
|
else
|
|
goto tLabel
|
|
fi
|
|
*)
|
|
DoJump(location, BuildGreaterThan(location, ta, td), NIL, string(fLabel)) ;
|
|
DoJump(location, BuildLessThan(location, tb, tc), NIL, string(fLabel)) ;
|
|
BuildGoto(location, string(tLabel)) ;
|
|
IF CascadedDebugging
|
|
THEN
|
|
printf1('label used %s\n', tLabel) ;
|
|
printf1('label used %s\n', fLabel)
|
|
END
|
|
END DoIsIntersection ;
|
|
|
|
|
|
(*
|
|
BuildCascadedIfThenElsif - mustCheck contains a list of variables which
|
|
must be checked against the address of (proc, param, i).
|
|
If the address matches we make a copy of the unbounded
|
|
parameter (proc, param) and quit further checking.
|
|
*)
|
|
|
|
PROCEDURE BuildCascadedIfThenElsif (tokenno: CARDINAL;
|
|
mustCheck: List;
|
|
proc, param: CARDINAL) ;
|
|
VAR
|
|
ta, tb,
|
|
tc, td : Tree ;
|
|
n, j : CARDINAL ;
|
|
tLabel,
|
|
fLabel,
|
|
nLabel : String ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
n := NoOfItemsInList(mustCheck) ;
|
|
(* want a sequence of if then elsif statements *)
|
|
IF n>0
|
|
THEN
|
|
INC(UnboundedLabelNo) ;
|
|
j := 1 ;
|
|
ta := GetAddressOfUnbounded(location, param) ;
|
|
tb := BuildConvert(TokenToLocation(tokenno),
|
|
GetPointerType(),
|
|
BuildAddAddress(location, ta, GetSizeOfHighFromUnbounded(tokenno, param)),
|
|
FALSE) ;
|
|
WHILE j<=n DO
|
|
IF j>1
|
|
THEN
|
|
nLabel := CreateLabelProcedureN(proc, "n", UnboundedLabelNo, j) ;
|
|
IF CascadedDebugging
|
|
THEN
|
|
printf1('label declared %s\n', nLabel)
|
|
END ;
|
|
DeclareLabel(location, string(nLabel)) ;
|
|
END ;
|
|
tc := GetParamAddress(location, proc, GetItemFromList(mustCheck, j)) ;
|
|
td := BuildConvert(TokenToLocation(tokenno),
|
|
GetPointerType(),
|
|
BuildAddAddress(location, tc, GetParamSize(tokenno, param)),
|
|
FALSE) ;
|
|
tLabel := CreateLabelProcedureN(proc, "t", UnboundedLabelNo, j+1) ;
|
|
fLabel := CreateLabelProcedureN(proc, "f", UnboundedLabelNo, j+1) ;
|
|
DoIsIntersection(tokenno, ta, tb, tc, td, tLabel, fLabel) ;
|
|
IF CascadedDebugging
|
|
THEN
|
|
printf1('label declared %s\n', tLabel)
|
|
END ;
|
|
DeclareLabel (location, string (tLabel)) ;
|
|
MakeCopyUse (tokenno, param) ;
|
|
IF j<n
|
|
THEN
|
|
nLabel := CreateLabelProcedureN(proc, "n", UnboundedLabelNo, n+1) ;
|
|
BuildGoto(location, string(nLabel)) ;
|
|
IF CascadedDebugging
|
|
THEN
|
|
printf1('goto %s\n', nLabel)
|
|
END
|
|
END ;
|
|
IF CascadedDebugging
|
|
THEN
|
|
printf1('label declared %s\n', fLabel)
|
|
END ;
|
|
DeclareLabel(location, string(fLabel)) ;
|
|
INC(j)
|
|
END ;
|
|
(*
|
|
nLabel := CreateLabelProcedureN(proc, "fin", UnboundedLabelNo, n+1) ;
|
|
IF CascadedDebugging
|
|
THEN
|
|
printf1('label declared %s\n', nLabel)
|
|
END ;
|
|
DeclareLabel(location, string(nLabel))
|
|
*)
|
|
END
|
|
END BuildCascadedIfThenElsif ;
|
|
|
|
|
|
(*
|
|
CheckUnboundedNonVarParameter - if non var unbounded parameter is written to
|
|
then
|
|
make a copy of the contents of this parameter
|
|
and use the copy
|
|
else if param
|
|
is type compatible with any parameter, symv
|
|
and at runtime its address matches symv
|
|
then
|
|
make a copy of the contents of this parameter
|
|
and use the copy
|
|
fi
|
|
*)
|
|
|
|
PROCEDURE CheckUnboundedNonVarParameter (tokenno: CARDINAL;
|
|
trashed: List;
|
|
proc, param: CARDINAL) ;
|
|
VAR
|
|
mustCheck : List ;
|
|
paramTrashed,
|
|
n, j : CARDINAL ;
|
|
f : String ;
|
|
l : CARDINAL ;
|
|
n1, n2 : Name ;
|
|
BEGIN
|
|
IF IsUnboundedWrittenTo(proc, param)
|
|
THEN
|
|
MakeCopyUse (tokenno, param)
|
|
ELSE
|
|
InitList(mustCheck) ;
|
|
n := NoOfItemsInList(trashed) ;
|
|
j := 1 ;
|
|
WHILE j<=n DO
|
|
paramTrashed := GetItemFromList(trashed, j) ;
|
|
IF IsAssignmentCompatible(GetLowestType(param), GetLowestType(paramTrashed))
|
|
THEN
|
|
(* we must check whether this unbounded parameter has the same
|
|
address as the trashed parameter *)
|
|
IF VerboseUnbounded
|
|
THEN
|
|
n1 := GetSymName(paramTrashed) ;
|
|
n2 := GetSymName(proc) ;
|
|
f := FindFileNameFromToken(GetDeclaredMod(paramTrashed), 0) ;
|
|
l := TokenToLineNo(GetDeclaredMod(paramTrashed), 0) ;
|
|
printf4('%s:%d:must check at runtime the address of parameter, %a, in procedure, %a, whose contents will be trashed\n',
|
|
f, l, n1, n2) ;
|
|
n1 := GetSymName(param) ;
|
|
n2 := GetSymName(paramTrashed) ;
|
|
printf4('%s:%d:against address of parameter, %a, possibly resulting in a copy of parameter, %a\n',
|
|
f, l, n1, n2)
|
|
END ;
|
|
PutItemIntoList(mustCheck, paramTrashed)
|
|
END ;
|
|
INC(j)
|
|
END ;
|
|
(* now we build a sequence of if then { elsif then } end to check addresses *)
|
|
BuildCascadedIfThenElsif (tokenno, mustCheck, proc, param) ;
|
|
KillList(mustCheck)
|
|
END
|
|
END CheckUnboundedNonVarParameter ;
|
|
|
|
|
|
(*
|
|
IsParameterWritten - returns TRUE if a parameter, sym, is written to.
|
|
*)
|
|
|
|
PROCEDURE IsParameterWritten (proc: CARDINAL; sym: CARDINAL) : BOOLEAN ;
|
|
BEGIN
|
|
IF IsParameter(sym)
|
|
THEN
|
|
sym := GetLocalSym(proc, GetSymName(sym))
|
|
END ;
|
|
IF IsVar(sym)
|
|
THEN
|
|
(* unbounded arrays will appear as vars *)
|
|
RETURN GetVarWritten(sym)
|
|
END ;
|
|
InternalError ('expecting IsVar to return TRUE')
|
|
END IsParameterWritten ;
|
|
|
|
|
|
(*
|
|
SaveNonVarUnboundedParameters - for each var parameter, symv, do
|
|
(* not just unbounded var parameters, but _all_
|
|
parameters *)
|
|
if symv is written to
|
|
then
|
|
add symv to a compile list
|
|
fi
|
|
done
|
|
|
|
for each parameter of procedure, symu, do
|
|
if non var unbounded parameter is written to
|
|
then
|
|
make a copy of the contents of this parameter
|
|
and use the copy
|
|
else if
|
|
symu is type compatible with any parameter, symv
|
|
and at runtime its address matches symv
|
|
then
|
|
make a copy of the contents of this parameter
|
|
and use the copy
|
|
fi
|
|
done
|
|
*)
|
|
|
|
PROCEDURE SaveNonVarUnboundedParameters (tokenno: CARDINAL; proc: CARDINAL) ;
|
|
VAR
|
|
i, p : CARDINAL ;
|
|
trashed: List ;
|
|
f : String ;
|
|
sym : CARDINAL ;
|
|
l : CARDINAL ;
|
|
n1, n2 : Name ;
|
|
BEGIN
|
|
InitList(trashed) ;
|
|
i := 1 ;
|
|
p := NoOfParam(proc) ;
|
|
WHILE i<=p DO
|
|
sym := GetNthParam(proc, i) ;
|
|
IF IsParameterWritten(proc, sym)
|
|
THEN
|
|
IF VerboseUnbounded
|
|
THEN
|
|
n1 := GetSymName(sym) ;
|
|
n2 := GetSymName(proc) ;
|
|
f := FindFileNameFromToken(GetDeclaredMod(sym), 0) ;
|
|
l := TokenToLineNo(GetDeclaredMod(sym), 0) ;
|
|
printf4('%s:%d:parameter, %a, in procedure, %a, is trashed\n',
|
|
f, l, n1, n2)
|
|
END ;
|
|
PutItemIntoList(trashed, sym)
|
|
END ;
|
|
INC(i)
|
|
END ;
|
|
(* now see whether we need to copy any unbounded array parameters *)
|
|
i := 1 ;
|
|
p := NoOfParam(proc) ;
|
|
WHILE i<=p DO
|
|
IF IsUnboundedParam(proc, i) AND (NOT IsVarParam(proc, i))
|
|
THEN
|
|
CheckUnboundedNonVarParameter (tokenno, trashed, proc, GetNth (proc, i))
|
|
END ;
|
|
INC(i)
|
|
END ;
|
|
KillList(trashed)
|
|
END SaveNonVarUnboundedParameters ;
|
|
|
|
|
|
(*
|
|
AutoInitVariable -
|
|
*)
|
|
|
|
PROCEDURE AutoInitVariable (location: location_t; sym: CARDINAL) ;
|
|
VAR
|
|
type: CARDINAL ;
|
|
BEGIN
|
|
IF (NOT IsParameter (sym)) AND IsVar (sym) AND
|
|
(NOT IsTemporary (sym))
|
|
THEN
|
|
(* PrintSym (sym) ; *)
|
|
type := SkipType (GetType (sym)) ;
|
|
(* the type SYSTEM.ADDRESS is a pointer type. *)
|
|
IF IsPointer (type)
|
|
THEN
|
|
BuildAssignmentStatement (location,
|
|
Mod2Gcc (sym),
|
|
BuildConvert (location,
|
|
Mod2Gcc (GetType (sym)),
|
|
GetPointerZero (location),
|
|
TRUE))
|
|
END
|
|
END
|
|
END AutoInitVariable ;
|
|
|
|
|
|
(*
|
|
AutoInitialize - scope will be a procedure, module or defimp. All pointer
|
|
variables are assigned to NIL.
|
|
*)
|
|
|
|
PROCEDURE AutoInitialize (location: location_t; scope: CARDINAL) ;
|
|
VAR
|
|
i, n: CARDINAL ;
|
|
BEGIN
|
|
IF AutoInit
|
|
THEN
|
|
n := NoOfVariables (scope) ;
|
|
i := 1 ;
|
|
IF IsProcedure (scope)
|
|
THEN
|
|
(* the parameters are stored as local variables. *)
|
|
INC (i, NoOfParam (scope))
|
|
END ;
|
|
WHILE i <= n DO
|
|
AutoInitVariable (location, GetNth (scope, i)) ;
|
|
INC (i)
|
|
END
|
|
END
|
|
END AutoInitialize ;
|
|
|
|
|
|
(*
|
|
CodeNewLocalVar - Builds a new frame on the stack to contain the procedure
|
|
local variables.
|
|
*)
|
|
|
|
PROCEDURE CodeNewLocalVar (tokenno, CurrentProcedure: CARDINAL) ;
|
|
VAR
|
|
begin, end: CARDINAL ;
|
|
BEGIN
|
|
(* callee saves non var unbounded parameter contents *)
|
|
SaveNonVarUnboundedParameters (tokenno, CurrentProcedure) ;
|
|
BuildPushFunctionContext ;
|
|
GetProcedureBeginEnd (CurrentProcedure, begin, end) ;
|
|
CurrentQuadToken := begin ;
|
|
SetBeginLocation (TokenToLocation (begin)) ;
|
|
AutoInitialize (TokenToLocation (begin), CurrentProcedure) ;
|
|
ForeachProcedureDo (CurrentProcedure, CodeBlock) ;
|
|
ForeachInnerModuleDo (CurrentProcedure, CodeBlock) ;
|
|
BuildPopFunctionContext ;
|
|
ForeachInnerModuleDo (CurrentProcedure, CallInnerInit)
|
|
END CodeNewLocalVar ;
|
|
|
|
|
|
(*
|
|
CodeKillLocalVar - removes local variables and returns to previous scope.
|
|
*)
|
|
|
|
PROCEDURE CodeKillLocalVar (CurrentProcedure: CARDINAL) ;
|
|
VAR
|
|
begin, end: CARDINAL ;
|
|
proc : Tree ;
|
|
BEGIN
|
|
GetProcedureBeginEnd (CurrentProcedure, begin, end) ;
|
|
CurrentQuadToken := end ;
|
|
proc := NIL ;
|
|
IF IsCtor (CurrentProcedure)
|
|
THEN
|
|
proc := DeclareModuleCtor (Mod2Gcc (CurrentProcedure))
|
|
END ;
|
|
BuildEndFunctionCode (TokenToLocation (end),
|
|
Mod2Gcc (CurrentProcedure),
|
|
IsProcedureGccNested (CurrentProcedure)) ;
|
|
IF IsCtor (CurrentProcedure) AND (proc # NIL)
|
|
THEN
|
|
BuildModuleCtor (proc)
|
|
END ;
|
|
PoisonSymbols (CurrentProcedure) ;
|
|
removeStmtNote () ;
|
|
PopScope
|
|
END CodeKillLocalVar ;
|
|
|
|
|
|
(*
|
|
CodeProcedureScope -
|
|
*)
|
|
|
|
PROCEDURE CodeProcedureScope (CurrentProcedure: CARDINAL) ;
|
|
VAR
|
|
begin, end: CARDINAL ;
|
|
BEGIN
|
|
removeStmtNote () ;
|
|
GetProcedureBeginEnd (CurrentProcedure, begin, end) ;
|
|
BuildStartFunctionCode (TokenToLocation (begin),
|
|
Mod2Gcc (CurrentProcedure),
|
|
IsExportedGcc (CurrentProcedure),
|
|
IsProcedureInline (CurrentProcedure)) ;
|
|
StartDeclareScope (CurrentProcedure) ;
|
|
PushScope (CurrentProcedure) ;
|
|
(* DeclareParameters(CurrentProcedure) *)
|
|
END CodeProcedureScope ;
|
|
|
|
|
|
(*
|
|
CodeReturnValue - places the operand into the return value space
|
|
allocated by the function call.
|
|
*)
|
|
|
|
PROCEDURE CodeReturnValue (res, Procedure: CARDINAL) ;
|
|
VAR
|
|
value, length, op3t : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
TryDeclareConstant (CurrentQuadToken, res) ; (* checks to see whether it is a constant and declares it *)
|
|
TryDeclareConstructor (CurrentQuadToken, res) ;
|
|
IF IsConstString (res) AND (SkipTypeAndSubrange (GetType (Procedure)) # Char)
|
|
THEN
|
|
DoCopyString (CurrentQuadToken, length, op3t, GetType (Procedure), res) ;
|
|
value := BuildArrayStringConstructor (location,
|
|
Mod2Gcc (GetType (Procedure)), op3t, length)
|
|
ELSE
|
|
value := Mod2Gcc (res)
|
|
END ;
|
|
BuildReturnValueCode (location, Mod2Gcc (Procedure), value)
|
|
END CodeReturnValue ;
|
|
|
|
|
|
(* *******************************
|
|
(*
|
|
GenerateCleanup - generates a try/catch/clobber tree containing the call to ptree
|
|
*)
|
|
|
|
PROCEDURE GenerateCleanup (location: location_t; procedure: CARDINAL; p, call: Tree) : Tree ;
|
|
VAR
|
|
i, n: CARDINAL ;
|
|
t : Tree ;
|
|
BEGIN
|
|
t := push_statement_list (begin_statement_list ()) ;
|
|
i := 1 ;
|
|
n := NoOfParam (procedure) ;
|
|
WHILE i<=n DO
|
|
IF IsParameterVar (GetNthParam (procedure, i))
|
|
THEN
|
|
AddStatement (location, BuildCleanUp (GetParamTree (call, i-1)))
|
|
END ;
|
|
INC(i)
|
|
END ;
|
|
RETURN BuildTryFinally (location, p, pop_statement_list ())
|
|
END GenerateCleanup ;
|
|
|
|
|
|
(*
|
|
CheckCleanup - checks whether a cleanup is required for a procedure with
|
|
VAR parameters. The final tree is returned.
|
|
*)
|
|
|
|
PROCEDURE CheckCleanup (location: location_t; procedure: CARDINAL; tree, call: Tree) : Tree ;
|
|
BEGIN
|
|
IF HasVarParameters(procedure)
|
|
THEN
|
|
RETURN tree ;
|
|
(* RETURN GenerateCleanup(location, procedure, tree, call) *)
|
|
ELSE
|
|
RETURN tree
|
|
END
|
|
END CheckCleanup ;
|
|
************************************** *)
|
|
|
|
|
|
(*
|
|
CodeCall - determines whether the procedure call is a direct call
|
|
or an indirect procedure call.
|
|
*)
|
|
|
|
PROCEDURE CodeCall (tokenno: CARDINAL; procedure: CARDINAL) ;
|
|
VAR
|
|
tree : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
IF IsProcedure (procedure)
|
|
THEN
|
|
DeclareParameters (procedure) ;
|
|
tree := CodeDirectCall (tokenno, procedure)
|
|
ELSIF IsProcType (SkipType (GetType (procedure)))
|
|
THEN
|
|
DeclareParameters (SkipType (GetType (procedure))) ;
|
|
tree := CodeIndirectCall (tokenno, procedure) ;
|
|
procedure := SkipType (GetType (procedure))
|
|
ELSE
|
|
InternalError ('expecting Procedure or ProcType')
|
|
END ;
|
|
IF GetType (procedure) = NulSym
|
|
THEN
|
|
location := TokenToLocation (tokenno) ;
|
|
AddStatement (location, tree)
|
|
(* was AddStatement(location, CheckCleanup(location, procedure, tree, tree)) *)
|
|
ELSE
|
|
(* leave tree alone - as it will be picked up when processing FunctValue *)
|
|
END
|
|
END CodeCall ;
|
|
|
|
|
|
(*
|
|
CanUseBuiltin - returns TRUE if the procedure, Sym, can be
|
|
inlined via a builtin function.
|
|
*)
|
|
|
|
PROCEDURE CanUseBuiltin (Sym: CARDINAL) : BOOLEAN ;
|
|
BEGIN
|
|
RETURN( (NOT DebugBuiltins) AND
|
|
(BuiltinExists(KeyToCharStar(GetProcedureBuiltin(Sym))) OR
|
|
BuiltinExists(KeyToCharStar(GetSymName(Sym)))) )
|
|
END CanUseBuiltin ;
|
|
|
|
|
|
(*
|
|
UseBuiltin - returns a Tree containing the builtin function
|
|
and parameters. It should only be called if
|
|
CanUseBuiltin returns TRUE.
|
|
*)
|
|
|
|
PROCEDURE UseBuiltin (tokenno: CARDINAL; Sym: CARDINAL) : Tree ;
|
|
BEGIN
|
|
IF BuiltinExists(KeyToCharStar(GetProcedureBuiltin(Sym)))
|
|
THEN
|
|
RETURN( BuildBuiltinTree(TokenToLocation (tokenno), KeyToCharStar(GetProcedureBuiltin(Sym))) )
|
|
ELSE
|
|
RETURN( BuildBuiltinTree(TokenToLocation (tokenno), KeyToCharStar(GetSymName(Sym))) )
|
|
END
|
|
END UseBuiltin ;
|
|
|
|
|
|
(*
|
|
CodeDirectCall - calls a function/procedure.
|
|
*)
|
|
|
|
PROCEDURE CodeDirectCall (tokenno: CARDINAL; procedure: CARDINAL) : Tree ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
IF IsProcedureBuiltin(procedure) AND CanUseBuiltin(procedure)
|
|
THEN
|
|
RETURN UseBuiltin (tokenno, procedure)
|
|
ELSE
|
|
IF GetType(procedure)=NulSym
|
|
THEN
|
|
RETURN BuildProcedureCallTree(location, Mod2Gcc(procedure), NIL)
|
|
ELSE
|
|
RETURN BuildProcedureCallTree(location, Mod2Gcc(procedure), Mod2Gcc(GetType(procedure)))
|
|
END
|
|
END
|
|
END CodeDirectCall ;
|
|
|
|
|
|
(*
|
|
CodeIndirectCall - calls a function/procedure indirectly.
|
|
*)
|
|
|
|
PROCEDURE CodeIndirectCall (tokenno: CARDINAL; ProcVar: CARDINAL) : Tree ;
|
|
VAR
|
|
ReturnType: Tree ;
|
|
proc : CARDINAL ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
proc := SkipType(GetType(ProcVar)) ;
|
|
IF GetType(proc)=NulSym
|
|
THEN
|
|
ReturnType := Tree(NIL)
|
|
ELSE
|
|
ReturnType := Tree(Mod2Gcc(GetType(proc)))
|
|
END ;
|
|
|
|
(* now we dereference the lvalue if necessary *)
|
|
|
|
IF GetMode(ProcVar)=LeftValue
|
|
THEN
|
|
RETURN BuildIndirectProcedureCallTree(location,
|
|
BuildIndirect(location, Mod2Gcc(ProcVar), Mod2Gcc(proc)),
|
|
ReturnType)
|
|
ELSE
|
|
RETURN BuildIndirectProcedureCallTree(location, Mod2Gcc(ProcVar), ReturnType)
|
|
END
|
|
END CodeIndirectCall ;
|
|
|
|
|
|
(*
|
|
StringToChar - if type=Char and str is a string (of size <= 1)
|
|
then convert the string into a character constant.
|
|
*)
|
|
|
|
PROCEDURE StringToChar (t: Tree; type, str: CARDINAL) : Tree ;
|
|
VAR
|
|
s: String ;
|
|
n: Name ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(GetDeclaredMod(str)) ;
|
|
type := SkipType(type) ;
|
|
IF (type=Char) AND IsConstString(str)
|
|
THEN
|
|
IF GetStringLength(str)=0
|
|
THEN
|
|
s := InitString('') ;
|
|
t := BuildCharConstant(location, s) ;
|
|
s := KillString(s) ;
|
|
ELSIF GetStringLength(str)>1
|
|
THEN
|
|
n := GetSymName(str) ;
|
|
WriteFormat1("type incompatibility, attempting to use a string ('%a') when a CHAR is expected", n) ;
|
|
s := InitString('') ; (* do something safe *)
|
|
t := BuildCharConstant(location, s)
|
|
END ;
|
|
s := InitStringCharStar(KeyToCharStar(GetString(str))) ;
|
|
s := Slice(s, 0, 1) ;
|
|
t := BuildCharConstant(location, string(s)) ;
|
|
s := KillString(s) ;
|
|
END ;
|
|
RETURN( t )
|
|
END StringToChar ;
|
|
|
|
|
|
(*
|
|
ConvertTo - convert gcc tree, t, (which currently represents Modula-2 op3) into
|
|
a symbol of, type.
|
|
*)
|
|
|
|
PROCEDURE ConvertTo (t: Tree; type, op3: CARDINAL) : Tree ;
|
|
BEGIN
|
|
IF SkipType(type)#SkipType(GetType(op3))
|
|
THEN
|
|
IF IsConst(op3) AND (NOT IsConstString(op3))
|
|
THEN
|
|
PushValue(op3) ;
|
|
RETURN( BuildConvert(TokenToLocation(GetDeclaredMod(op3)),
|
|
Mod2Gcc(type), t, FALSE) )
|
|
END
|
|
END ;
|
|
RETURN( t )
|
|
END ConvertTo ;
|
|
|
|
|
|
(*
|
|
ConvertRHS - convert (t, rhs) into, type. (t, rhs) refer to the
|
|
same entity t is a GCC Tree and, rhs, is a Modula-2
|
|
symbol. It checks for char and strings
|
|
first and then the remaining types.
|
|
*)
|
|
|
|
PROCEDURE ConvertRHS (t: Tree; type, rhs: CARDINAL) : Tree ;
|
|
BEGIN
|
|
t := StringToChar (Mod2Gcc (rhs), type, rhs) ;
|
|
RETURN ConvertTo (t, type, rhs)
|
|
END ConvertRHS ;
|
|
|
|
|
|
(*
|
|
IsCoerceableParameter - returns TRUE if symbol, sym, is a
|
|
coerceable parameter.
|
|
*)
|
|
|
|
PROCEDURE IsCoerceableParameter (sym: CARDINAL) : BOOLEAN ;
|
|
BEGIN
|
|
RETURN(
|
|
IsSet(sym) OR
|
|
(IsOrdinalType(sym) AND (sym#Boolean) AND (NOT IsEnumeration(sym))) OR
|
|
IsComplexType(sym) OR IsRealType(sym) OR
|
|
IsComplexN(sym) OR IsRealN(sym) OR IsSetN(sym)
|
|
)
|
|
END IsCoerceableParameter ;
|
|
|
|
|
|
(*
|
|
IsConstProcedure - returns TRUE if, p, is a const procedure.
|
|
*)
|
|
|
|
PROCEDURE IsConstProcedure (p: CARDINAL) : BOOLEAN ;
|
|
BEGIN
|
|
RETURN( IsConst(p) AND (GetType(p)#NulSym) AND IsProcType(GetType(p)) )
|
|
END IsConstProcedure ;
|
|
|
|
|
|
(*
|
|
IsConstant - returns TRUE if symbol, p, is either a const or procedure.
|
|
*)
|
|
|
|
PROCEDURE IsConstant (p: CARDINAL) : BOOLEAN ;
|
|
BEGIN
|
|
RETURN IsConst (p) OR IsProcedure (p)
|
|
END IsConstant ;
|
|
|
|
|
|
(*
|
|
CheckConvertCoerceParameter -
|
|
*)
|
|
|
|
PROCEDURE CheckConvertCoerceParameter (tokenno: CARDINAL; op1, op2, op3: CARDINAL) : Tree ;
|
|
VAR
|
|
OperandType,
|
|
ParamType : CARDINAL ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
IF GetNthParam(op2, op1)=NulSym
|
|
THEN
|
|
(* We reach here if the argument is being passed to a C vararg function. *)
|
|
RETURN( Mod2Gcc(op3) )
|
|
ELSE
|
|
OperandType := SkipType(GetType(op3)) ;
|
|
ParamType := SkipType(GetType(GetNthParam(op2, op1)))
|
|
END ;
|
|
IF IsProcType(ParamType)
|
|
THEN
|
|
IF IsProcedure(op3) OR IsConstProcedure(op3) OR (OperandType = ParamType)
|
|
THEN
|
|
RETURN( Mod2Gcc(op3) )
|
|
ELSE
|
|
RETURN( BuildConvert(location, Mod2Gcc(ParamType), Mod2Gcc(op3), FALSE) )
|
|
END
|
|
ELSIF IsRealType(OperandType) AND IsRealType(ParamType) AND
|
|
(ParamType#OperandType)
|
|
THEN
|
|
(* SHORTREAL, LONGREAL and REAL conversion during parameter passing *)
|
|
RETURN( BuildConvert(location, Mod2Gcc(ParamType),
|
|
Mod2Gcc(op3), FALSE) )
|
|
ELSIF (OperandType#NulSym) AND IsSet(OperandType) AND IsConst(op3)
|
|
THEN
|
|
RETURN( DeclareKnownConstant(location,
|
|
Mod2Gcc(ParamType),
|
|
Mod2Gcc(op3)) )
|
|
ELSIF IsConst(op3) AND
|
|
(IsOrdinalType(ParamType) OR IsSystemType(ParamType))
|
|
THEN
|
|
RETURN( BuildConvert(location, Mod2Gcc(ParamType),
|
|
StringToChar(Mod2Gcc(op3), ParamType, op3),
|
|
FALSE) )
|
|
ELSIF IsConstString(op3) OR ((OperandType#NulSym) AND IsCoerceableParameter(OperandType) AND (OperandType#ParamType))
|
|
THEN
|
|
RETURN( BuildConvert(location, Mod2Gcc(ParamType), Mod2Gcc(op3), FALSE) )
|
|
ELSE
|
|
RETURN( Mod2Gcc(op3) )
|
|
END
|
|
END CheckConvertCoerceParameter ;
|
|
|
|
|
|
(*
|
|
CheckConstant - checks to see whether we should declare the constant.
|
|
*)
|
|
|
|
PROCEDURE CheckConstant (tokenno: CARDINAL; des, expr: CARDINAL) : Tree ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
IF IsProcedure(expr)
|
|
THEN
|
|
RETURN( Mod2Gcc(expr) )
|
|
ELSE
|
|
RETURN( DeclareKnownConstant(location, Mod2Gcc(GetType(des)), Mod2Gcc(expr)) )
|
|
END
|
|
END CheckConstant ;
|
|
|
|
|
|
(*
|
|
CodeMakeAdr - code the function MAKEADR.
|
|
*)
|
|
|
|
PROCEDURE CodeMakeAdr (q: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
r : CARDINAL ;
|
|
n : CARDINAL ;
|
|
type : CARDINAL ;
|
|
op : QuadOperator ;
|
|
bits,
|
|
max,
|
|
tmp,
|
|
res,
|
|
val : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
n := q ;
|
|
REPEAT
|
|
IF op1>0
|
|
THEN
|
|
DeclareConstant(CurrentQuadToken, op3)
|
|
END ;
|
|
n := GetNextQuad(n) ;
|
|
GetQuad(n, op, r, op2, op3)
|
|
UNTIL op=FunctValueOp ;
|
|
|
|
n := q ;
|
|
GetQuad(n, op, op1, op2, op3) ;
|
|
res := Mod2Gcc(r) ;
|
|
max := GetSizeOfInBits(Mod2Gcc(Address)) ;
|
|
bits := GetIntegerZero(location) ;
|
|
val := GetPointerZero(location) ;
|
|
REPEAT
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
IF (op=ParamOp) AND (op1>0)
|
|
THEN
|
|
IF GetType(op3)=NulSym
|
|
THEN
|
|
WriteFormat0('must supply typed constants to MAKEADR')
|
|
ELSE
|
|
type := GetType(op3) ;
|
|
tmp := BuildConvert(location, GetPointerType(), Mod2Gcc(op3), FALSE) ;
|
|
IF CompareTrees(bits, GetIntegerZero(location))>0
|
|
THEN
|
|
tmp := BuildLSL(location, tmp, bits, FALSE)
|
|
END ;
|
|
bits := BuildAdd(location, bits, GetSizeOfInBits(Mod2Gcc(type)), FALSE) ;
|
|
val := BuildLogicalOrAddress(location, val, tmp, FALSE)
|
|
END
|
|
END ;
|
|
SubQuad(n) ;
|
|
n := GetNextQuad(n) ;
|
|
GetQuad(n, op, op1, op2, op3)
|
|
UNTIL op=FunctValueOp ;
|
|
IF CompareTrees(bits, max)>0
|
|
THEN
|
|
MetaErrorT0 (CurrentQuadToken,
|
|
'total number of bits specified as parameters to {%kMAKEADR} exceeds address width')
|
|
END ;
|
|
SubQuad(n) ;
|
|
BuildAssignmentStatement (location, res, val)
|
|
END CodeMakeAdr ;
|
|
|
|
|
|
(*
|
|
CodeBuiltinFunction - attempts to inline a function. Currently it only
|
|
inlines the SYSTEM function MAKEADR.
|
|
*)
|
|
|
|
PROCEDURE CodeBuiltinFunction (q: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF (op1=0) AND (op3=MakeAdr)
|
|
THEN
|
|
CodeMakeAdr (q, op1, op2, op3)
|
|
END
|
|
END CodeBuiltinFunction ;
|
|
|
|
|
|
(*
|
|
FoldMakeAdr - attempts to fold the function MAKEADR.
|
|
*)
|
|
|
|
PROCEDURE FoldMakeAdr (tokenno: CARDINAL; p: WalkAction;
|
|
q: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
resolved: BOOLEAN ;
|
|
r : CARDINAL ;
|
|
n : CARDINAL ;
|
|
op : QuadOperator ;
|
|
type : CARDINAL ;
|
|
bits,
|
|
max,
|
|
tmp,
|
|
val : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (tokenno) ;
|
|
resolved := TRUE ;
|
|
n := q ;
|
|
r := op1 ;
|
|
REPEAT
|
|
IF r>0
|
|
THEN
|
|
TryDeclareConstant (tokenno, op3) ;
|
|
IF NOT GccKnowsAbout(op3)
|
|
THEN
|
|
resolved := FALSE
|
|
END
|
|
END ;
|
|
n := GetNextQuad(n) ;
|
|
GetQuad(n, op, r, op2, op3)
|
|
UNTIL op=FunctValueOp ;
|
|
|
|
IF resolved AND IsConst(r)
|
|
THEN
|
|
n := q ;
|
|
GetQuad(n, op, op1, op2, op3) ;
|
|
max := GetSizeOfInBits(Mod2Gcc(Address)) ;
|
|
bits := GetIntegerZero(location) ;
|
|
val := GetPointerZero(location) ;
|
|
REPEAT
|
|
location := TokenToLocation(tokenno) ;
|
|
IF (op=ParamOp) AND (op1>0)
|
|
THEN
|
|
IF GetType(op3)=NulSym
|
|
THEN
|
|
MetaErrorT0 (tokenno,
|
|
'constants passed to {%kMAKEADR} must be typed')
|
|
ELSE
|
|
type := GetType(op3) ;
|
|
tmp := BuildConvert(location, GetPointerType(), Mod2Gcc(op3), FALSE) ;
|
|
IF CompareTrees(bits, GetIntegerZero(location))>0
|
|
THEN
|
|
tmp := BuildLSL(location, tmp, bits, FALSE)
|
|
END ;
|
|
bits := BuildAdd(location, bits, GetSizeOfInBits(Mod2Gcc(type)), FALSE) ;
|
|
val := BuildLogicalOrAddress(location, val, tmp, FALSE)
|
|
END
|
|
END ;
|
|
SubQuad(n) ;
|
|
n := GetNextQuad(n) ;
|
|
GetQuad(n, op, op1, op2, op3)
|
|
UNTIL op=FunctValueOp ;
|
|
IF CompareTrees(bits, max)>0
|
|
THEN
|
|
MetaErrorT0 (tokenno,
|
|
'total number of bits specified as parameters to {%kMAKEADR} exceeds address width')
|
|
END ;
|
|
PutConst(r, Address) ;
|
|
AddModGcc(r, DeclareKnownConstant(location, Mod2Gcc(Address), val)) ;
|
|
p(r) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(n)
|
|
END
|
|
END FoldMakeAdr ;
|
|
|
|
|
|
(*
|
|
doParam - builds the parameter, op3, which is to be passed to
|
|
procedure, op2. The number of the parameter is op1.
|
|
*)
|
|
|
|
PROCEDURE doParam (quad: 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))
|
|
END doParam ;
|
|
|
|
|
|
(*
|
|
FoldBuiltin - attempts to fold the gcc builtin function.
|
|
*)
|
|
|
|
PROCEDURE FoldBuiltin (tokenno: CARDINAL; p: WalkAction;
|
|
q: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
resolved : BOOLEAN ;
|
|
procedure,
|
|
r : CARDINAL ;
|
|
n : CARDINAL ;
|
|
op : QuadOperator ;
|
|
val : Tree ;
|
|
location : location_t ;
|
|
BEGIN
|
|
resolved := TRUE ;
|
|
procedure := NulSym ;
|
|
n := q ;
|
|
r := op1 ;
|
|
REPEAT
|
|
IF r>0
|
|
THEN
|
|
TryDeclareConstant(tokenno, op3) ;
|
|
IF NOT GccKnowsAbout(op3)
|
|
THEN
|
|
resolved := FALSE
|
|
END
|
|
END ;
|
|
IF (op=CallOp) AND (NOT IsProcedure(op3))
|
|
THEN
|
|
(* cannot fold an indirect procedure function call *)
|
|
resolved := FALSE
|
|
END ;
|
|
n := GetNextQuad(n) ;
|
|
GetQuad(n, op, r, op2, op3)
|
|
UNTIL op=FunctValueOp ;
|
|
|
|
IF resolved AND IsConst(r)
|
|
THEN
|
|
n := q ;
|
|
GetQuad(n, op, op1, op2, op3) ;
|
|
REPEAT
|
|
IF (op=ParamOp) AND (op1>0)
|
|
THEN
|
|
doParam(n, op1, op2, op3)
|
|
ELSIF op=CallOp
|
|
THEN
|
|
procedure := op3
|
|
END ;
|
|
SubQuad(n) ;
|
|
n := GetNextQuad(n) ;
|
|
GetQuad(n, op, op1, op2, op3)
|
|
UNTIL op=FunctValueOp ;
|
|
|
|
IF IsProcedureBuiltin(procedure) AND CanUseBuiltin(procedure)
|
|
THEN
|
|
location := TokenToLocation(tokenno) ;
|
|
val := FoldAndStrip (UseBuiltin (tokenno, procedure)) ;
|
|
PutConst(r, GetType(procedure)) ;
|
|
AddModGcc(r, DeclareKnownConstant(location, Mod2Gcc(GetType(procedure)), val)) ;
|
|
p(r) ;
|
|
SetLastFunction(NIL)
|
|
ELSE
|
|
MetaErrorT1 (tokenno, 'gcc builtin procedure {%1Ead} cannot be used in a constant expression', procedure) ;
|
|
END ;
|
|
NoChange := FALSE ;
|
|
SubQuad(n)
|
|
END
|
|
END FoldBuiltin ;
|
|
|
|
|
|
(*
|
|
FoldBuiltinFunction - attempts to inline a function. Currently it only
|
|
inlines the SYSTEM function MAKEADR.
|
|
*)
|
|
|
|
PROCEDURE FoldBuiltinFunction (tokenno: CARDINAL; p: WalkAction;
|
|
q: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF op1=0
|
|
THEN
|
|
(* must be a function as op1 is the return parameter *)
|
|
IF op3=MakeAdr
|
|
THEN
|
|
FoldMakeAdr (tokenno, p, q, op1, op2, op3)
|
|
ELSIF IsProcedure (op3) AND IsProcedureBuiltin (op3) AND CanUseBuiltin (op3)
|
|
THEN
|
|
FoldBuiltin (tokenno, p, q, op1, op2, op3)
|
|
END
|
|
END
|
|
END FoldBuiltinFunction ;
|
|
|
|
|
|
(*
|
|
CodeParam - builds a parameter list.
|
|
|
|
NOTE that we almost can treat VAR and NON VAR parameters the same, expect for
|
|
some types:
|
|
|
|
procedure parameters
|
|
unbounded parameters
|
|
|
|
these require special attention and thus it is easier to test individually
|
|
for VAR and NON VAR parameters.
|
|
|
|
NOTE that we CAN ignore ModeOfAddr though
|
|
*)
|
|
|
|
PROCEDURE CodeParam (quad: CARDINAL; nth, procedure, parameter: CARDINAL) ;
|
|
BEGIN
|
|
IF nth=0
|
|
THEN
|
|
CodeBuiltinFunction (quad, nth, procedure, parameter)
|
|
ELSE
|
|
IF StrictTypeChecking
|
|
THEN
|
|
IF (nth <= NoOfParam (procedure))
|
|
THEN
|
|
IF IsVarParam (procedure, nth) AND
|
|
(NOT ParameterTypeCompatible (CurrentQuadToken,
|
|
'parameter incompatibility when attempting to pass actual parameter {%3Ead} to a {%kVAR} formal parameter {%2ad} 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 a 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
|
|
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,
|
|
'cannot pass a constant {%1Ead} as a VAR parameter', parameter)
|
|
ELSIF IsAModula2Type (parameter)
|
|
THEN
|
|
MetaErrorT2 (CurrentQuadToken,
|
|
'cannot pass a type {%1Ead} as a parameter to procedure {%2ad}',
|
|
parameter, procedure)
|
|
ELSE
|
|
doParam (quad, nth, procedure, parameter)
|
|
END
|
|
(* --fixme remove E ND once M2Check works. *)
|
|
END
|
|
END CodeParam ;
|
|
|
|
|
|
(*
|
|
Replace - replace the entry for sym in the double entry bookkeeping with sym/tree.
|
|
*)
|
|
|
|
PROCEDURE Replace (sym: CARDINAL; tree: Tree) ;
|
|
BEGIN
|
|
IF GccKnowsAbout (sym)
|
|
THEN
|
|
RemoveMod2Gcc (sym)
|
|
END ;
|
|
AddModGcc (sym, tree)
|
|
END Replace ;
|
|
|
|
|
|
(*
|
|
CodeFunctValue - retrieves the function return value and assigns it
|
|
into a variable.
|
|
*)
|
|
|
|
PROCEDURE CodeFunctValue (location: location_t; op1: CARDINAL) ;
|
|
VAR
|
|
call,
|
|
value: Tree ;
|
|
BEGIN
|
|
(*
|
|
operator : FunctValueOp
|
|
op1 : The Returned Variable
|
|
op3 : The Function Returning this Variable
|
|
*)
|
|
IF EnableSSA AND IsVariableSSA (op1)
|
|
THEN
|
|
call := GetLastFunction () ;
|
|
SetLastFunction (NIL) ;
|
|
Replace (op1, call)
|
|
ELSE
|
|
value := BuildFunctValue (location, Mod2Gcc (op1)) ;
|
|
(* AddStatement (location, CheckCleanup (location, op3, value, call)) *)
|
|
AddStatement (location, value)
|
|
END
|
|
END CodeFunctValue ;
|
|
|
|
|
|
(*
|
|
Addr Operator - contains the address of a variable.
|
|
|
|
Yields the address of a variable - need to add the frame pointer if
|
|
a variable is local to a procedure.
|
|
|
|
Sym1<X> Addr Sym2<X> meaning Mem[Sym1<I>] := Sym2<I>
|
|
*)
|
|
|
|
PROCEDURE CodeAddr (quad: CARDINAL; op1, op3: CARDINAL) ;
|
|
VAR
|
|
value : Tree ;
|
|
type : CARDINAL ;
|
|
location: location_t ;
|
|
BEGIN
|
|
IF IsConst(op3) AND (NOT IsConstString(op3))
|
|
THEN
|
|
MetaErrorT1 (CurrentQuadToken, 'error in expression, trying to find the address of a constant {%1Ead}', op3)
|
|
ELSE
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
type := SkipType (GetType (op3)) ;
|
|
DeclareConstant (CurrentQuadToken, op3) ; (* we might be asked to find the address of a constant string *)
|
|
DeclareConstructor (CurrentQuadToken, quad, op3) ;
|
|
IF (IsConst (op3) AND (type=Char)) OR IsConstString (op3)
|
|
THEN
|
|
value := BuildStringConstant (location, KeyToCharStar (GetString (op3)), GetStringLength (op3))
|
|
ELSE
|
|
value := Mod2Gcc (op3)
|
|
END ;
|
|
BuildAssignmentStatement (location,
|
|
Mod2Gcc (op1),
|
|
BuildAddr (location, value, FALSE))
|
|
END
|
|
END CodeAddr ;
|
|
|
|
|
|
PROCEDURE stop ; BEGIN END stop ;
|
|
|
|
PROCEDURE CheckStop (q: CARDINAL) ;
|
|
BEGIN
|
|
IF q=3827
|
|
THEN
|
|
stop
|
|
END
|
|
END CheckStop ;
|
|
|
|
(*
|
|
------------------------------------------------------------------------------
|
|
:= Operator
|
|
------------------------------------------------------------------------------
|
|
Sym1<I> := Sym3<I> := produces a constant
|
|
*)
|
|
|
|
PROCEDURE FoldBecomes (tokenno: CARDINAL; p: WalkAction; quad: CARDINAL; op1, op3: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
TryDeclareConstant(tokenno, op3) ; (* checks to see whether it is a constant literal and declares it *)
|
|
TryDeclareConstructor(tokenno, op3) ;
|
|
location := TokenToLocation(tokenno) ;
|
|
IF IsConst (op1) AND IsConstant (op3)
|
|
THEN
|
|
(* constant folding taking place, but have we resolved op3 yet? *)
|
|
IF GccKnowsAbout (op3)
|
|
THEN
|
|
(* now we can tell gcc about the relationship between, op1 and op3 *)
|
|
(* RemoveSSAPlaceholder (quad, op1) ; *)
|
|
IF GccKnowsAbout (op1)
|
|
THEN
|
|
MetaErrorT1 (tokenno, 'constant {%1Ead} should not be reassigned', op1)
|
|
ELSE
|
|
IF IsConstString(op3)
|
|
THEN
|
|
PutConstString(tokenno, op1, GetString(op3)) ;
|
|
ELSIF GetType(op1)=NulSym
|
|
THEN
|
|
Assert(GetType(op3)#NulSym) ;
|
|
PutConst(op1, GetType(op3))
|
|
END ;
|
|
IF GetType(op3)=NulSym
|
|
THEN
|
|
CheckOrResetOverflow(tokenno, Mod2Gcc(op3), MustCheckOverflow(quad)) ;
|
|
AddModGcc(op1, Mod2Gcc(op3))
|
|
ELSE
|
|
IF NOT GccKnowsAbout(GetType(op1))
|
|
THEN
|
|
RETURN
|
|
END ;
|
|
IF IsProcedure(op3)
|
|
THEN
|
|
AddModGcc(op1,
|
|
BuildConvert(location,
|
|
Mod2Gcc(GetType(op1)), BuildAddr(location, Mod2Gcc(op3), FALSE), TRUE))
|
|
ELSIF IsValueSolved(op3)
|
|
THEN
|
|
PushValue(op3) ;
|
|
IF IsValueTypeReal()
|
|
THEN
|
|
CheckOrResetOverflow(tokenno, PopRealTree(), MustCheckOverflow(quad)) ;
|
|
PushValue(op3) ;
|
|
AddModGcc(op1, PopRealTree())
|
|
ELSIF IsValueTypeSet()
|
|
THEN
|
|
PopValue(op1) ;
|
|
PutConstSet(op1)
|
|
ELSIF IsValueTypeConstructor() OR IsValueTypeArray() OR IsValueTypeRecord()
|
|
THEN
|
|
PopValue(op1) ;
|
|
PutConstructor(op1)
|
|
ELSIF IsValueTypeComplex()
|
|
THEN
|
|
CheckOrResetOverflow(tokenno, PopComplexTree(), MustCheckOverflow(quad)) ;
|
|
PushValue(op3) ;
|
|
PopValue(op1)
|
|
ELSE
|
|
CheckOrResetOverflow(tokenno, PopIntegerTree(), MustCheckOverflow(quad)) ;
|
|
IF GetType(op1)=NulSym
|
|
THEN
|
|
PushValue(op3) ;
|
|
AddModGcc(op1, PopIntegerTree())
|
|
ELSE
|
|
PushValue(op3) ;
|
|
AddModGcc(op1, BuildConvert(location, Mod2Gcc(GetType(op1)), PopIntegerTree(), FALSE))
|
|
END
|
|
END
|
|
ELSE
|
|
CheckOrResetOverflow(tokenno, Mod2Gcc(op3), MustCheckOverflow(quad)) ;
|
|
AddModGcc(op1,
|
|
DeclareKnownConstant(location,
|
|
Mod2Gcc(GetType(op3)),
|
|
Mod2Gcc(op3)))
|
|
END
|
|
END ;
|
|
p (op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad) ;
|
|
Assert (RememberConstant(Mod2Gcc (op1)) = Mod2Gcc (op1))
|
|
END
|
|
ELSE
|
|
(* not to worry, we must wait until op3 is known *)
|
|
END
|
|
END
|
|
END FoldBecomes ;
|
|
|
|
VAR
|
|
tryBlock: Tree ; (* this must be placed into gccgm2 and it must follow the
|
|
current function scope - ie it needs work with nested procedures *)
|
|
handlerBlock: Tree ;
|
|
|
|
|
|
(*
|
|
CodeTry - starts building a GCC 'try' node.
|
|
*)
|
|
|
|
PROCEDURE CodeTry ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
handlerBlock := NIL ;
|
|
tryBlock := BuildTryBegin (location)
|
|
END CodeTry ;
|
|
|
|
|
|
(*
|
|
CodeThrow - builds a GCC 'throw' node.
|
|
*)
|
|
|
|
PROCEDURE CodeThrow (value: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
IF value = NulSym
|
|
THEN
|
|
AddStatement (location, BuildThrow (location, Tree (NIL)))
|
|
ELSE
|
|
DeclareConstant (CurrentQuadToken, value) ; (* checks to see whether it is a constant and declares it *)
|
|
AddStatement (location, BuildThrow (location, BuildConvert (location,
|
|
GetIntegerType (),
|
|
Mod2Gcc (value), FALSE)))
|
|
END
|
|
END CodeThrow ;
|
|
|
|
|
|
PROCEDURE CodeRetry (destQuad: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
BuildGoto (location, string (CreateLabelName (destQuad)))
|
|
END CodeRetry ;
|
|
|
|
|
|
PROCEDURE CodeCatchBegin ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
BuildTryEnd (tryBlock) ;
|
|
handlerBlock := BuildCatchBegin (location)
|
|
END CodeCatchBegin ;
|
|
|
|
|
|
PROCEDURE CodeCatchEnd ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
tryBlock := BuildCatchEnd (location, handlerBlock, tryBlock) ;
|
|
AddStatement (location, tryBlock)
|
|
END CodeCatchEnd ;
|
|
|
|
|
|
(*
|
|
DescribeTypeError -
|
|
*)
|
|
|
|
PROCEDURE DescribeTypeError (token: CARDINAL;
|
|
op1, op2: CARDINAL) ;
|
|
BEGIN
|
|
MetaErrorT2(token, 'incompatible set types in assignment, assignment between {%1ERad} and {%2ad}', op1, op2) ;
|
|
MetaError2('set types are {%1CDtsad} and {%2Dtsad}', op1, op2)
|
|
END DescribeTypeError ;
|
|
|
|
|
|
(*
|
|
DefaultConvertGM2 - provides a simple mapping between
|
|
front end data types and GCC equivalents.
|
|
This is only used to aid assignment of
|
|
typed constants.
|
|
*)
|
|
|
|
PROCEDURE DefaultConvertGM2 (sym: CARDINAL) : Tree ;
|
|
BEGIN
|
|
sym := SkipType (sym) ;
|
|
IF sym=Bitset
|
|
THEN
|
|
RETURN( GetWordType() )
|
|
ELSE
|
|
RETURN( Mod2Gcc(sym) )
|
|
END
|
|
END DefaultConvertGM2 ;
|
|
|
|
|
|
(*
|
|
GetTypeMode -
|
|
*)
|
|
|
|
PROCEDURE GetTypeMode (sym: CARDINAL) : CARDINAL ;
|
|
BEGIN
|
|
IF GetMode(sym)=LeftValue
|
|
THEN
|
|
RETURN( Address )
|
|
ELSE
|
|
RETURN( GetType(sym) )
|
|
END
|
|
END GetTypeMode ;
|
|
|
|
|
|
(*
|
|
FoldConstBecomes - returns a Tree containing op3.
|
|
The tree will have been folded and
|
|
type converted if necessary.
|
|
*)
|
|
|
|
PROCEDURE FoldConstBecomes (tokenno: CARDINAL;
|
|
op1, op3: CARDINAL) : Tree ;
|
|
VAR
|
|
t, type : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
IF IsConstSet(op3) OR ((SkipType(GetType(op3))#NulSym) AND
|
|
IsSet(SkipType(GetType(op3))))
|
|
THEN
|
|
(* we have not checked set compatibility in
|
|
M2Quads.mod:BuildAssignmentTree so we do it here.
|
|
*)
|
|
(*
|
|
IF (Iso AND (SkipType(GetType(op1))#SkipType(GetType(op3)))) OR
|
|
(Pim AND ((SkipType(GetType(op1))#SkipType(GetType(op3))) AND
|
|
(SkipType(GetType(op1))#Bitset) AND
|
|
(SkipType(GetType(op3))#Bitset)))
|
|
*)
|
|
IF SkipType(GetTypeMode(op1))#SkipType(GetTypeMode(op3))
|
|
THEN
|
|
DescribeTypeError (tokenno, op1, op3) ;
|
|
RETURN( Mod2Gcc (op1) ) (* we might crash if we execute the BuildAssignmentTree with op3 *)
|
|
END
|
|
END ;
|
|
location := TokenToLocation (tokenno) ;
|
|
TryDeclareConstant (tokenno, op3) ;
|
|
t := Mod2Gcc (op3) ;
|
|
Assert (t#NIL) ;
|
|
IF IsConstant (op3)
|
|
THEN
|
|
IF IsProcedure (op3)
|
|
THEN
|
|
RETURN t
|
|
(*
|
|
t := BuildConvert(location, Mod2Gcc(GetType(op1)), BuildAddr(location, Mod2Gcc(op3), FALSE), TRUE)
|
|
*)
|
|
ELSIF (NOT IsConstString (op3)) AND (NOT IsConstSet (op3)) AND
|
|
(SkipType (GetType (op3)) # SkipType (GetType (op1)))
|
|
THEN
|
|
type := DefaultConvertGM2 (GetType(op1)) ; (* do we need this now? --fixme-- *)
|
|
t := ConvertConstantAndCheck (location, type, t)
|
|
ELSIF GetType (op1) # NulSym
|
|
THEN
|
|
t := StringToChar (Mod2Gcc (op3), GetType (op1), op3)
|
|
END
|
|
END ;
|
|
RETURN( t )
|
|
END FoldConstBecomes ;
|
|
|
|
|
|
(*
|
|
DoCopyString - returns trees:
|
|
length number of bytes to be copied (including the nul)
|
|
op1t the new string _type_ (with the extra nul character).
|
|
op3t the actual string with the extra nul character.
|
|
*)
|
|
|
|
PROCEDURE DoCopyString (tokenno: CARDINAL; VAR length, op3t: Tree; op1t, op3: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
Assert(IsArray(SkipType(op1t))) ;
|
|
(* handle string assignments:
|
|
VAR
|
|
str: ARRAY [0..10] OF CHAR ;
|
|
ch : CHAR ;
|
|
|
|
str := 'abcde' but not ch := 'a'
|
|
*)
|
|
IF GetType (op3) = Char
|
|
THEN
|
|
(*
|
|
* create string from char and add nul to the end, nul is
|
|
* added by BuildStringConstant
|
|
*)
|
|
op3t := BuildStringConstant (location, KeyToCharStar (GetString (op3)), 1)
|
|
ELSE
|
|
op3t := Mod2Gcc (op3)
|
|
END ;
|
|
op3t := ConvertString (Mod2Gcc (op1t), op3t) ;
|
|
|
|
PushIntegerTree(FindSize(tokenno, op3)) ;
|
|
PushIntegerTree(FindSize(tokenno, op1t)) ;
|
|
IF Less(tokenno)
|
|
THEN
|
|
(* there is room for the extra <nul> character *)
|
|
length := BuildAdd(location, FindSize(tokenno, op3), GetIntegerOne(location), FALSE)
|
|
ELSE
|
|
PushIntegerTree(FindSize(tokenno, op3)) ;
|
|
PushIntegerTree(FindSize(tokenno, op1t)) ;
|
|
IF Gre (tokenno)
|
|
THEN
|
|
WarnStringAt (InitString('string constant is too large to be assigned to the array'),
|
|
tokenno) ;
|
|
length := FindSize (tokenno, op1t)
|
|
ELSE
|
|
(* equal so return max characters in the array *)
|
|
length := FindSize (tokenno, op1t)
|
|
END
|
|
END
|
|
END DoCopyString ;
|
|
|
|
|
|
(*
|
|
checkArrayElements - return TRUE if op1 or op3 are not arrays.
|
|
If they are arrays and have different number of
|
|
elements return FALSE, otherwise TRUE.
|
|
*)
|
|
|
|
PROCEDURE checkArrayElements (op1, op3: CARDINAL) : BOOLEAN ;
|
|
VAR
|
|
e1, e3 : Tree ;
|
|
t1, t3 : CARDINAL ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
t1 := GetType(op1) ;
|
|
t3 := GetType(op3) ;
|
|
IF (t1#NulSym) AND (t3#NulSym) AND
|
|
IsArray(SkipType(GetType(op3))) AND IsArray(SkipType(GetType(op1)))
|
|
THEN
|
|
(* both arrays continue checking *)
|
|
e1 := GetArrayNoOfElements(location, Mod2Gcc(SkipType(GetType(op1)))) ;
|
|
e3 := GetArrayNoOfElements(location, Mod2Gcc(SkipType(GetType(op3)))) ;
|
|
IF CompareTrees(e1, e3)#0
|
|
THEN
|
|
MetaErrorT2(CurrentQuadToken, 'not allowed to assign array {%2Ead} to {%1ad} as they have a different number of elements',
|
|
op1, op3) ;
|
|
RETURN( FALSE )
|
|
END
|
|
END ;
|
|
RETURN( TRUE )
|
|
END checkArrayElements ;
|
|
|
|
|
|
(*
|
|
CodeInitAddress -
|
|
*)
|
|
|
|
PROCEDURE CodeInitAddress (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
DeclareConstant (CurrentQuadToken, op3) ; (* checks to see whether it is a constant and declares it *)
|
|
DeclareConstructor (CurrentQuadToken, quad, op3) ;
|
|
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
Assert (op2 = NulSym) ;
|
|
Assert (GetMode (op1) = LeftValue) ;
|
|
BuildAssignmentStatement (location,
|
|
Mod2Gcc (op1),
|
|
BuildConvert (location, GetPointerType (), Mod2Gcc (op3), FALSE))
|
|
END CodeInitAddress ;
|
|
|
|
|
|
(*
|
|
checkRecordTypes - returns TRUE if op1 is not a record or if the record
|
|
is the same type as op2.
|
|
*)
|
|
|
|
PROCEDURE checkRecordTypes (op1, op2: CARDINAL) : BOOLEAN ;
|
|
VAR
|
|
t1, t2: CARDINAL ;
|
|
BEGIN
|
|
IF (GetType(op1)=NulSym) OR (GetMode(op1)=LeftValue)
|
|
THEN
|
|
RETURN( TRUE )
|
|
ELSE
|
|
t1 := SkipType(GetType(op1)) ;
|
|
IF IsRecord(t1)
|
|
THEN
|
|
IF GetType(op2)=NulSym
|
|
THEN
|
|
MetaErrorT2 (CurrentQuadToken, 'cannot assign an operand of type {%1Ets} to a record type {%2tsa}', op2, op1) ;
|
|
RETURN( FALSE )
|
|
ELSE
|
|
t2 := SkipType(GetType(op2)) ;
|
|
IF t1=t2
|
|
THEN
|
|
RETURN( TRUE )
|
|
ELSE
|
|
MetaErrorT2 (CurrentQuadToken, 'cannot assign an operand of type {%1ts} to a record type {%2tsa}', op2, op1) ;
|
|
RETURN( FALSE )
|
|
END
|
|
END
|
|
END
|
|
END ;
|
|
RETURN( TRUE )
|
|
END checkRecordTypes ;
|
|
|
|
|
|
(*
|
|
checkIncorrectMeta -
|
|
*)
|
|
|
|
PROCEDURE checkIncorrectMeta (op1, op2: CARDINAL) : BOOLEAN ;
|
|
VAR
|
|
t1, t2: CARDINAL ;
|
|
BEGIN
|
|
t1 := SkipType(GetType(op1)) ;
|
|
t2 := SkipType(GetType(op2)) ;
|
|
IF (t1=NulSym) OR (GetMode(op1)=LeftValue) OR
|
|
(t2=NulSym) OR (GetMode(op2)=LeftValue)
|
|
THEN
|
|
RETURN( TRUE )
|
|
ELSIF (t1#t2) AND (NOT IsGenericSystemType(t1)) AND (NOT IsGenericSystemType(t2))
|
|
THEN
|
|
IF IsArray(t1) OR IsSet(t1) OR IsRecord(t1)
|
|
THEN
|
|
IF NOT IsAssignmentCompatible(t1, t2)
|
|
THEN
|
|
MetaErrorT2 (CurrentQuadToken, 'illegal assignment error between {%1Etad} and {%2tad}', op1, op2) ;
|
|
RETURN( FALSE )
|
|
END
|
|
END
|
|
END ;
|
|
RETURN( TRUE )
|
|
END checkIncorrectMeta ;
|
|
|
|
|
|
(*
|
|
checkBecomes - returns TRUE if the checks pass.
|
|
*)
|
|
|
|
PROCEDURE checkBecomes (des, expr: CARDINAL) : BOOLEAN ;
|
|
BEGIN
|
|
IF (NOT checkArrayElements (des, expr)) OR
|
|
(NOT checkRecordTypes (des, expr)) OR
|
|
(NOT checkIncorrectMeta (des, expr))
|
|
THEN
|
|
RETURN FALSE
|
|
END ;
|
|
RETURN TRUE
|
|
END checkBecomes ;
|
|
|
|
|
|
(*
|
|
checkDeclare - checks to see if sym is declared and if it is not then declare it.
|
|
*)
|
|
|
|
PROCEDURE checkDeclare (sym: CARDINAL) ;
|
|
BEGIN
|
|
IF IsTemporary (sym) AND IsVariableSSA (sym) AND (NOT GccKnowsAbout (sym))
|
|
THEN
|
|
DeclareLocalVariable (sym)
|
|
END
|
|
END checkDeclare ;
|
|
|
|
|
|
(*
|
|
------------------------------------------------------------------------------
|
|
:= Operator
|
|
------------------------------------------------------------------------------
|
|
Sym1<I> := Sym3<I> := produces a constant
|
|
Sym1<O> := Sym3<O> := has the effect Mem[Sym1<I>] := Mem[Sym3<I>]
|
|
*)
|
|
|
|
PROCEDURE CodeBecomes (quad: CARDINAL) ;
|
|
VAR
|
|
op : QuadOperator ;
|
|
op1, op2,
|
|
op3 : CARDINAL ;
|
|
becomespos,
|
|
op1pos,
|
|
op2pos,
|
|
op3pos : CARDINAL ;
|
|
length,
|
|
op3t : Tree ;
|
|
location : location_t ;
|
|
BEGIN
|
|
GetQuadOtok (quad, becomespos, op, op1, op2, op3, op1pos, op2pos, op3pos) ;
|
|
DeclareConstant (CurrentQuadToken, op3) ; (* checks to see whether it is a constant and declares it *)
|
|
DeclareConstructor (CurrentQuadToken, quad, op3) ;
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
IF StrictTypeChecking AND
|
|
(NOT AssignmentTypeCompatible (CurrentQuadToken, "", op1, op3))
|
|
THEN
|
|
MetaErrorT2 (MakeVirtualTok (becomespos, op1pos, op3pos),
|
|
'assignment check caught mismatch between {%1Ead} and {%2ad}',
|
|
op1, op3)
|
|
END ;
|
|
IF IsConst (op1) AND (NOT GccKnowsAbout (op1))
|
|
THEN
|
|
ConstantKnownAndUsed (op1, CheckConstant (CurrentQuadToken, op1, op3))
|
|
ELSIF IsConstString (op3) AND (SkipTypeAndSubrange (GetType (op1)) # Char)
|
|
THEN
|
|
checkDeclare (op1) ;
|
|
DoCopyString (CurrentQuadToken, length, op3t, SkipType (GetType (op1)), op3) ;
|
|
AddStatement (location,
|
|
MaybeDebugBuiltinMemcpy (location, CurrentQuadToken,
|
|
BuildAddr (location, Mod2Gcc (op1), FALSE),
|
|
BuildAddr (location, op3t, FALSE),
|
|
length))
|
|
ELSE
|
|
IF ((IsGenericSystemType(SkipType(GetType(op1))) #
|
|
IsGenericSystemType(SkipType(GetType(op3)))) OR
|
|
(IsUnbounded(SkipType(GetType(op1))) AND
|
|
IsUnbounded(SkipType(GetType(op3))) AND
|
|
(IsGenericSystemType(SkipType(GetType(GetType(op1)))) #
|
|
IsGenericSystemType(SkipType(GetType(GetType(op3))))))) AND
|
|
(NOT IsConstant(op3))
|
|
THEN
|
|
checkDeclare (op1) ;
|
|
AddStatement (location,
|
|
MaybeDebugBuiltinMemcpy (location, CurrentQuadToken,
|
|
BuildAddr(location, Mod2Gcc (op1), FALSE),
|
|
BuildAddr(location, Mod2Gcc (op3), FALSE),
|
|
BuildSize(location, Mod2Gcc (op1), FALSE)))
|
|
ELSE
|
|
IF checkBecomes (op1, op3)
|
|
THEN
|
|
IF IsVariableSSA (op1)
|
|
THEN
|
|
Replace (op1, FoldConstBecomes (CurrentQuadToken, op1, op3))
|
|
ELSE
|
|
BuildAssignmentStatement (location,
|
|
Mod2Gcc (op1),
|
|
FoldConstBecomes (CurrentQuadToken, op1, op3))
|
|
END
|
|
ELSE
|
|
SubQuad (quad) (* we don't want multiple errors for the quad. *)
|
|
END
|
|
END
|
|
END
|
|
END CodeBecomes ;
|
|
|
|
|
|
(*
|
|
LValueToGenericPtr - returns a Tree representing symbol, sym.
|
|
It coerces a lvalue into an internal pointer type
|
|
*)
|
|
|
|
PROCEDURE LValueToGenericPtr (location: location_t; sym: CARDINAL) : Tree ;
|
|
VAR
|
|
t: Tree ;
|
|
BEGIN
|
|
t := Mod2Gcc (sym) ;
|
|
IF t = NIL
|
|
THEN
|
|
InternalError ('expecting symbol to be resolved')
|
|
END ;
|
|
IF GetMode (sym) = LeftValue
|
|
THEN
|
|
t := BuildConvert (location, GetPointerType (), t, FALSE)
|
|
END ;
|
|
RETURN t
|
|
END LValueToGenericPtr ;
|
|
|
|
|
|
(*
|
|
LValueToGenericPtrOrConvert - if sym is an lvalue then convert to pointer type
|
|
else convert to type, type. Return the converted tree.
|
|
*)
|
|
|
|
PROCEDURE LValueToGenericPtrOrConvert (sym: CARDINAL; type: Tree) : Tree ;
|
|
VAR
|
|
n : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
n := Mod2Gcc (sym) ;
|
|
location := TokenToLocation (GetDeclaredMod (sym)) ;
|
|
IF n = NIL
|
|
THEN
|
|
InternalError ('expecting symbol to be resolved')
|
|
END ;
|
|
IF GetMode (sym) = LeftValue
|
|
THEN
|
|
n := BuildConvert (location, GetPointerType (), n, FALSE)
|
|
ELSE
|
|
n := BuildConvert (location, type, n, FALSE)
|
|
END ;
|
|
RETURN n
|
|
END LValueToGenericPtrOrConvert ;
|
|
|
|
|
|
(*
|
|
ZConstToTypedConst - checks whether op1 and op2 are constants and
|
|
coerces, t, appropriately.
|
|
*)
|
|
|
|
PROCEDURE ZConstToTypedConst (t: Tree; op1, op2: CARDINAL) : Tree ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(GetDeclaredMod(op2)) ;
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
(* leave, Z type, alone *)
|
|
RETURN( t )
|
|
ELSIF IsConst(op1)
|
|
THEN
|
|
IF GetMode(op2)=LeftValue
|
|
THEN
|
|
(* convert, Z type const into type of non constant operand *)
|
|
RETURN( BuildConvert(location, GetPointerType(), t, FALSE) )
|
|
ELSE
|
|
(* convert, Z type const into type of non constant operand *)
|
|
RETURN( BuildConvert(location, Mod2Gcc(FindType(op2)), t, FALSE) )
|
|
END
|
|
ELSIF IsConst(op2)
|
|
THEN
|
|
IF GetMode(op1)=LeftValue
|
|
THEN
|
|
(* convert, Z type const into type of non constant operand *)
|
|
RETURN( BuildConvert(location, GetPointerType(), t, FALSE) )
|
|
ELSE
|
|
(* convert, Z type const into type of non constant operand *)
|
|
RETURN( BuildConvert(location, Mod2Gcc(FindType(op1)), t, FALSE) )
|
|
END
|
|
ELSE
|
|
(* neither operands are constants, leave alone *)
|
|
RETURN( t )
|
|
END
|
|
END ZConstToTypedConst ;
|
|
|
|
|
|
(*
|
|
FoldBinary - check whether we can fold the binop operation.
|
|
*)
|
|
|
|
PROCEDURE FoldBinary (tokenno: CARDINAL; p: WalkAction; binop: BuildBinProcedure;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
tl, tr, tv, resType: Tree ;
|
|
location : location_t ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
TryDeclareConstant(tokenno, op3) ;
|
|
TryDeclareConstant(tokenno, op2) ;
|
|
location := TokenToLocation(tokenno) ;
|
|
IF IsConst(op2) AND IsConst(op3)
|
|
THEN
|
|
IF GccKnowsAbout(op2) AND GccKnowsAbout(op3)
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
IF IsConst(op1)
|
|
THEN
|
|
Assert(MixTypes(FindType(op3), FindType(op2), tokenno)#NulSym) ;
|
|
PutConst(op1, MixTypes(FindType(op3), FindType(op2), tokenno)) ;
|
|
|
|
tl := LValueToGenericPtr(location, op2) ;
|
|
tr := LValueToGenericPtr(location, op3) ;
|
|
|
|
IF GetType(op1)=NulSym
|
|
THEN
|
|
resType := GetM2ZType()
|
|
ELSE
|
|
resType := Mod2Gcc(GetType(op1))
|
|
END ;
|
|
|
|
tl := BuildConvert(location, resType, tl, FALSE) ;
|
|
tr := BuildConvert(location, resType, tr, FALSE) ;
|
|
|
|
tv := binop(location, tl, tr, TRUE) ;
|
|
CheckOrResetOverflow(tokenno, tv, MustCheckOverflow(quad)) ;
|
|
|
|
AddModGcc(op1, DeclareKnownConstant(location, resType, tv)) ;
|
|
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
ELSE
|
|
(* we can still fold the expression, but not the assignment,
|
|
however, we will not do this here but in CodeBinary
|
|
*)
|
|
END
|
|
END
|
|
END
|
|
END FoldBinary ;
|
|
|
|
|
|
(*
|
|
ConvertBinaryOperands -
|
|
*)
|
|
|
|
PROCEDURE ConvertBinaryOperands (location: location_t; VAR tl, tr: Tree; type, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
tl := NIL ;
|
|
tr := NIL ;
|
|
IF GetMode(op2)=LeftValue
|
|
THEN
|
|
tl := LValueToGenericPtr(location, op2) ;
|
|
type := Address
|
|
END ;
|
|
IF GetMode(op3)=LeftValue
|
|
THEN
|
|
tr := LValueToGenericPtr(location, op3) ;
|
|
type := Address
|
|
END ;
|
|
IF (tl=NIL) AND (tr=NIL)
|
|
THEN
|
|
tl := BuildConvert(location, Mod2Gcc(type), Mod2Gcc(op2), FALSE) ;
|
|
tr := BuildConvert(location, Mod2Gcc(type), Mod2Gcc(op3), FALSE)
|
|
ELSIF tl=NIL
|
|
THEN
|
|
tl := BuildConvert(location, Mod2Gcc(type), Mod2Gcc(op2), FALSE)
|
|
ELSIF tr=NIL
|
|
THEN
|
|
tr := BuildConvert(location, Mod2Gcc(type), Mod2Gcc(op3), FALSE)
|
|
END
|
|
END ConvertBinaryOperands ;
|
|
|
|
|
|
(*
|
|
CodeBinaryCheck - encode a binary arithmetic operation.
|
|
*)
|
|
|
|
PROCEDURE CodeBinaryCheck (binop: BuildBinCheckProcedure; quad: CARDINAL) ;
|
|
VAR
|
|
op : QuadOperator ;
|
|
op1, op2,
|
|
op3 : CARDINAL ;
|
|
op1pos,
|
|
op2pos,
|
|
op3pos,
|
|
lowestType,
|
|
type : CARDINAL ;
|
|
min, max,
|
|
lowest,
|
|
tv,
|
|
tl, tr : Tree ;
|
|
location : location_t ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared. *)
|
|
GetQuadtok (quad, op, op1, op2, op3, op1pos, op2pos, op3pos) ;
|
|
DeclareConstant (op3pos, op3) ;
|
|
DeclareConstant (op2pos, op2) ;
|
|
location := TokenToLocation (op1pos) ;
|
|
|
|
type := MixTypes (FindType (op2), FindType (op3), op3pos) ;
|
|
ConvertBinaryOperands (location, tl, tr, type, op2, op3) ;
|
|
|
|
lowestType := GetLType (op1) ;
|
|
lowest := Mod2Gcc (lowestType) ;
|
|
IF GetMinMax (CurrentQuadToken, lowestType, min, max)
|
|
THEN
|
|
tv := binop (location, tl, tr, lowest, min, max)
|
|
ELSE
|
|
tv := binop (location, tl, tr, NIL, NIL, NIL)
|
|
END ;
|
|
CheckOrResetOverflow (op1pos, tv, MustCheckOverflow (quad)) ;
|
|
IF IsConst (op1)
|
|
THEN
|
|
(* still have a constant which was not resolved, pass it to gcc. *)
|
|
Assert (MixTypes (FindType (op3), FindType (op2), op3pos) # NulSym) ;
|
|
|
|
PutConst (op1, MixTypes (FindType (op3), FindType (op2), op3pos)) ;
|
|
ConstantKnownAndUsed (op1, DeclareKnownConstant (location, Mod2Gcc (GetType (op3)), tv))
|
|
ELSE
|
|
IF EnableSSA AND IsVariableSSA (op1)
|
|
THEN
|
|
Replace (op1, tv)
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (op1), tv)
|
|
END
|
|
END
|
|
END CodeBinaryCheck ;
|
|
|
|
|
|
(*
|
|
CodeBinary - encode a binary arithmetic operation.
|
|
*)
|
|
|
|
PROCEDURE CodeBinary (binop: BuildBinProcedure; quad: CARDINAL) ;
|
|
VAR
|
|
op : QuadOperator ;
|
|
op1, op2,
|
|
op3 : CARDINAL ;
|
|
op1pos,
|
|
op2pos,
|
|
op3pos,
|
|
type : CARDINAL ;
|
|
tv,
|
|
tl, tr : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
GetQuadtok (quad, op, op1, op2, op3, op1pos, op2pos, op3pos) ;
|
|
DeclareConstant (op3pos, op3) ;
|
|
DeclareConstant (op2pos, op2) ;
|
|
location := TokenToLocation (op1pos) ;
|
|
|
|
type := MixTypes (FindType (op2), FindType (op3), op1pos) ;
|
|
ConvertBinaryOperands (location, tl, tr, type, op2, op3) ;
|
|
|
|
tv := binop (location, tl, tr, FALSE) ;
|
|
CheckOrResetOverflow (op1pos, tv, MustCheckOverflow(quad)) ;
|
|
IF IsConst (op1)
|
|
THEN
|
|
(* still have a constant which was not resolved, pass it to gcc *)
|
|
Assert(MixTypes(FindType(op3), FindType(op2), op1pos)#NulSym) ;
|
|
|
|
PutConst (op1, MixTypes (FindType (op3), FindType (op2), op1pos)) ;
|
|
ConstantKnownAndUsed (op1, DeclareKnownConstant (location, Mod2Gcc(GetType(op3)), tv))
|
|
ELSE
|
|
IF EnableSSA AND IsVariableSSA (op1)
|
|
THEN
|
|
Replace (op1, tv)
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (op1), tv)
|
|
END
|
|
END
|
|
END CodeBinary ;
|
|
|
|
|
|
(*
|
|
CodeBinarySet - encode a binary set arithmetic operation.
|
|
Set operands may be longer than a word.
|
|
*)
|
|
|
|
PROCEDURE CodeBinarySet (binop: BuildBinProcedure; doOp: DoProcedure;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
DeclareConstant(CurrentQuadToken, op3) ;
|
|
DeclareConstant(CurrentQuadToken, op2) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op3) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op2) ;
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsConst(op1)
|
|
THEN
|
|
IF IsValueSolved(op2) AND IsValueSolved(op3)
|
|
THEN
|
|
Assert(MixTypes(FindType(op3), FindType(op2), CurrentQuadToken)#NulSym) ;
|
|
PutConst(op1, FindType(op3)) ;
|
|
PushValue(op2) ;
|
|
PushValue(op3) ;
|
|
doOp(CurrentQuadToken) ;
|
|
PopValue(op1) ;
|
|
PutConstSet(op1) ;
|
|
ELSE
|
|
MetaErrorT0 (CurrentQuadToken,
|
|
'{%E}constant expression cannot be evaluated')
|
|
END
|
|
ELSE
|
|
checkDeclare (op1) ;
|
|
BuildBinaryForeachWordDo(location,
|
|
Mod2Gcc(SkipType(GetType(op1))),
|
|
Mod2Gcc(op1), Mod2Gcc(op2), Mod2Gcc(op3), binop,
|
|
GetMode(op1)=LeftValue,
|
|
GetMode(op2)=LeftValue,
|
|
GetMode(op3)=LeftValue,
|
|
IsConst(op1),
|
|
IsConst(op2),
|
|
IsConst(op3))
|
|
END
|
|
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
|
|
binary operator: + - / * and friends. If FALSE
|
|
is returned, an error message will be generated
|
|
and the, quad, is deleted.
|
|
*)
|
|
|
|
PROCEDURE BinaryOperands (quad: CARDINAL; l, r: CARDINAL) : BOOLEAN ;
|
|
VAR
|
|
result: BOOLEAN ;
|
|
BEGIN
|
|
result := CheckBinaryOperand (quad, TRUE, l, TRUE) ;
|
|
result := CheckBinaryOperand (quad, FALSE, r, result) ;
|
|
IF NOT result
|
|
THEN
|
|
SubQuad (quad) (* We do not want multiple copies of the same error. *)
|
|
END ;
|
|
RETURN result
|
|
END BinaryOperands ;
|
|
|
|
|
|
(*
|
|
FoldAdd - check addition for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldAdd (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
s: String ;
|
|
BEGIN
|
|
IF IsConst(op2) AND IsConst(op3) AND IsConst(op3) AND
|
|
IsConstString(op2) AND IsConstString(op3)
|
|
THEN
|
|
(* handle special addition for constant strings *)
|
|
s := InitStringCharStar(KeyToCharStar(GetString(op2))) ;
|
|
s := ConCat(s, Mark(InitStringCharStar(KeyToCharStar(GetString(op3))))) ;
|
|
PutConstString(tokenno, op1, makekey(string(s))) ;
|
|
TryDeclareConstant(tokenno, op1) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad) ;
|
|
s := KillString(s)
|
|
ELSE
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
FoldBinary (tokenno, p, BuildAdd, quad, op1, op2, op3)
|
|
END
|
|
END
|
|
END FoldAdd ;
|
|
|
|
|
|
(*
|
|
CodeAddChecked - code an addition instruction, determine whether checking
|
|
is required.
|
|
*)
|
|
|
|
PROCEDURE CodeAddChecked (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF MustCheckOverflow (quad)
|
|
THEN
|
|
CodeAddCheck (quad, left, right)
|
|
ELSE
|
|
CodeAdd (quad, left, right)
|
|
END
|
|
END CodeAddChecked ;
|
|
|
|
|
|
(*
|
|
CodeAddCheck - encode addition but check for overflow.
|
|
*)
|
|
|
|
PROCEDURE CodeAddCheck (quad, left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinaryCheck (BuildAddCheck, quad)
|
|
END
|
|
END CodeAddCheck ;
|
|
|
|
|
|
(*
|
|
CodeAdd - encode addition.
|
|
*)
|
|
|
|
PROCEDURE CodeAdd (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinary (BuildAdd, quad)
|
|
END
|
|
END CodeAdd ;
|
|
|
|
|
|
(*
|
|
FoldSub - check subtraction for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldSub (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
FoldBinary(tokenno, p, BuildSub, quad, op1, op2, op3)
|
|
END
|
|
END FoldSub ;
|
|
|
|
|
|
(*
|
|
CodeSubChecked - code a subtract instruction, determine whether checking
|
|
is required.
|
|
*)
|
|
|
|
PROCEDURE CodeSubChecked (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF MustCheckOverflow (quad)
|
|
THEN
|
|
CodeSubCheck (quad, left, right)
|
|
ELSE
|
|
CodeSub (quad, left, right)
|
|
END
|
|
END CodeSubChecked ;
|
|
|
|
|
|
(*
|
|
CodeSubCheck - encode subtraction but check for overflow.
|
|
*)
|
|
|
|
PROCEDURE CodeSubCheck (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinaryCheck (BuildSubCheck, quad)
|
|
END
|
|
END CodeSubCheck ;
|
|
|
|
|
|
(*
|
|
CodeSub - encode subtraction.
|
|
*)
|
|
|
|
PROCEDURE CodeSub (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinary (BuildSub, quad)
|
|
END
|
|
END CodeSub ;
|
|
|
|
|
|
(*
|
|
FoldMult - check multiplication for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldMult (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
FoldBinary(tokenno, p, BuildMult, quad, op1, op2, op3)
|
|
END
|
|
END FoldMult ;
|
|
|
|
|
|
(*
|
|
CodeMultChecked - code a multiplication instruction, determine whether checking
|
|
is required.
|
|
*)
|
|
|
|
PROCEDURE CodeMultChecked (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF MustCheckOverflow (quad)
|
|
THEN
|
|
CodeMultCheck (quad, left, right)
|
|
ELSE
|
|
CodeMult (quad, left, right)
|
|
END
|
|
END CodeMultChecked ;
|
|
|
|
|
|
(*
|
|
CodeMultCheck - encode multiplication but check for overflow.
|
|
*)
|
|
|
|
PROCEDURE CodeMultCheck (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinaryCheck (BuildMultCheck, quad)
|
|
END
|
|
END CodeMultCheck ;
|
|
|
|
|
|
(*
|
|
CodeMult - encode multiplication.
|
|
*)
|
|
|
|
PROCEDURE CodeMult (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinary (BuildMult, quad)
|
|
END
|
|
END CodeMult ;
|
|
|
|
|
|
(*
|
|
CodeDivM2Checked - code a divide instruction, determine whether checking
|
|
is required.
|
|
*)
|
|
|
|
PROCEDURE CodeDivM2Checked (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF MustCheckOverflow (quad)
|
|
THEN
|
|
CodeDivM2Check (quad, left, right)
|
|
ELSE
|
|
CodeDivM2 (quad, left, right)
|
|
END
|
|
END CodeDivM2Checked ;
|
|
|
|
|
|
(*
|
|
CodeDivM2Check - encode addition but check for overflow.
|
|
*)
|
|
|
|
PROCEDURE CodeDivM2Check (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinaryCheck (BuildDivM2Check, quad)
|
|
END
|
|
END CodeDivM2Check ;
|
|
|
|
|
|
(*
|
|
CodeModM2Checked - code a modulus instruction, determine whether checking
|
|
is required.
|
|
*)
|
|
|
|
PROCEDURE CodeModM2Checked (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF MustCheckOverflow (quad)
|
|
THEN
|
|
CodeModM2Check (quad, left, right)
|
|
ELSE
|
|
CodeModM2 (quad, left, right)
|
|
END
|
|
END CodeModM2Checked ;
|
|
|
|
|
|
(*
|
|
CodeModM2Check - encode addition but check for overflow.
|
|
*)
|
|
|
|
PROCEDURE CodeModM2Check (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinaryCheck (BuildModM2Check, quad)
|
|
END
|
|
END CodeModM2Check ;
|
|
|
|
|
|
(*
|
|
BinaryOperandRealFamily -
|
|
*)
|
|
|
|
PROCEDURE BinaryOperandRealFamily (op: CARDINAL) : BOOLEAN ;
|
|
VAR
|
|
t: CARDINAL ;
|
|
BEGIN
|
|
t := SkipType(GetType(op)) ;
|
|
RETURN( IsComplexType(t) OR IsComplexN(t) OR
|
|
IsRealType(t) OR IsRealN(t) )
|
|
END BinaryOperandRealFamily ;
|
|
|
|
|
|
(*
|
|
FoldDivM2 - check division for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldDivM2 (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3)
|
|
THEN
|
|
FoldBinary(tokenno, p, BuildRDiv, quad, op1, op2, op3)
|
|
ELSE
|
|
FoldBinary(tokenno, p, BuildDivM2, quad, op1, op2, op3)
|
|
END
|
|
END
|
|
END FoldDivM2 ;
|
|
|
|
|
|
(*
|
|
CodeDivM2 - encode division.
|
|
*)
|
|
|
|
PROCEDURE CodeDivM2 (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
IF BinaryOperandRealFamily (left) OR BinaryOperandRealFamily (right)
|
|
THEN
|
|
CodeBinary (BuildRDiv, quad)
|
|
ELSE
|
|
CodeBinary (BuildDivM2, quad)
|
|
END
|
|
END
|
|
END CodeDivM2 ;
|
|
|
|
|
|
(*
|
|
FoldModM2 - check modulus for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldModM2 (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
FoldBinary(tokenno, p, BuildModM2, quad, op1, op2, op3)
|
|
END
|
|
END FoldModM2 ;
|
|
|
|
|
|
(*
|
|
CodeModM2 - encode modulus.
|
|
*)
|
|
|
|
PROCEDURE CodeModM2 (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinary (BuildModM2, quad)
|
|
END
|
|
END CodeModM2 ;
|
|
|
|
|
|
(*
|
|
FoldDivTrunc - check division for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldDivTrunc (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3)
|
|
THEN
|
|
FoldBinary(tokenno, p, BuildRDiv, quad, op1, op2, op3)
|
|
ELSE
|
|
FoldBinary(tokenno, p, BuildDivTrunc, quad, op1, op2, op3)
|
|
END
|
|
END
|
|
END FoldDivTrunc ;
|
|
|
|
|
|
(*
|
|
CodeDivTrunc - encode multiplication.
|
|
*)
|
|
|
|
PROCEDURE CodeDivTrunc (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
IF BinaryOperandRealFamily (left) OR BinaryOperandRealFamily (right)
|
|
THEN
|
|
CodeBinary (BuildRDiv, quad)
|
|
ELSE
|
|
CodeBinary (BuildDivTrunc, quad)
|
|
END
|
|
END
|
|
END CodeDivTrunc ;
|
|
|
|
|
|
(*
|
|
FoldModTrunc - check modulus for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldModTrunc (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
FoldBinary(tokenno, p, BuildModTrunc, quad, op1, op2, op3)
|
|
END
|
|
END FoldModTrunc ;
|
|
|
|
|
|
(*
|
|
CodeModTrunc - encode modulus.
|
|
*)
|
|
|
|
PROCEDURE CodeModTrunc (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinary (BuildModTrunc, quad)
|
|
END
|
|
END CodeModTrunc ;
|
|
|
|
|
|
(*
|
|
FoldDivCeil - check division for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldDivCeil (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3)
|
|
THEN
|
|
FoldBinary(tokenno, p, BuildRDiv, quad, op1, op2, op3)
|
|
ELSE
|
|
FoldBinary(tokenno, p, BuildDivCeil, quad, op1, op2, op3)
|
|
END
|
|
END
|
|
END FoldDivCeil ;
|
|
|
|
|
|
(*
|
|
CodeDivCeil - encode multiplication.
|
|
*)
|
|
|
|
PROCEDURE CodeDivCeil (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
IF BinaryOperandRealFamily (left) OR BinaryOperandRealFamily (right)
|
|
THEN
|
|
CodeBinary (BuildRDiv, quad)
|
|
ELSE
|
|
CodeBinary (BuildDivCeil, quad)
|
|
END
|
|
END
|
|
END CodeDivCeil ;
|
|
|
|
|
|
(*
|
|
FoldModCeil - check modulus for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldModCeil (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
FoldBinary(tokenno, p, BuildModCeil, quad, op1, op2, op3)
|
|
END
|
|
END FoldModCeil ;
|
|
|
|
|
|
(*
|
|
CodeModCeil - encode multiplication.
|
|
*)
|
|
|
|
PROCEDURE CodeModCeil (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinary (BuildModCeil, quad)
|
|
END
|
|
END CodeModCeil ;
|
|
|
|
|
|
(*
|
|
FoldDivFloor - check division for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldDivFloor (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
IF BinaryOperandRealFamily(op2) OR BinaryOperandRealFamily(op3)
|
|
THEN
|
|
FoldBinary(tokenno, p, BuildRDiv, quad, op1, op2, op3)
|
|
ELSE
|
|
FoldBinary(tokenno, p, BuildDivFloor, quad, op1, op2, op3)
|
|
END
|
|
END
|
|
END FoldDivFloor ;
|
|
|
|
|
|
(*
|
|
CodeDivFloor - encode multiplication.
|
|
*)
|
|
|
|
PROCEDURE CodeDivFloor (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
IF BinaryOperandRealFamily (left) OR BinaryOperandRealFamily (right)
|
|
THEN
|
|
CodeBinary (BuildRDiv, quad)
|
|
ELSE
|
|
CodeBinary (BuildDivFloor, quad)
|
|
END
|
|
END
|
|
END CodeDivFloor ;
|
|
|
|
|
|
(*
|
|
FoldModFloor - check modulus for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldModFloor (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, op2, op3)
|
|
THEN
|
|
FoldBinary(tokenno, p, BuildModFloor, quad, op1, op2, op3)
|
|
END
|
|
END FoldModFloor ;
|
|
|
|
|
|
(*
|
|
CodeModFloor - encode modulus.
|
|
*)
|
|
|
|
PROCEDURE CodeModFloor (quad: CARDINAL; left, right: CARDINAL) ;
|
|
BEGIN
|
|
IF BinaryOperands (quad, left, right)
|
|
THEN
|
|
CodeBinary (BuildModFloor, quad)
|
|
END
|
|
END CodeModFloor ;
|
|
|
|
|
|
(*
|
|
FoldBuiltinConst -
|
|
*)
|
|
|
|
PROCEDURE FoldBuiltinConst (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; result, constDesc: CARDINAL) ;
|
|
VAR
|
|
value: Tree ;
|
|
BEGIN
|
|
value := GetBuiltinConst (KeyToCharStar (Name (constDesc))) ;
|
|
IF value = NIL
|
|
THEN
|
|
MetaErrorT1 (tokenno, 'unknown built in constant {%1Ead}', constDesc)
|
|
ELSE
|
|
AddModGcc (result, value) ;
|
|
p (result) ;
|
|
NoChange := FALSE ;
|
|
SubQuad (quad)
|
|
END
|
|
END FoldBuiltinConst ;
|
|
|
|
|
|
(*
|
|
FoldBuiltinTypeInfo - attempts to fold a builtin attribute value on type op2.
|
|
*)
|
|
|
|
PROCEDURE FoldBuiltinTypeInfo (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
t : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
IF GccKnowsAbout(op2) AND CompletelyResolved(op2)
|
|
THEN
|
|
location := TokenToLocation(tokenno) ;
|
|
t := GetBuiltinTypeInfo(location, Mod2Gcc(op2), KeyToCharStar(Name(op3))) ;
|
|
IF t=NIL
|
|
THEN
|
|
MetaErrorT2 (tokenno, 'unknown built in constant {%1Ead} attribute for type {%2ad}', op3, op2)
|
|
ELSE
|
|
AddModGcc(op1, t) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
END
|
|
END FoldBuiltinTypeInfo ;
|
|
|
|
|
|
(*
|
|
FoldStandardFunction - attempts to fold a standard function.
|
|
*)
|
|
|
|
PROCEDURE FoldStandardFunction (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
s : String ;
|
|
type,
|
|
d,
|
|
result : CARDINAL ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
IF GetSymName(op2)=MakeKey('Length')
|
|
THEN
|
|
TryDeclareConstant(tokenno, op3) ;
|
|
IF IsConst(op3) AND GccKnowsAbout(op3)
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
IF IsConst(op1)
|
|
THEN
|
|
IF IsConstString(op3)
|
|
THEN
|
|
AddModGcc(op1, FindSize(tokenno, op3)) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
ELSE
|
|
MetaErrorT1 (tokenno, 'parameter to LENGTH must be a string {%1Ead}', op3)
|
|
END
|
|
ELSE
|
|
(* rewrite the quad to use becomes. *)
|
|
d := GetStringLength (op3) ;
|
|
s := Sprintf1 (Mark (InitString ("%d")), d) ;
|
|
result := MakeConstLit (tokenno, makekey (string (s)), Cardinal) ;
|
|
s := KillString (s) ;
|
|
TryDeclareConstant (tokenno, result) ;
|
|
PutQuad (quad, BecomesOp, op1, NulSym, result)
|
|
END
|
|
END
|
|
ELSIF GetSymName(op2)=MakeKey('CAP')
|
|
THEN
|
|
TryDeclareConstant(tokenno, op3) ;
|
|
IF IsConst(op3) AND GccKnowsAbout(op3)
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
IF IsConst(op1)
|
|
THEN
|
|
IF (IsConstString(op3) AND (GetStringLength(op3)=1)) OR
|
|
(GetType(op3)=Char)
|
|
THEN
|
|
AddModGcc(op1, BuildCap(location, Mod2Gcc(op3))) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
ELSE
|
|
MetaErrorT1 (tokenno, 'parameter to CAP must be a single character {%1Ead}', op3)
|
|
END
|
|
END
|
|
END
|
|
ELSIF GetSymName(op2)=MakeKey('ABS')
|
|
THEN
|
|
TryDeclareConstant(tokenno, op3) ;
|
|
IF IsConst(op3) AND GccKnowsAbout(op3)
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
IF IsConst(op1)
|
|
THEN
|
|
AddModGcc(op1, BuildAbs(location, Mod2Gcc(op3))) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
END
|
|
ELSIF op2=Im
|
|
THEN
|
|
TryDeclareConstant(tokenno, op3) ;
|
|
IF IsConst(op3) AND GccKnowsAbout(op3)
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
IF IsConst(op1)
|
|
THEN
|
|
AddModGcc(op1, BuildIm(Mod2Gcc(op3))) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
END
|
|
ELSIF op2=Re
|
|
THEN
|
|
TryDeclareConstant(tokenno, op3) ;
|
|
IF IsConst(op3) AND GccKnowsAbout(op3)
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
IF IsConst(op1)
|
|
THEN
|
|
AddModGcc(op1, BuildRe(Mod2Gcc(op3))) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
END
|
|
ELSIF op2=Cmplx
|
|
THEN
|
|
TryDeclareConstant(tokenno, GetNth(op3, 1)) ;
|
|
TryDeclareConstant(tokenno, GetNth(op3, 2)) ;
|
|
IF IsConst(GetNth(op3, 1)) AND GccKnowsAbout(GetNth(op3, 1)) AND
|
|
IsConst(GetNth(op3, 2)) AND GccKnowsAbout(GetNth(op3, 2))
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
IF IsConst(op1)
|
|
THEN
|
|
type := GetCmplxReturnType(GetType(GetNth(op3, 1)), GetType(GetNth(op3, 2))) ;
|
|
IF type=NulSym
|
|
THEN
|
|
MetaErrorT2 (tokenno, 'real {%1Eatd} and imaginary {%2atd} types are incompatible',
|
|
GetNth(op3, 1), GetNth(op3, 2))
|
|
ELSE
|
|
AddModGcc(op1, BuildCmplx(location,
|
|
Mod2Gcc(type),
|
|
Mod2Gcc(GetNth(op3, 1)),
|
|
Mod2Gcc(GetNth(op3, 2)))) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
END
|
|
END
|
|
ELSIF op2=TBitSize
|
|
THEN
|
|
IF GccKnowsAbout(op3)
|
|
THEN
|
|
AddModGcc(op1, BuildTBitSize(location, Mod2Gcc(op3))) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
ELSE
|
|
InternalError ('only expecting LENGTH, CAP, ABS, IM, RE')
|
|
END
|
|
END FoldStandardFunction ;
|
|
|
|
|
|
(*
|
|
CodeStandardFunction -
|
|
*)
|
|
|
|
PROCEDURE CodeStandardFunction (quad: CARDINAL; result, function, param: CARDINAL) ;
|
|
VAR
|
|
type : CARDINAL ;
|
|
location: location_t ;
|
|
BEGIN
|
|
DeclareConstant (CurrentQuadToken, param) ;
|
|
DeclareConstructor (CurrentQuadToken, quad, param) ;
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
IF (function # NulSym) AND (GetSymName (function) = MakeKey ('Length'))
|
|
THEN
|
|
IF IsConst (result)
|
|
THEN
|
|
InternalError ('LENGTH function should already have been folded')
|
|
END
|
|
ELSIF (function # NulSym) AND (GetSymName (function) = MakeKey ('CAP'))
|
|
THEN
|
|
IF IsConst (result)
|
|
THEN
|
|
InternalError ('CAP function should already have been folded')
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), BuildCap (location, Mod2Gcc (param)))
|
|
END
|
|
ELSIF (function # NulSym) AND (GetSymName (function) = MakeKey('ABS'))
|
|
THEN
|
|
IF IsConst (result)
|
|
THEN
|
|
InternalError ('ABS function should already have been folded')
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), BuildAbs (location, Mod2Gcc (param)))
|
|
END
|
|
ELSIF function = Im
|
|
THEN
|
|
IF IsConst (result)
|
|
THEN
|
|
InternalError ('IM function should already have been folded')
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), BuildIm (Mod2Gcc (param)))
|
|
END
|
|
ELSIF function = Re
|
|
THEN
|
|
IF IsConst (result)
|
|
THEN
|
|
InternalError ('RE function should already have been folded')
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), BuildRe (Mod2Gcc (param)))
|
|
END
|
|
ELSIF function = Cmplx
|
|
THEN
|
|
IF IsConst (result)
|
|
THEN
|
|
InternalError ('CMPLX function should already have been folded')
|
|
ELSE
|
|
type := GetCmplxReturnType (GetType (GetNth (param, 1)), GetType (GetNth (param, 2))) ;
|
|
IF type = NulSym
|
|
THEN
|
|
MetaErrorT2 (CurrentQuadToken,
|
|
'real {%1Eatd} and imaginary {%2atd} types are incompatible',
|
|
GetNth (param, 1), GetNth (param, 2))
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), BuildCmplx(location,
|
|
Mod2Gcc (type),
|
|
Mod2Gcc (GetNth (param, 1)),
|
|
Mod2Gcc (GetNth (param, 2))))
|
|
END
|
|
END
|
|
ELSIF function = TBitSize
|
|
THEN
|
|
IF IsConst (result)
|
|
THEN
|
|
InternalError ('TBITSIZE function should already have been folded')
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), BuildTBitSize (location, Mod2Gcc (param)))
|
|
END
|
|
ELSE
|
|
InternalError ('expecting LENGTH, CAP, ABS, IM')
|
|
END
|
|
END CodeStandardFunction ;
|
|
|
|
|
|
(*
|
|
CodeSavePriority - checks to see whether op2 is reachable and is directly accessible
|
|
externally. If so then it saves the current interrupt priority
|
|
in op1 and sets the current priority to that determined by
|
|
appropriate module.
|
|
|
|
op1 := op3(GetModuleScope(op2))
|
|
*)
|
|
|
|
PROCEDURE CodeSavePriority (oldValue, scopeSym, procedureSym: CARDINAL) ;
|
|
VAR
|
|
funcTree: Tree ;
|
|
mod : CARDINAL ;
|
|
n : Name ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsModule (scopeSym) OR IsDefImp (scopeSym) OR
|
|
(IsProcedure (scopeSym) AND GetNeedSavePriority (scopeSym))
|
|
THEN
|
|
IF IsProcedure (scopeSym)
|
|
THEN
|
|
mod := GetModuleScope (scopeSym) ;
|
|
ELSE
|
|
Assert (IsModule(scopeSym) OR IsDefImp (scopeSym)) ;
|
|
mod := scopeSym
|
|
END ;
|
|
IF GetPriority (mod) # NulSym
|
|
THEN
|
|
IF PriorityDebugging
|
|
THEN
|
|
n := GetSymName (scopeSym) ;
|
|
printf1 ('procedure <%a> needs to save interrupts\n', n)
|
|
END ;
|
|
DeclareConstant (CurrentQuadToken, GetPriority (mod)) ;
|
|
BuildParam (location, Mod2Gcc (GetPriority (mod))) ;
|
|
funcTree := BuildProcedureCallTree (location, Mod2Gcc (procedureSym), Mod2Gcc (GetType (procedureSym))) ;
|
|
funcTree := BuildFunctValue (location, Mod2Gcc (oldValue)) ;
|
|
AddStatement (location, funcTree)
|
|
END
|
|
END
|
|
END CodeSavePriority ;
|
|
|
|
|
|
(*
|
|
CodeRestorePriority - checks to see whether op2 is reachable and is directly accessible
|
|
externally. If so then it restores the previous interrupt priority
|
|
held in op1.
|
|
|
|
op1 := op3(op1)
|
|
*)
|
|
|
|
PROCEDURE CodeRestorePriority (oldValue, scopeSym, procedureSym: CARDINAL) ;
|
|
VAR
|
|
funcTree: Tree ;
|
|
mod : CARDINAL ;
|
|
n : Name ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
IF IsModule (scopeSym) OR IsDefImp (scopeSym) OR
|
|
(IsProcedure (scopeSym) AND GetNeedSavePriority (scopeSym))
|
|
THEN
|
|
IF IsProcedure (scopeSym)
|
|
THEN
|
|
mod := GetModuleScope (scopeSym) ;
|
|
ELSE
|
|
Assert (IsModule (scopeSym) OR IsDefImp (scopeSym)) ;
|
|
mod := scopeSym
|
|
END ;
|
|
IF GetPriority (mod) # NulSym
|
|
THEN
|
|
IF PriorityDebugging
|
|
THEN
|
|
n := GetSymName (scopeSym) ;
|
|
printf1 ('procedure <%a> needs to restore interrupts\n', n)
|
|
END ;
|
|
BuildParam (location, Mod2Gcc (oldValue)) ;
|
|
funcTree := BuildProcedureCallTree (location, Mod2Gcc (procedureSym), Mod2Gcc (GetType (procedureSym))) ;
|
|
funcTree := BuildFunctValue (location, Mod2Gcc (oldValue)) ;
|
|
AddStatement(location, funcTree)
|
|
END
|
|
END
|
|
END CodeRestorePriority ;
|
|
|
|
|
|
(*
|
|
FoldBinarySet - attempts to fold set arithmetic it removes the quad if successful.
|
|
*)
|
|
|
|
PROCEDURE FoldBinarySet (tokenno: CARDINAL; p: WalkAction; op: DoProcedure;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
(* firstly try and ensure that constants are declared *)
|
|
TryDeclareConstant(tokenno, op2) ;
|
|
TryDeclareConstant(tokenno, op3) ;
|
|
location := TokenToLocation(tokenno) ;
|
|
|
|
IF IsConst(op2) AND IsConstSet(op2) AND
|
|
IsConst(op3) AND IsConstSet(op3) AND
|
|
IsConst(op1)
|
|
THEN
|
|
IF IsValueSolved(op2) AND IsValueSolved(op3)
|
|
THEN
|
|
Assert(MixTypes(FindType(op3), FindType(op2), tokenno)#NulSym) ;
|
|
PutConst(op1, MixTypes(FindType(op3), FindType(op2), tokenno)) ;
|
|
PushValue(op2) ;
|
|
PushValue(op3) ;
|
|
op(tokenno) ;
|
|
PopValue(op1) ;
|
|
PushValue(op1) ;
|
|
PutConstSet(op1) ;
|
|
AddModGcc(op1,
|
|
DeclareKnownConstant(location,
|
|
Mod2Gcc(GetType(op3)),
|
|
PopSetTree(tokenno))) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
END
|
|
END FoldBinarySet ;
|
|
|
|
|
|
(*
|
|
FoldSetOr - check whether we can fold a set arithmetic or.
|
|
*)
|
|
|
|
PROCEDURE FoldSetOr (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
FoldBinarySet (tokenno, p, SetOr, quad, op1, op2, op3)
|
|
END FoldSetOr ;
|
|
|
|
|
|
(*
|
|
CodeSetOr - encode set arithmetic or.
|
|
*)
|
|
|
|
PROCEDURE CodeSetOr (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
CodeBinarySet (BuildLogicalOr, SetOr, quad, op1, op2, op3)
|
|
END CodeSetOr ;
|
|
|
|
|
|
(*
|
|
FoldSetAnd - check whether we can fold a logical and.
|
|
*)
|
|
|
|
PROCEDURE FoldSetAnd (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
FoldBinarySet(tokenno, p, SetAnd, quad, op1, op2, op3)
|
|
END FoldSetAnd ;
|
|
|
|
|
|
(*
|
|
CodeSetAnd - encode set arithmetic and.
|
|
*)
|
|
|
|
PROCEDURE CodeSetAnd (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
CodeBinarySet (BuildLogicalAnd, SetAnd, quad, op1, op2, op3)
|
|
END CodeSetAnd ;
|
|
|
|
|
|
(*
|
|
CodeBinarySetShift - encode a binary set arithmetic operation.
|
|
The set maybe larger than a machine word
|
|
and the value of one word may effect the
|
|
values of another - ie shift and rotate.
|
|
Set sizes of a word or less are evaluated
|
|
with binop, whereas multiword sets are
|
|
evaluated by M2RTS.
|
|
*)
|
|
|
|
PROCEDURE CodeBinarySetShift (binop: BuildSetProcedure;
|
|
doOp : DoProcedure;
|
|
var, left, right: Name;
|
|
quad: CARDINAL;
|
|
op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
nBits,
|
|
unbounded,
|
|
leftproc,
|
|
rightproc,
|
|
varproc : Tree ;
|
|
location : location_t ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
DeclareConstant(CurrentQuadToken, op3) ;
|
|
DeclareConstant(CurrentQuadToken, op2) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op3) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op2) ;
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsConst(op1)
|
|
THEN
|
|
IF IsValueSolved(op2) AND IsValueSolved(op3)
|
|
THEN
|
|
Assert(MixTypes(FindType(op3),
|
|
FindType(op2), CurrentQuadToken)#NulSym) ;
|
|
PutConst(op1, FindType(op3)) ;
|
|
PushValue(op2) ;
|
|
PushValue(op3) ;
|
|
doOp(CurrentQuadToken) ;
|
|
PopValue(op1) ;
|
|
PutConstSet(op1)
|
|
ELSE
|
|
MetaErrorT0 (CurrentQuadToken, '{%E}constant expression cannot be evaluated')
|
|
END
|
|
ELSE
|
|
varproc := Mod2Gcc(FromModuleGetSym(CurrentQuadToken, var, System)) ;
|
|
leftproc := Mod2Gcc(FromModuleGetSym(CurrentQuadToken, left, System)) ;
|
|
rightproc := Mod2Gcc(FromModuleGetSym(CurrentQuadToken, right, System)) ;
|
|
unbounded := Mod2Gcc(GetType(GetNthParam(FromModuleGetSym(CurrentQuadToken,
|
|
var, System), 1))) ;
|
|
PushValue(GetTypeMax(SkipType(GetType(op1)))) ;
|
|
PushIntegerTree(BuildConvert(location, GetM2ZType(), PopIntegerTree(), FALSE)) ;
|
|
|
|
PushValue(GetTypeMin(SkipType(GetType(op1)))) ;
|
|
PushIntegerTree(BuildConvert(location, GetM2ZType(), PopIntegerTree(), FALSE)) ;
|
|
Sub ;
|
|
PushCard(1) ;
|
|
PushIntegerTree(BuildConvert(location, GetM2ZType(), PopIntegerTree(), FALSE)) ;
|
|
Addn ;
|
|
nBits := PopIntegerTree() ;
|
|
BuildBinarySetDo(location,
|
|
Mod2Gcc(SkipType(GetType(op1))),
|
|
Mod2Gcc(op1),
|
|
Mod2Gcc(op2),
|
|
Mod2Gcc(op3),
|
|
binop,
|
|
GetMode(op1)=LeftValue,
|
|
GetMode(op2)=LeftValue,
|
|
GetMode(op3)=LeftValue,
|
|
nBits,
|
|
unbounded,
|
|
varproc, leftproc, rightproc)
|
|
END
|
|
END CodeBinarySetShift ;
|
|
|
|
|
|
(*
|
|
FoldSetShift - check whether we can fold a logical shift.
|
|
*)
|
|
|
|
PROCEDURE FoldSetShift (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
FoldBinarySet(tokenno, p, SetShift, quad, op1, op2, op3)
|
|
END FoldSetShift ;
|
|
|
|
|
|
(*
|
|
CodeSetShift - encode set arithmetic shift.
|
|
*)
|
|
|
|
PROCEDURE CodeSetShift (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
CodeBinarySetShift (BuildLogicalShift,
|
|
SetShift,
|
|
MakeKey('ShiftVal'),
|
|
MakeKey('ShiftLeft'),
|
|
MakeKey('ShiftRight'),
|
|
quad, op1, op2, op3)
|
|
END CodeSetShift ;
|
|
|
|
|
|
(*
|
|
FoldSetRotate - check whether we can fold a logical rotate.
|
|
*)
|
|
|
|
PROCEDURE FoldSetRotate (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
FoldBinarySet(tokenno, p, SetRotate, quad, op1, op2, op3)
|
|
END FoldSetRotate ;
|
|
|
|
|
|
(*
|
|
CodeSetRotate - encode set arithmetic rotate.
|
|
*)
|
|
|
|
PROCEDURE CodeSetRotate (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
CodeBinarySetShift (BuildLogicalRotate,
|
|
SetRotate,
|
|
MakeKey ('RotateVal'),
|
|
MakeKey ('RotateLeft'),
|
|
MakeKey ('RotateRight'),
|
|
quad, op1, op2, op3)
|
|
END CodeSetRotate ;
|
|
|
|
|
|
(*
|
|
FoldSetLogicalDifference - check whether we can fold a logical difference.
|
|
*)
|
|
|
|
(*
|
|
PROCEDURE FoldSetLogicalDifference (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
FoldBinarySet(tokenno, p, SetDifference, quad, op1, op2, op3)
|
|
END FoldSetLogicalDifference ;
|
|
*)
|
|
|
|
|
|
(*
|
|
CodeSetLogicalDifference - encode set arithmetic logical difference.
|
|
*)
|
|
|
|
PROCEDURE CodeSetLogicalDifference (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
CodeBinarySet (BuildLogicalDifference, SetDifference,
|
|
quad, op1, op2, op3)
|
|
END CodeSetLogicalDifference ;
|
|
|
|
|
|
(*
|
|
FoldSymmetricDifference - check whether we can fold a logical difference.
|
|
*)
|
|
|
|
PROCEDURE FoldSymmetricDifference (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
FoldBinarySet (tokenno, p, SetSymmetricDifference, quad, op1, op2, op3)
|
|
END FoldSymmetricDifference ;
|
|
|
|
|
|
(*
|
|
CodeSetSymmetricDifference - code set difference.
|
|
*)
|
|
|
|
PROCEDURE CodeSetSymmetricDifference (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
CodeBinarySet (BuildSymmetricDifference, SetSymmetricDifference,
|
|
quad, op1, op2, op3)
|
|
END CodeSetSymmetricDifference ;
|
|
|
|
|
|
(*
|
|
CodeUnarySet - encode a unary set arithmetic operation.
|
|
Set operands may be longer than a word.
|
|
*)
|
|
|
|
PROCEDURE CodeUnarySet (unop: BuildUnarySetFunction; constop: DoUnaryProcedure;
|
|
quad: CARDINAL; result, expr: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
DeclareConstant (CurrentQuadToken, expr) ;
|
|
DeclareConstructor (CurrentQuadToken, quad, expr) ;
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
IF IsConst (result)
|
|
THEN
|
|
IF IsValueSolved (expr)
|
|
THEN
|
|
Assert (FindType (expr) # NulSym) ;
|
|
PutConst (result, FindType (expr)) ;
|
|
PushValue (expr) ;
|
|
constop (CurrentQuadToken) ;
|
|
PopValue (result) ;
|
|
PushValue (result) ;
|
|
PutConstSet (result) ;
|
|
ConstantKnownAndUsed (result,
|
|
DeclareKnownConstant(location,
|
|
Mod2Gcc (GetType (expr)),
|
|
PopSetTree (CurrentQuadToken)))
|
|
ELSE
|
|
MetaErrorT0 (CurrentQuadToken,
|
|
'{%E}constant expression cannot be evaluated')
|
|
END
|
|
ELSE
|
|
checkDeclare (result) ;
|
|
BuildUnaryForeachWordDo (location,
|
|
Mod2Gcc (GetType (result)), Mod2Gcc (result), Mod2Gcc (expr), unop,
|
|
GetMode(result) = LeftValue, GetMode(expr) = LeftValue,
|
|
IsConst (result), IsConst (expr))
|
|
END
|
|
END CodeUnarySet ;
|
|
|
|
|
|
(*
|
|
FoldIncl - check whether we can fold the InclOp.
|
|
result := result + (1 << expr)
|
|
*)
|
|
|
|
PROCEDURE FoldIncl (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; result, expr: CARDINAL) ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
TryDeclareConstant (tokenno, expr) ;
|
|
IF IsConst (result) AND IsConst (expr)
|
|
THEN
|
|
IF GccKnowsAbout (expr) AND IsValueSolved (result)
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
PushValue (result) ;
|
|
AddBit (tokenno, expr) ;
|
|
AddModGcc (result, PopSetTree(tokenno)) ;
|
|
p (result) ;
|
|
NoChange := FALSE ;
|
|
SubQuad (quad)
|
|
END
|
|
END
|
|
END FoldIncl ;
|
|
|
|
|
|
(*
|
|
FoldIfLess - check to see if it is possible to evaluate
|
|
if op1 < op2 then goto op3.
|
|
*)
|
|
|
|
PROCEDURE FoldIfLess (tokenno: CARDINAL;
|
|
quad: CARDINAL; left, right, destQuad: CARDINAL) ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
TryDeclareConstant(tokenno, left) ;
|
|
TryDeclareConstant(tokenno, right) ;
|
|
IF IsConst (left) AND IsConst (right)
|
|
THEN
|
|
IF IsValueSolved (left) AND IsValueSolved (right)
|
|
THEN
|
|
(* fine, we can take advantage of this and evaluate the condition *)
|
|
PushValue (left) ;
|
|
PushValue (right) ;
|
|
IF Less (tokenno)
|
|
THEN
|
|
PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
|
|
ELSE
|
|
SubQuad (quad)
|
|
END
|
|
END
|
|
END
|
|
END FoldIfLess ;
|
|
|
|
|
|
(*
|
|
FoldIfIn - check whether we can fold the IfInOp
|
|
if op1 in op2 then goto op3
|
|
*)
|
|
|
|
PROCEDURE FoldIfIn (tokenno: CARDINAL;
|
|
quad: CARDINAL; left, right, destQuad: CARDINAL) ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
TryDeclareConstant (tokenno, left) ;
|
|
TryDeclareConstant (tokenno, right) ;
|
|
IF IsConst (left) AND IsConst (right)
|
|
THEN
|
|
IF IsValueSolved (left) AND IsValueSolved (right)
|
|
THEN
|
|
(* fine, we can take advantage of this and evaluate the condition *)
|
|
PushValue (right) ;
|
|
IF SetIn (tokenno, left)
|
|
THEN
|
|
PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
|
|
ELSE
|
|
SubQuad (quad)
|
|
END
|
|
END
|
|
END
|
|
END FoldIfIn ;
|
|
|
|
|
|
(*
|
|
FoldIfNotIn - check whether we can fold the IfNotInOp
|
|
if not (op1 in op2) then goto op3
|
|
*)
|
|
|
|
PROCEDURE FoldIfNotIn (tokenno: CARDINAL;
|
|
quad: CARDINAL; left, right, destQuad: CARDINAL) ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
TryDeclareConstant (tokenno, left) ;
|
|
TryDeclareConstant (tokenno, right) ;
|
|
IF IsConst (left) AND IsConst (right)
|
|
THEN
|
|
IF IsValueSolved (left) AND IsValueSolved (right)
|
|
THEN
|
|
(* fine, we can take advantage of this and evaluate the condition *)
|
|
PushValue (right) ;
|
|
IF NOT SetIn (tokenno, left)
|
|
THEN
|
|
PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
|
|
ELSE
|
|
SubQuad (quad)
|
|
END
|
|
END
|
|
END
|
|
END FoldIfNotIn ;
|
|
|
|
|
|
(*
|
|
GetSetLimits - assigns low and high to the limits of the declared, set.
|
|
*)
|
|
|
|
PROCEDURE GetSetLimits (set: CARDINAL; VAR low, high: CARDINAL) ;
|
|
VAR
|
|
type: CARDINAL ;
|
|
BEGIN
|
|
type := GetType(set) ;
|
|
IF IsSubrange(type)
|
|
THEN
|
|
GetSubrange(type, high, low) ;
|
|
ELSE
|
|
low := GetTypeMin(type) ;
|
|
high := GetTypeMax(type)
|
|
END
|
|
END GetSetLimits ;
|
|
|
|
|
|
(*
|
|
GetFieldNo - returns the field number in the, set, which contains, element.
|
|
*)
|
|
|
|
PROCEDURE GetFieldNo (tokenno: CARDINAL; element: CARDINAL; set: CARDINAL; VAR offset: Tree) : INTEGER ;
|
|
VAR
|
|
low, high, bpw, c: CARDINAL ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
bpw := GetBitsPerBitset() ;
|
|
GetSetLimits(set, low, high) ;
|
|
|
|
(* check element is legal *)
|
|
|
|
PushValue(element) ;
|
|
PushValue(low) ;
|
|
IF Less(tokenno)
|
|
THEN
|
|
(* out of range *)
|
|
RETURN( -1 )
|
|
ELSE
|
|
PushValue(element) ;
|
|
PushValue(high) ;
|
|
IF Gre(tokenno)
|
|
THEN
|
|
RETURN( -1 )
|
|
END
|
|
END ;
|
|
|
|
(* all legal *)
|
|
|
|
PushValue(low) ;
|
|
offset := PopIntegerTree() ;
|
|
c := 0 ;
|
|
PushValue(element) ;
|
|
PushValue(low) ;
|
|
PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
|
|
PushCard(bpw) ;
|
|
PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
|
|
Addn ;
|
|
WHILE GreEqu(tokenno) DO
|
|
INC(c) ; (* move onto next field *)
|
|
PushValue(element) ;
|
|
PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
|
|
PushCard((c+1)*bpw) ;
|
|
PushValue(low) ;
|
|
PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
|
|
Addn ;
|
|
PushIntegerTree(offset) ;
|
|
PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
|
|
PushCard(bpw) ;
|
|
PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
|
|
Addn ;
|
|
offset := PopIntegerTree()
|
|
END ;
|
|
RETURN( VAL(INTEGER, c) )
|
|
END GetFieldNo ;
|
|
|
|
|
|
(*
|
|
CodeIncl - encode an InclOp:
|
|
result := result + (1 << expr)
|
|
*)
|
|
|
|
PROCEDURE CodeIncl (result, expr: CARDINAL) ;
|
|
VAR
|
|
low,
|
|
high : CARDINAL ;
|
|
offset : Tree ;
|
|
fieldno : INTEGER ;
|
|
location: location_t ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
DeclareConstant (CurrentQuadToken, expr) ;
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
IF IsConst (result)
|
|
THEN
|
|
IF IsConst (expr)
|
|
THEN
|
|
InternalError ('this quadruple should have been removed by FoldIncl')
|
|
ELSE
|
|
InternalError ('should not get to here (why are we generating <incl const, var> ?)')
|
|
END
|
|
ELSE
|
|
IF IsConst (expr)
|
|
THEN
|
|
fieldno := GetFieldNo (CurrentQuadToken, expr, GetType (result), offset) ;
|
|
IF fieldno >= 0
|
|
THEN
|
|
PushValue (expr) ;
|
|
PushIntegerTree (offset) ;
|
|
Sub ;
|
|
BuildIncludeVarConst (location,
|
|
Mod2Gcc (GetType (result)),
|
|
Mod2Gcc (result),
|
|
PopIntegerTree (),
|
|
GetMode (result) = LeftValue, fieldno)
|
|
ELSE
|
|
MetaErrorT1 (CurrentQuadToken, 'bit exceeded the range of set {%1Eatd}', result)
|
|
END
|
|
ELSE
|
|
GetSetLimits (GetType (result), low, high) ;
|
|
BuildIncludeVarVar (location,
|
|
Mod2Gcc (GetType(result)),
|
|
Mod2Gcc (result), Mod2Gcc(expr), GetMode(result) = LeftValue, Mod2Gcc (low))
|
|
END
|
|
END
|
|
END CodeIncl ;
|
|
|
|
|
|
(*
|
|
FoldExcl - check whether we can fold the InclOp.
|
|
op1 := op1 - (1 << op3)
|
|
*)
|
|
|
|
PROCEDURE FoldExcl (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; result, expr: CARDINAL) ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
TryDeclareConstant (tokenno, expr) ;
|
|
IF IsConst (result) AND IsConst (expr)
|
|
THEN
|
|
IF GccKnowsAbout (expr) AND IsValueSolved (result)
|
|
THEN
|
|
PushValue (result) ;
|
|
SubBit (tokenno, expr) ;
|
|
AddModGcc (result, PopSetTree (tokenno)) ;
|
|
p (result) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
END
|
|
END FoldExcl ;
|
|
|
|
|
|
(*
|
|
CodeExcl - encode an ExclOp:
|
|
result := result - (1 << expr)
|
|
*)
|
|
|
|
PROCEDURE CodeExcl (result, expr: CARDINAL) ;
|
|
VAR
|
|
low,
|
|
high : CARDINAL ;
|
|
offset : Tree ;
|
|
fieldno : INTEGER ;
|
|
location: location_t ;
|
|
BEGIN
|
|
(* firstly ensure that constant literals are declared *)
|
|
DeclareConstant (CurrentQuadToken, expr) ;
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsConst (result)
|
|
THEN
|
|
InternalError ('should not get to here (if we do we should consider calling FoldInclOp)')
|
|
ELSE
|
|
IF IsConst (expr)
|
|
THEN
|
|
fieldno := GetFieldNo (CurrentQuadToken, expr, GetType (result), offset) ;
|
|
IF fieldno >= 0
|
|
THEN
|
|
PushValue (expr) ;
|
|
PushIntegerTree (offset) ;
|
|
Sub ;
|
|
BuildExcludeVarConst (location,
|
|
Mod2Gcc (GetType (result)),
|
|
Mod2Gcc (result), PopIntegerTree (),
|
|
GetMode (result)=LeftValue, fieldno)
|
|
ELSE
|
|
MetaErrorT1 (CurrentQuadToken, 'bit exceeded the range of set {%1Eatd}', result)
|
|
END
|
|
ELSE
|
|
GetSetLimits (GetType (result), low, high) ;
|
|
BuildExcludeVarVar (location,
|
|
Mod2Gcc (GetType(result)),
|
|
Mod2Gcc (result), Mod2Gcc(expr), GetMode(result) = LeftValue, Mod2Gcc (low))
|
|
END
|
|
END
|
|
END CodeExcl ;
|
|
|
|
|
|
(*
|
|
FoldUnary - check whether we can fold the unop operation.
|
|
*)
|
|
|
|
PROCEDURE FoldUnary (tokenno: CARDINAL; p: WalkAction;
|
|
unop: BuildUnaryProcedure; ZConstToTypedConst: Tree;
|
|
quad: CARDINAL; result, expr: CARDINAL) ;
|
|
VAR
|
|
tv : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
(* firstly ensure that any constant literal is declared *)
|
|
TryDeclareConstant (tokenno, expr) ;
|
|
location := TokenToLocation (tokenno) ;
|
|
|
|
IF IsConst (expr)
|
|
THEN
|
|
IF GccKnowsAbout (expr)
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
IF IsConst (result)
|
|
THEN
|
|
IF ZConstToTypedConst = Tree(NIL)
|
|
THEN
|
|
IF (GetType (expr) = NulSym) OR IsOrdinalType (SkipType (GetType (expr)))
|
|
THEN
|
|
ZConstToTypedConst := GetM2ZType ()
|
|
ELSIF IsRealType (SkipType (GetType (expr))) OR IsRealN (SkipType (GetType (expr)))
|
|
THEN
|
|
ZConstToTypedConst := GetM2RType ()
|
|
ELSIF IsComplexType (SkipType (GetType (expr))) OR
|
|
IsComplexN (SkipType (GetType (expr)))
|
|
THEN
|
|
ZConstToTypedConst := GetM2CType ()
|
|
END
|
|
END ;
|
|
IF GetType(result) = NulSym
|
|
THEN
|
|
PutConst (result, NegateType (GetType (expr) (* , tokenno *) ))
|
|
END ;
|
|
tv := unop (location, LValueToGenericPtrOrConvert (expr, ZConstToTypedConst), FALSE) ;
|
|
CheckOrResetOverflow (tokenno, tv, MustCheckOverflow (quad)) ;
|
|
|
|
AddModGcc (result, DeclareKnownConstant (location, ZConstToTypedConst, tv)) ;
|
|
p (result) ;
|
|
NoChange := FALSE ;
|
|
SubQuad (quad)
|
|
ELSE
|
|
(* we can still fold the expression, but not the assignment, however, we will
|
|
not do this here but in CodeUnary
|
|
*)
|
|
END
|
|
END
|
|
END
|
|
END FoldUnary ;
|
|
|
|
|
|
(*
|
|
FoldUnarySet - check whether we can fold the doOp operation.
|
|
*)
|
|
|
|
PROCEDURE FoldUnarySet (tokenno: CARDINAL; p: WalkAction; doOp: DoUnaryProcedure;
|
|
quad: CARDINAL; result, expr: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
(* firstly try and ensure that constants are declared *)
|
|
TryDeclareConstant (tokenno, expr) ;
|
|
location := TokenToLocation (tokenno) ;
|
|
|
|
IF IsConst (expr) AND IsConstSet (expr) AND
|
|
IsConst (result)
|
|
THEN
|
|
IF IsValueSolved (expr) AND (GetType (expr) # NulSym)
|
|
THEN
|
|
PutConst (result, FindType (expr)) ;
|
|
PushValue (expr) ;
|
|
doOp (tokenno) ;
|
|
PopValue (result) ;
|
|
PushValue (result) ;
|
|
PutConstSet (result) ;
|
|
AddModGcc (result,
|
|
DeclareKnownConstant (location,
|
|
Mod2Gcc (GetType (expr)),
|
|
PopSetTree (tokenno))) ;
|
|
p (result) ;
|
|
NoChange := FALSE ;
|
|
SubQuad (quad)
|
|
END
|
|
END
|
|
END FoldUnarySet ;
|
|
|
|
|
|
(*
|
|
CodeUnaryCheck - encode a unary arithmetic operation.
|
|
*)
|
|
|
|
PROCEDURE CodeUnaryCheck (unop: BuildUnaryCheckProcedure; ZConstToTypedConst: Tree;
|
|
quad: CARDINAL; result, expr: CARDINAL) ;
|
|
VAR
|
|
lowestType: CARDINAL ;
|
|
min, max,
|
|
lowest,
|
|
tv : Tree ;
|
|
location : location_t ;
|
|
BEGIN
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant(CurrentQuadToken, expr) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, expr) ;
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
lowestType := GetLType (result) ;
|
|
IF lowestType=NulSym
|
|
THEN
|
|
lowest := NIL ;
|
|
ELSE
|
|
lowest := Mod2Gcc (lowestType)
|
|
END ;
|
|
IF GetMinMax (CurrentQuadToken, lowestType, min, max)
|
|
THEN
|
|
tv := unop (location, LValueToGenericPtr (location, expr), lowest, min, max)
|
|
ELSE
|
|
tv := unop (location, LValueToGenericPtr (location, expr), NIL, NIL, NIL)
|
|
END ;
|
|
CheckOrResetOverflow (CurrentQuadToken, tv, MustCheckOverflow(quad)) ;
|
|
IF IsConst (result)
|
|
THEN
|
|
IF ZConstToTypedConst = Tree (NIL)
|
|
THEN
|
|
ZConstToTypedConst := Tree (Mod2Gcc( GetType (expr)))
|
|
END ;
|
|
(* still have a constant which was not resolved, pass it to gcc *)
|
|
PutConst (result, FindType (expr)) ;
|
|
ConstantKnownAndUsed (result, DeclareKnownConstant (location, ZConstToTypedConst, tv))
|
|
ELSE
|
|
IF EnableSSA AND IsVariableSSA (result)
|
|
THEN
|
|
Replace (result, tv)
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), tv)
|
|
END
|
|
END
|
|
END CodeUnaryCheck ;
|
|
|
|
|
|
(*
|
|
CodeUnary - encode a unary arithmetic operation.
|
|
*)
|
|
|
|
PROCEDURE CodeUnary (unop: BuildUnaryProcedure; ZConstToTypedConst: Tree;
|
|
quad: CARDINAL; result, expr: CARDINAL) ;
|
|
VAR
|
|
tv : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant (CurrentQuadToken, expr) ;
|
|
DeclareConstructor (CurrentQuadToken, quad, expr) ;
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
tv := unop(location, LValueToGenericPtr (location, expr), FALSE) ;
|
|
CheckOrResetOverflow (CurrentQuadToken, tv, MustCheckOverflow (quad)) ;
|
|
IF IsConst(result)
|
|
THEN
|
|
IF ZConstToTypedConst=Tree(NIL)
|
|
THEN
|
|
ZConstToTypedConst := Tree(Mod2Gcc(GetType(expr)))
|
|
END ;
|
|
(* still have a constant which was not resolved, pass it to gcc *)
|
|
PutConst (result, FindType (expr)) ;
|
|
ConstantKnownAndUsed (result, DeclareKnownConstant (location, ZConstToTypedConst, tv))
|
|
ELSE
|
|
IF EnableSSA AND IsVariableSSA (result)
|
|
THEN
|
|
Replace (result, tv)
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), tv)
|
|
END
|
|
END
|
|
END CodeUnary ;
|
|
|
|
|
|
(*
|
|
FoldNegate - check unary negate for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldNegate (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; result, expr: CARDINAL) ;
|
|
BEGIN
|
|
IF IsConstSet (expr)
|
|
THEN
|
|
FoldUnarySet (tokenno, p, SetNegate, quad, result, expr)
|
|
ELSE
|
|
FoldUnary (tokenno, p, BuildNegate, NIL, quad, result, expr)
|
|
END
|
|
END FoldNegate ;
|
|
|
|
|
|
(*
|
|
CodeNegateChecked - code a negate instruction, determine whether checking
|
|
is required.
|
|
*)
|
|
|
|
PROCEDURE CodeNegateChecked (quad: CARDINAL; op1, op3: CARDINAL) ;
|
|
BEGIN
|
|
IF IsConstSet (op3) OR IsSet (GetType (op3))
|
|
THEN
|
|
CodeUnarySet (BuildSetNegate, SetNegate, quad, op1, op3)
|
|
ELSIF UnaryOperand (quad, op3)
|
|
THEN
|
|
IF MustCheckOverflow (quad)
|
|
THEN
|
|
CodeUnaryCheck (BuildNegateCheck, NIL, quad, op1, op3)
|
|
ELSE
|
|
CodeUnary (BuildNegate, NIL, quad, op1, op3)
|
|
END
|
|
END
|
|
END CodeNegateChecked ;
|
|
|
|
|
|
(*
|
|
FoldSize - check unary SIZE for constant folding.
|
|
*)
|
|
|
|
PROCEDURE FoldSize (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
t : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
IF IsConst(op1) AND CompletelyResolved(op3)
|
|
THEN
|
|
IF op2=NulSym
|
|
THEN
|
|
t := BuildSize(location, Mod2Gcc(op3), FALSE) ;
|
|
PushIntegerTree(t) ;
|
|
PopValue(op1) ;
|
|
PutConst(op1, Cardinal) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad) ;
|
|
t := RememberConstant(t)
|
|
ELSIF GccKnowsAbout(op2)
|
|
THEN
|
|
(* ignore the chosen varients as we implement it as a C union *)
|
|
t := BuildSize(location, Mod2Gcc(op3), FALSE) ;
|
|
PushIntegerTree(t) ;
|
|
PopValue(op1) ;
|
|
PutConst(op1, Cardinal) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad) ;
|
|
t := RememberConstant(t)
|
|
END
|
|
END
|
|
END FoldSize ;
|
|
|
|
|
|
(*
|
|
CodeSize - encode the inbuilt SIZE function.
|
|
*)
|
|
|
|
PROCEDURE CodeSize (result, sym: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
PushIntegerTree (BuildSize (location, Mod2Gcc (sym), FALSE)) ;
|
|
IF IsConst (result)
|
|
THEN
|
|
PopValue (result) ;
|
|
PutConst (result, Cardinal) ;
|
|
PushValue (result) ;
|
|
ConstantKnownAndUsed (result,
|
|
DeclareKnownConstant (location,
|
|
GetIntegerType (),
|
|
PopIntegerTree ()))
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), PopIntegerTree ())
|
|
END
|
|
END CodeSize ;
|
|
|
|
|
|
(*
|
|
FoldRecordField - check whether we can fold an RecordFieldOp quadruple.
|
|
Very similar to FoldBinary, except that we need to
|
|
hard code a few parameters to the gcc backend.
|
|
*)
|
|
|
|
PROCEDURE FoldRecordField (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; result, record, field: CARDINAL) ;
|
|
VAR
|
|
recordType,
|
|
fieldType : CARDINAL ;
|
|
ptr : Tree ;
|
|
location : location_t ;
|
|
BEGIN
|
|
RETURN ; (* this procedure should no longer be called *)
|
|
|
|
location := TokenToLocation(tokenno) ;
|
|
(* firstly ensure that any constant literal is declared *)
|
|
TryDeclareConstant(tokenno, record) ;
|
|
IF IsRecordField(record) OR IsFieldVarient(record)
|
|
THEN
|
|
recordType := GetType (record) ;
|
|
fieldType := GetType (field) ;
|
|
IF GccKnowsAbout (record) AND GccKnowsAbout (field) AND
|
|
GccKnowsAbout (recordType) AND GccKnowsAbout (fieldType) AND
|
|
CompletelyResolved (recordType) AND CompletelyResolved (fieldType)
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
IF IsConst (result)
|
|
THEN
|
|
ptr := BuildComponentRef (location, Mod2Gcc (record), Mod2Gcc (field)) ;
|
|
IF NOT IsValueSolved (result)
|
|
THEN
|
|
PushIntegerTree (ptr) ;
|
|
PopValue (result)
|
|
END ;
|
|
PutConst (result, fieldType) ;
|
|
AddModGcc (result, DeclareKnownConstant (location, Mod2Gcc (fieldType), ptr)) ;
|
|
p (result) ;
|
|
NoChange := FALSE ;
|
|
SubQuad (quad)
|
|
ELSE
|
|
(* we can still fold the expression, but not the assignment, however, we will
|
|
not do this here but in CodeOffset
|
|
*)
|
|
END
|
|
END
|
|
END
|
|
END FoldRecordField ;
|
|
|
|
|
|
(*
|
|
CodeRecordField - encode a reference to a field within a record.
|
|
*)
|
|
|
|
PROCEDURE CodeRecordField (result, record, field: CARDINAL) ;
|
|
VAR
|
|
recordType,
|
|
fieldType : CARDINAL ;
|
|
ptr : Tree ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
(* firstly ensure that any constant literal is declared *)
|
|
IF IsRecordField (field) OR IsFieldVarient (field)
|
|
THEN
|
|
recordType := GetType (record) ;
|
|
fieldType := GetType (field) ;
|
|
IF GccKnowsAbout (record) AND GccKnowsAbout (field) AND
|
|
GccKnowsAbout (recordType) AND GccKnowsAbout (fieldType) AND
|
|
CompletelyResolved (recordType) AND CompletelyResolved (fieldType)
|
|
THEN
|
|
IF GetMode(record)=LeftValue
|
|
THEN
|
|
ptr := BuildComponentRef (location,
|
|
BuildIndirect (location, Mod2Gcc (record), Mod2Gcc (recordType)),
|
|
Mod2Gcc (field))
|
|
ELSE
|
|
ptr := BuildComponentRef (location, Mod2Gcc (record), Mod2Gcc (field))
|
|
END ;
|
|
AddModGcc (result, ptr)
|
|
ELSE
|
|
InternalError ('symbol type should have been declared by now')
|
|
END
|
|
ELSE
|
|
InternalError ('not expecting this type of symbol')
|
|
END
|
|
END CodeRecordField ;
|
|
|
|
|
|
(*
|
|
BuildHighFromChar -
|
|
*)
|
|
|
|
PROCEDURE BuildHighFromChar (operand: CARDINAL) : Tree ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(GetDeclaredMod(operand)) ;
|
|
RETURN( GetCardinalZero(location) )
|
|
END BuildHighFromChar ;
|
|
|
|
|
|
(*
|
|
SkipToArray -
|
|
*)
|
|
|
|
PROCEDURE SkipToArray (operand, dim: CARDINAL) : CARDINAL ;
|
|
VAR
|
|
type: CARDINAL ;
|
|
BEGIN
|
|
WHILE dim>1 DO
|
|
type := SkipType(GetType(operand)) ;
|
|
IF IsArray(type)
|
|
THEN
|
|
operand := type
|
|
END ;
|
|
DEC(dim)
|
|
END ;
|
|
RETURN( operand )
|
|
END SkipToArray ;
|
|
|
|
|
|
(*
|
|
BuildHighFromArray -
|
|
*)
|
|
|
|
PROCEDURE BuildHighFromArray (tokenno: CARDINAL; dim, operand: CARDINAL) : Tree ;
|
|
VAR
|
|
Type : CARDINAL ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
Type := SkipType (GetType (SkipToArray (operand, dim))) ;
|
|
RETURN BuildHighFromStaticArray (location, (* dim, *) Type)
|
|
END BuildHighFromArray ;
|
|
|
|
|
|
(*
|
|
BuildHighFromStaticArray -
|
|
*)
|
|
|
|
PROCEDURE BuildHighFromStaticArray (location: location_t; (* dim, *) Type: CARDINAL) : Tree ;
|
|
VAR
|
|
High, Low: CARDINAL ;
|
|
Subscript,
|
|
Subrange : CARDINAL ;
|
|
BEGIN
|
|
Assert (IsArray (Type)) ;
|
|
Subscript := GetArraySubscript (Type) ;
|
|
Subrange := SkipType (GetType (Subscript)) ;
|
|
IF IsEnumeration (Subrange)
|
|
THEN
|
|
GetBaseTypeMinMax (Subrange, Low, High) ;
|
|
IF GccKnowsAbout (High)
|
|
THEN
|
|
RETURN Tree (Mod2Gcc (High))
|
|
END
|
|
ELSIF IsSubrange(Subrange)
|
|
THEN
|
|
GetSubrange (Subrange, High, Low) ;
|
|
IF GccKnowsAbout (Low) AND GccKnowsAbout (High)
|
|
THEN
|
|
RETURN BuildSub (location, Mod2Gcc (High), Mod2Gcc (Low), TRUE)
|
|
END
|
|
ELSE
|
|
MetaError1 ('array subscript {%1EDad:for} must be a subrange or enumeration type', Type) ;
|
|
RETURN Tree(NIL)
|
|
END ;
|
|
IF GccKnowsAbout (High)
|
|
THEN
|
|
RETURN Tree (Mod2Gcc (High))
|
|
ELSE
|
|
RETURN Tree (NIL)
|
|
END
|
|
END BuildHighFromStaticArray ;
|
|
|
|
|
|
(*
|
|
BuildHighFromString -
|
|
*)
|
|
|
|
PROCEDURE BuildHighFromString (operand: CARDINAL) : Tree ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(GetDeclaredMod(operand)) ;
|
|
IF GccKnowsAbout(operand) AND (StringLength(Mod2Gcc(operand))>0)
|
|
THEN
|
|
RETURN( BuildIntegerConstant(StringLength(Mod2Gcc(operand))-1) )
|
|
ELSE
|
|
RETURN( GetIntegerZero(location) )
|
|
END
|
|
END BuildHighFromString ;
|
|
|
|
|
|
(*
|
|
ResolveHigh - given an Modula-2 operand, it resolves the HIGH(operand)
|
|
and returns a GCC constant symbol containing the value of
|
|
HIGH(operand).
|
|
*)
|
|
|
|
PROCEDURE ResolveHigh (tokenno: CARDINAL; dim, operand: CARDINAL) : Tree ;
|
|
VAR
|
|
Type : CARDINAL ;
|
|
location: location_t ;
|
|
BEGIN
|
|
Type := SkipType(GetType(operand)) ;
|
|
location := TokenToLocation(tokenno) ;
|
|
|
|
IF (Type=Char) AND (dim=1)
|
|
THEN
|
|
RETURN( BuildHighFromChar(operand) )
|
|
ELSIF IsConstString(operand) AND (dim=1)
|
|
THEN
|
|
RETURN( BuildHighFromString(operand) )
|
|
ELSIF IsArray(Type)
|
|
THEN
|
|
RETURN( BuildHighFromArray(tokenno, dim, operand) )
|
|
ELSIF IsUnbounded(Type)
|
|
THEN
|
|
RETURN( GetHighFromUnbounded(location, dim, operand) )
|
|
ELSE
|
|
MetaErrorT1 (tokenno,
|
|
'base procedure HIGH expects a variable of type array or a constant string or CHAR as its parameter, rather than {%1Etad}',
|
|
operand) ;
|
|
RETURN( GetIntegerZero(location) )
|
|
END
|
|
END ResolveHigh ;
|
|
|
|
|
|
(*
|
|
FoldHigh - if the array is not dynamic then we should be able to
|
|
remove the HighOp quadruple and assign op1 with
|
|
the known compile time HIGH(op3).
|
|
*)
|
|
|
|
PROCEDURE FoldHigh (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, dim, op3: CARDINAL) ;
|
|
VAR
|
|
t : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
(* firstly ensure that any constant literal is declared *)
|
|
TryDeclareConstant(tokenno, op3) ;
|
|
location := TokenToLocation(tokenno) ;
|
|
IF GccKnowsAbout(op3) AND CompletelyResolved(op3)
|
|
THEN
|
|
t := ResolveHigh(tokenno, dim, op3) ;
|
|
(* fine, we can take advantage of this and fold constants *)
|
|
IF IsConst(op1) AND (t#Tree(NIL))
|
|
THEN
|
|
PutConst(op1, Cardinal) ;
|
|
AddModGcc(op1,
|
|
DeclareKnownConstant(location, GetCardinalType(),
|
|
ToCardinal(location, t))) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
ELSE
|
|
(* we can still fold the expression, but not the assignment, however, we will
|
|
not do this here but in CodeHigh
|
|
*)
|
|
END
|
|
END
|
|
END FoldHigh ;
|
|
|
|
|
|
(*
|
|
CodeHigh - encode a unary arithmetic operation.
|
|
*)
|
|
|
|
PROCEDURE CodeHigh (result, dim, array: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant (CurrentQuadToken, array) ;
|
|
IF IsConst (result)
|
|
THEN
|
|
(* still have a constant which was not resolved, pass it to gcc *)
|
|
ConstantKnownAndUsed (result,
|
|
DeclareKnownConstant(location,
|
|
GetM2ZType (),
|
|
ResolveHigh (CurrentQuadToken, dim, array)))
|
|
ELSE
|
|
BuildAssignmentStatement (location,
|
|
Mod2Gcc (result),
|
|
BuildConvert (location,
|
|
Mod2Gcc (GetType (result)),
|
|
ResolveHigh (CurrentQuadToken, dim, array),
|
|
FALSE))
|
|
END
|
|
END CodeHigh ;
|
|
|
|
|
|
(*
|
|
CodeUnbounded - codes the creation of an unbounded parameter variable.
|
|
places the address of op3 into *op1
|
|
*)
|
|
|
|
PROCEDURE CodeUnbounded (result, array: CARDINAL) ;
|
|
VAR
|
|
Addr : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
DeclareConstant(CurrentQuadToken, array) ;
|
|
IF IsConstString(array)
|
|
THEN
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), BuildAddr (location, PromoteToString (CurrentQuadToken, array), FALSE))
|
|
ELSIF IsConstructor(array)
|
|
THEN
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), BuildAddr (location, Mod2Gcc (array), TRUE))
|
|
ELSIF IsUnbounded (GetType (array))
|
|
THEN
|
|
IF GetMode(array) = LeftValue
|
|
THEN
|
|
Addr := BuildConvert (location, Mod2Gcc (GetType (result)), Mod2Gcc (array), FALSE)
|
|
ELSE
|
|
Addr := BuildComponentRef (location, Mod2Gcc (array), Mod2Gcc (GetUnboundedAddressOffset (GetType (array))))
|
|
END ;
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), Addr)
|
|
ELSIF GetMode(array) = RightValue
|
|
THEN
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), BuildAddr (location, Mod2Gcc (array), FALSE))
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (result), Mod2Gcc (array))
|
|
END
|
|
END CodeUnbounded ;
|
|
|
|
|
|
(*
|
|
AreSubrangesKnown - returns TRUE if the subranges values used within, array, are known.
|
|
*)
|
|
|
|
PROCEDURE AreSubrangesKnown (array: CARDINAL) : BOOLEAN ;
|
|
VAR
|
|
type,
|
|
subscript,
|
|
low, high: CARDINAL ;
|
|
BEGIN
|
|
IF GccKnowsAbout(array)
|
|
THEN
|
|
subscript := GetArraySubscript(array) ;
|
|
IF subscript=NulSym
|
|
THEN
|
|
InternalError ('not expecting a NulSym as a subscript')
|
|
ELSE
|
|
type := SkipType(GetType(subscript)) ;
|
|
low := GetTypeMin(type) ;
|
|
high := GetTypeMax(type) ;
|
|
RETURN( GccKnowsAbout(low) AND GccKnowsAbout(high) )
|
|
END
|
|
ELSE
|
|
RETURN( FALSE )
|
|
END
|
|
END AreSubrangesKnown ;
|
|
|
|
|
|
(*
|
|
CodeArray - res is an lvalue which will point to the array element.
|
|
*)
|
|
|
|
PROCEDURE CodeArray (res, index, array: CARDINAL) ;
|
|
VAR
|
|
resType,
|
|
arrayDecl,
|
|
type,
|
|
low,
|
|
subscript : CARDINAL ;
|
|
a, ta,
|
|
ti, tl : Tree ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
arrayDecl := SkipType (GetType (array)) ;
|
|
IF AreSubrangesKnown (arrayDecl)
|
|
THEN
|
|
subscript := GetArraySubscript (arrayDecl) ;
|
|
type := SkipType (GetType (subscript)) ;
|
|
low := GetTypeMin (type) ;
|
|
resType := GetVarBackEndType(res) ;
|
|
IF resType=NulSym
|
|
THEN
|
|
resType := SkipType(GetType(res))
|
|
END ;
|
|
ta := Mod2Gcc(SkipType(GetType(arrayDecl))) ;
|
|
IF GetMode(array)=LeftValue
|
|
THEN
|
|
a := BuildIndirect(location, Mod2Gcc(array), Mod2Gcc(SkipType(GetType(array))))
|
|
ELSE
|
|
a := Mod2Gcc(array)
|
|
END ;
|
|
IF IsArrayLarge(arrayDecl)
|
|
THEN
|
|
tl := BuildConvert(location, Mod2Gcc(type), Mod2Gcc(low), FALSE) ;
|
|
ti := BuildConvert(location, Mod2Gcc(type), Mod2Gcc(index), FALSE) ;
|
|
ti := BuildConvert(location, GetIntegerType(), BuildSub(location, ti, tl, FALSE), FALSE) ;
|
|
tl := GetIntegerZero(location)
|
|
ELSE
|
|
tl := BuildConvert(location, GetIntegerType(), Mod2Gcc(low), FALSE) ;
|
|
ti := BuildConvert(location, GetIntegerType(), Mod2Gcc(index), FALSE)
|
|
END ;
|
|
(* ti := BuildConvert(location, GetIntegerType(), Mod2Gcc(high), FALSE) ; *)
|
|
BuildAssignmentStatement (location,
|
|
Mod2Gcc (res),
|
|
BuildConvert (location,
|
|
Mod2Gcc (resType),
|
|
BuildAddr (location, BuildArray (location,
|
|
ta, a, ti, tl),
|
|
FALSE),
|
|
FALSE))
|
|
ELSE
|
|
InternalError ('subranges not yet resolved')
|
|
END
|
|
END CodeArray ;
|
|
|
|
|
|
(*
|
|
FoldElementSizeForArray - attempts to calculate the Subscript
|
|
multiplier for the index op3.
|
|
*)
|
|
|
|
PROCEDURE FoldElementSizeForArray (tokenno: CARDINAL; quad: CARDINAL;
|
|
p: WalkAction;
|
|
result, type: CARDINAL) ;
|
|
VAR
|
|
Subscript: CARDINAL ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (tokenno) ;
|
|
|
|
IF IsConst (result) AND (NOT GccKnowsAbout (result))
|
|
THEN
|
|
Subscript := GetArraySubscript (type) ;
|
|
IF IsSizeSolved (Subscript)
|
|
THEN
|
|
PutConst (result, Integer) ;
|
|
PushSize (Subscript) ;
|
|
AddModGcc (result,
|
|
DeclareKnownConstant (location,
|
|
GetCardinalType (),
|
|
BuildConvert (location,
|
|
GetCardinalType (),
|
|
PopIntegerTree (),
|
|
TRUE))) ;
|
|
p (result) ;
|
|
NoChange := FALSE ;
|
|
SubQuad (quad)
|
|
END
|
|
END
|
|
END FoldElementSizeForArray ;
|
|
|
|
|
|
(*
|
|
FoldElementSizeForUnbounded - Unbounded arrays only have one index,
|
|
therefore element size will be the
|
|
TSIZE(Type) where Type is defined as:
|
|
ARRAY OF Type.
|
|
*)
|
|
|
|
PROCEDURE FoldElementSizeForUnbounded (tokenno: CARDINAL; quad: CARDINAL;
|
|
p: WalkAction;
|
|
result, ArrayType: CARDINAL) ;
|
|
VAR
|
|
Type : CARDINAL ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (tokenno) ;
|
|
|
|
IF IsConst (result)
|
|
THEN
|
|
IF GccKnowsAbout (result)
|
|
THEN
|
|
InternalError ('cannot assign a value twice to a constant')
|
|
ELSE
|
|
Assert (IsUnbounded (ArrayType)) ;
|
|
Type := GetType (ArrayType) ;
|
|
IF GccKnowsAbout (Type)
|
|
THEN
|
|
PutConst (result, Cardinal) ;
|
|
AddModGcc (result,
|
|
DeclareKnownConstant (location,
|
|
GetCardinalType (),
|
|
BuildConvert (location,
|
|
GetCardinalType (),
|
|
FindSize (tokenno, Type),
|
|
TRUE))) ;
|
|
p (result) ;
|
|
NoChange := FALSE ;
|
|
SubQuad (quad)
|
|
END
|
|
END
|
|
END
|
|
END FoldElementSizeForUnbounded ;
|
|
|
|
|
|
(*
|
|
FoldElementSize - folds the element size for an ArraySym or UnboundedSym.
|
|
ElementSize returns a constant which defines the
|
|
multiplier to be multiplied by this element index.
|
|
*)
|
|
|
|
PROCEDURE FoldElementSize (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; result, type: CARDINAL) ;
|
|
BEGIN
|
|
IF IsUnbounded (type)
|
|
THEN
|
|
FoldElementSizeForUnbounded (tokenno, quad, p, result, type)
|
|
ELSIF IsArray (type)
|
|
THEN
|
|
FoldElementSizeForArray (tokenno, quad, p, result, type)
|
|
ELSE
|
|
InternalError ('expecting UnboundedSym or ArraySym')
|
|
END
|
|
END FoldElementSize ;
|
|
|
|
|
|
(*
|
|
PopKindTree - returns a Tree from M2ALU of the type implied by, op.
|
|
*)
|
|
|
|
PROCEDURE PopKindTree (op: CARDINAL; tokenno: CARDINAL) : Tree ;
|
|
VAR
|
|
type: CARDINAL ;
|
|
BEGIN
|
|
type := SkipType (GetType (op)) ;
|
|
IF IsSet (type)
|
|
THEN
|
|
RETURN( PopSetTree (tokenno) )
|
|
ELSIF IsRealType (type)
|
|
THEN
|
|
RETURN( PopRealTree () )
|
|
ELSE
|
|
RETURN( PopIntegerTree () )
|
|
END
|
|
END PopKindTree ;
|
|
|
|
|
|
(*
|
|
FoldConvert - attempts to fold op3 to type op2 placing the result into
|
|
op1, providing that op1 and op3 are constants.
|
|
Convert will, if need be, alter the machine representation
|
|
of op3 to comply with TYPE op2.
|
|
*)
|
|
|
|
PROCEDURE FoldConvert (tokenno: CARDINAL; p: WalkAction;
|
|
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
|
|
VAR
|
|
tl : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(tokenno) ;
|
|
(* firstly ensure that constant literals are declared *)
|
|
TryDeclareConstant(tokenno, op3) ;
|
|
IF IsConstant(op3)
|
|
THEN
|
|
IF GccKnowsAbout(op2) AND
|
|
(IsProcedure(op3) OR IsValueSolved(op3)) AND
|
|
GccKnowsAbout(SkipType(op2))
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constant *)
|
|
IF IsConst(op1)
|
|
THEN
|
|
PutConst(op1, op2) ;
|
|
tl := Mod2Gcc(SkipType(op2)) ;
|
|
IF IsProcedure(op3)
|
|
THEN
|
|
AddModGcc(op1, BuildConvert(location, tl, Mod2Gcc(op3), TRUE))
|
|
ELSE
|
|
PushValue(op3) ;
|
|
IF IsConstSet(op3)
|
|
THEN
|
|
IF IsSet(SkipType(op2))
|
|
THEN
|
|
WriteFormat0('cannot convert values between sets')
|
|
ELSE
|
|
PushIntegerTree(FoldAndStrip(BuildConvert(location, tl, PopSetTree(tokenno), TRUE))) ;
|
|
PopValue(op1) ;
|
|
PushValue(op1) ;
|
|
AddModGcc(op1, PopIntegerTree())
|
|
END
|
|
ELSE
|
|
IF IsSet(SkipType(op2))
|
|
THEN
|
|
PushSetTree(tokenno,
|
|
FoldAndStrip(BuildConvert(location, tl, PopKindTree(op3, tokenno),
|
|
TRUE)), SkipType(op2)) ;
|
|
PopValue(op1) ;
|
|
PutConstSet(op1) ;
|
|
PushValue(op1) ;
|
|
AddModGcc(op1, PopSetTree(tokenno))
|
|
ELSIF IsRealType(SkipType(op2))
|
|
THEN
|
|
PushRealTree(FoldAndStrip(BuildConvert(location, tl, PopKindTree(op3, tokenno),
|
|
TRUE))) ;
|
|
PopValue(op1) ;
|
|
PushValue(op1) ;
|
|
AddModGcc(op1, PopKindTree(op1, tokenno))
|
|
ELSE
|
|
(* we let CheckOverflow catch a potential overflow rather than BuildConvert *)
|
|
PushIntegerTree(FoldAndStrip(BuildConvert(location, tl,
|
|
PopKindTree(op3, tokenno),
|
|
FALSE))) ;
|
|
PopValue(op1) ;
|
|
PushValue(op1) ;
|
|
CheckOrResetOverflow(tokenno, PopKindTree(op1, tokenno), MustCheckOverflow(quad)) ;
|
|
PushValue(op1) ;
|
|
AddModGcc(op1, PopKindTree(op1, tokenno))
|
|
END
|
|
END
|
|
END ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
END
|
|
END
|
|
END FoldConvert ;
|
|
|
|
|
|
(*
|
|
CodeConvert - Converts, rhs, to, type, placing the result into lhs.
|
|
Convert will, if need be, alter the machine representation
|
|
of op3 to comply with TYPE op2.
|
|
*)
|
|
|
|
PROCEDURE CodeConvert (quad: CARDINAL; lhs, type, rhs: CARDINAL) ;
|
|
VAR
|
|
tl, tr : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
CheckStop(quad) ;
|
|
|
|
(* firstly ensure that constant literals are declared *)
|
|
DeclareConstant(CurrentQuadToken, rhs) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, rhs) ;
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
tl := LValueToGenericPtr(location, type) ;
|
|
IF IsProcedure(rhs)
|
|
THEN
|
|
tr := BuildAddr(location, Mod2Gcc(rhs), FALSE)
|
|
ELSE
|
|
tr := LValueToGenericPtr(location, rhs) ;
|
|
tr := ConvertRHS(tr, type, rhs)
|
|
END ;
|
|
IF IsConst(lhs)
|
|
THEN
|
|
(* fine, we can take advantage of this and fold constant *)
|
|
PutConst(lhs, type) ;
|
|
tl := Mod2Gcc(SkipType(type)) ;
|
|
ConstantKnownAndUsed (lhs,
|
|
BuildConvert (location, tl, Mod2Gcc (rhs), TRUE))
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (lhs), BuildConvert (location, tl, tr, TRUE)) ;
|
|
END
|
|
END CodeConvert ;
|
|
|
|
|
|
(*
|
|
CodeCoerce - Coerce op3 to type op2 placing the result into
|
|
op1.
|
|
Coerce will NOT alter the machine representation
|
|
of op3 to comply with TYPE op2.
|
|
Therefore it _insists_ that under all circumstances that the
|
|
type sizes of op1 and op3 are the same.
|
|
CONVERT will perform machine manipulation to change variable
|
|
types, coerce does no such thing.
|
|
*)
|
|
|
|
PROCEDURE CodeCoerce (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
DeclareConstant(CurrentQuadToken, op3) ; (* checks to see whether it is a constant literal and declares it *)
|
|
DeclareConstructor(CurrentQuadToken, quad, op3) ;
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsProcedure(op3)
|
|
THEN
|
|
IF AreConstantsEqual(FindSize(CurrentQuadToken, op1), FindSize(CurrentQuadToken, Address))
|
|
THEN
|
|
IF IsConst(op1)
|
|
THEN
|
|
ConstantKnownAndUsed(op1, CheckConstant(CurrentQuadToken, op1, op3))
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc (op1), Mod2Gcc (op3))
|
|
END
|
|
ELSE
|
|
MetaErrorT0 (CurrentQuadToken,
|
|
'{%E}procedure address can only be stored in an address sized operand')
|
|
END
|
|
ELSIF IsConst(op3) OR AreConstantsEqual(FindSize(CurrentQuadToken, op1), FindSize(CurrentQuadToken, op3))
|
|
THEN
|
|
IF IsConst(op1)
|
|
THEN
|
|
ConstantKnownAndUsed(op1,
|
|
DeclareKnownConstant(location,
|
|
Mod2Gcc(GetType(op1)),
|
|
Mod2Gcc(op3)))
|
|
ELSE
|
|
Assert(GccKnowsAbout(op2)) ;
|
|
IF IsConst(op3)
|
|
THEN
|
|
BuildAssignmentStatement (location, Mod2Gcc(op1), Mod2Gcc(op3))
|
|
ELSE
|
|
(* does not work t := BuildCoerce(Mod2Gcc(op1), Mod2Gcc(op2), Mod2Gcc(op3)) *)
|
|
checkDeclare (op1) ;
|
|
AddStatement (location,
|
|
MaybeDebugBuiltinMemcpy(location, CurrentQuadToken,
|
|
BuildAddr(location, Mod2Gcc(op1), FALSE),
|
|
BuildAddr(location, Mod2Gcc(op3), FALSE),
|
|
FindSize(CurrentQuadToken, op2)))
|
|
END
|
|
END
|
|
ELSE
|
|
MetaErrorT0 (CurrentQuadToken,
|
|
'can only {%kCAST} objects of the same size')
|
|
END
|
|
END CodeCoerce ;
|
|
|
|
|
|
(*
|
|
FoldCoerce -
|
|
*)
|
|
|
|
PROCEDURE FoldCoerce (tokenno: CARDINAL; p: WalkAction;
|
|
quad, op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
TryDeclareConstant(tokenno, op3) ; (* checks to see whether it is a constant literal and declares it *)
|
|
location := TokenToLocation(tokenno) ;
|
|
|
|
IF GccKnowsAbout(op2) AND GccKnowsAbout(op3)
|
|
THEN
|
|
IF IsProcedure(op3)
|
|
THEN
|
|
IF AreConstantsEqual(FindSize(tokenno, op1), FindSize(tokenno, Address))
|
|
THEN
|
|
IF IsConst(op1)
|
|
THEN
|
|
AddModGcc(op1,
|
|
DeclareKnownConstant(location,
|
|
Mod2Gcc(GetType(op1)),
|
|
Mod2Gcc(op3))) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
ELSE
|
|
MetaErrorT0 (CurrentQuadToken,
|
|
'{%E}procedure address can only be stored in a address sized operand')
|
|
END
|
|
ELSIF IsConst(op3)
|
|
THEN
|
|
IF IsConst(op1)
|
|
THEN
|
|
AddModGcc(op1,
|
|
DeclareKnownConstant(location,
|
|
Mod2Gcc(GetType(op1)),
|
|
Mod2Gcc(op3))) ;
|
|
p(op1) ;
|
|
NoChange := FALSE ;
|
|
SubQuad(quad)
|
|
END
|
|
END
|
|
END
|
|
END FoldCoerce ;
|
|
|
|
|
|
(*
|
|
CanConvert - returns TRUE if we can convert variable, var, to a, type.
|
|
*)
|
|
|
|
PROCEDURE CanConvert (type, var: CARDINAL) : BOOLEAN ;
|
|
VAR
|
|
svar,
|
|
stype: CARDINAL ;
|
|
BEGIN
|
|
stype := SkipType(type) ;
|
|
svar := SkipType(GetType(var)) ;
|
|
RETURN (IsBaseType(stype) OR IsOrdinalType(stype) OR IsSystemType(stype)) AND
|
|
(IsBaseType(svar) OR IsOrdinalType(svar) OR IsSystemType(stype))
|
|
END CanConvert ;
|
|
|
|
|
|
(*
|
|
CodeCast - Cast op3 to type op2 placing the result into op1.
|
|
Cast will NOT alter the machine representation
|
|
of op3 to comply with TYPE op2 as long as SIZE(op3)=SIZE(op2).
|
|
If the sizes differ then Convert is called.
|
|
*)
|
|
|
|
PROCEDURE CodeCast (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
DeclareConstant(CurrentQuadToken, op3) ; (* checks to see whether it is a constant literal and declares it *)
|
|
DeclareConstructor(CurrentQuadToken, quad, op3) ;
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsProcedure(op3)
|
|
THEN
|
|
IF AreConstantsEqual(FindSize(CurrentQuadToken, op1), FindSize(CurrentQuadToken, Address))
|
|
THEN
|
|
IF IsConst(op1)
|
|
THEN
|
|
ConstantKnownAndUsed(op1, CheckConstant(CurrentQuadToken, op1, op3))
|
|
ELSE
|
|
BuildAssignmentStatement (location, Mod2Gcc(op1), Mod2Gcc(op3))
|
|
END
|
|
ELSE
|
|
MetaErrorT0 (CurrentQuadToken,
|
|
'{%E}procedure address can only be stored in an address sized operand')
|
|
END
|
|
ELSIF IsConst(op3) OR AreConstantsEqual(FindSize(CurrentQuadToken, op1), FindSize(CurrentQuadToken, op3))
|
|
THEN
|
|
CodeCoerce(quad, op1, op2, op3)
|
|
ELSE
|
|
IF PedanticCast AND (NOT CanConvert(op2, op3))
|
|
THEN
|
|
MetaError2 ('{%WkCAST} cannot copy a variable src {%2Dad} to a destination {%1Dad} as they are of different sizes and are not ordinal or real types',
|
|
op1, op3)
|
|
END ;
|
|
CodeConvert(quad, op1, op2, op3)
|
|
END
|
|
END CodeCast ;
|
|
|
|
|
|
(*
|
|
FoldCoerce -
|
|
*)
|
|
|
|
PROCEDURE FoldCast (tokenno: CARDINAL; p: WalkAction;
|
|
quad, op1, op2, op3: CARDINAL) ;
|
|
BEGIN
|
|
TryDeclareConstant(tokenno, op3) ; (* checks to see whether it is a constant literal and declares it *)
|
|
IF GccKnowsAbout(op2) AND GccKnowsAbout(op3)
|
|
THEN
|
|
IF IsProcedure(op3)
|
|
THEN
|
|
IF AreConstantsEqual(FindSize(tokenno, op1), FindSize(tokenno, Address))
|
|
THEN
|
|
FoldCoerce(tokenno, p, quad, op1, op2, op3)
|
|
ELSE
|
|
MetaErrorT0 (tokenno,
|
|
'{%E}procedure address can only be stored in an address sized operand')
|
|
END
|
|
ELSIF IsConst(op3)
|
|
THEN
|
|
FoldCoerce(tokenno, p, quad, op1, op2, op3)
|
|
END
|
|
END
|
|
END FoldCast ;
|
|
|
|
|
|
(*
|
|
CreateLabelProcedureN - creates a label using procedure name and
|
|
an integer.
|
|
*)
|
|
|
|
PROCEDURE CreateLabelProcedureN (proc: CARDINAL; leader: ARRAY OF CHAR;
|
|
unboundedCount, n: CARDINAL) : String ;
|
|
VAR
|
|
n1, n2: String ;
|
|
BEGIN
|
|
n1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(proc)))) ;
|
|
n2 := Mark(InitString(leader)) ;
|
|
(* prefixed by .L unboundedCount and n to ensure that no Modula-2 identifiers clash *)
|
|
RETURN( Sprintf4(Mark(InitString('.L%d.%d.unbounded.%s.%s')), unboundedCount, n, n1, n2) )
|
|
END CreateLabelProcedureN ;
|
|
|
|
|
|
(*
|
|
CreateLabelName - creates a namekey from quadruple, q.
|
|
*)
|
|
|
|
PROCEDURE CreateLabelName (q: CARDINAL) : String ;
|
|
BEGIN
|
|
(* prefixed by . to ensure that no Modula-2 identifiers clash *)
|
|
RETURN( Sprintf1(Mark(InitString('.L%d')), q) )
|
|
END CreateLabelName ;
|
|
|
|
|
|
(*
|
|
CodeGoto - creates a jump to a labeled quadruple.
|
|
*)
|
|
|
|
PROCEDURE CodeGoto (destquad: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
BuildGoto (location, string (CreateLabelName (destquad)))
|
|
END CodeGoto ;
|
|
|
|
|
|
(*
|
|
CheckReferenced - checks to see whether this quadruple requires a label.
|
|
*)
|
|
|
|
PROCEDURE CheckReferenced (quad: CARDINAL; op: QuadOperator) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
(* we do not create labels for procedure entries *)
|
|
IF (op#ProcedureScopeOp) AND (op#NewLocalVarOp) AND IsReferenced(quad)
|
|
THEN
|
|
DeclareLabel(location, string(CreateLabelName(quad)))
|
|
END
|
|
END CheckReferenced ;
|
|
|
|
|
|
(*
|
|
CodeIfSetLess -
|
|
*)
|
|
|
|
PROCEDURE CodeIfSetLess (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
settype : CARDINAL ;
|
|
falselabel: ADDRESS ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
InternalError ('this should have been folded in the calling procedure')
|
|
ELSIF IsConst(op1)
|
|
THEN
|
|
settype := SkipType(GetType(op2))
|
|
ELSE
|
|
settype := SkipType(GetType(op1))
|
|
END ;
|
|
IF CompareTrees(FindSize(CurrentQuadToken, settype), FindSize(CurrentQuadToken, Word)) <= 0
|
|
THEN
|
|
(* word size sets *)
|
|
DoJump(location,
|
|
BuildIsNotSuperset(location,
|
|
BuildConvert(location, GetWordType(), Mod2Gcc(op1), FALSE),
|
|
BuildConvert(location, GetWordType(), Mod2Gcc(op2), FALSE)),
|
|
NIL, string(CreateLabelName(op3)))
|
|
ELSE
|
|
falselabel := string(Sprintf1(Mark(InitString('.Lset%dcomp')), quad)) ;
|
|
|
|
BuildForeachWordInSetDoIfExpr(location,
|
|
Mod2Gcc(settype),
|
|
Mod2Gcc(op1), Mod2Gcc(op2),
|
|
GetMode(op1)=LeftValue,
|
|
GetMode(op2)=LeftValue,
|
|
IsConst(op1), IsConst(op2),
|
|
BuildIsSuperset,
|
|
falselabel) ;
|
|
|
|
BuildGoto(location, string(CreateLabelName(op3))) ;
|
|
DeclareLabel(location, falselabel)
|
|
END
|
|
END CodeIfSetLess ;
|
|
|
|
|
|
(*
|
|
CodeIfLess - codes the quadruple if op1 < op2 then goto op3
|
|
*)
|
|
|
|
PROCEDURE CodeIfLess (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
tl, tr : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant(CurrentQuadToken, op1) ;
|
|
DeclareConstant(CurrentQuadToken, op2) ;
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
PushValue(op1) ;
|
|
PushValue(op2) ;
|
|
IF Less(CurrentQuadToken)
|
|
THEN
|
|
BuildGoto(location, string(CreateLabelName(op3)))
|
|
ELSE
|
|
(* fall through *)
|
|
END
|
|
ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
|
|
IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
|
|
THEN
|
|
CodeIfSetLess(quad, op1, op2, op3)
|
|
ELSE
|
|
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
|
|
THEN
|
|
MetaErrorT2 (CurrentQuadToken,
|
|
'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
|
|
op1, op2)
|
|
ELSE
|
|
ConvertBinaryOperands(location,
|
|
tl, tr,
|
|
MixTypes(SkipType(GetType(op1)),
|
|
SkipType(GetType(op2)),
|
|
CurrentQuadToken),
|
|
op1, op2) ;
|
|
DoJump(location,
|
|
BuildLessThan(location, tl, tr), NIL, string(CreateLabelName(op3)))
|
|
END
|
|
END
|
|
END CodeIfLess ;
|
|
|
|
|
|
(*
|
|
CodeIfSetGre -
|
|
*)
|
|
|
|
PROCEDURE CodeIfSetGre (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
settype : CARDINAL ;
|
|
falselabel: ADDRESS ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
InternalError ('this should have been folded in the calling procedure')
|
|
ELSIF IsConst(op1)
|
|
THEN
|
|
settype := SkipType(GetType(op2))
|
|
ELSE
|
|
settype := SkipType(GetType(op1))
|
|
END ;
|
|
IF CompareTrees(FindSize(CurrentQuadToken, settype), FindSize(CurrentQuadToken, Word)) <= 0
|
|
THEN
|
|
(* word size sets *)
|
|
DoJump(location,
|
|
BuildIsNotSubset(location,
|
|
BuildConvert(location, GetWordType(), Mod2Gcc(op1), FALSE),
|
|
BuildConvert(location, GetWordType(), Mod2Gcc(op2), FALSE)),
|
|
NIL, string(CreateLabelName(op3)))
|
|
ELSE
|
|
falselabel := string(Sprintf1(Mark(InitString('.Lset%dcomp')), quad)) ;
|
|
|
|
BuildForeachWordInSetDoIfExpr(location,
|
|
Mod2Gcc(settype),
|
|
Mod2Gcc(op1), Mod2Gcc(op2),
|
|
GetMode(op1)=LeftValue,
|
|
GetMode(op2)=LeftValue,
|
|
IsConst(op1), IsConst(op2),
|
|
BuildIsSubset,
|
|
falselabel) ;
|
|
|
|
BuildGoto(location, string(CreateLabelName(op3))) ;
|
|
DeclareLabel(location, falselabel)
|
|
END
|
|
END CodeIfSetGre ;
|
|
|
|
|
|
(*
|
|
CodeIfGre - codes the quadruple if op1 > op2 then goto op3
|
|
*)
|
|
|
|
PROCEDURE CodeIfGre (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
tl, tr : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant(CurrentQuadToken, op1) ;
|
|
DeclareConstant(CurrentQuadToken, op2) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op1) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op2) ;
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
PushValue(op1) ;
|
|
PushValue(op2) ;
|
|
IF Gre(CurrentQuadToken)
|
|
THEN
|
|
BuildGoto(location, string(CreateLabelName(op3)))
|
|
ELSE
|
|
(* fall through *)
|
|
END
|
|
ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
|
|
IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
|
|
THEN
|
|
CodeIfSetGre(quad, op1, op2, op3)
|
|
ELSE
|
|
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
|
|
THEN
|
|
MetaErrorT2 (CurrentQuadToken,
|
|
'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
|
|
op1, op2)
|
|
ELSE
|
|
ConvertBinaryOperands(location,
|
|
tl, tr,
|
|
MixTypes(SkipType(GetType(op1)),
|
|
SkipType(GetType(op2)),
|
|
CurrentQuadToken),
|
|
op1, op2) ;
|
|
DoJump(location, BuildGreaterThan(location, tl, tr), NIL, string(CreateLabelName(op3)))
|
|
END
|
|
END
|
|
END CodeIfGre ;
|
|
|
|
|
|
(*
|
|
CodeIfSetLessEqu -
|
|
*)
|
|
|
|
PROCEDURE CodeIfSetLessEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
settype : CARDINAL ;
|
|
falselabel: ADDRESS ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
InternalError ('this should have been folded in the calling procedure')
|
|
ELSIF IsConst(op1)
|
|
THEN
|
|
settype := SkipType(GetType(op2))
|
|
ELSE
|
|
settype := SkipType(GetType(op1))
|
|
END ;
|
|
IF CompareTrees(FindSize(CurrentQuadToken, settype), FindSize(CurrentQuadToken, Word)) <= 0
|
|
THEN
|
|
(* word size sets *)
|
|
DoJump(location,
|
|
BuildIsSubset(location,
|
|
BuildConvert(location, GetWordType(), Mod2Gcc(op1), FALSE),
|
|
BuildConvert(location, GetWordType(), Mod2Gcc(op2), FALSE)),
|
|
NIL, string(CreateLabelName(op3)))
|
|
ELSE
|
|
falselabel := string(Sprintf1(Mark(InitString('.Lset%dcomp')), quad)) ;
|
|
|
|
BuildForeachWordInSetDoIfExpr(location,
|
|
Mod2Gcc(settype),
|
|
Mod2Gcc(op1), Mod2Gcc(op2),
|
|
GetMode(op1)=LeftValue,
|
|
GetMode(op2)=LeftValue,
|
|
IsConst(op1), IsConst(op2),
|
|
BuildIsNotSubset,
|
|
falselabel) ;
|
|
|
|
BuildGoto(location, string(CreateLabelName(op3))) ;
|
|
DeclareLabel(location, falselabel)
|
|
END
|
|
END CodeIfSetLessEqu ;
|
|
|
|
|
|
(*
|
|
CodeIfLessEqu - codes the quadruple if op1 <= op2 then goto op3
|
|
*)
|
|
|
|
PROCEDURE CodeIfLessEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
tl, tr : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant(CurrentQuadToken, op1) ;
|
|
DeclareConstant(CurrentQuadToken, op2) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op1) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op2) ;
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
PushValue(op1) ;
|
|
PushValue(op2) ;
|
|
IF LessEqu(CurrentQuadToken)
|
|
THEN
|
|
BuildGoto(location, string(CreateLabelName(op3)))
|
|
ELSE
|
|
(* fall through *)
|
|
END
|
|
ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
|
|
IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
|
|
THEN
|
|
CodeIfSetLessEqu(quad, op1, op2, op3)
|
|
ELSE
|
|
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
|
|
THEN
|
|
MetaErrorT2 (CurrentQuadToken,
|
|
'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
|
|
op1, op2)
|
|
ELSE
|
|
ConvertBinaryOperands(location,
|
|
tl, tr,
|
|
MixTypes(SkipType(GetType(op1)),
|
|
SkipType(GetType(op2)),
|
|
CurrentQuadToken),
|
|
op1, op2) ;
|
|
DoJump(location, BuildLessThanOrEqual(location, tl, tr), NIL, string(CreateLabelName(op3)))
|
|
END
|
|
END
|
|
END CodeIfLessEqu ;
|
|
|
|
|
|
(*
|
|
CodeIfSetGreEqu -
|
|
*)
|
|
|
|
PROCEDURE CodeIfSetGreEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
settype : CARDINAL ;
|
|
falselabel: ADDRESS ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
InternalError ('this should have been folded in the calling procedure')
|
|
ELSIF IsConst(op1)
|
|
THEN
|
|
settype := SkipType(GetType(op2))
|
|
ELSE
|
|
settype := SkipType(GetType(op1))
|
|
END ;
|
|
IF CompareTrees(FindSize(CurrentQuadToken, settype), FindSize(CurrentQuadToken, Word)) <= 0
|
|
THEN
|
|
(* word size sets *)
|
|
DoJump(location,
|
|
BuildIsSuperset(location,
|
|
BuildConvert(location, GetWordType(), Mod2Gcc(op1), FALSE),
|
|
BuildConvert(location, GetWordType(), Mod2Gcc(op2), FALSE)),
|
|
NIL, string(CreateLabelName(op3)))
|
|
ELSE
|
|
falselabel := string(Sprintf1(Mark(InitString('.Lset%dcomp')), quad)) ;
|
|
|
|
BuildForeachWordInSetDoIfExpr(location,
|
|
Mod2Gcc(settype),
|
|
Mod2Gcc(op1), Mod2Gcc(op2),
|
|
GetMode(op1)=LeftValue,
|
|
GetMode(op2)=LeftValue,
|
|
IsConst(op1), IsConst(op2),
|
|
BuildIsNotSuperset,
|
|
falselabel) ;
|
|
|
|
BuildGoto(location, string(CreateLabelName(op3))) ;
|
|
DeclareLabel(location, falselabel)
|
|
END
|
|
END CodeIfSetGreEqu ;
|
|
|
|
|
|
(*
|
|
CodeIfGreEqu - codes the quadruple if op1 >= op2 then goto op3
|
|
*)
|
|
|
|
PROCEDURE CodeIfGreEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
tl, tr: Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant(CurrentQuadToken, op1) ;
|
|
DeclareConstant(CurrentQuadToken, op2) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op1) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op2) ;
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
PushValue(op1) ;
|
|
PushValue(op2) ;
|
|
IF GreEqu(CurrentQuadToken)
|
|
THEN
|
|
BuildGoto(location, string(CreateLabelName(op3)))
|
|
ELSE
|
|
(* fall through *)
|
|
END
|
|
ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
|
|
IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
|
|
THEN
|
|
CodeIfSetGreEqu(quad, op1, op2, op3)
|
|
ELSE
|
|
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
|
|
THEN
|
|
MetaErrorT2 (CurrentQuadToken,
|
|
'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
|
|
op1, op2)
|
|
ELSE
|
|
ConvertBinaryOperands(location,
|
|
tl, tr,
|
|
MixTypes(SkipType(GetType(op1)),
|
|
SkipType(GetType(op2)),
|
|
CurrentQuadToken),
|
|
op1, op2) ;
|
|
DoJump(location, BuildGreaterThanOrEqual(location, tl, tr), NIL, string(CreateLabelName(op3)))
|
|
END
|
|
END
|
|
END CodeIfGreEqu ;
|
|
|
|
|
|
(*
|
|
CodeIfSetEqu - codes if op1 = op2 then goto op3
|
|
Note that if op1 and op2 are not both constants
|
|
since this will have been evaluated in CodeIfEqu.
|
|
*)
|
|
|
|
PROCEDURE CodeIfSetEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
settype : CARDINAL ;
|
|
falselabel: ADDRESS ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
InternalError ('this should have been folded in the calling procedure')
|
|
ELSIF IsConst(op1)
|
|
THEN
|
|
settype := SkipType(GetType(op2))
|
|
ELSE
|
|
settype := SkipType(GetType(op1))
|
|
END ;
|
|
IF CompareTrees(FindSize(CurrentQuadToken, settype), FindSize(CurrentQuadToken, Word)) <= 0
|
|
THEN
|
|
(* word size sets *)
|
|
DoJump(location,
|
|
BuildEqualTo(location,
|
|
BuildConvert(location, GetWordType(), Mod2Gcc(op1), FALSE),
|
|
BuildConvert(location, GetWordType(), Mod2Gcc(op2), FALSE)),
|
|
NIL, string(CreateLabelName(op3)))
|
|
ELSIF GetSType(op1)=GetSType(op2)
|
|
THEN
|
|
falselabel := string(Sprintf1(Mark(InitString('.Lset%dcomp')), quad)) ;
|
|
|
|
BuildForeachWordInSetDoIfExpr(location,
|
|
Mod2Gcc(settype),
|
|
Mod2Gcc(op1), Mod2Gcc(op2),
|
|
GetMode(op1)=LeftValue,
|
|
GetMode(op2)=LeftValue,
|
|
IsConst(op1), IsConst(op2),
|
|
BuildNotEqualTo,
|
|
falselabel) ;
|
|
|
|
BuildGoto(location, string(CreateLabelName(op3))) ;
|
|
DeclareLabel(location, falselabel)
|
|
ELSE
|
|
MetaErrorT2 (CurrentQuadToken,
|
|
'set comparison is only allowed between the same set type, the set types used by {%1Eatd} and {%2atd} are different',
|
|
op1, op2)
|
|
END
|
|
END CodeIfSetEqu ;
|
|
|
|
|
|
(*
|
|
CodeIfSetNotEqu - codes if op1 # op2 then goto op3
|
|
Note that if op1 and op2 are not both constants
|
|
since this will have been evaluated in CodeIfNotEqu.
|
|
*)
|
|
|
|
PROCEDURE CodeIfSetNotEqu (left, right, destQuad: CARDINAL) ;
|
|
VAR
|
|
settype : CARDINAL ;
|
|
truelabel: ADDRESS ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
IF IsConst (left) AND IsConst (right)
|
|
THEN
|
|
InternalError ('this should have been folded in the calling procedure')
|
|
ELSIF IsConst (left)
|
|
THEN
|
|
settype := SkipType (GetType (right))
|
|
ELSE
|
|
settype := SkipType (GetType (left))
|
|
END ;
|
|
IF CompareTrees (FindSize (CurrentQuadToken, settype), FindSize (CurrentQuadToken, Word)) <= 0
|
|
THEN
|
|
(* word size sets *)
|
|
DoJump (location,
|
|
BuildNotEqualTo(location,
|
|
BuildConvert (location, GetWordType (), Mod2Gcc (left), FALSE),
|
|
BuildConvert (location, GetWordType (), Mod2Gcc (right), FALSE)),
|
|
NIL, string (CreateLabelName (destQuad)))
|
|
ELSIF GetSType (left) = GetSType (right)
|
|
THEN
|
|
truelabel := string (CreateLabelName (destQuad)) ;
|
|
|
|
BuildForeachWordInSetDoIfExpr (location,
|
|
Mod2Gcc (settype),
|
|
Mod2Gcc (left), Mod2Gcc (right),
|
|
GetMode (left) = LeftValue,
|
|
GetMode (right) = LeftValue,
|
|
IsConst (left), IsConst (right),
|
|
BuildNotEqualTo,
|
|
truelabel)
|
|
ELSE
|
|
MetaErrorT2 (CurrentQuadToken,
|
|
'set comparison is only allowed between the same set type, the set types used by {%1Eatd} and {%2atd} are different',
|
|
left, right)
|
|
END
|
|
END CodeIfSetNotEqu ;
|
|
|
|
|
|
(*
|
|
CodeIfEqu - codes the quadruple if op1 = op2 then goto op3
|
|
*)
|
|
|
|
PROCEDURE CodeIfEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
tl, tr: Tree ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant(CurrentQuadToken, op1) ;
|
|
DeclareConstant(CurrentQuadToken, op2) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op1) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op2) ;
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
PushValue(op1) ;
|
|
PushValue(op2) ;
|
|
IF Equ(CurrentQuadToken)
|
|
THEN
|
|
BuildGoto(location, string(CreateLabelName(op3)))
|
|
ELSE
|
|
(* fall through *)
|
|
END
|
|
ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
|
|
IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
|
|
THEN
|
|
CodeIfSetEqu(quad, op1, op2, op3)
|
|
ELSE
|
|
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
|
|
THEN
|
|
MetaErrorT2 (CurrentQuadToken,
|
|
'equality tests between composite types not allowed {%1Eatd} and {%2atd}',
|
|
op1, op2)
|
|
ELSE
|
|
ConvertBinaryOperands(location,
|
|
tl, tr,
|
|
MixTypes(SkipType(GetType(op1)),
|
|
SkipType(GetType(op2)),
|
|
CurrentQuadToken),
|
|
op1, op2) ;
|
|
DoJump(location, BuildEqualTo(location, tl, tr), NIL, string(CreateLabelName(op3)))
|
|
END
|
|
END
|
|
END CodeIfEqu ;
|
|
|
|
|
|
(*
|
|
CodeIfNotEqu - codes the quadruple if op1 # op2 then goto op3
|
|
*)
|
|
|
|
PROCEDURE CodeIfNotEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
tl, tr : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant(CurrentQuadToken, op1) ;
|
|
DeclareConstant(CurrentQuadToken, op2) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op1) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op2) ;
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
PushValue(op1) ;
|
|
PushValue(op2) ;
|
|
IF NotEqu(CurrentQuadToken)
|
|
THEN
|
|
BuildGoto(location, string(CreateLabelName(op3)))
|
|
ELSE
|
|
(* fall through *)
|
|
END
|
|
ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
|
|
IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
|
|
THEN
|
|
CodeIfSetNotEqu (op1, op2, op3)
|
|
ELSE
|
|
IF IsComposite(op1) OR IsComposite(op2)
|
|
THEN
|
|
MetaErrorT2 (CurrentQuadToken,
|
|
'inequality tests between composite types not allowed {%1Eatd} and {%2atd}',
|
|
op1, op2)
|
|
ELSE
|
|
ConvertBinaryOperands(location,
|
|
tl, tr,
|
|
MixTypes(SkipType(GetType(op1)),
|
|
SkipType(GetType(op2)),
|
|
CurrentQuadToken),
|
|
op1, op2) ;
|
|
DoJump(location,
|
|
BuildNotEqualTo(location, tl, tr), NIL, string(CreateLabelName(op3)))
|
|
END
|
|
END
|
|
END CodeIfNotEqu ;
|
|
|
|
|
|
(*
|
|
MixTypes3 - returns a type compatible from, low, high, var.
|
|
*)
|
|
|
|
PROCEDURE MixTypes3 (low, high, var: CARDINAL; tokenno: CARDINAL) : CARDINAL ;
|
|
VAR
|
|
type: CARDINAL ;
|
|
BEGIN
|
|
type := MixTypes(SkipType(GetType(low)), SkipType(GetType(high)), tokenno) ;
|
|
type := MixTypes(type, SkipType(GetType(var)), tokenno) ;
|
|
RETURN( type )
|
|
END MixTypes3 ;
|
|
|
|
|
|
(*
|
|
BuildIfVarInConstValue - if var in constsetvalue then goto trueexit
|
|
*)
|
|
|
|
PROCEDURE BuildIfVarInConstValue (location: location_t; tokenno: CARDINAL;
|
|
constsetvalue: PtrToValue; var, trueexit: CARDINAL) ;
|
|
VAR
|
|
vt, lt, ht : Tree ;
|
|
type,
|
|
low, high, n: CARDINAL ;
|
|
truelabel : String ;
|
|
BEGIN
|
|
n := 1 ;
|
|
truelabel := string(CreateLabelName(trueexit)) ;
|
|
WHILE GetRange(constsetvalue, n, low, high) DO
|
|
type := MixTypes3(low, high, var, tokenno) ;
|
|
ConvertBinaryOperands(location, vt, lt, type, var, low) ;
|
|
ConvertBinaryOperands(location, ht, lt, type, high, low) ;
|
|
BuildIfInRangeGoto(location, vt, lt, ht, truelabel) ;
|
|
INC(n)
|
|
END
|
|
END BuildIfVarInConstValue ;
|
|
|
|
|
|
(*
|
|
BuildIfNotVarInConstValue - if not (var in constsetvalue) then goto trueexit
|
|
*)
|
|
|
|
PROCEDURE BuildIfNotVarInConstValue (quad: CARDINAL; constsetvalue: PtrToValue; var, trueexit: CARDINAL) ;
|
|
VAR
|
|
vt, lt, ht : Tree ;
|
|
type,
|
|
low, high, n: CARDINAL ;
|
|
falselabel,
|
|
truelabel : String ;
|
|
location : location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
truelabel := string(CreateLabelName(trueexit)) ;
|
|
n := 1 ;
|
|
WHILE GetRange(constsetvalue, n, low, high) DO
|
|
INC(n)
|
|
END ;
|
|
IF n=2
|
|
THEN
|
|
(* actually only one set range, so we invert it *)
|
|
type := MixTypes3(low, high, var, CurrentQuadToken) ;
|
|
ConvertBinaryOperands(location, vt, lt, type, var, low) ;
|
|
ConvertBinaryOperands(location, ht, lt, type, high, low) ;
|
|
BuildIfNotInRangeGoto(location, vt, lt, ht, truelabel)
|
|
ELSE
|
|
n := 1 ;
|
|
falselabel := string(Sprintf1(Mark(InitString('.Lset%d')), quad)) ;
|
|
WHILE GetRange(constsetvalue, n, low, high) DO
|
|
type := MixTypes3(low, high, var, CurrentQuadToken) ;
|
|
ConvertBinaryOperands(location, vt, lt, type, var, low) ;
|
|
ConvertBinaryOperands(location, ht, lt, type, high, low) ;
|
|
BuildIfInRangeGoto(location, vt, lt, ht, falselabel) ;
|
|
INC(n)
|
|
END ;
|
|
BuildGoto(location, truelabel) ;
|
|
DeclareLabel(location, falselabel)
|
|
END
|
|
END BuildIfNotVarInConstValue ;
|
|
|
|
|
|
(*
|
|
CodeIfIn - code the quadruple: if op1 in op2 then goto op3
|
|
*)
|
|
|
|
PROCEDURE CodeIfIn (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
low,
|
|
high : CARDINAL ;
|
|
lowtree,
|
|
hightree,
|
|
offset : Tree ;
|
|
fieldno : INTEGER ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant(CurrentQuadToken, op1) ;
|
|
DeclareConstant(CurrentQuadToken, op2) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op1) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op2) ;
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
InternalError ('should not get to here (if we do we should consider calling FoldIfIn)')
|
|
ELSE
|
|
IF IsConst(op1)
|
|
THEN
|
|
fieldno := GetFieldNo(CurrentQuadToken, op1, GetType(op2), offset) ;
|
|
IF fieldno>=0
|
|
THEN
|
|
PushValue(op1) ;
|
|
PushIntegerTree(offset) ;
|
|
ConvertToType(GetType(op1)) ;
|
|
Sub ;
|
|
BuildIfConstInVar(location,
|
|
Mod2Gcc(SkipType(GetType(op2))),
|
|
Mod2Gcc(op2), PopIntegerTree(),
|
|
GetMode(op2)=LeftValue, fieldno,
|
|
string(CreateLabelName(op3)))
|
|
ELSE
|
|
MetaErrorT1 (CurrentQuadToken, 'bit exceeded the range of set {%1Eatd}', op1)
|
|
END
|
|
ELSIF IsConst(op2)
|
|
THEN
|
|
(* builds a cascaded list of if statements *)
|
|
PushValue(op2) ;
|
|
BuildIfVarInConstValue(location, CurrentQuadToken, GetValue(CurrentQuadToken), op1, op3)
|
|
ELSE
|
|
GetSetLimits(SkipType(GetType(op2)), low, high) ;
|
|
|
|
PushValue(low) ;
|
|
lowtree := PopIntegerTree() ;
|
|
PushValue(high) ;
|
|
hightree := PopIntegerTree() ;
|
|
|
|
BuildIfVarInVar(location,
|
|
Mod2Gcc(SkipType(GetType(op2))),
|
|
Mod2Gcc(op2), Mod2Gcc(op1),
|
|
GetMode(op2)=LeftValue,
|
|
lowtree, hightree,
|
|
string(CreateLabelName(op3)))
|
|
END
|
|
END
|
|
END CodeIfIn ;
|
|
|
|
|
|
(*
|
|
CodeIfNotIn - code the quadruple: if not (op1 in op2) then goto op3
|
|
*)
|
|
|
|
PROCEDURE CodeIfNotIn (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
low,
|
|
high : CARDINAL ;
|
|
lowtree,
|
|
hightree,
|
|
offset : Tree ;
|
|
fieldno : INTEGER ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
(* firstly ensure that any constant literal is declared *)
|
|
DeclareConstant(CurrentQuadToken, op1) ;
|
|
DeclareConstant(CurrentQuadToken, op2) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op1) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op2) ;
|
|
IF IsConst(op1) AND IsConst(op2)
|
|
THEN
|
|
InternalError ('should not get to here (if we do we should consider calling FoldIfIn)')
|
|
ELSE
|
|
IF IsConst(op1)
|
|
THEN
|
|
fieldno := GetFieldNo(CurrentQuadToken, op1, SkipType(GetType(op2)), offset) ;
|
|
IF fieldno>=0
|
|
THEN
|
|
PushValue(op1) ;
|
|
PushIntegerTree(offset) ;
|
|
ConvertToType(GetType(op1)) ;
|
|
Sub ;
|
|
BuildIfNotConstInVar(location,
|
|
Mod2Gcc(SkipType(GetType(op2))),
|
|
Mod2Gcc(op2), PopIntegerTree(),
|
|
GetMode(op2)=LeftValue, fieldno,
|
|
string(CreateLabelName(op3)))
|
|
ELSE
|
|
MetaErrorT1 (CurrentQuadToken, 'bit exceeded the range of set {%1Eatd}', op2)
|
|
END
|
|
ELSIF IsConst(op2)
|
|
THEN
|
|
(* builds a cascaded list of if statements *)
|
|
PushValue(op2) ;
|
|
BuildIfNotVarInConstValue(quad, GetValue(CurrentQuadToken), op1, op3)
|
|
ELSE
|
|
GetSetLimits(SkipType(GetType(op2)), low, high) ;
|
|
|
|
PushValue(low) ;
|
|
lowtree := PopIntegerTree() ;
|
|
PushValue(high) ;
|
|
hightree := PopIntegerTree() ;
|
|
|
|
BuildIfNotVarInVar(location,
|
|
Mod2Gcc(SkipType(GetType(op2))),
|
|
Mod2Gcc(op2), Mod2Gcc(op1),
|
|
GetMode(op2)=LeftValue,
|
|
lowtree, hightree,
|
|
string(CreateLabelName(op3)))
|
|
END
|
|
END
|
|
END CodeIfNotIn ;
|
|
|
|
|
|
(*
|
|
------------------------------------------------------------------------------
|
|
IndrX Operator a = *b
|
|
------------------------------------------------------------------------------
|
|
Sym1<X> IndrX Sym2<I> Meaning Mem[Sym1<I>] := Mem[constant]
|
|
Sym1<X> IndrX Sym2<X> Meaning Mem[Sym1<I>] := Mem[Mem[Sym3<I>]]
|
|
|
|
(op2 is the type of the data being indirectly copied)
|
|
*)
|
|
|
|
PROCEDURE CodeIndrX (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
|
|
VAR
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation (CurrentQuadToken) ;
|
|
|
|
(*
|
|
Follow the Quadruple rules:
|
|
*)
|
|
DeclareConstant (CurrentQuadToken, op3) ; (* checks to see whether it is a constant and declares it *)
|
|
DeclareConstructor (CurrentQuadToken, quad, op3) ;
|
|
IF IsConstString (op3)
|
|
THEN
|
|
InternalError ('not expecting to index through a constant string')
|
|
ELSE
|
|
(*
|
|
Mem[op1] := Mem[Mem[op3]]
|
|
*)
|
|
BuildAssignmentStatement (location, Mod2Gcc (op1), BuildIndirect (location, Mod2Gcc (op3), Mod2Gcc (op2)))
|
|
END
|
|
END CodeIndrX ;
|
|
|
|
|
|
(*
|
|
------------------------------------------------------------------------------
|
|
XIndr Operator *a = b
|
|
------------------------------------------------------------------------------
|
|
Sym1<I> XIndr Sym2<X> Meaning Mem[constant] := Mem[Sym3<I>]
|
|
Sym1<X> XIndr Sym2<X> Meaning Mem[Mem[Sym1<I>]] := Mem[Sym3<I>]
|
|
|
|
(op2 is the type of the data being indirectly copied)
|
|
*)
|
|
|
|
PROCEDURE CodeXIndr (quad: CARDINAL; op1, type, op3: CARDINAL) ;
|
|
VAR
|
|
length,
|
|
newstr : Tree ;
|
|
location: location_t ;
|
|
BEGIN
|
|
location := TokenToLocation(CurrentQuadToken) ;
|
|
|
|
type := SkipType (type) ;
|
|
DeclareConstant(CurrentQuadToken, op3) ;
|
|
DeclareConstructor(CurrentQuadToken, quad, op3) ;
|
|
(*
|
|
Follow the Quadruple rule:
|
|
|
|
Mem[Mem[Op1]] := Mem[Op3]
|
|
*)
|
|
IF IsProcType(SkipType(type))
|
|
THEN
|
|
BuildAssignmentStatement (location, BuildIndirect(location, Mod2Gcc(op1), GetPointerType()), Mod2Gcc(op3))
|
|
ELSIF IsConstString(op3) AND (GetStringLength(op3)=0) AND (GetMode(op1)=LeftValue)
|
|
THEN
|
|
(*
|
|
no need to check for type errors,
|
|
but we handle nul string as a special case as back end
|
|
complains if we pass through a "" and ask it to copy the
|
|
contents.
|
|
*)
|
|
BuildAssignmentStatement (location,
|
|
BuildIndirect(location, LValueToGenericPtr(location, op1), Mod2Gcc(Char)),
|
|
StringToChar(Mod2Gcc(op3), Char, op3))
|
|
ELSIF IsConstString(op3) AND (SkipTypeAndSubrange(GetType(op1))#Char)
|
|
THEN
|
|
DoCopyString (CurrentQuadToken, length, newstr, type, op3) ;
|
|
AddStatement (location,
|
|
MaybeDebugBuiltinMemcpy (location, CurrentQuadToken,
|
|
Mod2Gcc (op1),
|
|
BuildAddr (location, newstr, FALSE),
|
|
length))
|
|
ELSE
|
|
BuildAssignmentStatement (location,
|
|
BuildIndirect (location, Mod2Gcc (op1), Mod2Gcc (type)),
|
|
ConvertRHS (Mod2Gcc (op3), type, op3))
|
|
END
|
|
END CodeXIndr ;
|
|
|
|
|
|
BEGIN
|
|
UnboundedLabelNo := 0 ;
|
|
CurrentQuadToken := 0 ;
|
|
ScopeStack := InitStackWord ()
|
|
END M2GenGCC.
|