MODULE FoxIntermediateBackend;
IMPORT Basic := FoxBasic, SyntaxTree := FoxSyntaxTree, SemanticChecker := FoxSemanticChecker, Backend := FoxBackend, Global := FoxGlobal,
Scanner := FoxScanner, IntermediateCode := FoxIntermediateCode, Sections := FoxSections, Printout := FoxPrintout,
SYSTEM, Diagnostics, Strings, Options, Streams, Compiler, Formats := FoxFormats, SymbolFileFormat := FoxTextualSymbolFile, D := Debugging,
FingerPrinter := FoxFingerPrinter, StringPool, ActiveCells := FoxActiveCells;
CONST
ModeUndefined = 0;
ModeReference = 1;
ModeValue = 2;
ArrayDimTable = 3;
MathPtrOffset=0;
MathAdrOffset=1;
MathFlagsOffset=2;
MathDimOffset=3;
MathElementSizeOffset=4;
MathLenOffset=5;
MathIncrOffset=6;
SysDataArrayOffset* = 8*8;
ArrDataArrayOffset*= 16*8;
TensorFlag* = 0;
RangeFlag* = 1;
StackFlag* = 2;
WithTrap* = 1;
CaseTrap* = 2;
ReturnTrap* = 3;
TypeEqualTrap* = 5;
TypeCheckTrap* = 6;
IndexCheckTrap* = 7;
AssertTrap* = 8;
ArraySizeTrap* = 9;
ArrayFormTrap*=10;
SetElementTrap*=11;
NegativeDivisorTrap*=12;
Trace = FALSE;
TraceRegisterUsage=TRUE;
ArrayAlignment = 8*8;
NumberSystemCalls* = 12;
SysNewRec* = 0; SysNewArr* = 1; SysNewSys* = 2; SysCaseTable* = 3; SysProcAddr* = 4;
SysLock* = 5; SysUnlock* = 6; SysStart* = 7; SysAwait* = 8; SysInterfaceLookup* = 9;
SysRegisterInterface* = 10; SysGetProcedure* = 11;
DefaultRuntimeModuleName ="Runtime";
DefaultTraceModuleName ="KernelLog";
ChannelModuleName = "Channels";
suppressModuleRegistration=FALSE;
NonPointer = -1;
NoType = 0;
LhsIsPointer = 0;
RhsIsPointer = 1;
DisableSysCalls= TRUE;
TYPE
SupportedInstructionProcedure* = PROCEDURE {DELEGATE} (CONST instr: IntermediateCode.Instruction; VAR moduleName,procedureName: ARRAY OF CHAR): BOOLEAN;
SupportedImmediateProcedure* = PROCEDURE {DELEGATE} (CONST op: IntermediateCode.Operand): BOOLEAN;
Operand = RECORD
mode: SHORTINT;
op: IntermediateCode.Operand;
tag: IntermediateCode.Operand;
extra: IntermediateCode.Operand;
dimOffset: LONGINT;
END;
Fixup= POINTER TO RECORD
pc: LONGINT;
nextFixup: Fixup;
END;
WriteBackCall = POINTER TO RECORD
call: SyntaxTree.ProcedureCallDesignator;
next: WriteBackCall;
END;
Label= OBJECT
VAR
fixups: Fixup;
section: IntermediateCode.Section;
pc: LONGINT;
PROCEDURE &InitLabel(section: IntermediateCode.Section);
BEGIN
SELF.section := section; pc := -1;
END InitLabel;
PROCEDURE Resolve(pc: LONGINT);
VAR at: LONGINT;
BEGIN
SELF.pc := pc;
WHILE(fixups # NIL) DO
at := fixups.pc;
section.PatchAddress(at,pc);
fixups := fixups.nextFixup;
END;
END Resolve;
PROCEDURE AddFixup(at: LONGINT);
VAR fixup: Fixup;
BEGIN
ASSERT(pc=-1);
NEW(fixup); fixup.pc := at; fixup.nextFixup := fixups; fixups := fixup;
END AddFixup;
END Label;
ConditionalBranch = PROCEDURE {DELEGATE}(label: Label; op1,op2: IntermediateCode.Operand);
DeclarationVisitor =OBJECT(SyntaxTree.Visitor)
VAR
backend: IntermediateBackend;
implementationVisitor: ImplementationVisitor;
meta: MetaDataGenerator;
system: Global.System;
currentScope: SyntaxTree.Scope;
module: Sections.Module;
moduleSelf: SyntaxTree.Variable;
dump: BOOLEAN;
forceModuleBody: BOOLEAN;
PROCEDURE & Init(system: Global.System; implementationVisitor: ImplementationVisitor; backend: IntermediateBackend; forceModuleBody, dump: BOOLEAN);
BEGIN
currentScope := NIL; module := NIL; moduleSelf := NIL;
SELF.system := system; SELF.implementationVisitor := implementationVisitor;
SELF.dump := dump;
SELF.backend := backend;
SELF.forceModuleBody := forceModuleBody;
END Init;
PROCEDURE Error(position: LONGINT; CONST s: ARRAY OF CHAR);
BEGIN
backend.Error(module.module.sourceName, position, Diagnostics.Invalid, s);
END Error;
PROCEDURE Type(x: SyntaxTree.Type);
BEGIN
x.Accept(SELF);
END Type;
PROCEDURE VisitBasicType(x: SyntaxTree.BasicType);
BEGIN END VisitBasicType;
PROCEDURE VisitCharacterType(x: SyntaxTree.CharacterType);
BEGIN END VisitCharacterType;
PROCEDURE VisitIntegerType(x: SyntaxTree.IntegerType);
BEGIN END VisitIntegerType;
PROCEDURE VisitFloatType(x: SyntaxTree.FloatType);
BEGIN END VisitFloatType;
PROCEDURE VisitComplexType(x: SyntaxTree.ComplexType);
BEGIN END VisitComplexType;
PROCEDURE VisitQualifiedType(x: SyntaxTree.QualifiedType);
VAR type: SyntaxTree.Type;
BEGIN
type := x.resolved;
IF (type.typeDeclaration # NIL) & (type.typeDeclaration.scope.ownerModule # module.module) THEN
meta.CheckTypeDeclaration(type);
END;
END VisitQualifiedType;
PROCEDURE VisitStringType(x: SyntaxTree.StringType);
BEGIN END VisitStringType;
PROCEDURE VisitArrayRangeType(x: SyntaxTree.RangeType);
BEGIN
END VisitArrayRangeType;
PROCEDURE VisitArrayType(x: SyntaxTree.ArrayType);
BEGIN END VisitArrayType;
PROCEDURE VisitMathArrayType(x: SyntaxTree.MathArrayType);
BEGIN
meta.CheckTypeDeclaration(x);
END VisitMathArrayType;
PROCEDURE VisitPointerType(x: SyntaxTree.PointerType);
BEGIN
meta.CheckTypeDeclaration(x);
END VisitPointerType;
PROCEDURE VisitRecordType(x: SyntaxTree.RecordType);
VAR name: ARRAY 256 OF CHAR; td: SyntaxTree.TypeDeclaration;
BEGIN
meta.CheckTypeDeclaration(x);
IF (x.recordScope.ownerModule = module.module) & (x.isObject) THEN
IF x.pointerType.typeDeclaration # NIL THEN
td := x.pointerType.typeDeclaration
ELSE
td := x.typeDeclaration
END;
Global.GetSymbolName(td,name);
END;
Scope(x.recordScope);
END VisitRecordType;
PROCEDURE HasFlag(modifiers: SyntaxTree.Modifier; CONST name: ARRAY OF CHAR): BOOLEAN;
VAR this: SyntaxTree.Modifier; id: SyntaxTree.Identifier;
BEGIN
this := modifiers; id := SyntaxTree.NewIdentifier(name);
WHILE (this # NIL) & (this.identifier# id) DO
this := this.nextModifier;
END;
RETURN this # NIL
END HasFlag;
PROCEDURE VisitCellType(x: SyntaxTree.CellType);
VAR name:Basic.PooledName; td: SyntaxTree.TypeDeclaration; type: SyntaxTree.Type; len,port,adr: LONGINT;
parameter: SyntaxTree.Parameter; symbol: IntermediateCode.Section; op: IntermediateCode.Operand; capabilities: SET;
BEGIN
meta.CheckTypeDeclaration(x);
IF (x.cellScope.ownerModule = module.module) THEN
td := x.typeDeclaration;
Global.GetSymbolPooledName(td,name);
END;
port := 0;
parameter := x.firstParameter;
WHILE parameter # NIL DO
type := parameter.type.resolved;
IF type IS SyntaxTree.PortType THEN
len := 1;
INC(port);
ELSIF SemanticChecker.IsStaticArray(type,type,len) THEN
Global.GetSymbolPooledName(parameter,name);
symbol := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.ConstSection, TRUE, name,parameter,dump);
WHILE len > 0 DO
adr := backend.activeCellsSpecification.GetPortAddress(port);
IntermediateCode.InitImmediate(op,IntermediateCode.GetType(system,system.addressType),adr);
symbol.Emit(Data(-1,op));
DEC(len); INC(port);
END;
ELSE
Error(parameter.position,"should never happen, check semantic checker!");
END;
parameter := parameter.nextParameter;
END;
capabilities := {};
IF HasFlag(x.modifiers, Global.StringFloatingPoint) THEN INCL(capabilities, Global.FloatingPointCapability) END;
IF HasFlag(x.modifiers, Global.StringVector) THEN INCL(capabilities, Global.VectorCapability) END;
backend.SetCapabilities(capabilities);
Scope(x.cellScope);
END VisitCellType;
PROCEDURE VisitProcedureType(x: SyntaxTree.ProcedureType);
BEGIN END VisitProcedureType;
PROCEDURE VisitEnumerationType(x: SyntaxTree.EnumerationType);
BEGIN
END VisitEnumerationType;
PROCEDURE VisitProcedure(x: SyntaxTree.Procedure);
BEGIN
Procedure(x);
END VisitProcedure;
PROCEDURE VisitOperator(x: SyntaxTree.Operator);
BEGIN
Procedure(x);
END VisitOperator;
PROCEDURE VisitVariable(x: SyntaxTree.Variable);
VAR name: Basic.PooledName; irv: IntermediateCode.Section;
BEGIN
IF (currentScope IS SyntaxTree.ModuleScope) OR (currentScope IS SyntaxTree.CellScope) THEN
Global.GetSymbolPooledName(x,name);
irv := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.VarSection, TRUE, name,x,dump);
irv.SetPositionOrAlignment(x.fixed, x.alignment);
irv.SetOffset(ToMemoryUnits(system,x.offsetInBits));
irv.Emit(Reserve(x.position,ToMemoryUnits(system,system.SizeOf(x.type))));
meta.CheckTypeDeclaration(x.type);
ELSIF currentScope IS SyntaxTree.RecordScope THEN
ELSIF currentScope IS SyntaxTree.ProcedureScope THEN
END;
END VisitVariable;
PROCEDURE VisitParameter(x: SyntaxTree.Parameter);
VAR name: Basic.PooledName; irv: IntermediateCode.Section; op: Operand;
BEGIN
ASSERT(currentScope.outerScope IS SyntaxTree.CellScope);
Global.GetSymbolPooledName(x,name);
irv := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.VarSection, TRUE, name,x,dump);
irv.SetPositionOrAlignment(x.fixed, x.alignment);
IF x.defaultValue = NIL THEN
irv.Emit(Reserve(x.position,ToMemoryUnits(system,system.SizeOf(x.type))))
ELSE
implementationVisitor.inData := TRUE;
implementationVisitor.Evaluate(x.defaultValue, op);
irv.Emit(Data(x.position,op.op));
implementationVisitor.inData := FALSE;
END;
meta.CheckTypeDeclaration(x.type);
END VisitParameter;
PROCEDURE VisitTypeDeclaration(x: SyntaxTree.TypeDeclaration);
BEGIN
Type(x.declaredType);
IF ~(x.declaredType IS SyntaxTree.QualifiedType) & (x.declaredType.resolved IS SyntaxTree.PointerType) THEN
Type(x.declaredType.resolved(SyntaxTree.PointerType).pointerBase);
END;
END VisitTypeDeclaration;
PROCEDURE VisitConstant(x: SyntaxTree.Constant);
BEGIN
IF (SyntaxTree.Public * x.access # {}) THEN
implementationVisitor.VisitConstant(x);
END;
END VisitConstant;
PROCEDURE Scope(x: SyntaxTree.Scope);
VAR procedure: SyntaxTree.Procedure;
constant: SyntaxTree.Constant;
variable: SyntaxTree.Variable;
prevScope: SyntaxTree.Scope; typeDeclaration: SyntaxTree.TypeDeclaration;
BEGIN
prevScope := currentScope;
currentScope := x;
typeDeclaration := x.firstTypeDeclaration;
WHILE typeDeclaration # NIL DO
VisitTypeDeclaration(typeDeclaration);
typeDeclaration := typeDeclaration.nextTypeDeclaration;
END;
variable := x.firstVariable;
WHILE variable # NIL DO
VisitVariable(variable);
variable := variable.nextVariable;
END;
procedure := x.firstProcedure;
WHILE procedure # NIL DO
VisitProcedure(procedure);
procedure := procedure.nextProcedure;
END;
constant := x.firstConstant;
WHILE constant # NIL DO
VisitConstant(constant);
constant := constant.nextConstant;
END;
currentScope := prevScope;
END Scope;
PROCEDURE Parameters(first: SyntaxTree.Parameter);
VAR parameter: SyntaxTree.Parameter;
BEGIN
parameter := first;
WHILE parameter # NIL DO
VisitParameter(parameter);
parameter := parameter.nextParameter;
END;
END Parameters;
PROCEDURE Procedure(x: SyntaxTree.Procedure);
VAR scope: SyntaxTree.ProcedureScope;
prevScope: SyntaxTree.Scope;
inline: BOOLEAN;
procedureType: SyntaxTree.ProcedureType;
pc: LONGINT;
stackSize: LONGINT;
parSize: LONGINT;
name: Basic.PooledName; ir: IntermediateCode.Section;
null,size,src,dest,fp: IntermediateCode.Operand;
cc: LONGINT;
actorType: SyntaxTree.CellType;
registerNumber: LONGINT;
registerClass: IntermediateCode.RegisterClass;
type: IntermediateCode.Type;
formalParameter: SyntaxTree.Parameter;
PROCEDURE Signature;
VAR parameter: SyntaxTree.Parameter; procedureType: SyntaxTree.ProcedureType; returnType : SyntaxTree.Type;
BEGIN
procedureType := x.type(SyntaxTree.ProcedureType);
returnType := procedureType.returnType;
IF returnType # NIL THEN
meta.CheckTypeDeclaration(returnType)
END;
parameter := procedureType.firstParameter;
WHILE parameter # NIL DO
meta.CheckTypeDeclaration(parameter.type);
parameter := parameter.nextParameter;
END;
END Signature;
PROCEDURE CheckIntegerValue(x: SyntaxTree.Expression; VAR value: LONGINT): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.IntegerValue) THEN
result := TRUE;
value := x.resolved(SyntaxTree.IntegerValue).value;
ELSE
Error(x.position,"expression is not an integer constant");
END;
RETURN result;
END CheckIntegerValue;
PROCEDURE HasValue(modifiers: SyntaxTree.Modifier; CONST name: ARRAY OF CHAR; VAR value: LONGINT): BOOLEAN;
VAR this: SyntaxTree.Modifier; id: SyntaxTree.Identifier;
BEGIN
this := modifiers; id := SyntaxTree.NewIdentifier(name);
WHILE (this # NIL) & (this.identifier # id) DO
this := this.nextModifier;
END;
IF this # NIL THEN
IF this.expression = NIL THEN
Error(this.position,"expected expression value");
ELSIF CheckIntegerValue(this.expression,value) THEN
END;
RETURN TRUE
ELSE RETURN FALSE
END;
END HasValue;
BEGIN
scope := x.procedureScope;
prevScope := currentScope;
currentScope := scope;
procedureType := x.type(SyntaxTree.ProcedureType);
implementationVisitor.GetCodeSectionNameForSymbol(x, name);
IF (scope.body # NIL) & (x.isInline) THEN
inline := TRUE;
ir := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.InlineCodeSection, TRUE, name,x,dump);
ELSIF (x.scope # NIL) & (x.scope IS SyntaxTree.CellScope) & (x.scope(SyntaxTree.CellScope).ownerCell.isCellNet)
OR (x.scope # NIL) & (x.scope IS SyntaxTree.ModuleScope) & (x.scope(SyntaxTree.ModuleScope).ownerModule.isCellNet) THEN
RETURN
ELSIF x = module.module.moduleScope.bodyProcedure THEN
inline := FALSE;
AddBodyCallStub(x);
ir := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.BodyCodeSection, TRUE, name,x,dump);
ELSIF (scope.outerScope IS SyntaxTree.CellScope) & (x = scope.outerScope(SyntaxTree.CellScope).bodyProcedure) THEN
inline := FALSE;
actorType := scope.outerScope(SyntaxTree.CellScope).ownerCell;
IF ~HasValue(actorType.modifiers,Global.StringDataMemorySize,stackSize) THEN stackSize := ActiveCells.defaultDataMemorySize END;
AddBodyCallStub(x);
AddStackAllocation(x,stackSize);
ir := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.BodyCodeSection, TRUE, name,x,dump);
ELSIF (scope.outerScope IS SyntaxTree.CellScope) & (x.isConstructor) THEN
inline := FALSE;
Parameters(procedureType.firstParameter);
ir := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.CodeSection, TRUE, name,x,dump);
ELSE
inline := FALSE;
ir := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.CodeSection, TRUE, name,x,dump);
END;
cc := procedureType.callingConvention;
IF cc = SyntaxTree.CCallingConvention THEN
parSize := 0
ELSE
parSize := ProcedureParametersSize(system,x);
END;
IF scope.body # NIL THEN
registerNumber := 0;
IF ~inline THEN
pc := ir.pc;
IF scope.lastVariable = NIL THEN
stackSize := 0
ELSE
stackSize := scope.lastVariable.offsetInBits;
IF stackSize <0 THEN stackSize := -stackSize END;
Basic.Align(stackSize,system.AlignmentOf(system.parameterAlignment,system.byteType));
END;
ir.Emit(Nop(-1));
IF procedureType.callingConvention # SyntaxTree.OberonCallingConvention THEN
formalParameter := procedureType.lastParameter;
WHILE (formalParameter # NIL) & (registerNumber < system.registerParameters) DO
IF ~PassInRegister(formalParameter) THEN
Error(formalParameter.position,"Calling convention error: cannot be passed as register");
ELSE
IntermediateCode.InitRegisterClass(registerClass, IntermediateCode.Parameter, SHORT(registerNumber));
type := GetType(system, formalParameter.type);
src := IntermediateCode.Register(type, registerClass, implementationVisitor.AcquireRegister(type, registerClass));
IntermediateCode.InitMemory(dest,GetType(system,formalParameter.type),implementationVisitor.fp,ToMemoryUnits(system,formalParameter.offsetInBits));
ir.Emit(Mov(-1,dest, src));
implementationVisitor.ReleaseIntermediateOperand(src);
INC(registerNumber);
formalParameter := formalParameter.prevParameter;
END;
END;
IF (registerNumber < system.registerParameters) & (procedureType.callingConvention # SyntaxTree.CCallingConvention) THEN
parSize := system.registerParameters*system.addressSize
END;
END;
ir.EnterValidPAF;
END;
implementationVisitor.tagsAvailable := procedureType.callingConvention = SyntaxTree.OberonCallingConvention;
implementationVisitor.Body(scope.body,currentScope,ir,x = module.module.moduleScope.bodyProcedure);
IF ~inline & ~(procedureType.noPAF) THEN
IF scope.lastVariable # NIL THEN
stackSize := scope.lastVariable.offsetInBits;
IF stackSize <0 THEN stackSize := -stackSize END;
Basic.Align(stackSize,system.AlignmentOf(system.parameterAlignment,system.byteType));
END;
END;
IF ~inline & ~(procedureType.noPAF) THEN
IF ToMemoryUnits(system,stackSize) > 4*1024-256 THEN
END;
ir.EmitAt(pc(*+2*),Enter(x.position,cc,ToMemoryUnits(system,stackSize),registerNumber));
IF stackSize > 0 THEN
IF (stackSize MOD system.addressSize = 0) THEN
null := IntermediateCode.Immediate(IntermediateCode.GetType(system,system.addressType),0);
fp := IntermediateCode.Register(IntermediateCode.GetType(system,system.addressType),IntermediateCode.GeneralPurposeRegister,IntermediateCode.FP);
IntermediateCode.AddOffset(fp,ToMemoryUnits(system,-system.addressSize));
size := IntermediateCode.Immediate(IntermediateCode.GetType(system,system.addressType),stackSize DIV system.addressSize);
ELSE
null := IntermediateCode.Immediate(int8,0);
fp := IntermediateCode.Register(IntermediateCode.GetType(system,system.addressType),IntermediateCode.GeneralPurposeRegister,IntermediateCode.FP);
IntermediateCode.AddOffset(fp,ToMemoryUnits(system,-null.type.sizeInBits));
size := IntermediateCode.Immediate(IntermediateCode.GetType(system,system.addressType),stackSize DIV null.type.sizeInBits);
END;
END;
ir.ExitValidPAF;
IF (procedureType.returnType = NIL) OR (scope.body.code # NIL) THEN
ir.Emit(Leave(x.position,cc));
ir.Emit(Exit(x.position,parSize, procedureType.pcOffset));
ELSE
ir.Emit(Trap(x.position,ReturnTrap));
END
END;
ELSE
ir.Emit(Enter(x.position,cc,0,0));
ir.EnterValidPAF;
implementationVisitor.Body(scope.body,currentScope,ir,x = module.module.moduleScope.bodyProcedure);
ir.ExitValidPAF;
ir.Emit(Leave(x.position,cc));
ir.Emit(Exit(x.position,parSize, procedureType.pcOffset));
END;
Scope(scope);
Signature;
IF (x IS SyntaxTree.Operator) & x(SyntaxTree.Operator).isDynamic THEN implementationVisitor.RegisterDynamicOperator(x(SyntaxTree.Operator)) END;
currentScope := prevScope;
END Procedure;
PROCEDURE AddBodyCallStub(bodyProcedure: SyntaxTree.Procedure);
VAR procedure: SyntaxTree.Procedure; procedureScope: SyntaxTree.ProcedureScope; name: Basic.PooledName;
ir: IntermediateCode.Section; op: IntermediateCode.Operand;
BEGIN
ASSERT (bodyProcedure # NIL);
procedureScope := SyntaxTree.NewProcedureScope(bodyProcedure.scope);
procedure := SyntaxTree.NewProcedure(-1,SyntaxTree.NewIdentifier("@BodyStub"), procedureScope);
procedure.SetScope(bodyProcedure.scope);
procedure.SetType(SyntaxTree.NewProcedureType(-1,bodyProcedure.scope));
procedure.SetAccess(SyntaxTree.Hidden);
Global.GetSymbolPooledName (procedure,name);
ir := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.InitCodeSection, TRUE, name,procedure,dump);
Global.GetSymbolPooledName (bodyProcedure,name);
IntermediateCode.InitAddress(op, IntermediateCode.GetType(system,system.addressType), implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.BodyCodeSection, TRUE, name,bodyProcedure,dump) , 0);
ir.Emit(Call(bodyProcedure.position,op, 0));
END AddBodyCallStub;
PROCEDURE AddStackAllocation(symbol: SyntaxTree.Symbol; initStack: LONGINT);
VAR procedure: SyntaxTree.Procedure; procedureScope: SyntaxTree.ProcedureScope; name: Basic.PooledName;
ir: IntermediateCode.Section; op: IntermediateCode.Operand;
BEGIN
Global.GetSymbolPooledName (symbol,name);
Basic.RemoveSuffix(name);
Basic.SuffixPooledName(name, Basic.MakeString("@StackAllocation"));
ir := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.InitCode2Section, TRUE, name,NIL,dump);
IntermediateCode.InitImmediate(op,IntermediateCode.GetType(system,system.addressType),initStack);
ir.Emit(Mov(-1,implementationVisitor.sp,op));
END AddStackAllocation;
PROCEDURE Module(x: SyntaxTree.Module; module: Sections.Module);
VAR
ir: IntermediateCode.Section; op: IntermediateCode.Operand; name: Basic.PooledName; idstr: SyntaxTree.IdentifierString;
hasDynamicOperatorDeclarations: BOOLEAN;
operator: SyntaxTree.Operator;
import: SyntaxTree.Import;
PROCEDURE TypeNeedsInitialization(type: SyntaxTree.Type): BOOLEAN;
BEGIN
type := type.resolved;
IF type IS SyntaxTree.RecordType THEN
IF ScopeNeedsInitialization(type(SyntaxTree.RecordType).recordScope) THEN RETURN TRUE END;
ELSIF (type IS SyntaxTree.ArrayType) THEN
IF type(SyntaxTree.ArrayType).form = SyntaxTree.Static THEN
IF TypeNeedsInitialization(type(SyntaxTree.ArrayType).arrayBase) THEN RETURN TRUE END;
END;
ELSIF type IS SyntaxTree.MathArrayType THEN
WITH type: SyntaxTree.MathArrayType DO
IF type.form = SyntaxTree.Open THEN
RETURN TRUE
ELSIF type.form = SyntaxTree.Static THEN
IF TypeNeedsInitialization(type.arrayBase) THEN RETURN TRUE END;
END;
END;
END;
RETURN FALSE
END TypeNeedsInitialization;
PROCEDURE ScopeNeedsInitialization(scope: SyntaxTree.Scope): BOOLEAN;
VAR variable: SyntaxTree.Variable;
BEGIN
variable := scope.firstVariable;
WHILE variable # NIL DO
IF TypeNeedsInitialization(variable.type) THEN RETURN TRUE END;
variable := variable.nextVariable;
END;
RETURN FALSE
END ScopeNeedsInitialization;
BEGIN
ASSERT(x # NIL); ASSERT(module # NIL);
SELF.module := module;
import := x.moduleScope.firstImport;
WHILE import # NIL DO
import.GetName(idstr);
module.imports.AddName(idstr);
import := import.nextImport
END;
IF ~implementationVisitor.newObjectFile & ~meta.simple THEN
Global.GetModulePooledName(module.module,name); Basic.SuffixPooledName(name, Basic.MakeString("@moduleSelf"));
moduleSelf := SyntaxTree.NewVariable(0,SyntaxTree.NewIdentifier("@moduleSelf"));
moduleSelf.SetType(system.anyType);
moduleSelf.SetScope(x.moduleScope);
moduleSelf.SetUntraced(TRUE);
ir := implementationVisitor.NewSection(module.allSections, Sections.RegularKind,Sections.ConstSection, TRUE, name,moduleSelf,dump); ir.SetOffset(0);
IntermediateCode.InitImmediate(op,IntermediateCode.GetType(system,system.addressType),0);
ir.Emit(Data(-1,op));
END;
implementationVisitor.module := module;
implementationVisitor.moduleScope := x.moduleScope;
implementationVisitor.moduleSelf := moduleSelf;
meta.SetModule(module);
IF (forceModuleBody OR implementationVisitor.newObjectFile OR ScopeNeedsInitialization(x.moduleScope)) & ~meta.simple THEN
EnsureBodyProcedure(x.moduleScope);
END;
IF backend.profile THEN
EnsureBodyProcedure(x.moduleScope);
Global.GetModulePooledName(module.module,name); Basic.SuffixPooledName(name, Basic.MakeString("@ModuleId"));
implementationVisitor.profileId := implementationVisitor.NewSection(module.allSections, Sections.RegularKind, Sections.VarSection, TRUE, name,NIL,dump);
implementationVisitor.profileId.Emit(Reserve(-1,ToMemoryUnits(system,system.SizeOf(system.longintType))));
Global.GetModulePooledName(module.module,name); Basic.SuffixPooledName(name, Basic.MakeString("@InitProfiler"));
implementationVisitor.profileInit := implementationVisitor.NewSection(module.allSections, Sections.RegularKind, Sections.CodeSection, TRUE, name,NIL,dump);
implementationVisitor.profileInit.Emit(Enter(-1,0,0,0));
Global.GetModuleName(module.module,idstr);
implementationVisitor.ProfilerAddModule(idstr);
implementationVisitor.numberProcedures := 0;
END;
implementationVisitor.profile := backend.profile;
hasDynamicOperatorDeclarations := FALSE;
operator := x.moduleScope.firstOperator;
WHILE operator # NIL DO
IF operator.isDynamic THEN hasDynamicOperatorDeclarations := TRUE END;
operator := operator.nextOperator
END;
IF hasDynamicOperatorDeclarations THEN
EnsureBodyProcedure(x.moduleScope);
Global.GetModulePooledName(module.module,name); Basic.SuffixPooledName(name, Basic.MakeString("@OperatorInitialization"));
implementationVisitor.operatorInitializationCodeSection := implementationVisitor.NewSection(module.allSections, Sections.RegularKind, Sections.CodeSection, TRUE, name, NIL, dump);
implementationVisitor.operatorInitializationCodeSection.Emit(Enter(-1,0,0,0));
END;
Scope(x.moduleScope);
IF hasDynamicOperatorDeclarations THEN
implementationVisitor.operatorInitializationCodeSection.Emit(Leave(-1,0));
implementationVisitor.operatorInitializationCodeSection.Emit(Exit(-1,0, 0));
END;
IF backend.profile THEN
implementationVisitor.ProfilerPatchInit;
END;
END Module;
END DeclarationVisitor;
UsedArray*=POINTER TO ARRAY OF RECORD count: LONGINT; map: LONGINT; type: IntermediateCode.Type; class: IntermediateCode.RegisterClass END;
RegisterUsage*=OBJECT
VAR used: UsedArray; count: LONGINT;
PROCEDURE &Init;
VAR i: LONGINT;
BEGIN
count := 0;
IF used = NIL THEN NEW(used,64); END;
FOR i := 0 TO LEN(used)-1 DO used[i].count := 0 END;
END Init;
PROCEDURE Grow;
VAR new: UsedArray; size,i: LONGINT;
BEGIN
size := LEN(used)*2;
NEW(new,size);
FOR i := 0 TO LEN(used)-1 DO
new[i].count := used[i].count;
new[i].type := used[i].type;
new[i].map := used[i].map
END;
FOR i := LEN(used) TO LEN(new)-1 DO new[i].count := 0 END;
used := new
END Grow;
PROCEDURE Next(type: IntermediateCode.Type; class: IntermediateCode.RegisterClass): LONGINT;
BEGIN
INC(count);
IF count = LEN(used) THEN Grow END;
used[count].type := type;
used[count].class := class;
used[count].map := count;
RETURN count;
END Next;
PROCEDURE IncUse(register: LONGINT);
BEGIN
INC(used[register].count);
END IncUse;
PROCEDURE DecUse(register: LONGINT);
BEGIN
DEC(used[register].count);
END DecUse;
PROCEDURE Map(register: LONGINT): LONGINT;
VAR map : LONGINT;
BEGIN
IF register > 0 THEN
map := used[register].map;
WHILE register # map DO register := map; map := used[register].map END;
END;
RETURN register
END Map;
PROCEDURE Remap(register: LONGINT; to: LONGINT);
BEGIN
used[register].map:= to
END Remap;
PROCEDURE Use(register: LONGINT): LONGINT;
BEGIN
IF register< LEN(used) THEN
RETURN used[register].count
ELSE
RETURN 0
END
END Use;
END RegisterUsage;
RegisterEntry = POINTER TO RECORD
prev,next: RegisterEntry;
register: LONGINT;
registerClass: IntermediateCode.RegisterClass;
type: IntermediateCode.Type;
END;
ImplementationVisitor =OBJECT(SyntaxTree.Visitor)
VAR
system: Global.System;
section: IntermediateCode.Section;
module: Sections.Module;
moduleScope : SyntaxTree.ModuleScope;
awaitProcCounter, labelId, constId, caseId: LONGINT;
hiddenPointerType: SyntaxTree.RecordType;
delegatePointerType: SyntaxTree.RecordType;
checker: SemanticChecker.Checker;
backend: IntermediateBackend;
meta: MetaDataGenerator;
position: LONGINT;
moduleSelf: SyntaxTree.Variable;
currentScope: SyntaxTree.Scope;
constantDeclaration : SyntaxTree.Symbol;
result: Operand;
destination: IntermediateCode.Operand;
arrayDestinationTag: IntermediateCode.Operand;
arrayDestinationDimension:LONGINT;
currentLoop: Label;
conditional: BOOLEAN;
trueLabel, falseLabel: Label;
locked: BOOLEAN;
registerUsage: RegisterUsage;
usedRegisters: RegisterEntry;
nil,fp,sp,true,false: IntermediateCode.Operand;
bool,addressType,setType, sizeType: IntermediateCode.Type;
commentPrintout: Printout.Printer;
dump: Streams.Writer;
tagsAvailable : BOOLEAN;
supportedInstruction: SupportedInstructionProcedure;
supportedImmediate: SupportedImmediateProcedure;
inData: BOOLEAN;
emitLabels: BOOLEAN;
runtimeModuleName : SyntaxTree.IdentifierString;
newObjectFile: BOOLEAN;
indexCounter: LONGINT;
profile: BOOLEAN;
profileId, profileInit: IntermediateCode.Section;
profileInitPatchPosition: LONGINT;
numberProcedures: LONGINT;
procedureResultDesignator : SyntaxTree.Designator;
operatorInitializationCodeSection: IntermediateCode.Section;
fingerPrinter: FingerPrinter.FingerPrinter;
PROCEDURE & Init(system: Global.System; checker: SemanticChecker.Checker; supportedInstructionProcedure: SupportedInstructionProcedure; supportedImmediateProcedure: SupportedImmediateProcedure; emitLabels: BOOLEAN; CONST runtime: SyntaxTree.IdentifierString; backend: IntermediateBackend;
newObjectFile: BOOLEAN);
BEGIN
SELF.system := system;
SELF.runtimeModuleName := runtime;
currentScope := NIL;
hiddenPointerType := NIL;
delegatePointerType := NIL;
awaitProcCounter := 0;
labelId := 0; constId := 0; labelId := 0;
SELF.checker := checker;
SELF.backend := backend;
position := Diagnostics.Invalid;
conditional := FALSE;
locked := FALSE;
InitOperand(result,ModeUndefined);
addressType := IntermediateCode.GetType(system,system.addressType);
setType := IntermediateCode.GetType(system,system.setType);
sizeType := IntermediateCode.GetType(system, system.sizeType);
fp := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.FP);
sp := IntermediateCode.Register(addressType,IntermediateCode.GeneralPurposeRegister,IntermediateCode.SP);
nil := IntermediateCode.Immediate(addressType,0);
IntermediateCode.InitOperand(destination);
tagsAvailable := TRUE;
supportedInstruction := supportedInstructionProcedure;
supportedImmediate := supportedImmediateProcedure;
inData := FALSE;
SELF.emitLabels := emitLabels;
IntermediateCode.InitOperand(arrayDestinationTag);
bool := IntermediateCode.GetType(system,system.booleanType);
IntermediateCode.InitImmediate(false,bool,0);
IntermediateCode.InitImmediate(true,bool,1);
SELF.newObjectFile := newObjectFile;
indexCounter := 0;
NEW(registerUsage);
usedRegisters := NIL;
procedureResultDesignator := NIL;
NEW(fingerPrinter, system)
END Init;
PROCEDURE NewSection(list: Sections.SectionList; kind, type: SHORTINT; isDefinition: BOOLEAN; CONST name: Basic.PooledName; syntaxTreeSymbol: SyntaxTree.Symbol; dump: BOOLEAN): IntermediateCode.Section;
VAR fp: SyntaxTree.FingerPrint;
BEGIN
IF (syntaxTreeSymbol # NIL) & ~((syntaxTreeSymbol IS SyntaxTree.Procedure) & (syntaxTreeSymbol(SyntaxTree.Procedure).isInline)) THEN
fp := fingerPrinter.SymbolFP(syntaxTreeSymbol)
END;
RETURN IntermediateCode.NewSection(list, kind, type, isDefinition, name, syntaxTreeSymbol, dump)
END NewSection;
PROCEDURE AcquireRegister(CONST type: IntermediateCode.Type; class: IntermediateCode.RegisterClass): LONGINT;
VAR new: LONGINT;
BEGIN
new := registerUsage.Next(type,class);
UseRegister(new);
RETURN new
END AcquireRegister;
PROCEDURE GetIndex(): LONGINT;
BEGIN
INC(indexCounter); RETURN indexCounter
END GetIndex;
PROCEDURE GetCodeSectionNameForSymbol(symbol: SyntaxTree.Symbol; VAR name: Basic.PooledName);
VAR
operatorFingerPrint: SyntaxTree.FingerPrint;
operatorFingerPrintString,string: ARRAY 32 OF CHAR;
BEGIN
Global.GetSymbolPooledName(symbol, name);
IF symbol IS SyntaxTree.Operator THEN
operatorFingerPrint := fingerPrinter.SymbolFP(symbol);
string := "[";
Strings.IntToHexStr(operatorFingerPrint.shallow, 8, operatorFingerPrintString);
Strings.Append(string, operatorFingerPrintString);
Strings.Append(string, "]");
Basic.AppendToPooledName(name,string);
END
END GetCodeSectionNameForSymbol;
PROCEDURE TraceEnter(CONST s: ARRAY OF CHAR);
BEGIN
IF dump # NIL THEN
dump.String("enter "); dump.String(s); dump.Ln;
END;
END TraceEnter;
PROCEDURE TraceExit(CONST s: ARRAY OF CHAR);
BEGIN
IF dump # NIL THEN
dump.String("exit "); dump.String(s); dump.Ln;
END;
END TraceExit;
PROCEDURE Emit(instruction: IntermediateCode.Instruction);
VAR moduleName, procedureName: SyntaxTree.IdentifierString;
PROCEDURE CheckRegister(VAR op: IntermediateCode.Operand);
BEGIN
IF op.register >0 THEN IntermediateCode.SetRegister(op,registerUsage.Map(op.register)) END;
END CheckRegister;
BEGIN
CheckRegister(instruction.op1);
CheckRegister(instruction.op2);
CheckRegister(instruction.op3);
IF supportedInstruction(instruction,moduleName,procedureName) THEN section.Emit(instruction)
ELSE Emulate(instruction,moduleName,procedureName);
END;
END Emit;
PROCEDURE Symbol(x: SyntaxTree.Symbol; VAR op: Operand);
BEGIN
position := x.position;
x.Accept(SELF);
op := result;
END Symbol;
PROCEDURE Expression(x: SyntaxTree.Expression);
BEGIN
position := x.position;
constantDeclaration := NIL;
IF (x IS SyntaxTree.SymbolDesignator) & (x(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Constant) THEN
constantDeclaration := x(SyntaxTree.SymbolDesignator).symbol;
END;
IF x.resolved # NIL THEN
x.resolved.Accept(SELF)
ELSE
x.Accept(SELF)
END;
END Expression;
PROCEDURE Statement(x: SyntaxTree.Statement);
BEGIN
position := x.position;
IF emitLabels THEN Emit(LabelInstruction(x.position)) END;
IF commentPrintout # NIL THEN
commentPrintout.Statement(x);
dump.Ln;
END;
x.Accept(SELF);
CheckRegistersFree();
END Statement;
PROCEDURE MakeMemory(VAR res: IntermediateCode.Operand; op: IntermediateCode.Operand; type: IntermediateCode.Type; offset: LONGINT);
BEGIN
IF op.mode = IntermediateCode.ModeMemory THEN
ReuseCopy(res,op);
ELSE
res := op;
UseIntermediateOperand(res);
END;
IntermediateCode.AddOffset(res,offset);
IntermediateCode.MakeMemory(res,type);
END MakeMemory;
PROCEDURE ToMemory(VAR res: IntermediateCode.Operand; type: IntermediateCode.Type; offset: LONGINT);
VAR mem: IntermediateCode.Operand;
BEGIN
MakeMemory(mem,res,type,offset);
ReleaseIntermediateOperand(res);
res := mem;
END ToMemory;
PROCEDURE LoadValue(VAR operand: Operand; type: SyntaxTree.Type);
VAR mem: IntermediateCode.Operand;
firstOp, lastOp, stepOp: IntermediateCode.Operand;
componentType: SyntaxTree.Type;
BEGIN
type := type.resolved;
IF operand.mode = ModeReference THEN
IF type IS SyntaxTree.RangeType THEN
MakeMemory(firstOp, operand.op, IntermediateCode.GetType(system, system.longintType), 0);
MakeMemory(lastOp, operand.op, IntermediateCode.GetType(system, system.longintType), ToMemoryUnits(system, system.SizeOf(system.longintType)));
MakeMemory(stepOp, operand.op, IntermediateCode.GetType(system, system.longintType), 2 * ToMemoryUnits(system, system.SizeOf(system.longintType)));
ReleaseIntermediateOperand(operand.op);
operand.op := firstOp;
operand.tag := lastOp;
operand.extra := stepOp;
ELSIF type IS SyntaxTree.ComplexType THEN
componentType := type(SyntaxTree.ComplexType).componentType;
ASSERT((componentType = system.realType) OR (componentType = system.longrealType));
MakeMemory(firstOp, operand.op, IntermediateCode.GetType(system, componentType), 0);
MakeMemory(lastOp, operand.op, IntermediateCode.GetType(system, componentType), ToMemoryUnits(system, system.SizeOf(componentType)));
ReleaseIntermediateOperand(operand.op);
operand.op := firstOp;
operand.tag := lastOp
ELSE
MakeMemory(mem,operand.op,IntermediateCode.GetType(system,type),0);
ReleaseIntermediateOperand(operand.op);
operand.op := mem;
END;
operand.mode := ModeValue;
END;
ASSERT(operand.mode = ModeValue);
END LoadValue;
PROCEDURE Evaluate(x: SyntaxTree.Expression; VAR op: Operand);
VAR prevConditional: BOOLEAN;
BEGIN
prevConditional := conditional;
conditional := FALSE;
Expression(x);
op := result;
LoadValue(op,x.type.resolved);
conditional := prevConditional;
END Evaluate;
PROCEDURE Designate(x: SyntaxTree.Expression; VAR op: Operand);
VAR prevConditional: BOOLEAN;
BEGIN
prevConditional := conditional;
conditional := FALSE;
Expression(x);
op := result;
conditional := prevConditional;
END Designate;
PROCEDURE Condition(x: SyntaxTree.Expression; trueL,falseL: Label);
VAR prevTrue, prevFalse: Label; prevConditional: BOOLEAN;
BEGIN
ASSERT(trueL # NIL); ASSERT(falseL # NIL);
prevTrue := trueLabel; prevFalse := falseLabel; prevConditional := conditional;
conditional := TRUE;
trueLabel := trueL; falseLabel := falseL;
Expression(x);
trueL := trueLabel; falseL := falseLabel;
trueLabel := prevTrue;falseLabel := prevFalse;conditional := prevConditional;
END Condition;
PROCEDURE NewRegisterOperand(type: IntermediateCode.Type): IntermediateCode.Operand;
VAR op: IntermediateCode.Operand; reg: LONGINT;
BEGIN
reg := AcquireRegister(type,IntermediateCode.GeneralPurposeRegister);
IntermediateCode.InitRegister(op, type, IntermediateCode.GeneralPurposeRegister,reg);
RETURN op
END NewRegisterOperand;
PROCEDURE UnuseRegister(register: LONGINT);
BEGIN
IF (register > 0) THEN
registerUsage.DecUse(register);
IF TraceRegisterUsage & (dump# NIL) THEN
dump.String("unuse register "); dump.Int(register,1); dump.String(": ");dump.Int(registerUsage.Use(register),1); dump.Ln; dump.Update;
END;
IF registerUsage.Use(register)=0 THEN RemoveRegisterEntry(usedRegisters,register) END;
END;
END UnuseRegister;
PROCEDURE UseRegister(register: LONGINT);
BEGIN
IF (register > 0) THEN
registerUsage.IncUse(register);
IF TraceRegisterUsage & (dump# NIL) THEN
dump.String("use register "); dump.Int(register,1); dump.String(": ");dump.Int(registerUsage.Use(register),1); dump.Ln; dump.Update;
END;
IF registerUsage.Use(register)=1 THEN
AddRegisterEntry(usedRegisters,register, registerUsage.used[register].class, registerUsage.used[register].type) END;
END;
END UseRegister;
PROCEDURE ReleaseIntermediateOperand(CONST op: IntermediateCode.Operand);
BEGIN
UnuseRegister(op.register)
END ReleaseIntermediateOperand;
PROCEDURE UseIntermediateOperand(CONST op: IntermediateCode.Operand);
BEGIN
UseRegister(op.register)
END UseIntermediateOperand;
PROCEDURE ReleaseOperand(CONST op: Operand);
BEGIN
UnuseRegister(op.op.register);
UnuseRegister(op.tag.register);
UnuseRegister(op.extra.register);
END ReleaseOperand;
PROCEDURE SaveRegisters();
VAR op: IntermediateCode.Operand; entry: RegisterEntry; type: IntermediateCode.Type;
BEGIN
entry := usedRegisters;
WHILE entry # NIL DO
type := registerUsage.used[entry.register].type;
IntermediateCode.InitRegister(op,entry.type,entry.registerClass, entry.register);
Emit(Push(position,op));
entry := entry.next;
END;
END SaveRegisters;
PROCEDURE ReleaseUsedRegisters(VAR saved: RegisterEntry);
BEGIN
saved := usedRegisters;
usedRegisters := NIL;
END ReleaseUsedRegisters;
PROCEDURE ReleaseParameterRegisters;
VAR op: IntermediateCode.Operand; entry,prev,next: RegisterEntry;
BEGIN
entry := usedRegisters; prev := NIL; usedRegisters := NIL;
WHILE entry # NIL DO
next := entry.next;
IF entry.registerClass.class = IntermediateCode.Parameter THEN
registerUsage.DecUse(entry.register);
ASSERT(registerUsage.Use(entry.register)=0);
IF TraceRegisterUsage & (dump# NIL) THEN
dump.String("unuse register "); dump.Int(entry.register,1); dump.Ln; dump.Update;
END;
ELSIF prev = NIL THEN
usedRegisters := entry; entry.prev := NIL; entry.next := NIL; prev := entry;
ELSE
prev.next := entry; entry.prev := prev; entry.next := NIL; prev:= entry;
END;
entry := next;
END;
END ReleaseParameterRegisters;
PROCEDURE RestoreRegisters(CONST saved: RegisterEntry);
VAR op: IntermediateCode.Operand; entry,prev: RegisterEntry; type: IntermediateCode.Type; class: IntermediateCode.RegisterClass;
BEGIN
entry := saved;
WHILE (entry # NIL) DO prev := entry; entry := entry.next END;
entry := prev;
WHILE entry # NIL DO
prev := entry.prev;
type := entry.type;
class := entry.registerClass;
IntermediateCode.InitRegister(op,type,class,entry.register);
registerUsage.Remap(entry.register,registerUsage.Next(type,class));
Emit(Pop(position,op));
AddRegisterEntry(usedRegisters,entry.register,entry.registerClass, entry.type);
entry := prev;
END;
END RestoreRegisters;
PROCEDURE CheckRegistersFree;
VAR r: RegisterEntry;
BEGIN
IF usedRegisters # NIL THEN
r := usedRegisters;
WHILE r # NIL DO
Error(r.register,"not released register");
r := r .next;
END;
Error(position,"register not released");
END;
END CheckRegistersFree;
PROCEDURE Reuse2(VAR result: IntermediateCode.Operand; src1,src2: IntermediateCode.Operand);
BEGIN
IF ReusableRegister(src1) THEN IntermediateCode.InitRegister(result,src1.type,src1.registerClass, src1.register);
UseIntermediateOperand(result);
ELSIF ReusableRegister(src2) THEN IntermediateCode.InitRegister(result,src2.type,src2.registerClass, src2.register);
UseIntermediateOperand(result);
ELSE IntermediateCode.InitRegister(result,src1.type,src1.registerClass,AcquireRegister(src1.type, src1.registerClass));
END;
END Reuse2;
PROCEDURE Reuse2a(VAR result: IntermediateCode.Operand; src1,src2: IntermediateCode.Operand; VAR alternative: IntermediateCode.Operand);
BEGIN
IF ReusableRegister(src1) THEN IntermediateCode.InitRegister(result,src1.type,src1.registerClass, src1.register);
UseIntermediateOperand(result);
ELSIF ReusableRegister(src2) THEN IntermediateCode.InitRegister(result,src2.type,src2.registerClass, src2.register);
UseIntermediateOperand(result);
ELSIF alternative.mode # IntermediateCode.Undefined THEN
result := alternative; alternative := emptyOperand;
UseIntermediateOperand(result);
ELSE IntermediateCode.InitRegister(result,src1.type,src1.registerClass, AcquireRegister(src1.type, src1.registerClass));
END;
END Reuse2a;
PROCEDURE Reuse1(VAR result: IntermediateCode.Operand; src1: IntermediateCode.Operand);
BEGIN
IF ReusableRegister(src1) THEN IntermediateCode.InitRegister(result,src1.type,src1.registerClass, src1.register);
UseIntermediateOperand(result);
ELSE IntermediateCode.InitRegister(result,src1.type,src1.registerClass, AcquireRegister(src1.type, src1.registerClass));
END;
END Reuse1;
PROCEDURE Reuse1a(VAR result: IntermediateCode.Operand; src1: IntermediateCode.Operand; VAR alternative: IntermediateCode.Operand);
BEGIN
IF ReusableRegister(src1) THEN IntermediateCode.InitRegister(result,src1.type,src1.registerClass, src1.register);
UseIntermediateOperand(result);
ELSIF alternative.mode # IntermediateCode.Undefined THEN result := alternative; alternative := emptyOperand;
UseIntermediateOperand(result);
ELSE IntermediateCode.InitRegister(result,src1.type,src1.registerClass, AcquireRegister(src1.type, src1.registerClass));
END;
END Reuse1a;
PROCEDURE ReuseCopy(VAR result: IntermediateCode.Operand; src1: IntermediateCode.Operand);
BEGIN
IF ReusableRegister(src1) THEN
IntermediateCode.InitRegister(result,src1.type,src1.registerClass, src1.register);
IF (src1.mode # IntermediateCode.ModeRegister) OR (src1.offset # 0) THEN
Emit(Mov(position,result,src1));
END;
UseIntermediateOperand(result);
ELSE
IntermediateCode.InitRegister(result,src1.type,src1.registerClass, AcquireRegister(src1.type, src1.registerClass));
Emit(Mov(position,result,src1));
END
END ReuseCopy;
PROCEDURE NewLabel(): Label;
VAR label: Label;
BEGIN
NEW(label,section); RETURN label;
END NewLabel;
PROCEDURE SetLabel(label: Label);
BEGIN label.Resolve(section.pc);
END SetLabel;
PROCEDURE LabelOperand(label: Label): IntermediateCode.Operand;
BEGIN
ASSERT(label # NIL);
IF label.pc < 0 THEN
label.AddFixup(section.pc);
END;
RETURN IntermediateCode.Address(addressType,label.section,label.pc);
END LabelOperand;
PROCEDURE BrL(label: Label);
BEGIN
Emit(Br(position,LabelOperand(label)));
END BrL;
PROCEDURE BrgeL(label: Label; left,right: IntermediateCode.Operand);
BEGIN
Emit(Brge(position,LabelOperand(label),left,right));
END BrgeL;
PROCEDURE BrltL(label: Label; left,right: IntermediateCode.Operand);
BEGIN
Emit(Brlt(position,LabelOperand(label),left,right));
END BrltL;
PROCEDURE BreqL(label: Label; left,right: IntermediateCode.Operand);
BEGIN
Emit(Breq(position,LabelOperand(label),left,right));
END BreqL;
PROCEDURE BrneL(label: Label; left,right: IntermediateCode.Operand);
BEGIN
Emit(Brne(position,LabelOperand(label),left,right));
END BrneL;
PROCEDURE Convert(VAR operand: IntermediateCode.Operand; type: IntermediateCode.Type);
VAR new: IntermediateCode.Operand;
BEGIN
IF IntermediateCode.TypeEquals(type,operand.type) THEN
ELSIF (operand.mode = IntermediateCode.ModeRegister) THEN
IF (type.sizeInBits = operand.type.sizeInBits) & (type.form IN IntermediateCode.Integer) & (operand.type.form IN IntermediateCode.Integer)
& (operand.offset = 0)
THEN
IntermediateCode.InitRegister(new,type,IntermediateCode.GeneralPurposeRegister,operand.register);
Emit(Conv(position,new,operand));
ELSE
IntermediateCode.InitRegister(new,type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(type,IntermediateCode.GeneralPurposeRegister));
Emit(Conv(position,new,operand));
ReleaseIntermediateOperand(operand);
END;
operand := new;
ELSIF (operand.mode = IntermediateCode.ModeImmediate) & (operand.symbol = NIL) & (operand.type.sizeInBits <= type.sizeInBits) & (operand.type.form IN IntermediateCode.Integer) & (type.form IN IntermediateCode.Integer) THEN
IntermediateCode.InitImmediate(operand,type,operand.intValue);
ELSE
IntermediateCode.InitRegister(new,type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(type,IntermediateCode.GeneralPurposeRegister));
Emit(Conv(position,new,operand));
ReleaseIntermediateOperand(operand);
operand := new;
END;
END Convert;
PROCEDURE TrapC(br: ConditionalBranch; left,right:IntermediateCode.Operand; trapNo: LONGINT);
VAR exit: Label;
BEGIN
Assert((left.mode # IntermediateCode.ModeImmediate) OR (right.mode # IntermediateCode.ModeImmediate),"trap emission with two immediates");
exit := NewLabel();
br(exit,left,right);
Emit(Trap(position,trapNo));
SetLabel(exit);
END TrapC;
PROCEDURE CheckSetElement(o: IntermediateCode.Operand);
VAR max: IntermediateCode.Operand;
BEGIN
IF backend.noRuntimeChecks THEN RETURN END;
IF o.mode # IntermediateCode.ModeImmediate THEN
IntermediateCode.InitImmediate(max, setType, setType.sizeInBits -1);
TrapC(BrgeL, max, o, SetElementTrap);
END;
END CheckSetElement;
PROCEDURE SetFromRange(x: SyntaxTree.RangeExpression): IntermediateCode.Operand;
VAR
operand: Operand;
resultingSet, temp, size, allBits, noBits, one: IntermediateCode.Operand;
BEGIN
ASSERT((x.first # NIL) & (x.last # NIL));
allBits := IntermediateCode.Immediate(setType, -1);
noBits := IntermediateCode.Immediate(setType, 0);
one := IntermediateCode.Immediate(setType, 1);
Evaluate(x, operand);
Convert(operand.op, setType);
Convert(operand.tag, setType);
CheckSetElement(operand.op);
CheckSetElement(operand.tag);
Reuse1(temp, operand.op);
Emit(Shl(position,temp, allBits, operand.op));
ReleaseIntermediateOperand(operand.op);
operand.op := temp;
IF (operand.tag.mode = IntermediateCode.ModeImmediate) & (operand.tag.symbol = NIL) THEN
IntermediateCode.InitImmediate(operand.tag, operand.tag.type, operand.op.type.sizeInBits - 1- operand.tag.intValue);
Reuse1(temp, operand.tag);
ELSE
Reuse1(temp, operand.tag);
IntermediateCode.InitImmediate(size, operand.tag.type, operand.op.type.sizeInBits - 1);
Emit(Sub(position,temp, size, operand.tag));
END;
Emit(Shr(position,temp, allBits, operand.tag));
ReleaseIntermediateOperand(operand.tag);
operand.tag := temp;
Reuse2(resultingSet, operand.op, operand.tag);
Emit(And(position,resultingSet, operand.op, operand.tag));
ReleaseOperand(operand);
RETURN resultingSet
END SetFromRange;
PROCEDURE VisitSet(x: SyntaxTree.Set);
VAR
res, operand: Operand;
temp, one, noBits, dest: IntermediateCode.Operand;
expression: SyntaxTree.Expression;
i: LONGINT;
BEGIN
IF Trace THEN TraceEnter("VisitSet") END;
dest := destination;
destination := emptyOperand;
noBits := IntermediateCode.Immediate(setType, 0);
one := IntermediateCode.Immediate(setType, 1);
InitOperand(res, ModeValue);
IntermediateCode.InitRegister(res.op, setType, IntermediateCode.GeneralPurposeRegister, AcquireRegister(setType, IntermediateCode.GeneralPurposeRegister));
Emit(Mov(position,res.op, noBits));
FOR i := 0 TO x.elements.Length() - 1 DO
expression := x.elements.GetExpression(i);
IF expression IS SyntaxTree.RangeExpression THEN
temp := SetFromRange(expression(SyntaxTree.RangeExpression));
ASSERT(IntermediateCode.TypeEquals(setType, temp.type));
Emit(Or(position,res.op, res.op, temp));
ReleaseIntermediateOperand(temp)
ELSE
Evaluate(expression, operand);
Convert(operand.op, setType);
CheckSetElement(operand.op);
Reuse1(temp, operand.op);
Emit(Shl(position,temp, one, operand.op));
ReleaseOperand(operand);
Emit(Or(position,res.op, res.op, temp));
ReleaseIntermediateOperand(temp);
END
END;
result := res;
destination := dest;
IF Trace THEN TraceExit("VisitSet") END;
END VisitSet;
PROCEDURE VisitMathArrayExpression(x: SyntaxTree.MathArrayExpression);
VAR variable: SyntaxTree.Variable; index: SyntaxTree.IndexDesignator; dim: LONGINT;
designator: SyntaxTree.Designator; i: LONGINT; element: SyntaxTree.IntegerValue;
PROCEDURE RecursiveAssignment(x: SyntaxTree.MathArrayExpression; dim: LONGINT);
VAR numberElements,i: LONGINT; expression: SyntaxTree.Expression;
element: SyntaxTree.IntegerValue;
BEGIN
numberElements := x.elements.Length();
expression := index.parameters.GetExpression(dim);
element := expression(SyntaxTree.IntegerValue);
FOR i := 0 TO numberElements-1 DO
expression := x.elements.GetExpression(i);
element.SetValue(i);
IF expression IS SyntaxTree.MathArrayExpression THEN
RecursiveAssignment(expression(SyntaxTree.MathArrayExpression),dim+1);
ELSE
Assign(index,expression);
END;
END;
END RecursiveAssignment;
BEGIN
variable := GetTemporaryVariable(x.type);
designator := SyntaxTree.NewSymbolDesignator(-1,NIL,variable);
designator.SetType(variable.type);
dim := SemanticChecker.Dimension(x.type,{SyntaxTree.Static});
index := SyntaxTree.NewIndexDesignator(x.position,designator);
FOR i := 0 TO dim-1 DO
element := SyntaxTree.NewIntegerValue(x.position,0);
element.SetType(system.longintType);
index.parameters.AddExpression(element);
END;
index.SetType(SemanticChecker.ArrayBase(x.type,dim));
RecursiveAssignment(x,0);
Expression(designator);
END VisitMathArrayExpression;
PROCEDURE VisitUnaryExpression(x: SyntaxTree.UnaryExpression);
VAR type: SyntaxTree.Type; operand: Operand; dest: IntermediateCode.Operand;
BEGIN
IF Trace THEN TraceEnter("VisitUnaryExpression") END;
dest := destination; destination := emptyOperand;
IF x.operator = Scanner.Not THEN
IF conditional THEN
Condition(x.left,falseLabel,trueLabel)
ELSE
Evaluate(x.left,operand);
InitOperand(result,ModeValue);
Reuse1a(result.op,operand.op,dest);
Emit(Xor(position,result.op,operand.op,true));
ReleaseOperand(operand);
END;
ELSIF x.operator = Scanner.Minus THEN
Evaluate(x.left,operand);
InitOperand(result,ModeValue);
Reuse1a(result.op,operand.op,dest);
type := x.left.type.resolved;
IF type IS SyntaxTree.SetType THEN
Emit(Not(position,result.op,operand.op));
ELSIF (type IS SyntaxTree.ComplexType) THEN
Reuse1(result.tag,operand.tag);
Emit(Neg(position,result.op,operand.op));
Emit(Neg(position,result.tag,operand.tag))
ELSIF (type IS SyntaxTree.NumberType) OR (type IS SyntaxTree.SizeType) OR (type IS SyntaxTree.AddressType) THEN
Emit(Neg(position,result.op,operand.op));
ELSE HALT(200)
END;
ReleaseOperand(operand);
ELSE HALT(100)
END;
destination := dest;
IF Trace THEN TraceExit("VisitUnaryExpression") END;
END VisitUnaryExpression;
PROCEDURE TypeTest(tag: IntermediateCode.Operand; type: SyntaxTree.Type; trueL,falseL: Label);
VAR left,right: IntermediateCode.Operand; level,offset: LONGINT;
BEGIN
type := type.resolved;
IF type IS SyntaxTree.PointerType THEN
type := type(SyntaxTree.PointerType).pointerBase.resolved;
END;
IF type IS SyntaxTree.ObjectType THEN
BrL(trueL);
ELSE
ASSERT(type IS SyntaxTree.RecordType);
level := type(SyntaxTree.RecordType).Level();
offset := (meta.BaseTypesTableOffset - level) * addressType.sizeInBits;
ReuseCopy(left,tag);
IntermediateCode.AddOffset(left,ToMemoryUnits(system,offset));
right := TypeDescriptorAdr(type);
IntermediateCode.MakeMemory(left,addressType);
IF ~newObjectFile THEN
IntermediateCode.MakeMemory(right,addressType);
END;
BreqL(trueL,left,right);
ReleaseIntermediateOperand(left); ReleaseIntermediateOperand(right);
BrL(falseL);
END;
END TypeTest;
PROCEDURE Error(position: LONGINT; CONST s: ARRAY OF CHAR);
BEGIN
backend.Error(module.module.sourceName,position,Diagnostics.Invalid,s);
IF dump # NIL THEN
dump.String(s); dump.Ln;
END;
END Error;
PROCEDURE AddImport(CONST moduleName: ARRAY OF CHAR; VAR module: SyntaxTree.Module; force: BOOLEAN): BOOLEAN;
VAR import: SyntaxTree.Import;
s: Basic.MessageString;
selfName: SyntaxTree.IdentifierString;
BEGIN
moduleScope.ownerModule.GetName(selfName);
IF (moduleName = selfName) & (moduleScope.ownerModule.context = Global.A2Name) THEN
module := moduleScope.ownerModule
ELSE
import := moduleScope.ImportByModuleName(SyntaxTree.NewIdentifier(moduleName),SyntaxTree.NewIdentifier("A2"));
IF import = NIL THEN
import := SyntaxTree.NewImport(-1,SyntaxTree.NewIdentifier(moduleName),SyntaxTree.NewIdentifier(moduleName),TRUE);
import.SetContext(SyntaxTree.NewIdentifier("A2"));
IF ~checker.AddImport(moduleScope.ownerModule,import) THEN
IF force THEN
s := "Module ";
Strings.Append(s,moduleName);
Strings.Append(s," cannot be imported.");
Error(position,s);
END;
RETURN FALSE
ELSE
SELF.module.imports.AddName(moduleName)
END;
ELSIF import.module = NIL THEN
RETURN FALSE
END;
module := import.module;
END;
RETURN TRUE
END AddImport;
PROCEDURE Emulate(CONST x: IntermediateCode.Instruction; CONST moduleName,procedureName: SyntaxTree.IdentifierString);
VAR
machine: SyntaxTree.Module;
procedure: SyntaxTree.Procedure;
saved: RegisterEntry;
s: Basic.MessageString;
prevResult: Operand;
BEGIN
IF AddImport(moduleName,machine,TRUE) THEN
IF x.op1.register >0 THEN RemoveRegisterEntry(usedRegisters,x.op1.register) END;
procedure := machine.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
IF procedure = NIL THEN
s := "Instruction not supported on target, emulation procedure ";
Strings.Append(s,moduleName);
Strings.Append(s,".");
Strings.Append(s,procedureName);
Strings.Append(s," not present");
Error(position,s);
ELSE
prevResult := result;
StaticCallOperand(result,procedure);
SaveRegisters();
IF x.op2.mode # IntermediateCode.Undefined THEN
Emit(Push(position,x.op2));
END;
IF x.op3.mode # IntermediateCode.Undefined THEN
Emit(Push(position,x.op3));
END;
ReleaseUsedRegisters(saved);
Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
Emit(Result(position,x.op1));
result := prevResult;
RestoreRegisters(saved);
IF x.op1.register >0 THEN AddRegisterEntry(usedRegisters,x.op1.register, x.op1.registerClass, x.op1.type) END;
END;
END;
END Emulate;
PROCEDURE SysCall(nr: LONGINT);
VAR op: IntermediateCode.Operand; section: IntermediateCode.Section; pooledName: Basic.PooledName;
BEGIN
Basic.InitPooledName(pooledName);
pooledName[0] := systemCalls[nr].name;
section := NewSection(module.allSections, Sections.SystemCallKind,Sections.CodeSection, FALSE, pooledName,systemCalls[nr],commentPrintout # NIL);
section.SetEntryNumber(nr);
IntermediateCode.InitAddress(op,addressType,section,0);
Emit(Call(position,op,0));
END SysCall;
PROCEDURE ConditionToValue(x: SyntaxTree.Expression);
VAR exit: Label; trueL,falseL: Label;
BEGIN
trueL := NewLabel();
falseL := NewLabel();
exit := NewLabel();
Condition(x,trueL,falseL);
InitOperand(result,ModeValue);
SetLabel(trueL);
IntermediateCode.InitRegister(result.op,IntermediateCode.GetType(system,x.type),IntermediateCode.GeneralPurposeRegister,AcquireRegister(IntermediateCode.GetType(system,x.type),IntermediateCode.GeneralPurposeRegister));
Emit(Mov(position,result.op,true));
BrL(exit);
SetLabel(falseL);
Emit(MovReplace(position,result.op,false));
SetLabel(exit);
END ConditionToValue;
PROCEDURE ValueToCondition(VAR op: Operand);
BEGIN
LoadValue(op,system.booleanType);
BrneL(trueLabel,op.op, false);
ReleaseOperand(op);
BrL(falseLabel);
END ValueToCondition;
PROCEDURE GetDynamicSize(type: SyntaxTree.Type; tag: IntermediateCode.Operand):IntermediateCode.Operand;
VAR size: LONGINT;
PROCEDURE GetArraySize(type: SyntaxTree.ArrayType; offset: LONGINT):IntermediateCode.Operand;
VAR baseType: SyntaxTree.Type; size: LONGINT; sizeOperand,len,res: IntermediateCode.Operand;
BEGIN
ASSERT(type.form = SyntaxTree.Open);
baseType := type.arrayBase.resolved;
IF IsOpenArray(baseType) THEN
sizeOperand := GetArraySize(baseType(SyntaxTree.ArrayType),offset+system.addressSize);
ELSE
size := ToMemoryUnits(system,system.SizeOf(baseType));
sizeOperand := IntermediateCode.Immediate(addressType,size);
END;
len := tag;
IntermediateCode.AddOffset(len,ToMemoryUnits(system,offset));
IntermediateCode.MakeMemory(len,addressType);
UseIntermediateOperand(len);
Reuse2(res,sizeOperand,len);
Emit(Mul(position,res,sizeOperand,len));
ReleaseIntermediateOperand(sizeOperand); ReleaseIntermediateOperand(len);
RETURN res
END GetArraySize;
BEGIN
type := type.resolved;
IF IsOpenArray(type) THEN
IF tag.mode = IntermediateCode.ModeImmediate THEN
RETURN tag
ELSE
RETURN GetArraySize(type.resolved(SyntaxTree.ArrayType),0)
END;
ELSE
size := ToMemoryUnits(system,system.SizeOf(type));
RETURN IntermediateCode.Immediate(addressType,size)
END;
END GetDynamicSize;
PROCEDURE GetRuntimeProcedure(CONST moduleName, procedureName: ARRAY OF CHAR; VAR procedure: SyntaxTree.Procedure; force: BOOLEAN): BOOLEAN;
VAR runtimeModule: SyntaxTree.Module; s: Basic.MessageString;
BEGIN
IF AddImport(moduleName,runtimeModule,force) THEN
procedure := runtimeModule.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
IF procedure = NIL THEN
s := "Procedure ";
Strings.Append(s,moduleName);
Strings.Append(s,".");
Strings.Append(s,procedureName);
Strings.Append(s," not present");
Error(position,s);
RETURN FALSE
ELSE
RETURN TRUE
END;
ELSE RETURN FALSE
END;
END GetRuntimeProcedure;
PROCEDURE GetTypeDescriptor(CONST moduleName, typeName: ARRAY OF CHAR): IntermediateCode.Section;
VAR importedModule: SyntaxTree.Module; source: IntermediateCode.Section; symbol: SyntaxTree.Symbol; pooledName: Basic.PooledName;
s: Basic.MessageString;
BEGIN
Basic.InitPooledName(pooledName);
pooledName[0] := Basic.MakeString(moduleName);
pooledName[1] := Basic.MakeString(typeName);
IF AddImport(moduleName,importedModule, FALSE) THEN
symbol := importedModule.moduleScope.FindTypeDeclaration(SyntaxTree.NewIdentifier(typeName));
IF symbol = NIL THEN
s := "type ";
Strings.Append(s,moduleName);
Strings.Append(s,".");
Strings.Append(s,typeName);
Strings.Append(s," not present");
Error(position,s);
END;
ELSE symbol := NIL;
END;
IF importedModule = moduleScope.ownerModule THEN
source := NewSection(module.allSections, Sections.RegularKind, Sections.ConstSection, TRUE, pooledName, symbol, commentPrintout # NIL);
ELSE
source := NewSection(module.allSections, Sections.ImportedSymbolKind, Sections.ConstSection, FALSE, pooledName, symbol, commentPrintout # NIL);
END;
RETURN source
END GetTypeDescriptor;
PROCEDURE CallThis(CONST moduleName, procedureName: ARRAY OF CHAR);
VAR procedure: SyntaxTree.Procedure; result: Operand; reg: IntermediateCode.Operand; source: IntermediateCode.Section;
pooledName: Basic.PooledName;
BEGIN
IF GetRuntimeProcedure(moduleName,procedureName,procedure,FALSE) THEN
StaticCallOperand(result,procedure);
Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
ReleaseOperand(result);
ELSE
Basic.InitPooledName(pooledName);
pooledName[0] := Basic.MakeString(moduleName);
pooledName[1] := Basic.MakeString(procedureName);
source := NewSection(module.allSections, Sections.UnknownKind, Sections.CodeSection, FALSE, pooledName, NIL,commentPrintout # NIL);
IntermediateCode.InitAddress(reg, addressType, source , 0);
Emit(Call(position,reg, 0));
END;
END CallThis;
PROCEDURE CallThis2(CONST moduleName, procedureName,altModuleName, altProcedureName: ARRAY OF CHAR; return: IntermediateCode.Operand);
VAR procedure: SyntaxTree.Procedure; result: Operand; address: IntermediateCode.Operand; source: IntermediateCode.Section;
pooledName: Basic.PooledName;
BEGIN
IF GetRuntimeProcedure(moduleName,procedureName,procedure,FALSE) THEN
StaticCallOperand(result,procedure);
Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
Emit(Result(position,return));
ReleaseOperand(result);
ELSE
Basic.InitPooledName(pooledName);
pooledName[0] := Basic.MakeString(altModuleName);
pooledName[1] := Basic.MakeString(altProcedureName);
source := NewSection(module.allSections, Sections.UnknownKind, Sections.CodeSection, FALSE, pooledName, NIL,commentPrintout # NIL);
IntermediateCode.InitAddress(address, addressType, source , 0);
Emit(Call(position,address, 0));
Emit(Result(position,return));
END;
END CallThis2;
PROCEDURE CompareString(br: ConditionalBranch; leftExpression,rightExpression: SyntaxTree.Expression);
VAR
left,right: Operand;
leftSize, rightSize: IntermediateCode.Operand;
procedure: SyntaxTree.Procedure;
saved: RegisterEntry;
reg: IntermediateCode.Operand;
procedureName: SyntaxTree.IdentifierString;
BEGIN
procedureName := "CompareString";
IF GetRuntimeProcedure(runtimeModuleName,procedureName,procedure,TRUE) THEN
SaveRegisters();ReleaseUsedRegisters(saved);
Designate(leftExpression,left);
leftSize := GetDynamicSize(leftExpression.type,left.tag);
Emit(Push(position,leftSize));
ReleaseIntermediateOperand(leftSize);
Emit(Push(position,left.op));
ReleaseOperand(left);
Designate(rightExpression,right);
rightSize := GetDynamicSize(rightExpression.type,right.tag);
Emit(Push(position,rightSize));
ReleaseIntermediateOperand(rightSize);
Emit(Push(position,right.op));
ReleaseOperand(right);
StaticCallOperand(result,procedure);
IntermediateCode.InitRegister(reg,int8,IntermediateCode.GeneralPurposeRegister,AcquireRegister(int8,IntermediateCode.GeneralPurposeRegister));
Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
Emit(Result(position,reg));
ReleaseOperand(result);
RestoreRegisters(saved);
br(trueLabel,reg,IntermediateCode.Immediate(int8,0));
ReleaseIntermediateOperand(reg);
BrL(falseLabel);
END;
END CompareString;
PROCEDURE CopyString(leftExpression,rightExpression: SyntaxTree.Expression);
VAR
left,right: Operand;
leftSize, rightSize: IntermediateCode.Operand;
procedure: SyntaxTree.Procedure;
saved: RegisterEntry;
procedureName: SyntaxTree.IdentifierString;
BEGIN
procedureName := "CopyString";
IF GetRuntimeProcedure(runtimeModuleName,procedureName,procedure,TRUE) THEN
SaveRegisters();ReleaseUsedRegisters(saved);
Designate(leftExpression,left);
leftSize := GetDynamicSize(leftExpression.type,left.tag);
Emit(Push(position,leftSize));
ReleaseIntermediateOperand(leftSize);
Emit(Push(position,left.op));
ReleaseOperand(left);
Designate(rightExpression,right);
rightSize := GetDynamicSize(rightExpression.type,right.tag);
Emit(Push(position,rightSize));
ReleaseIntermediateOperand(rightSize);
Emit(Push(position,right.op));
ReleaseOperand(right);
StaticCallOperand(result,procedure);
Emit(Call(position,result.op,ProcedureParametersSize(system,procedure)));
ReleaseOperand(result);
RestoreRegisters(saved);
END;
END CopyString;
PROCEDURE VisitBinaryExpression(x: SyntaxTree.BinaryExpression);
VAR left,right: Operand; temp: Operand; zero, one, tempReg, tempReg2: IntermediateCode.Operand;
leftType,rightType: SyntaxTree.Type;
leftExpression,rightExpression : SyntaxTree.Expression;
componentType: IntermediateCode.Type;
value: HUGEINT; exp: LONGINT;next,exit: Label; recordType: SyntaxTree.RecordType; dest: IntermediateCode.Operand;
BEGIN
IF Trace THEN TraceEnter("VisitBinaryExpression") END;
dest := destination; destination := emptyOperand;
leftType := x.left.type.resolved;
rightType := x.right.type.resolved;
CASE x.operator OF
Scanner.Or:
IF ~conditional THEN ConditionToValue(x);
ELSE
next := NewLabel();
Condition(x.left,trueLabel,next);
SetLabel(next);
Condition(x.right,trueLabel,falseLabel);
END;
|Scanner.And:
IF ~conditional THEN ConditionToValue(x);
ELSE
next := NewLabel();
Condition(x.left,next,falseLabel);
SetLabel(next);
Condition(x.right,trueLabel,falseLabel);
END;
|Scanner.Is:
IF ~conditional THEN ConditionToValue(x);
ELSE
IF IsPointerToRecord(leftType,recordType) THEN
Evaluate(x.left,left);
Dereference(left,recordType)
ELSE
Designate(x.left,left);
END;
TypeTest(left.tag,x.right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved,trueLabel,falseLabel);
ReleaseOperand(left);
END;
|Scanner.Plus:
Evaluate(x.left,left);
Evaluate(x.right,right);
IF leftType IS SyntaxTree.SetType THEN
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Emit(Or(position,result.op,left.op,right.op));
ELSIF leftType IS SyntaxTree.ComplexType THEN
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Reuse2(result.tag,left.tag,right.tag);
Emit(Add(position,result.op,left.op,right.op));
Emit(Add(position,result.tag,left.tag,right.tag))
ELSE
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Emit(Add(position,result.op,left.op,right.op));
END;
ReleaseOperand(left); ReleaseOperand(right);
|Scanner.Minus:
Evaluate(x.left,left);
Evaluate(x.right,right);
IF leftType IS SyntaxTree.SetType THEN
InitOperand(result,ModeValue);
Reuse1(result.op,right.op);
Emit(Not(position,result.op,right.op));
ReleaseOperand(right);
Emit(And(position,result.op,result.op,left.op));
ReleaseOperand(left);
ELSIF leftType IS SyntaxTree.ComplexType THEN
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Reuse2(result.tag,left.tag,right.tag);
Emit(Sub(position,result.op,left.op,right.op));
Emit(Sub(position,result.tag,left.tag,right.tag));
ReleaseOperand(left); ReleaseOperand(right)
ELSE
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Emit(Sub(position,result.op,left.op,right.op));
ReleaseOperand(left); ReleaseOperand(right);
END;
|Scanner.Times:
Evaluate(x.left,left);
Evaluate(x.right,right);
IF leftType IS SyntaxTree.SetType THEN
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Emit(And(position,result.op,left.op,right.op));
ELSIF (x.type.resolved IS SyntaxTree.IntegerType) & IsIntegerConstant(x.right,value) & PowerOf2(value,exp) THEN
InitOperand(result,ModeValue);
Reuse1a(result.op,left.op,dest);
IntermediateCode.InitImmediate(right.op,IntermediateCode.GetType(system, system.longintType),exp);
Emit(Shl(position,result.op,left.op,right.op));
ELSIF leftType IS SyntaxTree.ComplexType THEN
InitOperand(result, ModeValue);
componentType := left.op.type;
result.op := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
Emit(Mul(position,result.op, left.op, right.op));
tempReg := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
Emit(Mul(position,tempReg, left.tag, right.tag));
Emit(Sub(position,result.op, result.op, tempReg));
Reuse2(result.tag, left.tag, right.op);
Emit(Mul(position,result.tag, left.tag, right.op));
Emit(Mul(position,tempReg, left.op, right.tag));
Emit(Add(position,result.tag, result.tag, tempReg));
ReleaseIntermediateOperand(tempReg)
ELSE
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Emit(Mul(position,result.op,left.op,right.op));
END;
ReleaseOperand(left); ReleaseOperand(right);
|Scanner.Div:
Evaluate(x.left,left);
Evaluate(x.right,right);
IF (x.type.resolved IS SyntaxTree.IntegerType) & IsIntegerConstant(x.right,value) & PowerOf2(value,exp) THEN
InitOperand(result,ModeValue);
Reuse1a(result.op,left.op,dest);
IntermediateCode.InitImmediate(right.op,IntermediateCode.GetType(system, system.longintType),exp);
Emit(Shr(position,result.op,left.op,right.op));
ELSE
IF (x.type.resolved IS SyntaxTree.IntegerType) & (x.right.resolved = NIL) THEN
IntermediateCode.InitImmediate(zero,IntermediateCode.GetType(system,rightType),0);
IF ~backend.noRuntimeChecks THEN
exit := NewLabel();
BrltL(exit,zero,right.op);
Emit(Trap(position,NegativeDivisorTrap));
SetLabel(exit);
END;
END;
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Emit(Div(position,result.op,left.op,right.op));
END;
ReleaseOperand(left); ReleaseOperand(right);
|Scanner.Mod:
Evaluate(x.left,left);
Evaluate(x.right,right);
IF (x.type.resolved IS SyntaxTree.IntegerType) & IsIntegerConstant(x.right,value) & PowerOf2(value,exp) THEN
IntermediateCode.InitImmediate(right.op,IntermediateCode.GetType(system,x.type),value-1);
InitOperand(result,ModeValue);
Reuse1a(result.op,left.op,dest);
Emit(And(position,result.op,left.op,right.op));
ELSE
IF (x.type.resolved IS SyntaxTree.IntegerType) & (x.right.resolved = NIL) THEN
IntermediateCode.InitImmediate(zero,IntermediateCode.GetType(system,rightType),0);
IF ~backend.noRuntimeChecks THEN
exit := NewLabel();
BrltL(exit,zero,right.op);
Emit(Trap(position,NegativeDivisorTrap));
SetLabel(exit);
END;
END;
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Emit(Mod(position,result.op,left.op,right.op));
END;
ReleaseOperand(left); ReleaseOperand(right);
|Scanner.Slash:
Evaluate(x.left,left);
Evaluate(x.right,right);
IF leftType IS SyntaxTree.SetType THEN
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Emit(Xor(position,result.op,left.op,right.op));
ELSIF leftType IS SyntaxTree.ComplexType THEN
InitOperand(result,ModeValue);
componentType := left.op.type;
tempReg := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
tempReg2 := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
Emit(Mul(position,tempReg, right.op, right.op));
Emit(Mul(position,tempReg2, right.tag, right.tag));
Emit(Add(position,tempReg, tempReg, tempReg2));
result.op := tempReg2;
Emit(Mul(position,result.op, left.op, right.op));
tempReg2 := IntermediateCode.Register(componentType, IntermediateCode.GeneralPurposeRegister, AcquireRegister(componentType,IntermediateCode.GeneralPurposeRegister));
Emit(Mul(position,tempReg2, left.tag, right.tag));
Emit(Add(position,result.op, result.op, tempReg2));
Emit(Div(position,result.op, result.op, tempReg));
Reuse2(result.tag, left.tag, right.op);
Emit(Mul(position,result.tag, left.tag, right.op));
Emit(Mul(position,tempReg2, left.op, right.tag));
Emit(Sub(position,result.tag, result.tag, tempReg2));
Emit(Div(position,result.tag, result.tag, tempReg));
ReleaseIntermediateOperand(tempReg);
ReleaseIntermediateOperand(tempReg2)
ELSE
InitOperand(result,ModeValue);
Reuse2a(result.op,left.op,right.op,dest);
Emit(Div(position,result.op,left.op,right.op));
END;
ReleaseOperand(left); ReleaseOperand(right);
|Scanner.Equal:
IF ~conditional THEN ConditionToValue(x);
ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN
CompareString(BreqL,x.left,x.right);
ELSE
Evaluate(x.left,left);
Evaluate(x.right,right);
IF leftType IS SyntaxTree.RangeType THEN
ASSERT(rightType IS SyntaxTree.RangeType);
BrneL(falseLabel, left.op, right.op);
BrneL(falseLabel, left.tag, right.tag);
BrneL(falseLabel, left.extra, right.extra);
ReleaseOperand(left); ReleaseOperand(right);
BrL(trueLabel)
ELSIF leftType IS SyntaxTree.ComplexType THEN
BrneL(falseLabel, left.op, right.op);
BrneL(falseLabel, left.tag, right.tag);
ReleaseOperand(left); ReleaseOperand(right);
BrL(trueLabel)
ELSE
BrneL(falseLabel,left.op,right.op);
ReleaseOperand(left); ReleaseOperand(right);
BrL(trueLabel);
END;
END;
|Scanner.LessEqual:
IF ~conditional THEN ConditionToValue(x);
ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN
CompareString(BrgeL,x.right,x.left);
ELSE
Evaluate(x.left,left);
Evaluate(x.right,right);
IF leftType IS SyntaxTree.SetType THEN
Reuse1(temp.op,right.op);
Emit(And(position,temp.op,left.op,right.op));
ReleaseOperand(right);
BreqL(trueLabel,temp.op,left.op);
BrL(falseLabel);
ReleaseOperand(temp);ReleaseOperand(left);
ELSE
BrltL(falseLabel,right.op,left.op);
ReleaseOperand(left); ReleaseOperand(right);
BrL(trueLabel);
END;
END;
|Scanner.Less:
IF leftType IS SyntaxTree.SetType THEN
leftExpression := SyntaxTree.NewBinaryExpression(-1,x.left,x.right,Scanner.LessEqual);
leftExpression.SetType(system.booleanType);
rightExpression := SyntaxTree.NewBinaryExpression(-1,x.left,x.right,Scanner.Unequal);
rightExpression.SetType(system.booleanType);
leftExpression := SyntaxTree.NewBinaryExpression(-1,leftExpression,rightExpression,Scanner.And);
leftExpression.SetType(system.booleanType);
Expression(leftExpression);
ELSIF ~conditional THEN ConditionToValue(x);
ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN
CompareString(BrltL,x.left,x.right);
ELSE
Evaluate(x.left,left);
Evaluate(x.right,right);
BrgeL(falseLabel,left.op,right.op);
ReleaseOperand(left); ReleaseOperand(right);
BrL(trueLabel);
END;
|Scanner.Greater:
IF leftType IS SyntaxTree.SetType THEN
leftExpression := SyntaxTree.NewBinaryExpression(-1,x.left,x.right,Scanner.GreaterEqual);
leftExpression.SetType(system.booleanType);
rightExpression := SyntaxTree.NewBinaryExpression(-1,x.left,x.right,Scanner.Unequal);
rightExpression.SetType(system.booleanType);
leftExpression := SyntaxTree.NewBinaryExpression(-1,leftExpression,rightExpression,Scanner.And);
leftExpression.SetType(system.booleanType);
Expression(leftExpression);
ELSIF ~conditional THEN ConditionToValue(x);
ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN
CompareString(BrltL,x.right,x.left);
ELSE
Evaluate(x.left,left);
Evaluate(x.right,right);
BrgeL(falseLabel, right.op,left.op);
ReleaseOperand(left); ReleaseOperand(right);
BrL(trueLabel);
END;
|Scanner.GreaterEqual:
IF ~conditional THEN ConditionToValue(x);
ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN
CompareString(BrgeL,x.left,x.right);
ELSE
Evaluate(x.left,left);
Evaluate(x.right,right);
IF leftType IS SyntaxTree.SetType THEN
Reuse1(temp.op,left.op);
Emit(And(position,temp.op,left.op,right.op));
ReleaseOperand(left);
BreqL(trueLabel, temp.op,right.op);
ReleaseOperand(temp); ReleaseOperand(right);
BrL(falseLabel);
ELSE
BrltL(falseLabel, left.op,right.op);
ReleaseOperand(left); ReleaseOperand(right);
BrL(trueLabel);
END;
END;
|Scanner.Unequal:
IF ~conditional THEN ConditionToValue(x);
ELSIF (leftType IS SyntaxTree.ArrayType) OR (leftType IS SyntaxTree.StringType) THEN
CompareString(BrneL,x.left,x.right);
ELSE
Evaluate(x.left,left);
Evaluate(x.right,right);
IF leftType IS SyntaxTree.RangeType THEN
ASSERT(rightType IS SyntaxTree.RangeType);
BrneL(trueLabel, left.op, right.op);
BrneL(trueLabel, left.tag, right.tag);
BrneL(trueLabel, left.extra, right.extra);
ReleaseOperand(left); ReleaseOperand(right);
BrL(falseLabel)
ELSIF leftType IS SyntaxTree.ComplexType THEN
BrneL(trueLabel, left.op, right.op);
BrneL(trueLabel, left.tag, right.tag);
ReleaseOperand(left); ReleaseOperand(right);
BrL(falseLabel)
ELSE
BreqL(falseLabel,left.op,right.op);
ReleaseOperand(left); ReleaseOperand(right);
BrL(trueLabel);
END;
END;
|Scanner.In:
ASSERT(rightType.resolved IS SyntaxTree.SetType);
Evaluate(x.left,left);
Evaluate(x.right,right);
Convert(left.op,setType);
ReuseCopy(temp.op,right.op);
Emit(Shr(position,temp.op,temp.op,left.op));
ReleaseOperand(right); ReleaseOperand(left);
IntermediateCode.InitImmediate(one,setType,1);
Emit(And(position,temp.op,temp.op,one));
IF conditional THEN
IntermediateCode.InitImmediate(zero,setType,0);
BrneL(trueLabel,temp.op,zero);
ReleaseOperand(temp);
BrL(falseLabel);
ELSE
Convert(temp.op,bool);
result.mode := ModeValue;
result.op := temp.op;
END;
ELSE
HALT(100);
END;
destination := dest;
IF Trace THEN TraceExit("VisitBinaryExpression") END;
END VisitBinaryExpression;
PROCEDURE VisitRangeExpression(x: SyntaxTree.RangeExpression);
VAR localResult, operand: Operand;
BEGIN
IF Trace THEN TraceEnter("VisitRangeExpression") END;
InitOperand(localResult, ModeValue);
ASSERT(x.first # NIL);
Evaluate(x.first, operand);
localResult.op := operand.op;
ReleaseOperand(operand);
UseIntermediateOperand(localResult.op);
ASSERT(x.last # NIL);
Evaluate(x.last, operand);
localResult.tag := operand.op;
ReleaseOperand(operand);
UseIntermediateOperand(localResult.tag);
IF x.step # NIL THEN
Evaluate(x.step, operand);
localResult.extra := operand.op;
ReleaseOperand(operand);
UseIntermediateOperand(localResult.extra);
END;
result := localResult;
IF Trace THEN TraceExit("VisitRangeExpression") END
END VisitRangeExpression;
PROCEDURE VisitTensorRangeExpression*(x: SyntaxTree.TensorRangeExpression);
BEGIN
HALT(100);
END VisitTensorRangeExpression;
PROCEDURE VisitConversion(x: SyntaxTree.Conversion);
VAR old: Operand; dest: IntermediateCode.Operand; componentType: SyntaxTree.Type;
BEGIN
IF Trace THEN TraceEnter("VisitConversion") END;
ASSERT(~(x.expression.type.resolved IS SyntaxTree.RangeType));
dest := destination; destination := emptyOperand;
Evaluate(x.expression,old);
InitOperand(result,ModeValue);
result.op := old.op;
ASSERT(result.op.mode # 0);
IF x.type.resolved IS SyntaxTree.ComplexType THEN
componentType := x.type.resolved(SyntaxTree.ComplexType).componentType;
Convert(result.op,IntermediateCode.GetType(system, componentType));
ASSERT(result.op.mode # 0);
IF x.expression.type.resolved IS SyntaxTree.ComplexType THEN
result.tag := old.tag;
ASSERT(result.tag.mode # 0);
Convert(result.tag,IntermediateCode.GetType(system, componentType));
ASSERT(result.tag.mode # 0)
ELSE
ASSERT(componentType IS SyntaxTree.FloatType);
result.tag := IntermediateCode.FloatImmediate(IntermediateCode.GetType(system, componentType), 0);
END
ELSE
Convert(result.op,IntermediateCode.GetType(system,x.type));
ASSERT(result.op.mode # 0);
result.tag := old.tag;
END;
destination := dest;
IF Trace THEN TraceExit("VisitConversion") END;
END VisitConversion;
PROCEDURE VisitTypeDeclaration(x: SyntaxTree.TypeDeclaration);
BEGIN
IF Trace THEN TraceEnter("VisitTypeDeclaration") END;
ASSERT((x.declaredType.resolved IS SyntaxTree.EnumerationType) OR (x.declaredType.resolved IS SyntaxTree.RecordType)
OR (x.declaredType.resolved IS SyntaxTree.PointerType) & (x.declaredType.resolved(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType));
IF Trace THEN TraceExit("VisitTypeDeclaration") END;
END VisitTypeDeclaration;
PROCEDURE VisitSymbolDesignator(x: SyntaxTree.SymbolDesignator);
BEGIN
IF Trace THEN TraceEnter("VisitSymbolDesignator") END;
IF x.left # NIL THEN Expression(x.left) END;
Symbol(x.symbol,result);
IF Trace THEN TraceExit("VisitSymbolDesignator") END;
END VisitSymbolDesignator;
PROCEDURE BoundCheck(index,length: IntermediateCode.Operand);
BEGIN
IF backend.noRuntimeChecks THEN RETURN END;
IF tagsAvailable THEN
TrapC(BrltL,index,length,IndexCheckTrap);
END;
END BoundCheck;
PROCEDURE DimensionCheck(base,dim: IntermediateCode.Operand; op: ConditionalBranch );
VAR d: IntermediateCode.Operand;
BEGIN
IF backend.noRuntimeChecks THEN RETURN END;
MakeMemory(d,base,dim.type,ToMemoryUnits(system,MathDimOffset * addressType.sizeInBits));
TrapC(op,dim,d,ArraySizeTrap);
ReleaseIntermediateOperand(d);
END DimensionCheck;
PROCEDURE MathIndexDesignator(x: SyntaxTree.IndexDesignator);
VAR
index, range, array, sourceLength, sourceIncrement, localResult: Operand;
firstIndex, lastIndex, stepSize, summand, targetLength, targetIncrement, tmp, srcDim, destDim: IntermediateCode.Operand;
expression: SyntaxTree.Expression;
resultingType, leftType, baseType: SyntaxTree.Type;
skipLabel1, skipLabel2: Label;
i, indexListSize, indexDim, rangeCount, indexCount, srcDimOffset, destDimOffset, targetArrayDimensionality: LONGINT;
staticSourceLength, staticSourceIncrement, staticIndex, staticFirstIndex, staticLastIndex, staticStepSize, staticTargetLength: LONGINT;
variableOp: Operand;
variable: SyntaxTree.Variable;
hasTensorRange: BOOLEAN;
BEGIN
ASSERT(tagsAvailable);
resultingType := x.type.resolved;
leftType := x.left.type.resolved;
InitOperand(localResult, ModeReference);
IF resultingType IS SyntaxTree.MathArrayType THEN
targetArrayDimensionality := resultingType(SyntaxTree.MathArrayType).Dimensionality();
IF arrayDestinationTag.mode # IntermediateCode.Undefined THEN
localResult.tag := arrayDestinationTag;
IntermediateCode.InitOperand(arrayDestinationTag)
ELSE
variable := GetTemporaryVariable(GetMathArrayDescriptorType(targetArrayDimensionality));
Symbol(variable, variableOp);
ReuseCopy(localResult.tag, variableOp.op);
ReleaseOperand(variableOp);
END
END;
indexListSize := x.parameters.Length();
rangeCount := 0; hasTensorRange := FALSE; indexCount := 0;
FOR i := 0 TO indexListSize - 1 DO
expression := x.parameters.GetExpression(i);
IF expression IS SyntaxTree.TensorRangeExpression THEN hasTensorRange := TRUE
ELSIF (expression.type # NIL) & (expression.type.resolved IS SyntaxTree.RangeType) THEN INC(rangeCount)
ELSE INC(indexCount)
END
END;
Designate(x.left, array);
IF leftType(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
Dereference(array, leftType);
IF ~hasTensorRange THEN
DimensionCheck(array.tag, IntermediateCode.Immediate(int32, rangeCount+indexCount), BreqL)
END
END;
IF x.parameters.GetExpression(0) IS SyntaxTree.TensorRangeExpression THEN
srcDimOffset := -indexListSize;
destDimOffset := -rangeCount
ELSE
srcDimOffset := 0;
destDimOffset := 0
END;
indexDim := 0;
ReuseCopy(localResult.op, array.op);
FOR i := 0 TO indexListSize - 1 DO
expression := x.parameters.GetExpression(i);
IF expression IS SyntaxTree.TensorRangeExpression THEN
ELSE
IF srcDimOffset < 0 THEN
GetMathArrayField(tmp, array.tag, MathDimOffset);
ReuseCopy(srcDim, tmp);
ReleaseIntermediateOperand(tmp);
Emit(Add(position,srcDim, srcDim, IntermediateCode.Immediate(addressType, i + srcDimOffset)))
ELSE
srcDim := IntermediateCode.Immediate(int32, i)
END;
GetMathArrayLength(leftType(SyntaxTree.MathArrayType), array, srcDim, FALSE, sourceLength);
Convert(sourceLength.op, sizeType);
GetMathArrayIncrement(leftType(SyntaxTree.MathArrayType), array, srcDim, FALSE, sourceIncrement);
Convert(sourceIncrement.op, sizeType);
ReleaseIntermediateOperand(srcDim);
IF SemanticChecker.IsIntegerType(expression.type.resolved) THEN
Evaluate(expression, index);
Convert(index.op, sizeType);
IF IsIntegerImmediate(index.op, staticIndex) THEN
ASSERT(staticIndex >= 0)
ELSIF backend.noRuntimeChecks THEN
ELSE
TrapC(BrgeL, index.op, IntermediateCode.Immediate(sizeType, 0), IndexCheckTrap)
END;
IF IsIntegerImmediate(index.op, staticIndex) & IsIntegerImmediate(sourceLength.op, staticSourceLength) THEN
ASSERT(staticIndex < staticSourceLength)
ELSIF backend.noRuntimeChecks THEN
ELSE
TrapC(BrltL, index.op, sourceLength.op, IndexCheckTrap)
END;
ReleaseOperand(sourceLength);
Convert(index.op, addressType);
ReuseCopy(summand, index.op);
ReleaseOperand(index)
ELSIF expression.type.resolved IS SyntaxTree.RangeType THEN
Evaluate(expression, range);
firstIndex := range.op; UseIntermediateOperand(firstIndex);
lastIndex := range.tag; UseIntermediateOperand(lastIndex);
stepSize := range.extra; UseIntermediateOperand(stepSize);
ReleaseOperand(range);
Convert(firstIndex, sizeType);
Convert(lastIndex, sizeType);
Convert(stepSize, sizeType);
IF ~IsIntegerImmediate(lastIndex, staticLastIndex) THEN
tmp := lastIndex;
ReuseCopy(lastIndex, tmp);
ReleaseIntermediateOperand(tmp);
skipLabel1 := NewLabel();
BrneL(skipLabel1, lastIndex, IntermediateCode.Immediate(sizeType, MAX(LONGINT)));
Emit(MovReplace(position,lastIndex, sourceLength.op));
Emit(Sub(position,lastIndex, lastIndex, IntermediateCode.Immediate(sizeType, 1)));
SetLabel(skipLabel1)
END;
IF IsIntegerImmediate(stepSize, staticStepSize) THEN
ASSERT(staticStepSize >= 1)
ELSIF backend.noRuntimeChecks THEN
ELSE
TrapC(BrgeL, stepSize, IntermediateCode.Immediate(sizeType, 1), IndexCheckTrap)
END;
IF IsIntegerImmediate(firstIndex, staticFirstIndex) THEN
ASSERT(staticFirstIndex >= 0)
ELSIF backend.noRuntimeChecks THEN
ELSE
TrapC(BrgeL, firstIndex, IntermediateCode.Immediate(sizeType, 0), IndexCheckTrap)
END;
IF IsIntegerImmediate(lastIndex, staticLastIndex) & (staticLastIndex = MAX(LONGINT)) THEN
ELSIF IsIntegerImmediate(lastIndex, staticLastIndex) & IsIntegerImmediate(sourceLength.op, staticSourceLength) THEN
ASSERT(staticLastIndex < staticSourceLength)
ELSIF backend.noRuntimeChecks THEN
ELSE
TrapC(BrltL, lastIndex, sourceLength.op, IndexCheckTrap)
END;
IF IsIntegerImmediate(lastIndex, staticLastIndex) THEN
IF IsIntegerImmediate(lastIndex, staticLastIndex) & (staticLastIndex = MAX(LONGINT)) THEN
targetLength := sourceLength.op
ELSE
targetLength := IntermediateCode.Immediate(sizeType, staticLastIndex + 1)
END;
UseIntermediateOperand(targetLength);
ELSE
Reuse1(targetLength, lastIndex);
Emit(Add(position,targetLength, lastIndex, IntermediateCode.Immediate(sizeType, 1)));
END;
ReleaseOperand(sourceLength);
ReleaseIntermediateOperand(lastIndex);
IF IsIntegerImmediate(firstIndex, staticFirstIndex) & IsIntegerImmediate(targetLength, staticTargetLength) THEN
targetLength := IntermediateCode.Immediate(sizeType, staticTargetLength - staticFirstIndex)
ELSIF IsIntegerImmediate(firstIndex, staticFirstIndex) & (staticFirstIndex = 0) THEN
ELSE
ReleaseIntermediateOperand(targetLength);
ReuseCopy(targetLength, targetLength);
Emit(Sub(position,targetLength, targetLength, firstIndex))
END;
IF IsIntegerImmediate(targetLength, staticTargetLength) THEN
IF staticTargetLength < 0 THEN
targetLength := IntermediateCode.Immediate(sizeType, 0)
END
ELSE
skipLabel1 := NewLabel();
BrgeL(skipLabel1, targetLength, IntermediateCode.Immediate(sizeType, 0));
Emit(Mov(position,targetLength, IntermediateCode.Immediate(sizeType, 0)));
SetLabel(skipLabel1)
END;
IF IsIntegerImmediate(stepSize, staticStepSize) & IsIntegerImmediate(targetLength, staticTargetLength) THEN
IF staticTargetLength MOD staticStepSize = 0 THEN
staticTargetLength := staticTargetLength DIV staticStepSize
ELSE
staticTargetLength := 1 + staticTargetLength DIV staticStepSize
END;
targetLength := IntermediateCode.Immediate(sizeType, staticTargetLength)
ELSIF IsIntegerImmediate(stepSize, staticStepSize) & (staticStepSize = 1) THEN
ELSE
skipLabel1 := NewLabel();
skipLabel2 := NewLabel();
tmp := IntermediateCode.Register(sizeType, IntermediateCode.GeneralPurposeRegister,AcquireRegister(sizeType,IntermediateCode.GeneralPurposeRegister));
Emit(Mod(position,tmp, targetLength, stepSize));
BrneL(skipLabel1, tmp, IntermediateCode.Immediate(sizeType, 0));
ReleaseIntermediateOperand(targetLength);
ReuseCopy(targetLength, targetLength);
Emit(Div(position,targetLength, targetLength, stepSize));
BrL(skipLabel2);
SetLabel(skipLabel1);
Emit(Div(position,targetLength, targetLength, stepSize));
Emit(Add(position,targetLength, targetLength, IntermediateCode.Immediate(sizeType, 1)));
SetLabel(skipLabel2);
ReleaseIntermediateOperand(tmp);
END;
IF IsIntegerImmediate(sourceIncrement.op, staticSourceIncrement) & IsIntegerImmediate(stepSize, staticStepSize) THEN
targetIncrement := IntermediateCode.Immediate(sizeType, staticSourceIncrement * staticStepSize);
UseIntermediateOperand(targetIncrement)
ELSIF IsIntegerImmediate(stepSize, staticStepSize) & (staticStepSize = 1) THEN
targetIncrement := sourceIncrement.op;
UseIntermediateOperand(targetIncrement)
ELSE
Reuse1(targetIncrement, stepSize);
ASSERT((sourceIncrement.op.mode # IntermediateCode.ModeImmediate) OR (stepSize.mode # IntermediateCode.ModeImmediate));
Emit(Mul(position,targetIncrement, sourceIncrement.op, stepSize))
END;
ReleaseIntermediateOperand(stepSize);
IF destDimOffset < 0 THEN
GetMathArrayField(tmp, array.tag, MathDimOffset);
ReuseCopy(destDim, tmp);
ReleaseIntermediateOperand(tmp);
Emit(Add(position,destDim, destDim, IntermediateCode.Immediate(sizeType, indexDim + destDimOffset)));
PutMathArrayLenOrIncr(localResult.tag, targetLength, destDim, FALSE);
PutMathArrayLenOrIncr(localResult.tag, targetIncrement, destDim, TRUE);
ReleaseIntermediateOperand(destDim)
ELSE
PutMathArrayLength(localResult.tag, targetLength, indexDim);
PutMathArrayIncrement(localResult.tag , targetIncrement, indexDim)
END;
ReleaseIntermediateOperand(targetLength);
ReleaseIntermediateOperand(targetIncrement);
INC(indexDim);
Convert(firstIndex, addressType);
ReuseCopy(summand, firstIndex);
ReleaseIntermediateOperand(firstIndex)
ELSE HALT(100);
END;
ASSERT((summand.mode # IntermediateCode.ModeImmediate) OR (sourceIncrement.op.mode # IntermediateCode.ModeImmediate));
Convert(sourceIncrement.op, addressType);
Convert(summand, addressType);
Emit(Mul(position,summand, summand, sourceIncrement.op));
ReleaseOperand(sourceIncrement);
Emit(Add(position,localResult.op, localResult.op, summand));
ReleaseIntermediateOperand(summand);
END
END;
result := localResult;
IF (resultingType IS SyntaxTree.RecordType) & (resultingType(SyntaxTree.RecordType).pointerType = NIL) THEN
ReleaseIntermediateOperand(result.tag);
result.tag := TypeDescriptorAdr(resultingType);
IF ~newObjectFile THEN
IntermediateCode.MakeMemory(result.tag,addressType);
END;
ELSIF IsDelegate(resultingType) THEN
ReleaseIntermediateOperand(result.tag);
IntermediateCode.InitMemory(result.tag,addressType,result.op,ToMemoryUnits(system,system.addressSize));
UseIntermediateOperand(result.tag);
ELSIF (resultingType IS SyntaxTree.ArrayType) & (resultingType(SyntaxTree.ArrayType).form = SyntaxTree.Static) THEN
ReleaseIntermediateOperand(result.tag);
IntermediateCode.InitImmediate(result.tag,addressType,resultingType(SyntaxTree.ArrayType).staticLength);
ELSIF (resultingType IS SyntaxTree.ArrayType) THEN
result.tag := array.tag; UseIntermediateOperand(result.tag); result.dimOffset := array.dimOffset+indexListSize-1;
ELSIF (resultingType IS SyntaxTree.MathArrayType) THEN
ASSERT(result.tag.mode # IntermediateCode.Undefined);
i := indexListSize;
WHILE indexDim < targetArrayDimensionality DO
srcDim := IntermediateCode.Immediate(int32, i);
GetMathArrayLength(leftType(SyntaxTree.MathArrayType),array,srcDim,FALSE, sourceLength);
PutMathArrayLength(result.tag, sourceLength.op,indexDim);
ReleaseOperand(sourceLength);
GetMathArrayIncrement(leftType(SyntaxTree.MathArrayType),array,srcDim,FALSE,sourceIncrement);
PutMathArrayIncrement(result.tag, sourceIncrement.op,indexDim);
ReleaseOperand(sourceIncrement);
INC(i); INC(indexDim);
END;
IF leftType(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
tmp := nil;
ELSE
GetMathArrayField(tmp,array.tag,MathPtrOffset);
END;
PutMathArrayField(result.tag, tmp, MathPtrOffset);
ReleaseIntermediateOperand(tmp);
IF leftType(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
baseType := SemanticChecker.ArrayBase(resultingType, indexDim);
tmp := IntermediateCode.Immediate(addressType, ToMemoryUnits(system,system.SizeOf(baseType)));
ELSE
GetMathArrayField(tmp,array.tag, MathElementSizeOffset);
END;
PutMathArrayField(result.tag, tmp, MathElementSizeOffset);
ReleaseIntermediateOperand(tmp);
PutMathArrayField(result.tag, result.op, MathAdrOffset);
IF targetArrayDimensionality # 0 THEN
PutMathArrayField(result.tag, IntermediateCode.Immediate(addressType, targetArrayDimensionality),MathDimOffset);
END;
PutMathArrayField(result.tag, IntermediateCode.Immediate(addressType,SYSTEM.VAL(LONGINT,{RangeFlag})),MathFlagsOffset);
END;
ReleaseOperand(array);
IF conditional & (resultingType.resolved IS SyntaxTree.BooleanType) THEN
ValueToCondition(result);
END;
END MathIndexDesignator;
PROCEDURE DumpOperand(operand: Operand);
BEGIN
D.Log.String(" op = ");
IntermediateCode.DumpOperand(D.Log, operand.op );
D.Log.Ln;
D.Log.String(" tag = ");
IntermediateCode.DumpOperand(D.Log, operand.tag );
D.Log.Ln;
D.Log.String(" extra = ");
IntermediateCode.DumpOperand(D.Log, operand.extra );
D.Log.Ln;
D.Log.Update
END DumpOperand;
PROCEDURE IndexDesignator(x: SyntaxTree.IndexDesignator);
VAR length,res: IntermediateCode.Operand; type: SyntaxTree.Type; maxDim: LONGINT; array:Operand;
index: Operand; e: SyntaxTree.Expression;i: LONGINT; size: LONGINT;
PROCEDURE Length(type: SyntaxTree.Type; dim: LONGINT; tag: IntermediateCode.Operand): IntermediateCode.Operand;
VAR res: IntermediateCode.Operand; size: LONGINT;
BEGIN
type := type.resolved;
IF type IS SyntaxTree.ArrayType THEN
IF type(SyntaxTree.ArrayType).form = SyntaxTree.Static THEN
RETURN IntermediateCode.Immediate(addressType,type(SyntaxTree.ArrayType).staticLength);
ELSE
res := tag;
IntermediateCode.AddOffset(res,ToMemoryUnits(system,addressType.sizeInBits*(DynamicDim(type(SyntaxTree.ArrayType))-1)));
IntermediateCode.MakeMemory(res,addressType);
RETURN res
END
ELSE
size := ToMemoryUnits(system,system.SizeOf(type));
RETURN IntermediateCode.Immediate(addressType,size);
END;
END Length;
PROCEDURE StaticSize(type: SyntaxTree.Type): LONGINT;
BEGIN
WHILE (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form # SyntaxTree.Static) DO
type := type(SyntaxTree.ArrayType).arrayBase;
END;
WHILE (type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form # SyntaxTree.Static) DO
type := type(SyntaxTree.MathArrayType).arrayBase;
END;
RETURN ToMemoryUnits(system,system.SizeOf(type));
END StaticSize;
PROCEDURE IsImmediate(x: IntermediateCode.Operand): BOOLEAN;
BEGIN
RETURN (x.mode = IntermediateCode.ModeImmediate) & (x.symbol = NIL);
END IsImmediate;
PROCEDURE AddInt(VAR res: IntermediateCode.Operand; x,y: IntermediateCode.Operand);
BEGIN
IF IsImmediate(x) & IsImmediate(y) THEN
IntermediateCode.InitImmediate(res,x.type,x.intValue+y.intValue);
ELSE
IF res.mode # IntermediateCode.ModeRegister THEN
IntermediateCode.InitRegister(res,x.type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(x.type,IntermediateCode.GeneralPurposeRegister));
END;
IF IsImmediate(x) & (x.intValue = 0) THEN
Emit(Mov(position,res,y))
ELSIF IsImmediate(y) & (y.intValue=0) THEN
Emit(Mov(position,res,x))
ELSE
Emit(Add(position,res, x, y));
END;
END;
END AddInt;
PROCEDURE MulInt(VAR res: IntermediateCode.Operand; x,y: IntermediateCode.Operand);
BEGIN
IF IsImmediate(x) & IsImmediate(y) THEN
IntermediateCode.InitImmediate(res,x.type,x.intValue*y.intValue);
ELSE
IF res.mode # IntermediateCode.ModeRegister THEN
IntermediateCode.InitRegister(res,x.type,IntermediateCode.GeneralPurposeRegister,AcquireRegister(x.type,IntermediateCode.GeneralPurposeRegister));
END;
IF IsImmediate(x) & (x.intValue = 1) THEN
Emit(Mov(position,res,y))
ELSIF IsImmediate(y) & (y.intValue=1) THEN
Emit(Mov(position,res,x))
ELSE
Emit(Mul(position,res, x, y));
END;
END;
END MulInt;
BEGIN
type := x.left.type.resolved;
maxDim := x.parameters.Length()-1;
IntermediateCode.InitImmediate(res,addressType,0);
FOR i := 0 TO maxDim DO
e := x.parameters.GetExpression(i);
Evaluate(e,index);
Convert(index.op,addressType);
AddInt(res,res,index.op);
IF i = 0 THEN
Designate(x.left,array);
type := x.left.type.resolved;
END;
length := Length(type(SyntaxTree.ArrayType),array.dimOffset+i,array.tag);
IF ((length.mode # IntermediateCode.ModeImmediate) OR (index.op.mode # IntermediateCode.ModeImmediate)) & tagsAvailable THEN
BoundCheck(index.op, length);
END;
ReleaseOperand(index);
type := type(SyntaxTree.ArrayType).arrayBase.resolved;
length := Length(type,array.dimOffset+i-1,array.tag);
IF (length.mode # IntermediateCode.ModeImmediate) OR (length.intValue # 1) THEN
MulInt(res,res,length);
END;
END;
IF (type IS SyntaxTree.ArrayType) THEN
IF (type(SyntaxTree.ArrayType).form # SyntaxTree.Static) THEN
size := StaticSize(type);
IF size # 1 THEN
length := IntermediateCode.Immediate(addressType,size);
MulInt(res,res,length);
END;
ELSE
size := StaticSize(type(SyntaxTree.ArrayType).arrayBase);
IF size # 1 THEN
length := IntermediateCode.Immediate(addressType,size);
MulInt(res,res,length);
END;
END;
END;
AddInt(res,res,array.op);
InitOperand(result,ModeReference);
result.op := res;
IF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType = NIL) THEN
ReleaseIntermediateOperand(result.tag);
result.tag := TypeDescriptorAdr(type);
IF ~newObjectFile THEN
IntermediateCode.MakeMemory(result.tag,addressType);
END
ELSIF IsDelegate(type) THEN
ReleaseIntermediateOperand(result.tag);
IntermediateCode.InitMemory(result.tag,addressType,result.op,ToMemoryUnits(system,system.addressSize));
UseIntermediateOperand(result.tag);
ELSIF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Static) THEN
ReleaseIntermediateOperand(result.tag);
IntermediateCode.InitImmediate(result.tag,addressType,type(SyntaxTree.ArrayType).staticLength);
ELSIF (type IS SyntaxTree.ArrayType) THEN
result.tag := array.tag; UseIntermediateOperand(result.tag); result.dimOffset := array.dimOffset+maxDim;
END;
ReleaseOperand(array);
IF (conditional) & (type.resolved IS SyntaxTree.BooleanType) THEN
ValueToCondition(result);
END;
END IndexDesignator;
PROCEDURE VisitIndexDesignator(x: SyntaxTree.IndexDesignator);
VAR type: SyntaxTree.Type; dest: IntermediateCode.Operand;
BEGIN
IF Trace THEN TraceEnter("VisitIndexDesignator") END;
dest := destination; destination := emptyOperand;
type := x.left.type.resolved;
IF type IS SyntaxTree.MathArrayType THEN
MathIndexDesignator(x);
ELSE ASSERT(type IS SyntaxTree.ArrayType);
IndexDesignator(x);
END;
destination := dest;
IF Trace THEN TraceExit("VisitIndexDesignator") END;
END VisitIndexDesignator;
PROCEDURE PrepareTensorDescriptor(expression: SyntaxTree.IndexDesignator): SyntaxTree.Variable;
VAR variable: SyntaxTree.Variable; srcOperand,destOperand,procOp: Operand;
moduleName, procedureName: SyntaxTree.IdentifierString; arrayBase: SyntaxTree.Module; saved: RegisterEntry; s: Basic.MessageString;
procedure: SyntaxTree.Procedure;
parameters: SyntaxTree.ExpressionList; e: SyntaxTree.Expression;
prefixIndices, prefixRanges, suffixIndices, suffixRanges,i : LONGINT; tensorFound: BOOLEAN;
BEGIN
variable := GetTemporaryVariable(expression.left.type);
parameters := expression.parameters;
moduleName := "FoxArrayBase";
procedureName := "CopyDescriptor";
IF AddImport(moduleName,arrayBase,TRUE) THEN
SaveRegisters();ReleaseUsedRegisters(saved);
procedure := arrayBase.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
IF procedure = NIL THEN
s := "procedure ";
Strings.Append(s,moduleName);
Strings.Append(s,".");
Strings.Append(s,procedureName);
Strings.Append(s," not present");
Error(position,s);
ELSE
Symbol(variable,destOperand);
Emit(Push(position,destOperand.op));
ReleaseOperand(destOperand);
Evaluate(expression.left,srcOperand);
Emit(Push(position,srcOperand.op));
ReleaseOperand(srcOperand);
tensorFound := FALSE;
FOR i := 0 TO parameters.Length()-1 DO
e := parameters.GetExpression(i);
IF e IS SyntaxTree.TensorRangeExpression THEN
tensorFound := TRUE;
ELSIF e IS SyntaxTree.RangeExpression THEN
IF tensorFound THEN INC(suffixRanges) ELSE INC(prefixRanges) END;
ELSE
IF tensorFound THEN INC(suffixIndices) ELSE INC(prefixIndices) END;
END;
END;
Emit(Push(position,IntermediateCode.Immediate(int32,prefixIndices)));
Emit(Push(position,IntermediateCode.Immediate(int32,prefixRanges)));
Emit(Push(position,IntermediateCode.Immediate(int32,suffixIndices)));
Emit(Push(position,IntermediateCode.Immediate(int32,suffixRanges)));
StaticCallOperand(procOp,procedure);
Emit(Call(position,procOp.op,ProcedureParametersSize(system,procedure)));
ReleaseOperand(procOp);
END;
RestoreRegisters(saved);
END;
RETURN variable
END PrepareTensorDescriptor;
PROCEDURE PushParameter(expression: SyntaxTree.Expression; parameter: SyntaxTree.Parameter; callingConvention: LONGINT; needsParameterBackup: BOOLEAN; VAR parameterBackup: IntermediateCode.Operand; numberRegister: LONGINT);
VAR
type, descriptorType, baseType: SyntaxTree.Type;
operand, tmpOperand, variableOp: Operand;
baseReg, tmp, dimOp: IntermediateCode.Operand;
variable: SyntaxTree.Variable;
dim, i, size: LONGINT;
oldArrayDestinationTag: IntermediateCode.Operand;
oldArrayDestinationDimension: LONGINT;
position: LONGINT;
PROCEDURE Pass(op: IntermediateCode.Operand);
VAR registerClass: IntermediateCode.RegisterClass; parameterRegister: IntermediateCode.Operand;
BEGIN
IF numberRegister >= 0 THEN
IntermediateCode.InitRegisterClass(registerClass, IntermediateCode.Parameter, SHORT(numberRegister));
IntermediateCode.InitRegister(parameterRegister, op.type, registerClass, AcquireRegister(op.type, registerClass));
Emit(Mov(position,parameterRegister, op));
ELSE
Emit(Push(position,op))
END
END Pass;
PROCEDURE PushArrayLens(formalType,actualType: SyntaxTree.Type; dim: LONGINT);
VAR tmp: IntermediateCode.Operand; actualArrayBase: SyntaxTree.Type;
BEGIN
formalType := formalType.resolved; actualType := actualType.resolved;
IF IsOpenArray(formalType)THEN
IF actualType IS SyntaxTree.StringType THEN
Pass((IntermediateCode.Immediate(addressType,actualType(SyntaxTree.StringType).length)));
RETURN;
ELSIF (actualType IS SyntaxTree.MathArrayType) & (actualType(SyntaxTree.MathArrayType).form = SyntaxTree.Static) THEN
Pass((IntermediateCode.Immediate(addressType,actualType(SyntaxTree.MathArrayType).staticLength)));
actualArrayBase := actualType(SyntaxTree.MathArrayType).arrayBase.resolved;
ELSIF actualType(SyntaxTree.ArrayType).form = SyntaxTree.Static THEN
Pass((IntermediateCode.Immediate(addressType,actualType(SyntaxTree.ArrayType).staticLength)));
actualArrayBase := actualType(SyntaxTree.ArrayType).arrayBase.resolved;
ELSE
tmp := baseReg;
IntermediateCode.AddOffset(tmp,ToMemoryUnits(system,dim*system.addressSize));
IntermediateCode.MakeMemory(tmp,addressType);
Pass((tmp));
actualArrayBase := actualType(SyntaxTree.ArrayType).arrayBase.resolved;
END;
PushArrayLens(formalType(SyntaxTree.ArrayType).arrayBase.resolved, actualArrayBase,dim-1);
END;
END PushArrayLens;
BEGIN
IF Trace THEN TraceEnter("PushParameter") END;
position := expression.position;
IF expression.resolved # NIL THEN expression := expression.resolved END;
type := expression.type.resolved;
ASSERT( ((type IS SyntaxTree.MathArrayType) = (parameter.type.resolved IS SyntaxTree.MathArrayType))
OR (type IS SyntaxTree.MathArrayType) & (parameter.type.resolved IS SyntaxTree.ArrayType)
& (type(SyntaxTree.MathArrayType).form = SyntaxTree.Static)
& (parameter.type.resolved(SyntaxTree.ArrayType).form = SyntaxTree.Open)
);
oldArrayDestinationTag := arrayDestinationTag;
oldArrayDestinationDimension := arrayDestinationDimension;
IF IsArrayOfSystemByte(parameter.type) THEN
Designate(expression,operand);
tmp := GetDynamicSize(type,operand.tag);
ReleaseIntermediateOperand(operand.tag);
operand.tag := tmp;
IF callingConvention = SyntaxTree.OberonCallingConvention THEN
Pass((operand.tag));
END;
Pass((operand.op));
ELSIF IsOpenArray(parameter.type) THEN
Designate(expression,operand);
baseReg := operand.tag;
IF callingConvention = SyntaxTree.OberonCallingConvention THEN
PushArrayLens(parameter.type,type,operand.dimOffset+DynamicDim(parameter.type)-1);
END;
Pass((operand.op));
ELSIF parameter.type.resolved IS SyntaxTree.MathArrayType THEN
IF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) &
(parameter.kind IN {SyntaxTree.ValueParameter, SyntaxTree.ConstParameter}) THEN
size := MathLenOffset + 2*SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
size := ToMemoryUnits(system,size*addressType.sizeInBits);
Emit(Sub(position,sp,sp,IntermediateCode.Immediate(addressType,size)));
dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
arrayDestinationTag := sp;
IF expression IS SyntaxTree.IndexDesignator THEN
ReuseCopy(arrayDestinationTag,arrayDestinationTag);
dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
arrayDestinationDimension := dim;
Designate(expression,operand);
ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
Designate(expression,operand);
Emit(Copy(position,arrayDestinationTag,operand.tag,IntermediateCode.Immediate(addressType,size)));
i := 0;
WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
INC(i);
END;
type := expression.type.resolved;
WHILE (i<dim) DO
dimOp := IntermediateCode.Immediate(addressType,i);
GetMathArrayLength(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
GetMathArrayIncrement(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
INC(i);
END;
dimOp := IntermediateCode.Immediate(addressType,dim);
PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
Designate(expression,operand);
Dereference(operand,type.resolved);
DimensionCheck(operand.tag, IntermediateCode.Immediate(int32,dim),BreqL);
Emit(Copy(position,sp(*arrayDestinationTag*),operand.tag,IntermediateCode.Immediate(addressType,size)));
PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
Designate(expression,operand);
FOR i := 0 TO dim-1 DO
dimOp := IntermediateCode.Immediate(addressType,i);
GetMathArrayLength(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
GetMathArrayIncrement(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
END;
dimOp := IntermediateCode.Immediate(addressType,dim);
PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
baseType := SemanticChecker.ArrayBase(type,dim);
tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.SizeOf(baseType)));
PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
ELSE HALT(100);
END;
ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) & (parameter.kind = SyntaxTree.VarParameter) THEN
dim := SemanticChecker.Dimension(parameter.type.resolved,{SyntaxTree.Open});
IF expression IS SyntaxTree.IndexDesignator THEN
descriptorType := GetMathArrayDescriptorType(dim);
variable := GetTemporaryVariable(descriptorType);
Symbol(variable,variableOp);
arrayDestinationTag := variableOp.op;
ReuseCopy(arrayDestinationTag,arrayDestinationTag);
arrayDestinationDimension := dim;
Designate(expression,operand);
Pass((operand.tag));
ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
INC(i);
END;
IF i = dim THEN
Designate(expression,operand);
Pass((operand.tag));
ELSE
type := expression.type.resolved;
descriptorType := GetMathArrayDescriptorType(dim);
variable := GetTemporaryVariable(descriptorType);
Symbol(variable,variableOp);
arrayDestinationTag := variableOp.op;
Designate(expression,operand);
FOR i := 0 TO dim-1 DO
dimOp := IntermediateCode.Immediate(addressType,i);
GetMathArrayLength(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
GetMathArrayIncrement(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
END;
dimOp := IntermediateCode.Immediate(addressType,dim);
PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
baseType := SemanticChecker.ArrayBase(type,dim);
tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.SizeOf(baseType)));
PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
Pass((arrayDestinationTag));
END;
ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
Designate(expression,operand);
Dereference(operand,type.resolved);
DimensionCheck(operand.tag, IntermediateCode.Immediate(int32,dim),BreqL);
Pass((operand.tag));
ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
descriptorType := GetMathArrayDescriptorType(dim);
variable := GetTemporaryVariable(descriptorType);
Symbol(variable,variableOp);
arrayDestinationTag := variableOp.op;
Designate(expression,operand);
FOR i := 0 TO dim-1 DO
dimOp := IntermediateCode.Immediate(addressType,i);
GetMathArrayLength(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
GetMathArrayIncrement(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
END;
dimOp := IntermediateCode.Immediate(addressType,dim);
PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
baseType := SemanticChecker.ArrayBase(type,dim);
tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.SizeOf(baseType)));
PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
Pass((arrayDestinationTag));
ELSE HALT(100);
END;
ELSIF (parameter.type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) & (parameter.kind IN {SyntaxTree.ConstParameter,SyntaxTree.ValueParameter}) THEN
dim := SemanticChecker.Dimension(type,{SyntaxTree.Open,SyntaxTree.Static});
IF expression IS SyntaxTree.IndexDesignator THEN
IF type(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
variable := PrepareTensorDescriptor(expression(SyntaxTree.IndexDesignator));
Symbol(variable,variableOp);
LoadValue(variableOp,system.addressType);
ELSE
descriptorType := GetMathArrayDescriptorType(dim);
variable := GetTemporaryVariable(descriptorType);
Symbol(variable,variableOp);
END;
arrayDestinationTag := variableOp.op;
ReuseCopy(arrayDestinationTag,arrayDestinationTag);
arrayDestinationDimension := 0;
Designate(expression,operand);
Pass((operand.tag));
ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open THEN
i := 0;
WHILE (i< dim) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Open) DO
type := type.resolved(SyntaxTree.MathArrayType).arrayBase;
INC(i);
END;
IF i = dim THEN
Designate(expression,operand);
Pass((operand.tag));
ELSE
type := expression.type.resolved;
descriptorType := GetMathArrayDescriptorType(dim);
variable := GetTemporaryVariable(descriptorType);
Symbol(variable,variableOp);
arrayDestinationTag := variableOp.op;
Designate(expression,operand);
FOR i := 0 TO dim-1 DO
dimOp := IntermediateCode.Immediate(addressType,i);
GetMathArrayLength(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
GetMathArrayIncrement(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
END;
dimOp := IntermediateCode.Immediate(addressType,dim);
PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
baseType := SemanticChecker.ArrayBase(type,dim);
tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.SizeOf(baseType)));
PutMathArrayField(arrayDestinationTag,tmp,MathElementSizeOffset);
Pass((arrayDestinationTag));
END;
ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
Designate(expression,operand);
Dereference(operand,type.resolved);
Pass((operand.tag));
ELSIF type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Static THEN
descriptorType := GetMathArrayDescriptorType(dim);
variable := GetTemporaryVariable(descriptorType);
Symbol(variable,variableOp);
arrayDestinationTag := variableOp.op;
Designate(expression,operand);
FOR i := 0 TO dim-1 DO
dimOp := IntermediateCode.Immediate(addressType,i);
GetMathArrayLength(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayLength(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
GetMathArrayIncrement(type.resolved(SyntaxTree.MathArrayType),operand,dimOp,FALSE,tmpOperand);
PutMathArrayIncrement(arrayDestinationTag,tmpOperand.op,i);
ReleaseOperand(tmpOperand);
END;
dimOp := IntermediateCode.Immediate(addressType,dim);
PutMathArrayField(arrayDestinationTag,dimOp,MathDimOffset);
PutMathArrayField(arrayDestinationTag,operand.op,MathAdrOffset);
PutMathArrayField(arrayDestinationTag,nil,MathPtrOffset);
PutMathArrayField(arrayDestinationTag,nil,MathFlagsOffset);
baseType := SemanticChecker.ArrayBase(type,dim);
tmp := IntermediateCode.Immediate(addressType,ToMemoryUnits(system,system.SizeOf(