(* M2GenGCC.mod convert the quadruples into GCC trees. Copyright (C) 2001-2023 Free Software Foundation, Inc. Contributed by Gaius Mulley . 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 . *) 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, IsConstStringCnul, IsConstStringM2nul, 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, UnknownTokenNo ; 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, 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, InitStringChar, Dup ; 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 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, PopChar, 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, GetCstInteger, 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, 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 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 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 := Sym3 := produces a constant Sym1 := Sym3 := has the effect Mem[Sym1] := Mem[Sym3] ------------------------------------------------------------------------------ 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 Addr Sym2 meaning Mem[Sym1] := Sym2 Sym1 Addr Sym2 meaning Mem[Sym1] := Sym2 Sym1 Addr Sym2 meaning Mem[Sym1] := Mem[Sym2] Sym1 Addr Sym2 meaning Mem[Sym1] := Mem[Sym2] ------------------------------------------------------------------------------ Xindr Operator ( *a = b) ------------------------------------------------------------------------------ Sym1 Copy Sym2 Meaning Mem[Sym1] := constant Sym1 Copy Sym2 Meaning Mem[Sym1] := constant Sym1 Copy Sym2 meaning Mem[Sym1] := Mem[Sym2] Sym1 Copy Sym2 meaning Mem[Sym1] := Mem[Sym2] Sym1 Copy Sym2 meaning Mem[Sym1] := Mem[Mem[Sym2]] Sym1 Copy Sym2 meaning Mem[Sym1] := Mem[Mem[Sym2]] ------------------------------------------------------------------------------ IndrX Operator (a = *b) where means any value ------------------------------------------------------------------------------ Sym1 IndrX Sym2 meaning Mem[Sym1] := Mem[constant] Sym1 IndrX Sym2 meaning Mem[Sym1] := Mem[constant] Sym1 IndrX Sym2 meaning Mem[Sym1] := Mem[Mem[Sym2]] Sym1 IndrX Sym2 meaning Mem[Sym1] := Mem[Mem[Sym2]] ------------------------------------------------------------------------------ + - / * Operators ------------------------------------------------------------------------------ Sym1 + Sym2 Sym3 meaning Sym1 := Sym2 + Sym3 Sym1 + Sym2 Sym3 meaning Mem[Sym1] := Mem[Sym2] + Sym3 Sym1 + Sym2 Sym3 meaning Mem[Sym1] := Mem[Sym2] + Mem[Sym3] Sym1 + Sym2 Sym3 meaning Mem[Sym1] := Mem[Sym2] + Mem[Sym3] Sym1 + Sym2 Sym3 meaning Mem[Sym1] := Mem[Sym2] + Mem[Sym3] Sym1 + Sym2 Sym3 meaning Mem[Sym1] := Mem[Sym2] + Mem[Sym3] ------------------------------------------------------------------------------ Base Operator ------------------------------------------------------------------------------ Sym1 Base Sym2 Sym3 meaning Mem[Sym1] := Sym3 Sym1 Base Sym2 Sym3 meaning Should Never Occur But If it did.. Mem[Mem[Sym1]] := Sym3 Sym1 Base Sym2 Sym3 meaning Mem[Sym1] := Mem[Sym3] Sym1 Base Sym2 Sym3 meaning Should Never Occur But If it did.. Mem[Mem[Sym1]] := Mem[Sym3] 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 ; InternalError ('expecting scope to eventually reach a module or defimp symbol') 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 (op3, IsCompilingMainModule (op3)) | InitEndOp : CodeInitEnd (op3, IsCompilingMainModule (op3)) | FinallyStartOp : CodeFinallyStart (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 (q) | TryOp : CodeTry | ThrowOp : CodeThrow (op3) | CatchBeginOp : CodeCatchBegin | CatchEndOp : CodeCatchEnd | RetryOp : CodeRetry (op3) | DummyOp : | InitAddressOp : CodeInitAddress(q, op1, op2, op3) | BecomesOp : CodeBecomes(q) | ArithAddOp, 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) | 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) | ArithAddOp : FoldArithAdd (op1pos, p, quad, op1, op2, 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 (sym: CARDINAL) : Tree ; VAR tok : CARDINAL ; i : CARDINAL ; name : Name ; str, obj : CARDINAL ; gccName, tree : Tree ; BEGIN tree := Tree (NIL) ; IF sym#NulSym THEN i := 1 ; REPEAT GetRegInterface (sym, i, tok, name, str, obj) ; IF str#NulSym THEN IF IsConstString (str) THEN DeclareConstant (tok, obj) ; IF name = NulName THEN gccName := NIL ELSE gccName := BuildStringConstant (KeyToCharStar (name), LengthKey (name)) END ; tree := ChainOnParamValue (tree, gccName, PromoteToString (tok, 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 tok : CARDINAL ; i : CARDINAL ; str, obj : CARDINAL ; name: Name ; tree: Tree ; BEGIN tree := Tree (NIL) ; IF sym#NulSym THEN i := 1 ; REPEAT GetRegInterface (sym, i, tok, name, str, obj) ; IF str # NulSym THEN IF IsConstString (str) THEN tree := AddStringToTreeList (tree, PromoteToString (tok, 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 (GetGnuAsmInput(GnuAsm)) ; outputs := BuildTreeFromInterface (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 (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 (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; tokenpos : CARDINAL ; ctor, init, fini, dep : CARDINAL ; BEGIN IF CompilingMainModule OR WholeProgram THEN (* SetFileNameAndLineNo(string(FileName), op1) ; EmitLineNote(string(FileName), op1) ; *) tokenpos := GetDeclaredMod (moduleSym) ; location := TokenToLocation (tokenpos) ; GetModuleCtors (moduleSym, ctor, init, fini, dep) ; finishFunctionDecl (location, Mod2Gcc (fini)) ; BuildEndFunctionCode (location, Mod2Gcc (fini), IsModuleWithinProcedure (moduleSym)) 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) ; RETURN GetCardinalZero (location) 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) ; RETURN GetCardinalZero (location) 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 *) 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 (tb0 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 j1 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) ; VAR resolved : BOOLEAN ; procedure, r : CARDINAL ; n : CARDINAL ; op1, op2, op3 : CARDINAL ; op : QuadOperator ; val : Tree ; location : location_t ; BEGIN GetQuad (q, op, op1, op2, op3) ; 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) 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 Addr Sym2 meaning Mem[Sym1] := Sym2 *) 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 (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 := Sym3 := 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 ; (* PrepareCopyString - returns two trees: length number of bytes to be copied (including the nul if room) srcTreeType the new string type (with the extra nul character). Pre condition: destStrType the dest type string. src is the original string (without a nul) to be copied. Post condition: TRUE or FALSE is returned. if true length and srcTreeType will be assigned else length is set to the maximum length to be copied and srcTree is set to the max length which fits in dest. *) PROCEDURE PrepareCopyString (tokenno: CARDINAL; VAR length, srcTree: Tree; src, destStrType: CARDINAL) : BOOLEAN ; VAR location : location_t ; intLength: INTEGER ; BEGIN location := TokenToLocation (tokenno) ; Assert (IsArray (SkipType (destStrType))) ; (* Handle string assignments: VAR str: ARRAY [0..10] OF CHAR ; ch : CHAR ; str := 'abcde' but not ch := 'a' *) IF GetType (src) = Char THEN (* * Create string from char and add nul to the end, nul is * added by BuildStringConstant *) srcTree := BuildStringConstant (KeyToCharStar (GetString (src)), 1) ELSE srcTree := Mod2Gcc (src) END ; srcTree := ConvertString (Mod2Gcc (destStrType), srcTree) ; PushIntegerTree (FindSize (tokenno, src)) ; PushIntegerTree (FindSize (tokenno, destStrType)) ; IF Less (tokenno) THEN (* There is room for the extra character. *) length := BuildAdd (location, FindSize (tokenno, src), GetIntegerOne (location), FALSE) ELSE length := FindSize (tokenno, destStrType) ; PushIntegerTree (FindSize (tokenno, src)) ; PushIntegerTree (length) ; (* Greater or Equal so return max characters in the array. *) IF Gre (tokenno) THEN intLength := GetCstInteger (length) ; srcTree := BuildStringConstant (KeyToCharStar (GetString (src)), intLength) ; RETURN FALSE END END ; RETURN TRUE END PrepareCopyString ; (* 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 := Sym3 := produces a constant Sym1 := Sym3 := has the effect Mem[Sym1] := Mem[Sym3] *) 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) ; Assert (op2pos = UnknownTokenNo) ; DeclareConstant (CurrentQuadToken, op3) ; (* Check to see whether op3 is a constant and declare 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) ; IF NOT PrepareCopyString (becomespos, length, op3t, op3, SkipType (GetType (op1))) THEN MetaErrorT2 (MakeVirtualTok (becomespos, op1pos, op3pos), 'string constant {%1Ea} is too large to be assigned to the array {%2ad}', op3, op1) END ; 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 ; (* IsConstStr - returns TRUE if sym is a constant string or a char constant. *) PROCEDURE IsConstStr (sym: CARDINAL) : BOOLEAN ; BEGIN RETURN IsConstString (sym) OR (IsConst (sym) AND (GetSType (sym) = Char)) END IsConstStr ; (* GetStr - return a string containing a constant string value associated with sym. A nul char constant will return an empty string. *) PROCEDURE GetStr (tokenno: CARDINAL; sym: CARDINAL) : String ; VAR ch: CHAR ; BEGIN Assert (IsConst (sym)) ; IF IsConstString (sym) THEN RETURN InitStringCharStar (KeyToCharStar (GetString (sym))) ELSE Assert (GetSType (sym) = Char) ; PushValue (sym) ; ch := PopChar (tokenno) ; RETURN InitStringChar (ch) END END GetStr ; (* FoldAdd - check addition for constant folding. It checks for conststrings overloading the +. *) PROCEDURE FoldAdd (tokenno: CARDINAL; p: WalkAction; quad: CARDINAL; op1, op2, op3: CARDINAL) ; VAR s: String ; BEGIN IF IsConstStr (op2) AND IsConstStr (op3) THEN (* Handle special addition for constant strings. *) s := Dup (GetStr (tokenno, op2)) ; s := ConCat (s, GetStr (tokenno, op3)) ; PutConstString (tokenno, op1, makekey (string (s))) ; TryDeclareConstant (tokenno, op1) ; p (op1) ; NoChange := FALSE ; SubQuad (quad) ; s := KillString (s) ELSE FoldArithAdd (tokenno, p, quad, op1, op2, op3) END END FoldAdd ; (* FoldArithAdd - check arithmetic addition for constant folding. *) PROCEDURE FoldArithAdd (tokenno: CARDINAL; p: WalkAction; quad: CARDINAL; op1, op2, op3: CARDINAL) ; BEGIN IF BinaryOperands (quad, op2, op3) THEN FoldBinary (tokenno, p, BuildAdd, quad, op1, op2, op3) END END FoldArithAdd ; (* 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 ?)') 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)) ; IF IsConstString (operand) AND (IsConstStringM2nul (operand) OR IsConstStringCnul (operand)) THEN RETURN GetCardinalOne (location) END ; 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) OR (IsConst (array) AND (GetSType (array) = Char)) 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 IndrX Sym2 Meaning Mem[Sym1] := Mem[constant] Sym1 IndrX Sym2 Meaning Mem[Sym1] := Mem[Mem[Sym3]] (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 XIndr Sym2 Meaning Mem[constant] := Mem[Sym3] Sym1 XIndr Sym2 Meaning Mem[Mem[Sym1]] := Mem[Sym3] (op2 is the type of the data being indirectly copied) *) PROCEDURE CodeXIndr (quad: CARDINAL) ; VAR op : QuadOperator ; tokenno, op1, type, op3, op1pos, op3pos, typepos, xindrpos: CARDINAL ; length, newstr : Tree ; location: location_t ; BEGIN GetQuadOtok (quad, xindrpos, op, op1, type, op3, op1pos, typepos, op3pos) ; tokenno := MakeVirtualTok (xindrpos, op1pos, op3pos) ; location := TokenToLocation (tokenno) ; type := SkipType (type) ; DeclareConstant (op3pos, op3) ; DeclareConstructor (op3pos, 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 IF NOT PrepareCopyString (tokenno, length, newstr, op3, type) THEN MetaErrorT2 (MakeVirtualTok (xindrpos, op1pos, op3pos), 'string constant {%1Ea} is too large to be assigned to the array {%2ad}', op3, op1) END ; AddStatement (location, MaybeDebugBuiltinMemcpy (location, tokenno, 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.