diff --git a/origin/.gitignore b/origin/.gitignore new file mode 100644 index 000000000..290abd9b8 --- /dev/null +++ b/origin/.gitignore @@ -0,0 +1,8 @@ +*.bak +*.exe +*.xex +*.tmp +*.log +*.lps +backup/ +lib/ diff --git a/origin/Common.pas b/origin/Common.pas index 922d94785..65bf009b7 100644 --- a/origin/Common.pas +++ b/origin/Common.pas @@ -567,7 +567,7 @@ TIdentifier = record NumDefines: integer = 1; // NumDefines = AddDefines NumTok, NumIdent, NumTypes, NumPredefIdent, NumStaticStrChars, NumUnits, NumBlocks, NumProc, - BlockStackTop, CodeSize, CodePosStackTop, BreakPosStackTop, VarDataSize, Pass, ShrShlCnt, + BlockStackTop, CodeSize, CodePosStackTop, BreakPosStackTop, _VarDataSize, Pass, ShrShlCnt, NumStaticStrCharsTmp, AsmBlockIndex, IfCnt, CaseCnt, IfdefLevel, run_func: Integer; iOut: integer = -1; @@ -675,12 +675,64 @@ TIdentifier = record function StrToInt(const a: string): Int64; + type TTokenIndex = Integer; + procedure IncVarDataSize(const tokenIndex: TTokenIndex; const size: Integer); + + function GetVarDataSize: Integer; + procedure SetVarDataSize(const tokenIndex: TTokenIndex; const size: Integer); + + var TraceFile: TextFile; + procedure LogTrace(message: String); + // ---------------------------------------------------------------------------- implementation uses SysUtils, Messages; +procedure LogTrace(message: String); +begin +{$IFDEF USETRACEFILE} + Writeln(traceFile, message); +{$ENDIF} +end; + +// ---------------------------------------------------------------------------- +// ---------------------------------------------------------------------------- + +function GetVarDataSize: Integer; +begin + Result := _VarDataSize; +end; + + +procedure SetVarDataSize(const tokenIndex: TTokenIndex; const size: Integer); +var token: TToken; +// var GetSourceFileLocationString: String; + +begin + _VarDataSize := size; + token:= Tok[tokenIndex]; + + (* + GetSourceFileLocationString := UnitName[ token.UnitIndex].Path; + + if (token.line>0) then + begin + GetSourceFileLocationString:=GetSourceFileLocationString+ ' ( line ' + IntToStr(token.Line) + ', column ' + IntToStr(token.Column) + ')'; + end; + + + // LogTrace(Format('SetVarDataSize: TokenIndex=%d: %s %s VarDataSize=%d', [tokenIndex, GetSourceFileLocationString,'TODO', _VarDataSize])); + *) +end; + + +procedure IncVarDataSize(const tokenIndex: TTokenIndex; const size: Integer); +begin + SetVarDataSize(tokenIndex, _VarDataSize + size); +end; + // ---------------------------------------------------------------------------- diff --git a/origin/Parser.pas b/origin/Parser.pas index ff0dfa989..43da863ec 100644 --- a/origin/Parser.pas +++ b/origin/Parser.pas @@ -455,6 +455,9 @@ procedure SaveToDataSegment(ConstDataSize: integer; ConstVal: Int64; ConstValTyp var ftmp: TFloat; begin +// LogTrace(Format('SaveToDataSegment(index=%d, value=%d, valueDataType=%d', [ConstDataSize, ConstVal, ConstValType])); + + if (ConstDataSize < 0) or (ConstDataSize > $FFFF) then begin writeln('SaveToDataSegment: ', ConstDataSize); halt end; ftmp:=Default(TFloat); @@ -1747,10 +1750,10 @@ procedure DefineIdent(ErrTokenIndex: Integer; Name: TString; Kind: Byte; DataTyp if Ident[NumIdent].isAbsolute then Ident[NumIdent].Value := Data - 1 else - Ident[NumIdent].Value := DATAORIGIN + VarDataSize; // Variable address + Ident[NumIdent].Value := DATAORIGIN + GetVarDataSize; // Variable address if not OutputDisabled then - VarDataSize := VarDataSize + DataSize[DataType]; + IncVarDataSize( ErrTokenIndex,DataSize[DataType]); Ident[NumIdent].NumAllocElements := NumAllocElements; // Number of array elements (0 for single variable) Ident[NumIdent].NumAllocElements_ := NumAllocElements_; @@ -1760,28 +1763,28 @@ procedure DefineIdent(ErrTokenIndex: Integer; Name: TString; Kind: Byte; DataTyp if not OutputDisabled then begin if (DataType = POINTERTOK) and (AllocElementType in [RECORDTOK, OBJECTTOK]) and (NumAllocElements_ = 0) then - inc(VarDataSize, DataSize[POINTERTOK]) + IncVarDataSize( ErrTokenIndex, DataSize[POINTERTOK]) else if DataType in [ENUMTYPE] then - inc(VarDataSize) + IncVarDataSize( ErrTokenIndex,1) else if (DataType in [RECORDTOK, OBJECTTOK]) and (NumAllocElements > 0) then - VarDataSize := VarDataSize + 0 + IncVarDataSize( ErrTokenIndex, 0) else if (DataType in [FILETOK, TEXTFILETOK]) and (NumAllocElements > 0) then - VarDataSize := VarDataSize + 12 + IncVarDataSize( ErrTokenIndex, 12) else begin if (Ident[NumIdent].idType = ARRAYTOK) and (Ident[NumIdent].isAbsolute = false) and (Elements(NumIdent) = 1) then // [0..0] ; [0..0, 0..0] else - VarDataSize := VarDataSize + integer(Elements(NumIdent) * DataSize[AllocElementType]); + IncVarDataSize( ErrTokenIndex, integer(Elements(NumIdent) * DataSize[AllocElementType])); end; - if NumAllocElements > 0 then dec(VarDataSize, DataSize[DataType]); + if NumAllocElements > 0 then IncVarDataSize( ErrTokenIndex,-DataSize[DataType]); end; diff --git a/origin/Scanner.pas b/origin/Scanner.pas index d457182f8..5fb2cdd61 100644 --- a/origin/Scanner.pas +++ b/origin/Scanner.pas @@ -47,7 +47,7 @@ procedure TokenizeProgramInitialization; SetLength(msgWarning, 1); SetLength(msgNote, 1); - NumBlocks := 0; BlockStackTop := 0; CodeSize := 0; CodePosStackTop := 0; VarDataSize := 0; + NumBlocks := 0; BlockStackTop := 0; CodeSize := 0; CodePosStackTop := 0; SetVarDataSize(0,0); CaseCnt := 0; IfCnt := 0; ShrShlCnt := 0; NumTypes := 0; run_func := 0; NumProc := 0; NumTok := 0; NumIdent := 0; diff --git a/origin/define.inc b/origin/define.inc index 83df26fab..34688fd65 100644 --- a/origin/define.inc +++ b/origin/define.inc @@ -1,7 +1,11 @@ //{$DEFINE WHILEDO} //{$DEFINE USEOPTFILE} +//{$DEFINE USETRACEFILE} {$DEFINE OPTIMIZECODE} +// The origin version still relies on accessing the element [0] of arrays starting at 1. +{$RANGECHECKS OFF} + {$I+} diff --git a/origin/mp.pas b/origin/mp.pas index aeb5daade..04d09bff4 100644 --- a/origin/mp.pas +++ b/origin/mp.pas @@ -14476,6 +14476,13 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: integer; VarSize: Boolean = // ---------------------------------------------------------------------------- + procedure IncSize(bytes: Integer); + begin + // LogTrace(Format('IncSize %d by %d', [size, bytes])); + Inc(size, bytes); + end; + +// ---------------------------------------------------------------------------- begin if Pass = CODEGENERATIONPASS then begin @@ -14559,7 +14566,7 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: integer; VarSize: Boolean = asm65('.var ' + Ident[IdentIndex].Name + #9'= adr.' + Ident[IdentIndex].Name + ' .word'); if size = 0 then varbegin := Ident[IdentIndex].Name; - inc(size, Ident[IdentIndex].NumAllocElements * DataSize[Ident[IdentIndex].AllocElementType] ); + IncSize( Ident[IdentIndex].NumAllocElements * DataSize[Ident[IdentIndex].AllocElementType] ); end else if Ident[IdentIndex].DataType = FILETOK then @@ -14600,7 +14607,7 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: integer; VarSize: Boolean = end; if size = 0 then varbegin := Ident[IdentIndex].Name; - inc(size, Ident[IdentIndex].NumAllocElements * DataSize[Ident[IdentIndex].AllocElementType] ); + IncSize( Ident[IdentIndex].NumAllocElements * DataSize[Ident[IdentIndex].AllocElementType] ); end else if (Ident[IdentIndex].DataType = FILETOK) {and (Ident[IdentIndex].Block = 1)} then @@ -14616,9 +14623,9 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: integer; VarSize: Boolean = else if Ident[IdentIndex].DataType = ENUMTYPE then - inc(size, DataSize[Ident[IdentIndex].AllocElementType]) + IncSize( DataSize[Ident[IdentIndex].AllocElementType]) else - inc(size, DataSize[Ident[IdentIndex].DataType]); + IncSize( DataSize[Ident[IdentIndex].DataType]); end; @@ -15366,7 +15373,7 @@ procedure CompileRecordDeclaration(i: integer; var VarOfSameType: TVariableList; // writeln('> ',VarOfSameType[VarOfSameTypeIndex].Name,',',NestedDataType, ',',NestedAllocElementType,',', NestedNumAllocElements,',',NestedNumAllocElements and $ffff,'/',NestedNumAllocElements shr 16); - tmpVarDataSize_ := VarDataSize; + tmpVarDataSize_ := GetVarDataSize; if (NumAllocElements shr 16) > 0 then begin // array [0..x] of record @@ -15374,9 +15381,9 @@ procedure CompileRecordDeclaration(i: integer; var VarOfSameType: TVariableList; Ident[NumIdent].NumAllocElements := NumAllocElements and $FFFF; Ident[NumIdent].NumAllocElements_ := NumAllocElements shr 16; - VarDataSize := tmpVarDataSize + (NumAllocElements shr 16) * DataSize[POINTERTOK]; + SetVarDataSize(i, tmpVarDataSize + (NumAllocElements shr 16) * DataSize[POINTERTOK]); - tmpVarDataSize := VarDataSize; + tmpVarDataSize := GetVarDataSize; NumAllocElements := NumAllocElements and $FFFF; @@ -15405,7 +15412,7 @@ procedure CompileRecordDeclaration(i: integer; var VarOfSameType: TVariableList; end; - VarDataSize := tmpVarDataSize; + SetVarDataSize(i, tmpVarDataSize); end else @@ -15415,7 +15422,7 @@ procedure CompileRecordDeclaration(i: integer; var VarOfSameType: TVariableList; // writeln('b ',',',VarOfSameType[VarOfSameTypeIndex].Name + '.' + Types[NumAllocElements].Field[ParamIndex].Name,',',Types[NumAllocElements].Field[ParamIndex].DataType,',',Types[NumAllocElements].Field[ParamIndex].AllocElementType,',',Types[NumAllocElements].Field[ParamIndex].NumAllocElements,' | ',Ident[NumIdent].Value); - tmpVarDataSize_ := VarDataSize; + tmpVarDataSize_ := GetVarDataSize; DefineIdent(i, VarOfSameType[VarOfSameTypeIndex].Name + '.' + Types[NumAllocElements].Field[ParamIndex].Name, VARIABLE, @@ -15425,7 +15432,7 @@ procedure CompileRecordDeclaration(i: integer; var VarOfSameType: TVariableList; if isAbsolute then if not (Types[NumAllocElements].Field[ParamIndex].DataType in [RECORDTOK, OBJECTTOK]) then // fixed https://forums.atariage.com/topic/240919-mad-pascal/?do=findComment&comment=5422587 - inc(ConstVal, VarDataSize - tmpVarDataSize_);// DataSize[Types[NumAllocElements].Field[ParamIndex].DataType]); + inc(ConstVal, GetVarDataSize - tmpVarDataSize_);// DataSize[Types[NumAllocElements].Field[ParamIndex].DataType]); end; @@ -15596,14 +15603,14 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; if Param[ParamIndex].PassMethod = VARPASSING then begin if isReg and (ParamIndex in [1..3]) then begin - tmpVarDataSize := VarDataSize; + tmpVarDataSize := GetVarDataSize; DefineIdent(i, Param[ParamIndex].Name, VARIABLE, Param[ParamIndex].DataType, Param[ParamIndex].NumAllocElements, Param[ParamIndex].AllocElementType, 0); Ident[GetIdent(Param[ParamIndex].Name)].isAbsolute := true; Ident[GetIdent(Param[ParamIndex].Name)].Value := (byte(ParamIndex) shl 24) or $80000000; - VarDataSize := tmpVarDataSize; + SetVarDataSize( i, tmpVarDataSize); end else if Param[ParamIndex].DataType in Pointers then @@ -15614,7 +15621,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; if (Param[ParamIndex].DataType in [RECORDTOK, OBJECTTOK]) then begin - tmpVarDataSize := VarDataSize; + tmpVarDataSize := GetVarDataSize; for j := 1 to Types[Param[ParamIndex].NumAllocElements].NumFields do begin @@ -15631,7 +15638,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; end; - VarDataSize := tmpVarDataSize; + SetVarDataSize(i, tmpVarDataSize); end else @@ -15645,14 +15652,14 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; end else begin if isReg and (ParamIndex in [1..3]) then begin - tmpVarDataSize := VarDataSize; + tmpVarDataSize := GetVarDataSize; DefineIdent(i, Param[ParamIndex].Name, VARIABLE, Param[ParamIndex].DataType, Param[ParamIndex].NumAllocElements, Param[ParamIndex].AllocElementType, 0); Ident[GetIdent(Param[ParamIndex].Name)].isAbsolute := true; Ident[GetIdent(Param[ParamIndex].Name)].Value := (byte(ParamIndex) shl 24) or $80000000; - VarDataSize := tmpVarDataSize; + SetVarDataSize (i,tmpVarDataSize); end else DefineIdent(i, Param[ParamIndex].Name, VARIABLE, Param[ParamIndex].DataType, Param[ParamIndex].NumAllocElements, Param[ParamIndex].AllocElementType, 0); @@ -15661,7 +15668,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; if (Param[ParamIndex].DataType = POINTERTOK) and (Param[ParamIndex].AllocElementType in [RECORDTOK, OBJECTTOK]) then begin // fix issue #94 // - tmpVarDataSize := VarDataSize; // + tmpVarDataSize := GetVarDataSize; // // for j := 1 to Types[Param[ParamIndex].NumAllocElements].NumFields do begin // // @@ -15678,7 +15685,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; // end; // // - VarDataSize := tmpVarDataSize; // + SetVarDataSize (i, tmpVarDataSize); // // end else @@ -15705,7 +15712,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; // Allocate Result variable if the current block is a function if IsFunction then begin //DefineIdent(i, 'RESULT', VARIABLE, FunctionResultType, 0, 0, 0); - tmpVarDataSize := VarDataSize; + tmpVarDataSize := GetVarDataSize; // writeln(Ident[BlockIdentIndex].name,',',FunctionResultType,',',FunctionNumAllocElements,',',FunctionAllocElementType); @@ -15715,7 +15722,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; Ident[NumIdent].isAbsolute := true; Ident[NumIdent].Value := $87000000; // :STACKORIGIN-4 -> :TMP - VarDataSize := tmpVarDataSize; + SetVarDataSize(i, tmpVarDataSize); end; if FunctionResultType in [RECORDTOK, OBJECTTOK] then @@ -15844,7 +15851,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; if Ident[BlockIdentIndex].ObjectIndex > 0 then for ParamIndex := 1 to Types[Ident[BlockIdentIndex].ObjectIndex].NumFields do begin - tmpVarDataSize := VarDataSize; + tmpVarDataSize := GetVarDataSize; { writeln(Types[Ident[BlockIdentIndex].ObjectIndex].Field[ParamIndex].Name,',', @@ -15874,14 +15881,14 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; Ident[NumIdent].ObjectVariable := TRUE; - VarDataSize := tmpVarDataSize + DataSize[POINTERTOK]; + SetVarDataSize(i, tmpVarDataSize + DataSize[POINTERTOK]); if Types[Ident[BlockIdentIndex].ObjectIndex].Field[ParamIndex].ObjectVariable then begin Ident[NumIdent].Value := ConstVal + DATAORIGIN; inc(ConstVal, DataSize[Types[Ident[BlockIdentIndex].ObjectIndex].Field[ParamIndex].DataType]); - VarDataSize := tmpVarDataSize; + SetVarDataSize (i, tmpVarDataSize); end; end; @@ -16742,7 +16749,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; - tmpVarDataSize := VarDataSize; // dla ABSOLUTE, RECORD + tmpVarDataSize := GetVarDataSize; // dla ABSOLUTE, RECORD for VarOfSameTypeIndex := 1 to NumVarOfSameType do begin @@ -16817,19 +16824,19 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; if NumAllocElements shr 16 > 0 then begin for j:=0 to (NumAllocElements and $FFFF) * (NumAllocElements shr 16) - 1 do begin - SaveToDataSegment(idx, VarDataSize, DATAORIGINOFFSET); + SaveToDataSegment(idx, GetVarDataSize, DATAORIGINOFFSET); inc(idx, 2); - inc(VarDataSize, NestedNumAllocElements); + incVarDataSize(i, NestedNumAllocElements); end; end else begin for j:=0 to NumAllocElements - 1 do begin - SaveToDataSegment(idx, VarDataSize, DATAORIGINOFFSET); + SaveToDataSegment(idx, GetVarDataSize, DATAORIGINOFFSET); inc(idx, 2); - inc(VarDataSize, NestedNumAllocElements); + incVarDataSize(i, NestedNumAllocElements); end; end; @@ -16858,7 +16865,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; if isAbsolute and (open_array = false) then - VarDataSize := tmpVarDataSize + SetVarDataSize( i, tmpVarDataSize ) else @@ -17008,7 +17015,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; Ident[NumIdent].NumAllocElements := NumAllocElements; end; - inc(VarDataSize, NumAllocElements * DataSize[Ident[NumIdent].AllocElementType]); + incVarDataSize(i, NumAllocElements * DataSize[Ident[NumIdent].AllocElementType]); end else begin // array [] of type = ( ) @@ -17576,12 +17583,12 @@ procedure CompileProgram; if DataSegmentUse then begin if Pass = CODEGENERATIONPASS then begin -// !!! musze zapisac wszystko, lacznie z 'zerami' !!! np. aby TextAtr dzialal +// !!! I need to save everything, including the 'zeros'!!! For example, for TextAtr to work - DataSegmentSize := VarDataSize; + DataSegmentSize := GetVarDataSize; if LIBRARYTOK_USE = FALSE then - for j := VarDataSize - 1 downto 0 do + for j := GetVarDataSize - 1 downto 0 do if DataSegment[j] <> 0 then begin DataSegmentSize := j+1; Break end; tmp:=''; @@ -17633,7 +17640,7 @@ procedure CompileProgram; asm65; asm65('VARINITSIZE'#9'= *-DATAORIGIN'); - asm65('VARDATASIZE'#9'= '+IntToStr(VarDataSize)); + asm65('VARDATASIZE'#9'= '+IntToStr(GetVarDataSize)); asm65; asm65('PROGRAMSTACK'#9'= DATAORIGIN+VARDATASIZE'); @@ -18014,22 +18021,20 @@ procedure ParseParam; FilePath := MainPath + ExtractFilePath(UnitName[1].Name); DefaultFormatSettings.DecimalSeparator := '.'; - - {$IFDEF USEOPTFILE} - AssignFile(OptFile, ChangeFileExt(UnitName[1].Name, '.opt') ); FileMode:=1; rewrite(OptFile); - {$ENDIF} - if ExtractFileName(outputFile) <> '' then - AssignFile(OutFile, outputFile) - else - AssignFile(OutFile, ChangeFileExt(UnitName[1].Name, '.a65') ); + if ExtractFileName(outputFile) = '' then + begin + outputFile :=ChangeFileExt(UnitName[1].Name, '.a65'); + end; + + AssignFile(OutFile, outputFile); FileMode:=1; - rewrite(OutFile); + Rewrite(OutFile); TextColor(WHITE); @@ -18037,6 +18042,11 @@ procedure ParseParam; start_time:=GetTickCount64; + {$IFDEF USETRACEFILE} + Assign(traceFile, ChangeFileExt( outputFile, '.log')); + FileMode:=1; + Rewrite(traceFile); + {$ENDIF} // ---------------------------------------------------------------------------- // Set defines for first pass; @@ -18095,7 +18105,7 @@ procedure ParseParam; for CodeSize := 1 to High(UnitName) do UnitName[CodeSize].Units := 0; - NumBlocks := 0; BlockStackTop := 0; CodeSize := 0; CodePosStackTop := 0; VarDataSize := 0; + NumBlocks := 0; BlockStackTop := 0; CodeSize := 0; CodePosStackTop := 0; SetVarDataSize(0, 0); CaseCnt := 0; IfCnt := 0; ShrShlCnt := 0; NumTypes := 0; run_func := 0; NumProc := 0; NumStaticStrChars := NumStaticStrCharsTmp; @@ -18126,11 +18136,12 @@ procedure ParseParam; CloseFile(OutFile); {$IFDEF USEOPTFILE} - CloseFile(OptFile); - {$ENDIF} +{$IFDEF USETRACEFILE} +CloseFile(TraceFile); +{$ENDIF} // Diagnostics if DiagMode then Diagnostics; @@ -18152,4 +18163,8 @@ procedure ParseParam; NormVideo; + // JAC! + repeat + until KeyPressed; + end. diff --git a/projects/MakeMadPascal.bat b/projects/MakeMadPascal.bat index 307e9346c..d0aabeae0 100644 --- a/projects/MakeMadPascal.bat +++ b/projects/MakeMadPascal.bat @@ -1,17 +1,18 @@ -rem Replace .pas ^ .pas ^ ^ +rem Replace .pas ^ .pas ^ ^ rem Replace -inputFilePattern IdentifierAt(IdentIndex) -inputFilePattern MakeMadPascal.exe -allThreads -allFiles -mpFolderPath .\.. -compileReference -compile -compare -openResults ^ --inputFilePattern samples\a8\games\mine.pas ^ --inputFilePattern samples\a8\games\hitbox\hitbox2.pas ^ --inputFilePattern samples\a8\graph\stereogram.pas ^ --inputFilePattern samples\a8\math\aes\aes_test.pas ^ --inputFilePattern samples\a8\math\sha256\sha256_test.pas ^ --inputFilePattern samples\a8\tools\sortviz\source\SortViz.pas ^ --inputFilePattern samples\common\dynrec.pas ^ --inputFilePattern samples\common\math\fft\fourier.pas ^ --inputFilePattern samples\common\object\hello.pas ^ --inputFilePattern samples\tests\tests-basic\negative-index-range.pas ^ --inputFilePattern samples\tests\tests-enum\enum_proc_arg.pas ^ --inputFilePattern samples\tests\tests-medium\array-with-char-index.pas ^ +-inputFilePattern samples\tests\tests-enum\enum_proc_arg.pas ^ +-inputFilePattern samples\a8\games\mine.pas ^ +-inputFilePattern samples\a8\games\hitbox\hitbox2.pas ^ +-inputFilePattern samples\a8\graph\stereogram.pas ^ +-inputFilePattern samples\a8\math\aes\aes_test.pas ^ +-inputFilePattern samples\a8\math\sha256\sha256_test.pas ^ +-inputFilePattern samples\a8\tools\sortviz\source\SortViz.pas ^ +-inputFilePattern samples\common\dynrec.pas ^ +-inputFilePattern samples\common\math\fft\fourier.pas ^ +-inputFilePattern samples\common\object\hello.pas ^ +-inputFilePattern samples\tests\tests-basic\negative-index-range.pas ^ +-inputFilePattern samples\tests\tests-enum\enum_proc_arg.pas ^ +-inputFilePattern samples\tests\tests-medium\array-with-char-index.pas ^ -inputFilePattern samples\vic-20\snake\vic20.pas pause diff --git a/projects/MakeMadPascal.lpi b/projects/MakeMadPascal.lpi index f9e6e8694..e136129c9 100644 --- a/projects/MakeMadPascal.lpi +++ b/projects/MakeMadPascal.lpi @@ -36,7 +36,7 @@ - + diff --git a/projects/TestMadPascal.lpi b/projects/TestMadPascal.lpi index b0f13121b..2b9ae62c9 100644 --- a/projects/TestMadPascal.lpi +++ b/projects/TestMadPascal.lpi @@ -26,14 +26,8 @@ - - - - - - - - + + @@ -624,10 +618,8 @@ - - - +-dUSEOPTFILE +-dUSETRACEFILE"/> diff --git a/projects/TestMadPascalOrigin.lpi b/projects/TestMadPascalOrigin.lpi new file mode 100644 index 000000000..cb96887bb --- /dev/null +++ b/projects/TestMadPascalOrigin.lpi @@ -0,0 +1,206 @@ + + + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes> + <Item Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes> + <Mode Name="default"> + <local> + <CommandLineParams Value="-iPath:C:\jac\system\Atari800\Programming\Repositories\Mad-Pascal\lib enum_proc_arg.pas -o:enum_proc_arg-Reference.a65"/> + <WorkingDirectory Value="C:\jac\system\Atari800\Programming\Repositories\Mad-Pascal\samples\tests\tests-enum\"/> + </local> + </Mode> + <Mode Name="samples"> + <local> + <CommandLineParams Value="-iPath:C:\jac\system\Atari800\Programming\Repositories\Mad-Pascal\lib lzhuf.pas"/> + <WorkingDirectory Value="C:\jac\system\Atari800\Programming\Repositories\Mad-Pascal\samples\a8\compression\lzh"/> + </local> + </Mode> + <Mode Name="test"> + <local> + <CommandLineParams Value="-iPath:C:\jac\system\Atari800\Programming\Repositories\Mad-Pascal\lib const-var-scope.pas"/> + <WorkingDirectory Value="C:\jac\system\Atari800\Programming\Repositories\Mad-Pascal\samples\tests\tests-basic\"/> + </local> + </Mode> + </Modes> + </RunParams> + <Units> + <Unit> + <Filename Value="TestMadPascalOrigin.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="MADPASCAL"/> + </Unit> + <Unit> + <Filename Value="..\origin\Parser.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\Scanner.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\Common.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\Diagnostic.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\MathEvaluate.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\Messages.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\mp.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="MADPASCAL"/> + </Unit> + <Unit> + <Filename Value="..\origin\Optimize.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\define.inc"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\include\cmd_listing.inc"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\include\cmd_temporary.inc"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\include\compile_pchar.inc"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\include\compile_string.inc"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\include\doevaluate.inc"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\include\for_in_ident.inc"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\include\for_in_stringliteral.inc"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="..\origin\include\syntax.inc"/> + <IsPartOfProject Value="True"/> + </Unit> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="TestMadPascalOrigin"/> + </Target> + <SearchPaths> + <IncludeFiles Value="..\origin;$(ProjOutDir)"/> + <OtherUnitFiles Value="..\origin"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <SyntaxMode Value="Delphi"/> + <IncludeAssertionCode Value="True"/> + </SyntaxOptions> + </Parsing> + <CodeGeneration> + <Checks> + <IOChecks Value="True"/> + <OverflowChecks Value="True"/> + <StackChecks Value="True"/> + </Checks> + <VerifyObjMethodCallValidity Value="True"/> + <Optimizations> + <OptimizationLevel Value="0"/> + </Optimizations> + </CodeGeneration> + <Linking> + <Debugging> + <DebugInfoType Value="dsDwarf2Set"/> + </Debugging> + </Linking> + <Other> + <Verbosity> + <ShoLineNum Value="True"/> + <ShowHintsForUnusedUnitsInMainSrc Value="True"/> + </Verbosity> + <ConfigFile> + <StopAfterErrCount Value="100"/> + </ConfigFile> + <CustomOptions Value="-dDEBUG +-dSIMULATED_COMMAND_LINE2 +-dSIMULATED_FILE_IO2 +-dUSEOPTFILE +-dUSETRACEFILE"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions> + <Item> + <Name Value="EAbort"/> + <Enabled Value="False"/> + </Item> + <Item> + <Name Value="ECodetoolError"/> + <Enabled Value="False"/> + </Item> + <Item> + <Name Value="EFOpenError"/> + </Item> + <Item> + <Name Value="THaltException"/> + </Item> + <Item> + <Name Value="ERangeError"/> + <Enabled Value="False"/> + </Item> + <Item> + <Name Value="RunError(201)"/> + </Item> + <Item> + <Name Value="EEValuationException"/> + </Item> + <Item> + <Name Value="RunError(100)"/> + </Item> + <Item> + <Name Value="EInOutError"/> + </Item> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/projects/TestMadPascalOrigin.lpr b/projects/TestMadPascalOrigin.lpr new file mode 100644 index 000000000..ce3be69cd --- /dev/null +++ b/projects/TestMadPascalOrigin.lpr @@ -0,0 +1,7 @@ +(* TODOs + + Writeln('') correctly creates line breaks in the PAS2JS browser console, but WriteLN doesn't. + +*) +{$I ..\origin\mp.pas} + diff --git a/src/Common.pas b/src/Common.pas index 8f2db8c54..ca9d43893 100644 --- a/src/Common.pas +++ b/src/Common.pas @@ -166,37 +166,53 @@ function LowBound(const i: TTokenIndex; const DataType: TDataType): TInteger; function HighBound(const i: TTokenIndex; const DataType: TDataType): TInteger; -procedure IncVarDataSize(const size: Integer); - function GetVarDataSize: Integer; -procedure SetVarDataSize(const size: Integer); +procedure SetVarDataSize(const tokenIndex: TTokenIndex; const size: Integer); +procedure IncVarDataSize(const tokenIndex: TTokenIndex; const size: Integer); function GetTypeAtIndex(const typeIndex: TTypeIndex): TType; +var + TraceFile: ITextFile; + +procedure LogTrace(message: String); + // ---------------------------------------------------------------------------- implementation uses Messages, Utilities; +procedure LogTrace(message: String); +begin + {$IFDEF USETRACEFILE} + traceFile.Writeln(message); + {$ENDIF} +end; // ---------------------------------------------------------------------------- // ---------------------------------------------------------------------------- -procedure IncVarDataSize(const size: Integer); -begin - SetVarDataSize(_VarDataSize + size); -end; - function GetVarDataSize: Integer; begin Result := _VarDataSize; end; -procedure SetVarDataSize(const size: Integer); +procedure SetVarDataSize(const tokenIndex: TTokenIndex; const size: Integer); +//var +// token: TToken; begin _VarDataSize := size; + // token := TokenAt(tokenIndex); + // LogTrace(Format('SetVarDataSize: TokenIndex=%d: %s %s VarDataSize=%d', + // [tokenIndex, token.GetSourceFileLocationString, 'TODO' {*token.GetSpelling*}, _VarDataSize])); +end; + + +procedure IncVarDataSize(const tokenIndex: TTokenIndex; const size: Integer); +begin + SetVarDataSize(tokenIndex, _VarDataSize + size); end; @@ -220,7 +236,7 @@ function FindFile(FileName: String; ftyp: TString): TFilePath; overload; end else begin - unitPathText := 'unit path '''+unitPathList.ToString+''''; + unitPathText := 'unit path ''' + unitPathList.ToString + ''''; end; if ftyp = 'unit' then begin diff --git a/src/Compiler.pas b/src/Compiler.pas index b1b70d62c..0a1cf29e1 100644 --- a/src/Compiler.pas +++ b/src/Compiler.pas @@ -2328,35 +2328,39 @@ procedure GenerateIncDec(IndirectionLevel: Byte; ExpressionType: TDataType; Down if (NumAllocElements > 256) or (NumAllocElements in [0, 1]) then begin - if (IdentIndex > 0) and (IdentifierAt(IdentIndex).isAbsolute) and (IdentifierAt(IdentIndex).idType = ARRAYTOK) and (IdentifierAt(IdentIndex).Value >= 0) then begin + if (IdentIndex > 0) and (IdentifierAt(IdentIndex).isAbsolute) and + (IdentifierAt(IdentIndex).idType = ARRAYTOK) and (IdentifierAt(IdentIndex).Value >= 0) then + begin - asm65(#9'lda #$' + IntToHex(byte(IdentifierAt(IdentIndex).Value), 2)); - asm65(#9'add :STACKORIGIN-1,x'); - asm65(#9'tay'); - asm65(#9'lda #$' + IntToHex(byte(IdentifierAt(IdentIndex).Value shr 8), 2)); - asm65(#9'adc :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta :bp+1'); + asm65(#9'lda #$' + IntToHex(Byte(IdentifierAt(IdentIndex).Value), 2)); + asm65(#9'add :STACKORIGIN-1,x'); + asm65(#9'tay'); + asm65(#9'lda #$' + IntToHex(Byte(IdentifierAt(IdentIndex).Value shr 8), 2)); + asm65(#9'adc :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta :bp+1'); - asm65(#9'lda (:bp),y'); - asm65(#9 + b + ' :STACKORIGIN,x'); - asm65(#9'sta (:bp),y'); + asm65(#9'lda (:bp),y'); + asm65(#9 + b + ' :STACKORIGIN,x'); + asm65(#9'sta (:bp),y'); - end else begin + end + else + begin - asm65(#9'lda ' + svar); - asm65(#9'add :STACKORIGIN-1,x'); - asm65(#9'tay'); + asm65(#9'lda ' + svar); + asm65(#9'add :STACKORIGIN-1,x'); + asm65(#9'tay'); - asm65(#9'lda ' + svar + '+1'); - asm65(#9'adc :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta :bp+1'); + asm65(#9'lda ' + svar + '+1'); + asm65(#9'adc :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta :bp+1'); - asm65; - asm65(#9'lda (:bp),y'); - asm65(#9 + b + ' :STACKORIGIN,x'); - asm65(#9'sta (:bp),y'); + asm65; + asm65(#9'lda (:bp),y'); + asm65(#9 + b + ' :STACKORIGIN,x'); + asm65(#9'sta (:bp),y'); - end; + end; end else @@ -4157,7 +4161,8 @@ procedure GenerateCaseRangeCheck(Value1, Value2: Int64; SelectorType: TDataType; Gen; Gen; // cmp :ecx, Value1 - if (SelectorType in [TDataType.BYTETOK, TDataType.CHARTOK, TDataType.ENUMTOK]) and (Value1 >= 0) and (Value2 >= 0) then + if (SelectorType in [TDataType.BYTETOK, TDataType.CHARTOK, TDataType.ENUMTOK]) and + (Value1 >= 0) and (Value2 >= 0) then begin if (Value1 = 0) and (Value2 = 255) then @@ -5976,118 +5981,123 @@ procedure GenerateBinaryOperation(op: TTokenKind; ResultType: TDataType); procedure GenerateRelationString(relation: TTokenKind; LeftValType, RightValType: TDataType); begin -// asm65; -// asm65('; relation STRING'); + // asm65; + // asm65('; relation STRING'); - Gen; + Gen; - asm65(#9'ldy #1'); + asm65(#9'ldy #1'); - Gen; + Gen; { if (LeftValType = POINTERTOK) and (RightValType = POINTERTOK) then begin - asm65(#9'lda :STACKORIGIN,x'); - asm65(#9'sta @cmpPCHAR.B'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); - asm65(#9'sta @cmpPCHAR.B+1'); + asm65(#9'lda :STACKORIGIN,x'); + asm65(#9'sta @cmpPCHAR.B'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'sta @cmpPCHAR.B+1'); - asm65(#9'lda :STACKORIGIN-1,x'); - asm65(#9'sta @cmpPCHAR.A'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta @cmpPCHAR.A+1'); + asm65(#9'lda :STACKORIGIN-1,x'); + asm65(#9'sta @cmpPCHAR.A'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta @cmpPCHAR.A+1'); - asm65(#9'jsr @cmpPCHAR'); + asm65(#9'jsr @cmpPCHAR'); end else if (LeftValType = POINTERTOK) and (RightValType = STRINGPOINTERTOK) then begin - asm65(#9'lda :STACKORIGIN,x'); - asm65(#9'sta @cmpPCHAR2STRING.B'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); - asm65(#9'sta @cmpPCHAR2STRING.B+1'); + asm65(#9'lda :STACKORIGIN,x'); + asm65(#9'sta @cmpPCHAR2STRING.B'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'sta @cmpPCHAR2STRING.B+1'); - asm65(#9'lda :STACKORIGIN-1,x'); - asm65(#9'sta @cmpPCHAR2STRING.A'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta @cmpPCHAR2STRING.A+1'); + asm65(#9'lda :STACKORIGIN-1,x'); + asm65(#9'sta @cmpPCHAR2STRING.A'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta @cmpPCHAR2STRING.A+1'); - asm65(#9'jsr @cmpPCHAR2STRING'); + asm65(#9'jsr @cmpPCHAR2STRING'); end else if (LeftValType = STRINGPOINTERTOK) and (RightValType = POINTERTOK) then begin - asm65(#9'lda :STACKORIGIN,x'); - asm65(#9'sta @cmpSTRING2PCHAR.B'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); - asm65(#9'sta @cmpSTRING2PCHAR.B+1'); + asm65(#9'lda :STACKORIGIN,x'); + asm65(#9'sta @cmpSTRING2PCHAR.B'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'sta @cmpSTRING2PCHAR.B+1'); - asm65(#9'lda :STACKORIGIN-1,x'); - asm65(#9'sta @cmpSTRING2PCHAR.A'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta @cmpSTRING2PCHAR.A+1'); + asm65(#9'lda :STACKORIGIN-1,x'); + asm65(#9'sta @cmpSTRING2PCHAR.A'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta @cmpSTRING2PCHAR.A+1'); - asm65(#9'jsr @cmpSTRING2PCHAR'); + asm65(#9'jsr @cmpSTRING2PCHAR'); end else } - if (LeftValType = TDatatype.STRINGPOINTERTOK) and (RightValType = TDatatype.STRINGPOINTERTOK) then begin -// a65(__cmpSTRING) // STRING ? STRING + if (LeftValType = TDatatype.STRINGPOINTERTOK) and (RightValType = TDatatype.STRINGPOINTERTOK) then + begin + // a65(__cmpSTRING) // STRING ? STRING - asm65(#9'lda :STACKORIGIN,x'); - asm65(#9'sta @cmpSTRING.B'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); - asm65(#9'sta @cmpSTRING.B+1'); + asm65(#9'lda :STACKORIGIN,x'); + asm65(#9'sta @cmpSTRING.B'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'sta @cmpSTRING.B+1'); - asm65(#9'lda :STACKORIGIN-1,x'); - asm65(#9'sta @cmpSTRING.A'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta @cmpSTRING.A+1'); + asm65(#9'lda :STACKORIGIN-1,x'); + asm65(#9'sta @cmpSTRING.A'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta @cmpSTRING.A+1'); - asm65(#9'jsr @cmpSTRING'); + asm65(#9'jsr @cmpSTRING'); - end else - if LeftValType = TDatatype.CHARTOK then begin -// a65(__cmpCHAR2STRING) // CHAR ? STRING + end + else + if LeftValType = TDatatype.CHARTOK then + begin + // a65(__cmpCHAR2STRING) // CHAR ? STRING - asm65(#9'lda :STACKORIGIN,x'); - asm65(#9'sta @cmpCHAR2STRING.B'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); - asm65(#9'sta @cmpCHAR2STRING.B+1'); + asm65(#9'lda :STACKORIGIN,x'); + asm65(#9'sta @cmpCHAR2STRING.B'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'sta @cmpCHAR2STRING.B+1'); - asm65(#9'lda :STACKORIGIN-1,x'); - asm65(#9'sta @cmpCHAR2STRING.A'); + asm65(#9'lda :STACKORIGIN-1,x'); + asm65(#9'sta @cmpCHAR2STRING.A'); - asm65(#9'jsr @cmpCHAR2STRING'); + asm65(#9'jsr @cmpCHAR2STRING'); - end else - if RightValType = TDatatype.CHARTOK then begin -// a65(__cmpSTRING2CHAR); // STRING ? CHAR + end + else + if RightValType = TDatatype.CHARTOK then + begin + // a65(__cmpSTRING2CHAR); // STRING ? CHAR - asm65(#9'lda :STACKORIGIN,x'); - asm65(#9'sta @cmpSTRING2CHAR.B'); + asm65(#9'lda :STACKORIGIN,x'); + asm65(#9'sta @cmpSTRING2CHAR.B'); - asm65(#9'lda :STACKORIGIN-1,x'); - asm65(#9'sta @cmpSTRING2CHAR.A'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta @cmpSTRING2CHAR.A+1'); + asm65(#9'lda :STACKORIGIN-1,x'); + asm65(#9'sta @cmpSTRING2CHAR.A'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta @cmpSTRING2CHAR.A+1'); - asm65(#9'jsr @cmpSTRING2CHAR'); - end; + asm65(#9'jsr @cmpSTRING2CHAR'); + end; - GenerateRelationOperation(relation, TDatatype.BYTETOK); + GenerateRelationOperation(relation, TDatatype.BYTETOK); - Gen; + Gen; - asm65(#9'dey'); - asm65('@'); -// asm65(#9'tya'); !!! ~ - asm65(#9'sty :STACKORIGIN-1,x'); + asm65(#9'dey'); + asm65('@'); + // asm65(#9'tya'); !!! ~ + asm65(#9'sty :STACKORIGIN-1,x'); - a65(TCode65.subBX); + a65(TCode65.subBX); end; @@ -6429,197 +6439,230 @@ function SafeCompileConstExpression(var i: Integer; out ConstVal: Int64; out Val // ---------------------------------------------------------------------------- // ---------------------------------------------------------------------------- -function CompileArrayIndex(i: integer; IdentIndex: integer; out VarType: TDatatype): integer; -var ConstVal: Int64; - ActualParamType, ArrayIndexType: TDatatype; - Size: Byte; - NumAllocElements, NumAllocElements_: cardinal; - j: integer; - yes, ShortArrayIndex: Boolean; +function CompileArrayIndex(i: Integer; IdentIndex: Integer; out VarType: TDatatype): Integer; +var + ConstVal: Int64; + ActualParamType, ArrayIndexType: TDatatype; + Size: Byte; + NumAllocElements, NumAllocElements_: Cardinal; + j: Integer; + yes, ShortArrayIndex: Boolean; begin - if common.optimize.use = false then StartOptimization(i); + if common.optimize.use = False then StartOptimization(i); - if (IdentifierAt(IdentIndex).isStriped) then - Size := 1 - else - Size := GetDataSize(IdentifierAt(IdentIndex).AllocElementType); + if (IdentifierAt(IdentIndex).isStriped) then + Size := 1 + else + Size := GetDataSize(IdentifierAt(IdentIndex).AllocElementType); - ShortArrayIndex := false; + ShortArrayIndex := False; - VarType := IdentifierAt(IdentIndex).AllocElementType; + VarType := IdentifierAt(IdentIndex).AllocElementType; - if ((IdentifierAt(IdentIndex).DataType = POINTERTOK) and (IdentifierAt(IdentIndex).IdType = DEREFERENCEARRAYTOK)) then begin - NumAllocElements := IdentifierAt(IdentIndex).NestedNumAllocElements and $FFFF; - NumAllocElements_ := IdentifierAt(IdentIndex).NestedNumAllocElements shr 16; + if ((IdentifierAt(IdentIndex).DataType = POINTERTOK) and (IdentifierAt(IdentIndex).IdType = + DEREFERENCEARRAYTOK)) then + begin + NumAllocElements := IdentifierAt(IdentIndex).NestedNumAllocElements and $FFFF; + NumAllocElements_ := IdentifierAt(IdentIndex).NestedNumAllocElements shr 16; - if NumAllocElements_ > 0 then begin - if (NumAllocElements * NumAllocElements_ > 1) and (NumAllocElements * NumAllocElements_ * Size < 256) then ShortArrayIndex := true; - end else - if (NumAllocElements > 1) and (NumAllocElements * Size < 256) then ShortArrayIndex := true; + if NumAllocElements_ > 0 then + begin + if (NumAllocElements * NumAllocElements_ > 1) and (NumAllocElements * NumAllocElements_ * Size < 256) then + ShortArrayIndex := True; + end + else + if (NumAllocElements > 1) and (NumAllocElements * Size < 256) then ShortArrayIndex := True; - end else begin - NumAllocElements := IdentifierAt(IdentIndex).NumAllocElements; - NumAllocElements_ := IdentifierAt(IdentIndex).NumAllocElements_; - end; + end + else + begin + NumAllocElements := IdentifierAt(IdentIndex).NumAllocElements; + NumAllocElements_ := IdentifierAt(IdentIndex).NumAllocElements_; + end; - if IdentifierAt(IdentIndex).AllocElementType in [RECORDTOK, OBJECTTOK, PROCVARTOK] then NumAllocElements_ := 0; + if IdentifierAt(IdentIndex).AllocElementType in [RECORDTOK, OBJECTTOK, PROCVARTOK] then NumAllocElements_ := 0; - ActualParamType := TDatatype.WORDTOK; // !!! aby dzialaly optymalizacje dla ADR. + ActualParamType := TDatatype.WORDTOK; // !!! aby dzialaly optymalizacje dla ADR. - j := i + 2; + j := i + 2; - if SafeCompileConstExpression(j, ConstVal, ArrayIndexType, ActualParamType) then begin - i := j; + if SafeCompileConstExpression(j, ConstVal, ArrayIndexType, ActualParamType) then + begin + i := j; - CheckArrayIndex(i, IdentIndex, ConstVal, ArrayIndexType); + CheckArrayIndex(i, IdentIndex, ConstVal, ArrayIndexType); - ArrayIndexType := WORDTOK; - ShortArrayIndex := false; + ArrayIndexType := WORDTOK; + ShortArrayIndex := False; - if NumAllocElements_ > 0 then - Push(ConstVal * NumAllocElements_ * Size, ASVALUE, GetDataSize(ArrayIndexType)) - else - Push(ConstVal * Size, ASVALUE, GetDataSize(ArrayIndexType)); + if NumAllocElements_ > 0 then + Push(ConstVal * NumAllocElements_ * Size, ASVALUE, GetDataSize(ArrayIndexType)) + else + Push(ConstVal * Size, ASVALUE, GetDataSize(ArrayIndexType)); - end else begin - i := CompileExpression(i + 2, ArrayIndexType, ActualParamType); // array index [x, ..] + end + else + begin + i := CompileExpression(i + 2, ArrayIndexType, ActualParamType); // array index [x, ..] - GetCommonType(i, ActualParamType, ArrayIndexType); + GetCommonType(i, ActualParamType, ArrayIndexType); - case ArrayIndexType of - SHORTINTTOK: ArrayIndexType := BYTETOK; - SMALLINTTOK: ArrayIndexType := WORDTOK; - INTEGERTOK: ArrayIndexType := CARDINALTOK; - end; + case ArrayIndexType of + SHORTINTTOK: ArrayIndexType := BYTETOK; + SMALLINTTOK: ArrayIndexType := WORDTOK; + INTEGERTOK: ArrayIndexType := CARDINALTOK; + end; - if GetDataSize(ArrayIndexType) = 4 then begin // remove oldest bytes - asm65(#9'lda :STACKORIGIN+STACKWIDTH*2,x'); - asm65(#9'sta :STACKORIGIN+STACKWIDTH*2,x'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH*3,x'); - asm65(#9'sta :STACKORIGIN+STACKWIDTH*3,x'); - end; + if GetDataSize(ArrayIndexType) = 4 then + begin // remove oldest bytes + asm65(#9'lda :STACKORIGIN+STACKWIDTH*2,x'); + asm65(#9'sta :STACKORIGIN+STACKWIDTH*2,x'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH*3,x'); + asm65(#9'sta :STACKORIGIN+STACKWIDTH*3,x'); + end; - if GetDataSize(ArrayIndexType) = 1 then begin - ExpandParam(WORDTOK, ArrayIndexType); -// ArrayIndexType := WORDTOK; - end else - ArrayIndexType := WORDTOK; + if GetDataSize(ArrayIndexType) = 1 then + begin + ExpandParam(WORDTOK, ArrayIndexType); + // ArrayIndexType := WORDTOK; + end + else + ArrayIndexType := WORDTOK; - if (Size > 1) or (Elements(IdentIndex) > 256) or (Elements(IdentIndex) in [0,1]) {or (NumAllocElements_ > 0)} then begin -// ExpandParam(WORDTOK, ArrayIndexType); - ArrayIndexType := WORDTOK; - end; + if (Size > 1) or (Elements(IdentIndex) > 256) or (Elements(IdentIndex) in [0, 1]) {or (NumAllocElements_ > 0)} then + begin + // ExpandParam(WORDTOK, ArrayIndexType); + ArrayIndexType := WORDTOK; + end; - if NumAllocElements_ > 0 then begin + if NumAllocElements_ > 0 then + begin - Push(integer(NumAllocElements_ * Size), ASVALUE, GetDataSize(ArrayIndexType)); + Push(Integer(NumAllocElements_ * Size), ASVALUE, GetDataSize(ArrayIndexType)); - GenerateBinaryOperation(MULTOK, ArrayIndexType); + GenerateBinaryOperation(MULTOK, ArrayIndexType); - end else - if IdentifierAt(IdentIndex).isStriped = FALSE then GenerateIndexShift( IdentifierAt(IdentIndex).AllocElementType ); + end + else + if IdentifierAt(IdentIndex).isStriped = False then + GenerateIndexShift(IdentifierAt(IdentIndex).AllocElementType); - end; + end; - yes:=false; + yes := False; - if NumAllocElements_ > 0 then begin + if NumAllocElements_ > 0 then + begin - if ( TokenAt(i + 1).Kind = CBRACKETTOK) and ( TokenAt(i + 2).Kind in [ASSIGNTOK, SEMICOLONTOK]) then begin - yes := FALSE; + if (TokenAt(i + 1).Kind = CBRACKETTOK) and (TokenAt(i + 2).Kind in [ASSIGNTOK, SEMICOLONTOK]) then + begin + yes := False; - Push(0, ASVALUE, GetDataSize(ArrayIndexType)); + Push(0, ASVALUE, GetDataSize(ArrayIndexType)); - GenerateBinaryOperation(PLUSTOK, WORDTOK); + GenerateBinaryOperation(PLUSTOK, WORDTOK); - VarType := ARRAYTOK; - end else - if TokenAt(i + 1).Kind = CBRACKETTOK then begin - inc(i); - CheckTok(i + 1, OBRACKETTOK); - yes := TRUE; - end else begin - CheckTok(i + 1, COMMATOK); - yes := TRUE; - end; + VarType := ARRAYTOK; + end + else + if TokenAt(i + 1).Kind = CBRACKETTOK then + begin + Inc(i); + CheckTok(i + 1, OBRACKETTOK); + yes := True; + end + else + begin + CheckTok(i + 1, COMMATOK); + yes := True; + end; - end else - CheckTok(i + 1, CBRACKETTOK); + end + else + CheckTok(i + 1, CBRACKETTOK); - if { TokenAt(i + 1].Kind = COMMATOK} yes then begin + if { TokenAt(i + 1].Kind = COMMATOK} yes then + begin - j := i + 2; + j := i + 2; - if SafeCompileConstExpression(j, ConstVal, ArrayIndexType, ActualParamType) then begin - i := j; + if SafeCompileConstExpression(j, ConstVal, ArrayIndexType, ActualParamType) then + begin + i := j; - CheckArrayIndex_(i, IdentIndex, ConstVal, ArrayIndexType); + CheckArrayIndex_(i, IdentIndex, ConstVal, ArrayIndexType); - ArrayIndexType := TDatatype.WORDTOK; - ShortArrayIndex := false; + ArrayIndexType := TDatatype.WORDTOK; + ShortArrayIndex := False; - Push(ConstVal * Size, ASVALUE, GetDataSize(ArrayIndexType)); + Push(ConstVal * Size, ASVALUE, GetDataSize(ArrayIndexType)); - end else begin - i := CompileExpression(i + 2, ArrayIndexType, ActualParamType); // array index [.., y] + end + else + begin + i := CompileExpression(i + 2, ArrayIndexType, ActualParamType); // array index [.., y] - GetCommonType(i, ActualParamType, ArrayIndexType); + GetCommonType(i, ActualParamType, ArrayIndexType); - case ArrayIndexType of - SHORTINTTOK: ArrayIndexType := TDatatype.BYTETOK; - SMALLINTTOK: ArrayIndexType := TDatatype.WORDTOK; - INTEGERTOK: ArrayIndexType := TDatatype.CARDINALTOK; - end; + case ArrayIndexType of + SHORTINTTOK: ArrayIndexType := TDatatype.BYTETOK; + SMALLINTTOK: ArrayIndexType := TDatatype.WORDTOK; + INTEGERTOK: ArrayIndexType := TDatatype.CARDINALTOK; + end; - if GetDataSize(ArrayIndexType) = 4 then begin // remove oldest bytes - asm65(#9'lda :STACKORIGIN+STACKWIDTH*2,x'); - asm65(#9'sta :STACKORIGIN+STACKWIDTH*2,x'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH*3,x'); - asm65(#9'sta :STACKORIGIN+STACKWIDTH*3,x'); - end; + if GetDataSize(ArrayIndexType) = 4 then + begin // remove oldest bytes + asm65(#9'lda :STACKORIGIN+STACKWIDTH*2,x'); + asm65(#9'sta :STACKORIGIN+STACKWIDTH*2,x'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH*3,x'); + asm65(#9'sta :STACKORIGIN+STACKWIDTH*3,x'); + end; - if GetDataSize(ArrayIndexType) = 1 then begin - ExpandParam(TDatatype.WORDTOK, ArrayIndexType); - ArrayIndexType := TDatatype.WORDTOK; - end else - ArrayIndexType := TDatatype.WORDTOK; + if GetDataSize(ArrayIndexType) = 1 then + begin + ExpandParam(TDatatype.WORDTOK, ArrayIndexType); + ArrayIndexType := TDatatype.WORDTOK; + end + else + ArrayIndexType := TDatatype.WORDTOK; -// if (Size > 1) or (Elements(IdentIndex) > 256) or (Elements(IdentIndex) in [0,1]) {or (NumAllocElements_ > 0)} then begin -// ExpandParam(WORDTOK, ArrayIndexType); -// ArrayIndexType := WORDTOK; -// end; + // if (Size > 1) or (Elements(IdentIndex) > 256) or (Elements(IdentIndex) in [0,1]) {or (NumAllocElements_ > 0)} then begin + // ExpandParam(WORDTOK, ArrayIndexType); + // ArrayIndexType := WORDTOK; + // end; - if IdentifierAt(IdentIndex).isStriped = FALSE then GenerateIndexShift( IdentifierAt(IdentIndex).AllocElementType ); + if IdentifierAt(IdentIndex).isStriped = False then GenerateIndexShift(IdentifierAt(IdentIndex).AllocElementType); - end; + end; - GenerateBinaryOperation(TTokenKind.PLUSTOK, TDatatype.WORDTOK); + GenerateBinaryOperation(TTokenKind.PLUSTOK, TDatatype.WORDTOK); - end; + end; - if ShortArrayIndex then begin + if ShortArrayIndex then + begin - asm65(#9'lda #$00'); - asm65(#9'sta :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'lda #$00'); + asm65(#9'sta :STACKORIGIN+STACKWIDTH,x'); - end; + end; -// writeln(IdentifierAt(IdentIndex).Name,',',Elements(IdentIndex)); + // writeln(IdentifierAt(IdentIndex).Name,',',Elements(IdentIndex)); - Result := i; + Result := i; -end; //CompileArrayIndex +end; //CompileArrayIndex // ---------------------------------------------------------------------------- // ---------------------------------------------------------------------------- @@ -7116,139 +7159,146 @@ function NumActualParameters(i: Integer; IdentIndex: Integer; out NumActualParam procedure RealTypeConversion(var ValType, RightValType: TDataType; Kind: TTokenKind = TTokenKind.UNTYPETOK); begin - If ((ValType = TDataType.SINGLETOK) or (Kind = TTokenKind.SINGLETOK)) and (RightValType in IntegerTypes) then begin - - ExpandParam(TDataType.INTEGERTOK, RightValType); + if ((ValType = TDataType.SINGLETOK) or (Kind = TTokenKind.SINGLETOK)) and (RightValType in IntegerTypes) then + begin -// asm65(#9'jsr @I2F'); + ExpandParam(TDataType.INTEGERTOK, RightValType); - asm65(#9'lda :STACKORIGIN,x'); - asm65(#9'sta :FPMAN0'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); - asm65(#9'sta :FPMAN1'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH*2,x'); - asm65(#9'sta :FPMAN2'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH*3,x'); - asm65(#9'sta :FPMAN3'); + // asm65(#9'jsr @I2F'); - asm65(#9'jsr @I2F'); + asm65(#9'lda :STACKORIGIN,x'); + asm65(#9'sta :FPMAN0'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'sta :FPMAN1'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH*2,x'); + asm65(#9'sta :FPMAN2'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH*3,x'); + asm65(#9'sta :FPMAN3'); - asm65(#9'lda :FPMAN0'); - asm65(#9'sta :STACKORIGIN,x'); - asm65(#9'lda :FPMAN1'); - asm65(#9'sta :STACKORIGIN+STACKWIDTH,x'); - asm65(#9'lda :FPMAN2'); - asm65(#9'sta :STACKORIGIN+STACKWIDTH*2,x'); - asm65(#9'lda :FPMAN3'); - asm65(#9'sta :STACKORIGIN+STACKWIDTH*3,x'); + asm65(#9'jsr @I2F'); - if (ValType <> TDataType.SINGLETOK) and (Kind = TTokenKind.SINGLETOK) then - RightValType := Kind - else - RightValType := ValType; + asm65(#9'lda :FPMAN0'); + asm65(#9'sta :STACKORIGIN,x'); + asm65(#9'lda :FPMAN1'); + asm65(#9'sta :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'lda :FPMAN2'); + asm65(#9'sta :STACKORIGIN+STACKWIDTH*2,x'); + asm65(#9'lda :FPMAN3'); + asm65(#9'sta :STACKORIGIN+STACKWIDTH*3,x'); + + if (ValType <> TDataType.SINGLETOK) and (Kind = TTokenKind.SINGLETOK) then + RightValType := Kind + else + RightValType := ValType; end; - If (ValType in IntegerTypes) and ((RightValType = TDataType.SINGLETOK) or (Kind = TTokenKind.SINGLETOK)) then begin + if (ValType in IntegerTypes) and ((RightValType = TDataType.SINGLETOK) or (Kind = TTokenKind.SINGLETOK)) then + begin - ExpandParam_m1(TDataType.INTEGERTOK, ValType); + ExpandParam_m1(TDataType.INTEGERTOK, ValType); -// asm65(#9'jsr @I2F_M'); + // asm65(#9'jsr @I2F_M'); - asm65(#9'lda :STACKORIGIN-1,x'); - asm65(#9'sta :FPMAN0'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta :FPMAN1'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH*2,x'); - asm65(#9'sta :FPMAN2'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH*3,x'); - asm65(#9'sta :FPMAN3'); + asm65(#9'lda :STACKORIGIN-1,x'); + asm65(#9'sta :FPMAN0'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta :FPMAN1'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH*2,x'); + asm65(#9'sta :FPMAN2'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH*3,x'); + asm65(#9'sta :FPMAN3'); - asm65(#9'jsr @I2F'); + asm65(#9'jsr @I2F'); - asm65(#9'lda :FPMAN0'); - asm65(#9'sta :STACKORIGIN-1,x'); - asm65(#9'lda :FPMAN1'); - asm65(#9'sta :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'lda :FPMAN2'); - asm65(#9'sta :STACKORIGIN-1+STACKWIDTH*2,x'); - asm65(#9'lda :FPMAN3'); - asm65(#9'sta :STACKORIGIN-1+STACKWIDTH*3,x'); + asm65(#9'lda :FPMAN0'); + asm65(#9'sta :STACKORIGIN-1,x'); + asm65(#9'lda :FPMAN1'); + asm65(#9'sta :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'lda :FPMAN2'); + asm65(#9'sta :STACKORIGIN-1+STACKWIDTH*2,x'); + asm65(#9'lda :FPMAN3'); + asm65(#9'sta :STACKORIGIN-1+STACKWIDTH*3,x'); - if (RightValType <> TDataType.SINGLETOK) and (Kind = TTokenKind.SINGLETOK) then - ValType := Kind - else - ValType := RightValType; + if (RightValType <> TDataType.SINGLETOK) and (Kind = TTokenKind.SINGLETOK) then + ValType := Kind + else + ValType := RightValType; end; - If ((ValType = TDataType.HALFSINGLETOK) or (Kind = TTokenKind.HALFSINGLETOK)) and (RightValType in IntegerTypes) then begin + if ((ValType = TDataType.HALFSINGLETOK) or (Kind = TTokenKind.HALFSINGLETOK)) and (RightValType in IntegerTypes) then + begin - ExpandParam(TDataType.INTEGERTOK, RightValType); + ExpandParam(TDataType.INTEGERTOK, RightValType); -// asm65(#9'jsr @F16_I2F'); + // asm65(#9'jsr @F16_I2F'); - asm65(#9'lda :STACKORIGIN,x'); - asm65(#9'sta @F16_I2F.SV'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); - asm65(#9'sta @F16_I2F.SV+1'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH*2,x'); - asm65(#9'sta @F16_I2F.SV+2'); - asm65(#9'lda :STACKORIGIN+STACKWIDTH*3,x'); - asm65(#9'sta @F16_I2F.SV+3'); + asm65(#9'lda :STACKORIGIN,x'); + asm65(#9'sta @F16_I2F.SV'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'sta @F16_I2F.SV+1'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH*2,x'); + asm65(#9'sta @F16_I2F.SV+2'); + asm65(#9'lda :STACKORIGIN+STACKWIDTH*3,x'); + asm65(#9'sta @F16_I2F.SV+3'); - asm65(#9'jsr @F16_I2F'); + asm65(#9'jsr @F16_I2F'); - asm65(#9'lda :eax'); - asm65(#9'sta :STACKORIGIN,x'); - asm65(#9'lda :eax+1'); - asm65(#9'sta :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'lda :eax'); + asm65(#9'sta :STACKORIGIN,x'); + asm65(#9'lda :eax+1'); + asm65(#9'sta :STACKORIGIN+STACKWIDTH,x'); - if (ValType <> HALFSINGLETOK) and (Kind = TTokenKind.HALFSINGLETOK) then - RightValType := Kind - else - RightValType := ValType; + if (ValType <> HALFSINGLETOK) and (Kind = TTokenKind.HALFSINGLETOK) then + RightValType := Kind + else + RightValType := ValType; end; - If (ValType in IntegerTypes) and ((RightValType = TTokenKind.HALFSINGLETOK) or (Kind = TTokenKind.HALFSINGLETOK)) then begin + if (ValType in IntegerTypes) and ((RightValType = TTokenKind.HALFSINGLETOK) or + (Kind = TTokenKind.HALFSINGLETOK)) then + begin - ExpandParam_m1(TDataType.INTEGERTOK, ValType); + ExpandParam_m1(TDataType.INTEGERTOK, ValType); -// asm65(#9'jsr @F16_I2F');//_m'); + // asm65(#9'jsr @F16_I2F');//_m'); - asm65(#9'lda :STACKORIGIN-1,x'); - asm65(#9'sta @F16_I2F.SV'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta @F16_I2F.SV+1'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH*2,x'); - asm65(#9'sta @F16_I2F.SV+2'); - asm65(#9'lda :STACKORIGIN-1+STACKWIDTH*3,x'); - asm65(#9'sta @F16_I2F.SV+3'); + asm65(#9'lda :STACKORIGIN-1,x'); + asm65(#9'sta @F16_I2F.SV'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta @F16_I2F.SV+1'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH*2,x'); + asm65(#9'sta @F16_I2F.SV+2'); + asm65(#9'lda :STACKORIGIN-1+STACKWIDTH*3,x'); + asm65(#9'sta @F16_I2F.SV+3'); - asm65(#9'jsr @F16_I2F'); + asm65(#9'jsr @F16_I2F'); - asm65(#9'lda :eax'); - asm65(#9'sta :STACKORIGIN-1,x'); - asm65(#9'lda :eax+1'); - asm65(#9'sta :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'lda :eax'); + asm65(#9'sta :STACKORIGIN-1,x'); + asm65(#9'lda :eax+1'); + asm65(#9'sta :STACKORIGIN-1+STACKWIDTH,x'); - if (RightValType <> TDataType.HALFSINGLETOK) and (Kind = TTokenKind.HALFSINGLETOK) then - ValType := Kind - else - ValType := RightValType; + if (RightValType <> TDataType.HALFSINGLETOK) and (Kind = TTokenKind.HALFSINGLETOK) then + ValType := Kind + else + ValType := RightValType; end; - If ((ValType in [TDatatype.REALTOK, TDatatype.SHORTREALTOK]) or (Kind in [TTokenKind.REALTOK, TTokenKind.SHORTREALTOK])) and (RightValType in IntegerTypes) then begin + if ((ValType in [TDatatype.REALTOK, TDatatype.SHORTREALTOK]) or + (Kind in [TTokenKind.REALTOK, TTokenKind.SHORTREALTOK])) and (RightValType in IntegerTypes) then + begin - ExpandParam(TDataType.INTEGERTOK, RightValType); + ExpandParam(TDataType.INTEGERTOK, RightValType); - asm65(#9'jsr @expandToREAL'); + asm65(#9'jsr @expandToREAL'); { asm65(#9'lda :STACKORIGIN+STACKWIDTH*2,x'); asm65(#9'sta :STACKORIGIN+STACKWIDTH*3,x'); @@ -7259,19 +7309,22 @@ procedure RealTypeConversion(var ValType, RightValType: TDataType; Kind: TTokenK asm65(#9'lda #$00'); asm65(#9'sta :STACKORIGIN,x'); } - if not(ValType in [TDatatype.REALTOK, TDatatype.SHORTREALTOK]) and (Kind in [TTokenKind.REALTOK, TTokenKind.SHORTREALTOK]) then - RightValType := Kind - else - RightValType := ValType; + if not (ValType in [TDatatype.REALTOK, TDatatype.SHORTREALTOK]) and + (Kind in [TTokenKind.REALTOK, TTokenKind.SHORTREALTOK]) then + RightValType := Kind + else + RightValType := ValType; end; - If (ValType in IntegerTypes) and ((RightValType in [TTokenKind.REALTOK, TTokenKind.SHORTREALTOK]) or (Kind in [TTokenKind.REALTOK, TTokenKind.SHORTREALTOK])) then begin + if (ValType in IntegerTypes) and ((RightValType in [TTokenKind.REALTOK, TTokenKind.SHORTREALTOK]) or + (Kind in [TTokenKind.REALTOK, TTokenKind.SHORTREALTOK])) then + begin - ExpandParam_m1(TDataType.INTEGERTOK, ValType); + ExpandParam_m1(TDataType.INTEGERTOK, ValType); - asm65(#9'jsr @expandToREAL1'); + asm65(#9'jsr @expandToREAL1'); { asm65(#9'lda :STACKORIGIN-1+STACKWIDTH*2,x'); asm65(#9'sta :STACKORIGIN-1+STACKWIDTH*3,x'); @@ -7283,14 +7336,15 @@ procedure RealTypeConversion(var ValType, RightValType: TDataType; Kind: TTokenK asm65(#9'sta :STACKORIGIN-1,x'); } - if not(RightValType in [TDatatype.REALTOK, TDatatype.SHORTREALTOK]) and (Kind in [TTokenKind.REALTOK, TTokenKind.SHORTREALTOK]) then - ValType := Kind - else - ValType := RightValType; + if not (RightValType in [TDatatype.REALTOK, TDatatype.SHORTREALTOK]) and + (Kind in [TTokenKind.REALTOK, TTokenKind.SHORTREALTOK]) then + ValType := Kind + else + ValType := RightValType; end; -end; //RealTypeConversion +end; //RealTypeConversion // ---------------------------------------------------------------------------- // ---------------------------------------------------------------------------- @@ -7724,27 +7778,35 @@ procedure CompileActualParameters(var i: Integer; IdentIndex: Integer; ProcVarIn // Writeln(IdentifierAt(IdentIndex).name,',', IdentifierAt(IdentIndex).kind,',', IdentifierAt(IdentIndex).Param[NumActualParams].DataType,',',IdentifierAt(IdentIndex).Param[NumActualParams].AllocElementType ,'|',ActualParamType); - if (ActualParamType in IntegerTypes) and (IdentifierAt(IdentIndex).Param[NumActualParams].DataType in RealTypes) then begin + if (ActualParamType in IntegerTypes) and (IdentifierAt(IdentIndex).Param[NumActualParams].DataType in + RealTypes) then + begin AllocElementType := IdentifierAt(IdentIndex).Param[NumActualParams].DataType; - RealTypeConversion(AllocElementType, ActualParamType); + RealTypeConversion(AllocElementType, ActualParamType); - end; + end; - if (IdentifierAt(IdentIndex).Param[NumActualParams].DataType in IntegerTypes + RealTypes) and (ActualParamType in RealTypes) - then GetCommonType(i, IdentifierAt(IdentIndex).Param[NumActualParams].DataType, ActualParamType); + if (IdentifierAt(IdentIndex).Param[NumActualParams].DataType in IntegerTypes + RealTypes) and + (ActualParamType in RealTypes) then + GetCommonType(i, IdentifierAt(IdentIndex).Param[NumActualParams].DataType, ActualParamType); - if (TokenAt(i).Kind = IDENTTOK) and (IdentifierAt(IdentIndex).Param[NumActualParams].DataType = ENUMTOK) then begin - IdentTemp := GetIdentIndex(TokenAt(i).Name); + if (TokenAt(i).Kind = IDENTTOK) and (IdentifierAt(IdentIndex).Param[NumActualParams].DataType = ENUMTOK) then + begin + IdentTemp := GetIdentIndex(TokenAt(i).Name); - if _TypeArray[IdentifierAt(IdentTemp).NumAllocElements].Field[0].Name <> _TypeArray[IdentifierAt(IdentIndex).Param[NumActualParams].NumAllocElements].Field[0].Name then - Error(i, 'Incompatible types: got "' + _TypeArray[IdentifierAt(IdentTemp).NumAllocElements].Field[0].Name +'" expected "' + _TypeArray[IdentifierAt(IdentIndex).Param[NumActualParams].NumAllocElements].Field[0].Name + '"'); + if _TypeArray[IdentifierAt(IdentTemp).NumAllocElements].Field[0].Name <> + _TypeArray[IdentifierAt(IdentIndex).Param[NumActualParams].NumAllocElements].Field[0].Name then + Error(i, 'Incompatible types: got "' + + _TypeArray[IdentifierAt(IdentTemp).NumAllocElements].Field[0].Name + + '" expected "' + _TypeArray[IdentifierAt(IdentIndex).Param[NumActualParams].NumAllocElements].Field[ + 0].Name + '"'); ActualParamType := IdentifierAt(IdentTemp).Kind; -// Writeln(IdentifierAt(IdentTemp).Kind,',', IdentifierAt(IdentTemp).NumAllocElements,'/', IdentifierAt(IdentIndex).Param[NumActualParams].NumAllocElements, ',',_TypeArray[IdentifierAt(IdentTemp).NumAllocElements].Field[0].name); - end; + // Writeln(IdentifierAt(IdentTemp).Kind,',', IdentifierAt(IdentTemp).NumAllocElements,'/', IdentifierAt(IdentIndex).Param[NumActualParams].NumAllocElements, ',',_TypeArray[IdentifierAt(IdentTemp).NumAllocElements].Field[0].name); + end; if (TokenAt(i).Kind = TTokenKind.IDENTTOK) and (ActualParamType in [TTokenKind.RECORDTOK, TTokenKind.OBJECTTOK]) and not @@ -8114,7 +8176,8 @@ procedure CompileActualParameters(var i: Integer; IdentIndex: Integer; ProcVarIn begin ActualParamType := IdentifierAt(IdentIndex).Param[ParamIndex].DataType; - if ActualParamType = TDataType.ENUMTOK then ActualParamType := IdentifierAt(IdentIndex).Param[ParamIndex].AllocElementType; + if ActualParamType = TDataType.ENUMTOK then + ActualParamType := IdentifierAt(IdentIndex).Param[ParamIndex].AllocElementType; if IdentifierAt(IdentIndex).Param[ParamIndex].PassMethod = TParameterPassingMethod.VARPASSING then begin @@ -10028,7 +10091,7 @@ // === record^. i := CompileArrayIndex(i, GetIdentIndex(IdentifierAt(IdentIndex).Name + - '.' + TokenAt(i).Name),AllocElementType); + '.' + TokenAt(i).Name), AllocElementType); Push(IdentifierAt(IdentIndex).Value, IndirectionLevel, GetDataSize(ValType), IdentIndex, IdentTemp and $ffff); @@ -10181,27 +10244,30 @@ // === record^. // if GetDataSize(ValType) > GetDataSize( TDataType.VarType] then ValType := VarType; // skracaj typ danych !!! niemozliwe skoro VarType = TDataType.INTEGERTOK - if (IdentifierAt(IdentIndex).Kind = CONSTANT) then begin + if (IdentifierAt(IdentIndex).Kind = CONSTANT) then + begin if {(Ident[IdentIndex].Kind = CONSTANT) and} (ValType in Pointers) then - ConstVal := IdentifierAt(IdentIndex).Value - CODEORIGIN + ConstVal := IdentifierAt(IdentIndex).Value - CODEORIGIN else - ConstVal := IdentifierAt(IdentIndex).Value; + ConstVal := IdentifierAt(IdentIndex).Value; - if (ValType in IntegerTypes) and (VarType in [TDataType.SINGLETOK, TDataType.HALFSINGLETOK]) then - ConstVal := FromInt64(ConstVal); + if (ValType in IntegerTypes) and (VarType in [TDataType.SINGLETOK, + TDataType.HALFSINGLETOK]) then + ConstVal := FromInt64(ConstVal); - if (VarType = TDataType.HALFSINGLETOK) {or (ValType = TDataType. TTokenKind.HALFSINGLETOK)} then - begin - ConstVal := CastToHalfSingle(ConstVal); - //ValType := TTokenKind. TTokenKind.HALFSINGLETOK; - end; + if (VarType = TDataType.HALFSINGLETOK) + {or (ValType = TDataType. TTokenKind.HALFSINGLETOK)} then + begin + ConstVal := CastToHalfSingle(ConstVal); + //ValType := TTokenKind. TTokenKind.HALFSINGLETOK; + end; - if (VarType = TDataType.SINGLETOK) then - begin - ConstVal := CastToSingle(ConstVal); - //ValType := TTokenKind.SINGLETOK; - end; + if (VarType = TDataType.SINGLETOK) then + begin + ConstVal := CastToSingle(ConstVal); + //ValType := TTokenKind.SINGLETOK; + end; end; @@ -11408,7 +11474,7 @@ procedure RestoreBreakAddress; // ---------------------------------------------------------------------------- -function CompileBlockRead(var i: Integer; IdentIndex: TIdentIndex; IdentBlock: Integer): Integer; +function CompileBlockRead(var i: TTokenIndex; IdentIndex: TIdentIndex; IdentBlock: Integer): Integer; var NumActualParams, idx: Integer; ActualParamType, AllocElementType: TDataType; @@ -12673,166 +12739,195 @@ function CompileStatement(i: Integer; isAsm: Boolean = False): Integer; // dla PROC, FUNC -> IdentifierAt(GetIdentIndex(TokenAt(k).Name)).NumAllocElements -> oznacza liczbe parametrow takiej procedury/funkcji - if (VarType in Pointers) and ( (ExpressionType in Pointers) and (TokenAt(k).Kind = IDENTTOK) ) and - ( not (IdentifierAt(IdentIndex).AllocElementType in Pointers + [RECORDTOK, OBJECTTOK]) and not (IdentifierAt(GetIdentIndex(TokenAt(k).Name)).AllocElementType in Pointers + [RECORDTOK, OBJECTTOK]) ) then - begin - + if (VarType in Pointers) and ((ExpressionType in Pointers) and (TokenAt(k).Kind = IDENTTOK)) and + (not (IdentifierAt(IdentIndex).AllocElementType in Pointers + [RECORDTOK, OBJECTTOK]) and + not (IdentifierAt(GetIdentIndex(TokenAt(k).Name)).AllocElementType in + Pointers + [RECORDTOK, OBJECTTOK])) then + begin - j := Elements(IdentIndex) {IdentifierAt(IdentIndex).NumAllocElements} * GetDataSize(IdentifierAt(IdentIndex).AllocElementType); + j := Elements(IdentIndex) {IdentifierAt(IdentIndex).NumAllocElements} * + GetDataSize(IdentifierAt(IdentIndex).AllocElementType); - IdentTemp := GetIdentIndex(TokenAt(k).Name); + IdentTemp := GetIdentIndex(TokenAt(k).Name); - Name := 'adr.'+TokenAt(k).Name; - svar := TokenAt(k).Name; + Name := 'adr.' + TokenAt(k).Name; + svar := TokenAt(k).Name; - if IdentTemp > 0 then begin + if IdentTemp > 0 then + begin - if IdentifierAt(IdentTemp).Kind = FUNCTIONTOK then begin + if IdentifierAt(IdentTemp).Kind = FUNCTIONTOK then + begin - svar := GetLocalName(IdentTemp); + svar := GetLocalName(IdentTemp); - IdentTemp := GetIdentResult(IdentifierAt(IdentTemp).ProcAsBlock); + IdentTemp := GetIdentResult(IdentifierAt(IdentTemp).ProcAsBlock); - Name := svar+'.adr.result'; - svar := svar+'.result'; + Name := svar + '.adr.result'; + svar := svar + '.result'; - end; + end; - //if (IdentifierAt(IdentIndex).NumAllocElements > 1) and (IdentifierAt(IdentTemp).NumAllocElements > 1) then begin - if (Elements(IdentIndex) > 1) and (Elements(IdentTemp) > 1) then begin + //if (IdentifierAt(IdentIndex).NumAllocElements > 1) and (IdentifierAt(IdentTemp).NumAllocElements > 1) then begin + if (Elements(IdentIndex) > 1) and (Elements(IdentTemp) > 1) then + begin -//writeln(j,',', Elements(IdentTemp) ); -// perl - if IdentifierAt(IdentTemp).AllocElementType <> RECORDTOK then - if (j <> integer(Elements(IdentTemp) {IdentifierAt(IdentTemp).NumAllocElements} * GetDataSize(IdentifierAt(IdentTemp).AllocElementType))) then - if (IdentifierAt(IdentIndex).AllocElementType <> IdentifierAt(IdentTemp).AllocElementType) or - ((IdentifierAt(IdentTemp).NumAllocElements <> IdentifierAt(IdentIndex).NumAllocElements_) and (IdentifierAt(IdentTemp).NumAllocElements_ = 0)) or - ((IdentifierAt(IdentIndex).NumAllocElements <> IdentifierAt(IdentTemp).NumAllocElements_) and (IdentifierAt(IdentIndex).NumAllocElements_ = 0)) then - ErrorIdentifierIncompatibleTypesArrayIdentifier(i, IdentTemp, IdentIndex); + //writeln(j,',', Elements(IdentTemp) ); + // perl + if IdentifierAt(IdentTemp).AllocElementType <> RECORDTOK then + if (j <> Integer(Elements(IdentTemp) {IdentifierAt(IdentTemp).NumAllocElements} * + GetDataSize(IdentifierAt(IdentTemp).AllocElementType))) then + if (IdentifierAt(IdentIndex).AllocElementType <> + IdentifierAt(IdentTemp).AllocElementType) or + ((IdentifierAt(IdentTemp).NumAllocElements <> + IdentifierAt(IdentIndex).NumAllocElements_) and + (IdentifierAt(IdentTemp).NumAllocElements_ = 0)) or + ((IdentifierAt(IdentIndex).NumAllocElements <> IdentifierAt( + IdentTemp).NumAllocElements_) and (IdentifierAt(IdentIndex).NumAllocElements_ = 0)) + then + ErrorIdentifierIncompatibleTypesArrayIdentifier(i, IdentTemp, IdentIndex); { - a65(__subBX); - StopOptimization; + a65(__subBX); + StopOptimization; - ResetOpty; + ResetOpty; } - if j <> integer(Elements(IdentTemp) * GetDataSize(IdentifierAt(IdentTemp).AllocElementType)) then begin - - if (IdentifierAt(IdentIndex).NumAllocElements_ > 0) and - ((IdentifierAt(IdentIndex).NumAllocElements_ = IdentifierAt(IdentTemp).NumAllocElements) or - (IdentifierAt(IdentIndex).NumAllocElements_ = IdentifierAt(IdentTemp).NumAllocElements_)) then begin - -//writeln( TokenAt(k].line,',', IdentifierAt(IdentTemp).NumAllocElements_); - - if IdentifierAt(IdentTemp).NumAllocElements_ = 0 then begin - - asm65(#9'lda ' + GetLocalName(IdentIndex)); - asm65(#9'add :STACKORIGIN-1,x'); - asm65(#9'sta @move.dst'); - asm65(#9'lda ' + GetLocalName(IdentIndex) + '+1'); - asm65(#9'adc :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta @move.dst+1'); + if j <> Integer(Elements(IdentTemp) * + GetDataSize(IdentifierAt(IdentTemp).AllocElementType)) then + begin - asm65(#9'lda ' + GetLocalName(IdentTemp)); - asm65(#9'sta @move.src'); - asm65(#9'lda ' + GetLocalName(IdentTemp) + '+1'); - asm65(#9'sta @move.src+1'); + if (IdentifierAt(IdentIndex).NumAllocElements_ > 0) and + ((IdentifierAt(IdentIndex).NumAllocElements_ = + IdentifierAt(IdentTemp).NumAllocElements) or + (IdentifierAt(IdentIndex).NumAllocElements_ = + IdentifierAt(IdentTemp).NumAllocElements_)) then + begin - end else begin - a65(TCode65.subBX); + //writeln( TokenAt(k].line,',', IdentifierAt(IdentTemp).NumAllocElements_); - asm65(#9'lda ' + GetLocalName(IdentIndex)); - asm65(#9'add :STACKORIGIN-1,x'); - asm65(#9'sta @move.dst'); - asm65(#9'lda ' + GetLocalName(IdentIndex) + '+1'); - asm65(#9'adc :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta @move.dst+1'); + if IdentifierAt(IdentTemp).NumAllocElements_ = 0 then + begin - asm65(#9'lda ' + GetLocalName(IdentTemp)); - asm65(#9'add :STACKORIGIN,x'); - asm65(#9'sta @move.src'); - asm65(#9'lda ' + GetLocalName(IdentTemp) + '+1'); - asm65(#9'adc :STACKORIGIN+STACKWIDTH,x'); - asm65(#9'sta @move.src+1'); + asm65(#9'lda ' + GetLocalName(IdentIndex)); + asm65(#9'add :STACKORIGIN-1,x'); + asm65(#9'sta @move.dst'); + asm65(#9'lda ' + GetLocalName(IdentIndex) + '+1'); + asm65(#9'adc :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta @move.dst+1'); - end; + asm65(#9'lda ' + GetLocalName(IdentTemp)); + asm65(#9'sta @move.src'); + asm65(#9'lda ' + GetLocalName(IdentTemp) + '+1'); + asm65(#9'sta @move.src+1'); - a65(TCode65.subBX); - a65(TCode65.subBX); - StopOptimization; + end + else + begin + a65(TCode65.subBX); + + asm65(#9'lda ' + GetLocalName(IdentIndex)); + asm65(#9'add :STACKORIGIN-1,x'); + asm65(#9'sta @move.dst'); + asm65(#9'lda ' + GetLocalName(IdentIndex) + '+1'); + asm65(#9'adc :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta @move.dst+1'); + + asm65(#9'lda ' + GetLocalName(IdentTemp)); + asm65(#9'add :STACKORIGIN,x'); + asm65(#9'sta @move.src'); + asm65(#9'lda ' + GetLocalName(IdentTemp) + '+1'); + asm65(#9'adc :STACKORIGIN+STACKWIDTH,x'); + asm65(#9'sta @move.src+1'); - ResetOpty; + end; - asm65(#9'lda <' + IntToStr(IdentifierAt(IdentIndex).NumAllocElements_ * GetDataSize(IdentifierAt(IdentIndex).AllocElementType))); - asm65(#9'sta @move.cnt'); - asm65(#9'lda >' + IntToStr(IdentifierAt(IdentIndex).NumAllocElements_ * GetDataSize(IdentifierAt(IdentIndex).AllocElementType))); - asm65(#9'sta @move.cnt+1'); + a65(TCode65.subBX); + a65(TCode65.subBX); + StopOptimization; - asm65(#9'jsr @move'); + ResetOpty; - end else begin + asm65(#9'lda <' + IntToStr(IdentifierAt(IdentIndex).NumAllocElements_ * + GetDataSize(IdentifierAt(IdentIndex).AllocElementType))); + asm65(#9'sta @move.cnt'); + asm65(#9'lda >' + IntToStr(IdentifierAt(IdentIndex).NumAllocElements_ * + GetDataSize(IdentifierAt(IdentIndex).AllocElementType))); + asm65(#9'sta @move.cnt+1'); -//writeln('2: ',IdentifierAt(IdentIndex).NumAllocElements); + asm65(#9'jsr @move'); - asm65(#9'lda ' + GetLocalName(IdentIndex)); - asm65(#9'sta @move.dst'); - asm65(#9'lda ' + GetLocalName(IdentIndex) + '+1'); - asm65(#9'sta @move.dst+1'); + end + else + begin - asm65(#9'lda ' + GetLocalName(IdentTemp)); - asm65(#9'add :STACKORIGIN-1,x'); - asm65(#9'sta @move.src'); - asm65(#9'lda ' + GetLocalName(IdentTemp) + '+1'); - asm65(#9'adc :STACKORIGIN-1+STACKWIDTH,x'); - asm65(#9'sta @move.src+1'); + //writeln('2: ',IdentifierAt(IdentIndex).NumAllocElements); - a65(TCode65.subBX); - a65(TCode65.subBX); - StopOptimization; + asm65(#9'lda ' + GetLocalName(IdentIndex)); + asm65(#9'sta @move.dst'); + asm65(#9'lda ' + GetLocalName(IdentIndex) + '+1'); + asm65(#9'sta @move.dst+1'); - ResetOpty; + asm65(#9'lda ' + GetLocalName(IdentTemp)); + asm65(#9'add :STACKORIGIN-1,x'); + asm65(#9'sta @move.src'); + asm65(#9'lda ' + GetLocalName(IdentTemp) + '+1'); + asm65(#9'adc :STACKORIGIN-1+STACKWIDTH,x'); + asm65(#9'sta @move.src+1'); - asm65(#9'lda <' + IntToStr(IdentifierAt(IdentIndex).NumAllocElements * GetDataSize(IdentifierAt(IdentIndex).AllocElementType))); - asm65(#9'sta @move.cnt'); - asm65(#9'lda >' + IntToStr(IdentifierAt(IdentIndex).NumAllocElements * GetDataSize(IdentifierAt(IdentIndex).AllocElementType))); - asm65(#9'sta @move.cnt+1'); + a65(TCode65.subBX); + a65(TCode65.subBX); + StopOptimization; - asm65(#9'jsr @move'); + ResetOpty; - end; + asm65(#9'lda <' + IntToStr(IdentifierAt(IdentIndex).NumAllocElements * + GetDataSize(IdentifierAt(IdentIndex).AllocElementType))); + asm65(#9'sta @move.cnt'); + asm65(#9'lda >' + IntToStr(IdentifierAt(IdentIndex).NumAllocElements * + GetDataSize(IdentifierAt(IdentIndex).AllocElementType))); + asm65(#9'sta @move.cnt+1'); - end else begin + asm65(#9'jsr @move'); - a65(TCode65.subBX); - StopOptimization; + end; - ResetOpty; + end + else + begin - if (j <= 4) and (IdentifierAt(IdentTemp).AllocElementType <> RECORDTOK) then - asm65(#9':' + IntToStr(j) + ' mva ' + Name + '+# ' + GetLocalName(IdentIndex, 'adr.') + '+#') - else - asm65(#9'@move ' + svar + ' ' + GetLocalName(IdentIndex) + ' #' + IntToStr(j)); + a65(TCode65.subBX); + StopOptimization; - end; + ResetOpty; - end else - GenerateAssignment(IndirectionLevel, GetDataSize(VarType), IdentIndex, par1, par2); + if (j <= 4) and (IdentifierAt(IdentTemp).AllocElementType <> RECORDTOK) then + asm65(#9':' + IntToStr(j) + ' mva ' + Name + '+# ' + + GetLocalName(IdentIndex, 'adr.') + '+#') + else + asm65(#9'@move ' + svar + ' ' + GetLocalName(IdentIndex) + ' #' + IntToStr(j)); + end; - end else - Error(k, TErrorCode.UnknownIdentifier); + end + else + GenerateAssignment(IndirectionLevel, GetDataSize(VarType), IdentIndex, par1, par2); + end + else + Error(k, TErrorCode.UnknownIdentifier); - end else - GenerateAssignment(IndirectionLevel, GetDataSize(VarType), IdentIndex, par1, par2); + end + else + GenerateAssignment(IndirectionLevel, GetDataSize(VarType), IdentIndex, par1, par2); - end; + end; -// StopOptimization; + // StopOptimization; - end;// VARIABLE + end;// VARIABLE @@ -13040,23 +13135,27 @@ function CompileStatement(i: Integer; isAsm: Boolean = False): Integer; end else -// if TokenAt(i).Kind = TTokenKind.IDENTTOK then -// EnumName := GetEnumName(GetIdentIndex(TokenAt(i).Name)); + // if TokenAt(i).Kind = TTokenKind.IDENTTOK then + // EnumName := GetEnumName(GetIdentIndex(TokenAt(i).Name)); - if (SelectorType = TDatatype.ENUMTOK) and (TokenAt(j).Kind = IDENTTOK) and (IdentifierAt(GetIdentIndex(TokenAt(j).Name)).Kind = TYPETOK) then begin + if (SelectorType = TDatatype.ENUMTOK) and (TokenAt(j).Kind = IDENTTOK) and + (IdentifierAt(GetIdentIndex(TokenAt(j).Name)).Kind = TYPETOK) then + begin - IdentTemp:=GetIdentIndex(TokenAt(j).Name); - EnumName := GetEnumName(IdentTemp); + IdentTemp := GetIdentIndex(TokenAt(j).Name); + EnumName := GetEnumName(IdentTemp); - SelectorType := IdentifierAt(IdentTemp).AllocElementType; + SelectorType := IdentifierAt(IdentTemp).AllocElementType; - end else - if TokenAt(i).Kind = IDENTTOK then begin + end + else + if TokenAt(i).Kind = IDENTTOK then + begin - IdentTemp:=GetIdentIndex(TokenAt(i).Name); - EnumName := GetEnumName(IdentTemp); + IdentTemp := GetIdentIndex(TokenAt(i).Name); + EnumName := GetEnumName(IdentTemp); - end; + end; if SelectorType <> TDataType.ENUMTOK then @@ -13247,37 +13346,39 @@ function CompileStatement(i: Integer; isAsm: Boolean = False): Integer; WITHTOK: begin - inc(CodeSize); // !!! aby dzialaly zagniezdzone WHILE + Inc(CodeSize); // !!! aby dzialaly zagniezdzone WHILE CheckTok(i + 1, IDENTTOK); IdentIndex := GetIdentIndex(TokenAt(i + 1).Name); - if (IdentifierAt(IdentIndex).Kind = USERTYPE) and (IdentifierAt(IdentIndex).DataType in [RECORDTOK, OBJECTTOK]) then + if (IdentifierAt(IdentIndex).Kind = USERTYPE) and (IdentifierAt(IdentIndex).DataType in + [RECORDTOK, OBJECTTOK]) then else - if (IdentifierAt(IdentIndex).Kind <> VARTOK) then - Error(i + 1, 'Expression type must be object or record type'); + if (IdentifierAt(IdentIndex).Kind <> VARTOK) then + Error(i + 1, 'Expression type must be object or record type'); - if (IdentifierAt(IdentIndex).DataType = POINTERTOK) and (IdentifierAt(IdentIndex).AllocElementType = RECORDTOK) then + if (IdentifierAt(IdentIndex).DataType = POINTERTOK) and (IdentifierAt(IdentIndex).AllocElementType = + RECORDTOK) then else - if not (IdentifierAt(IdentIndex).DataType in [RECORDTOK, OBJECTTOK]) then - Error(i + 1, 'Expression type must be object or record type'); + if not (IdentifierAt(IdentIndex).DataType in [RECORDTOK, OBJECTTOK]) then + Error(i + 1, 'Expression type must be object or record type'); CheckTok(i + 2, DOTOK); - k:=High(WithName); + k := High(WithName); WithName[k] := IdentifierAt(IdentIndex).Name; - SetLength(WithName, k+2); + SetLength(WithName, k + 2); - inc(i, 2); + Inc(i, 2); j := CompileStatement(i + 1); - SetLength(WithName, k+1); + SetLength(WithName, k + 1); Result := j; @@ -14801,8 +14902,8 @@ function CompileStatement(i: Integer; isAsm: Boolean = False): Integer; IndirectionLevel := ASPOINTER; if IdentifierAt(IdentIndex).DataType = ENUMTOK then - ExpressionType := IdentifierAt(IdentIndex).AllocElementType - else + ExpressionType := IdentifierAt(IdentIndex).AllocElementType + else if IdentifierAt(IdentIndex).DataType in Pointers then ExpressionType := TTokenKind.WORDTOK else @@ -14880,7 +14981,8 @@ function CompileStatement(i: Integer; isAsm: Boolean = False): Integer; j := i + 2; yes := False; - if SafeCompileConstExpression(j, ConstVal, ActualParamType, { IdentifierAt(IdentIndex).DataType } ExpressionType, True) then + if SafeCompileConstExpression(j, ConstVal, ActualParamType, + { IdentifierAt(IdentIndex).DataType } ExpressionType, True) then yes := True else j := CompileExpression(j, ActualParamType); @@ -15419,9 +15521,6 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: Integer; VarSize: Boolean = fnam, txt, svar: String; varbegin: TString; HeaFile: ITextFile; - // Debugging - traceSize: Boolean; - varDataSizeString: String; // ---------------------------------------------------------------------------- @@ -15573,13 +15672,21 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: Integer; VarSize: Boolean = begin dataSize := GetDataSize(identifier.AllocElementType); Result := identifier.NumAllocElements * dataSize; - if (traceSize) then Writeln('Identifier ', GetIdentifierFullName(identifier), ' has ', - identifier.NumAllocElements, ' elements of size ', dataSize, ' = ', Result, ' bytes.'); + // LogTrace(Format('Identifier %s has %d element of size %d = %d', + // [GetIdentifierFullName(identifier), identifier.NumAllocElements, dataSize, Result])); end; // ---------------------------------------------------------------------------- + procedure IncSize(bytes: Integer); + begin + // LogTrace(Format('IncSize %d by %d', [size, bytes])); + Inc(size, bytes); + end; + + // ---------------------------------------------------------------------------- + begin if Pass = TPass.CODE_GENERATION then @@ -15590,15 +15697,6 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: Integer; VarSize: Boolean = emptyLine := True; size := 0; varbegin := ''; - traceSize := False; - - // For debugging - (* - if IdentifierAt(BlockIdentIndex).Name = 'DRAWSPLINE' then - begin - traceSize := True; - Writeln('Tracing ', GetIdentifierFullName(IdentifierAt(BlockIdentIndex)), '.'); - end; *) for IdentIndex := 1 to NumIdent do if (IdentifierAt(IdentIndex).Block = IdentifierAt(BlockIdentIndex).ProcAsBlock) and @@ -15697,7 +15795,7 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: Integer; VarSize: Boolean = IdentifierAt(IdentIndex).Name + ' .word'); if size = 0 then varbegin := IdentifierAt(IdentIndex).Name; - Inc(size, GetIdentifierDataSize(IdentifierAt(IdentIndex))); + Incsize(GetIdentifierDataSize(IdentifierAt(IdentIndex))); end else @@ -15757,7 +15855,7 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: Integer; VarSize: Boolean = end; if size = 0 then varbegin := IdentifierAt(IdentIndex).Name; - Inc(size, GetIdentifierDataSize(IdentifierAt(IdentIndex))); + Incsize(GetIdentifierDataSize(IdentifierAt(IdentIndex))); end else @@ -15778,8 +15876,11 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: Integer; VarSize: Boolean = // RESULT nie zliczaj else - Inc(size, GetDataSize(IdentifierAt(IdentIndex).DataType)); + if IdentifierAt(IdentIndex).DataType = ENUMTYPE then + IncSize(GetDataSize(IdentifierAt(IdentIndex).AllocElementType)) + else + IncSize(GetDataSize(IdentifierAt(IdentIndex).DataType)); end; CONSTANT: if (IdentifierAt(IdentIndex).DataType in Pointers) and @@ -15807,15 +15908,7 @@ procedure GenerateProcFuncAsmLabels(BlockIdentIndex: Integer; VarSize: Boolean = if VarSize and (size > 0) then begin asm65('@VarData'#9'= ' + varbegin); - varDataSizeString := IntToStr(size); - if traceSize then - begin - Writeln(GetIdentifierFullName(IdentifierAt(BlockIdentIndex)), ' has VarDataSize=', - varDataSizeString, ' bytes.'); - // TODO - end; - - asm65('@VarDataSize'#9'= ' + varDataSizeString); + asm65('@VarDataSize'#9'= ' + IntToStr(size)); asm65; end; @@ -16569,9 +16662,9 @@ procedure CheckForwardResolutions(typ: Boolean = True); // ---------------------------------------------------------------------------- -procedure CompileRecordDeclaration(i: Integer; var VarOfSameType: TVariableList; var tmpVarDataSize: Integer; - var ConstVal: Int64; VarOfSameTypeIndex: Integer; VarType, AllocElementType: TDataType; - NumAllocElements: Cardinal; isAbsolute: Boolean); // TODO: Actually not used +procedure CompileRecordDeclaration(i: Integer; var VarOfSameType: TVariableList; + var tmpVarDataSize: Integer; var ConstVal: Int64; VarOfSameTypeIndex: Integer; + VarType, AllocElementType: TDataType; NumAllocElements: Cardinal; isAbsolute: Boolean); // TODO: Actually not used var tmpVarDataSize_, ParamIndex{, idx}: Integer; begin @@ -16592,7 +16685,7 @@ procedure CompileRecordDeclaration(i: Integer; var VarOfSameType: TVariableList; IdentifierAt(NumIdent).NumAllocElements := NumAllocElements and $FFFF; IdentifierAt(NumIdent).NumAllocElements_ := NumAllocElements shr 16; - SetVarDataSize(tmpVarDataSize + (NumAllocElements shr 16) * GetDataSize(TDataType.POINTERTOK)); + SetVarDataSize(i, tmpVarDataSize + (NumAllocElements shr 16) * GetDataSize(TDataType.POINTERTOK)); tmpVarDataSize := GetVarDataSize; @@ -16628,7 +16721,7 @@ procedure CompileRecordDeclaration(i: Integer; var VarOfSameType: TVariableList; end; - SetVarDataSize(tmpVarDataSize); + SetVarDataSize(i, tmpVarDataSize); end else @@ -16666,8 +16759,8 @@ procedure CompileRecordDeclaration(i: Integer; var VarOfSameType: TVariableList; // ---------------------------------------------------------------------------- -function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; IsFunction: Boolean; - FunctionResultType: TDataType; FunctionNumAllocElements: Cardinal = 0; +function CompileBlock(i: TTokenIndex; BlockIdentIndex: Integer; NumParams: Integer; + IsFunction: Boolean; FunctionResultType: TDataType; FunctionNumAllocElements: Cardinal = 0; FunctionAllocElementType: TDataType = TDataType.UNTYPETOK): Integer; var VarOfSameType: TVariableList; @@ -16867,7 +16960,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; IdentifierAt(GetIdentIndex(Param[ParamIndex].Name)).isAbsolute := True; IdentifierAt(GetIdentIndex(Param[ParamIndex].Name)).Value := (Byte(ParamIndex) shl 24) or $80000000; - SetVarDataSize(tmpVarDataSize); + SetVarDataSize(i, tmpVarDataSize); end else @@ -16902,7 +16995,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; end; - SetVarDataSize(tmpVarDataSize); + SetVarDataSize(i, tmpVarDataSize); end else @@ -16930,7 +17023,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; IdentifierAt(GetIdentIndex(Param[ParamIndex].Name)).isAbsolute := True; IdentifierAt(GetIdentIndex(Param[ParamIndex].Name)).Value := (Byte(ParamIndex) shl 24) or $80000000; - SetVarDataSize(tmpVarDataSize); + SetVarDataSize(i, tmpVarDataSize); end else @@ -16964,7 +17057,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; end; - SetVarDataSize(tmpVarDataSize); + SetVarDataSize(i, tmpVarDataSize); end else @@ -17006,7 +17099,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; IdentifierAt(NumIdent).isAbsolute := True; IdentifierAt(NumIdent).Value := $87000000; // :STACKORIGIN-4 -> :TMP - SetVarDataSize(tmpVarDataSize); + SetVarDataSize(i, tmpVarDataSize); end; if FunctionResultType in [TDataType.RECORDTOK, TDataType.OBJECTTOK] then @@ -17071,10 +17164,11 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; if Param[ParamIndex].PassMethod = TParameterPassingMethod.VARPASSING then GenerateAssignment(ASPOINTER, GetDataSize(TDataType.POINTERTOK), 0, Param[ParamIndex].Name) - else begin - if Param[ParamIndex].DataType = TDatatype.ENUMTOK then - GenerateAssignment(ASPOINTER, GetDataSize(Param[ParamIndex].AllocElementType), 0, Param[ParamIndex].Name) - else + else + begin + if Param[ParamIndex].DataType = TDatatype.ENUMTOK then + GenerateAssignment(ASPOINTER, GetDataSize(Param[ParamIndex].AllocElementType), 0, Param[ParamIndex].Name) + else GenerateAssignment(ASPOINTER, GetDataSize(Param[ParamIndex].DataType), 0, Param[ParamIndex].Name); end; @@ -17134,9 +17228,10 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; if Assignment then if Param[ParamIndex].PassMethod = TParameterPassingMethod.VARPASSING then GenerateAssignment(ASPOINTER, GetDataSize(TDataType.POINTERTOK), 0, Param[ParamIndex].Name) - else begin + else + begin if Param[ParamIndex].DataType = ENUMTYPE then - GenerateAssignment(ASPOINTER, GetDataSize(Param[ParamIndex].AllocElementType), 0, Param[ParamIndex].Name) + GenerateAssignment(ASPOINTER, GetDataSize(Param[ParamIndex].AllocElementType), 0, Param[ParamIndex].Name) else GenerateAssignment(ASPOINTER, GetDataSize(Param[ParamIndex].DataType), 0, Param[ParamIndex].Name); end; @@ -17188,7 +17283,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; IdentifierAt(NumIdent).PassMethod := TParameterPassingMethod.VARPASSING; - SetVarDataSize(tmpVarDataSize + GetDataSize(TDataType.POINTERTOK)); + SetVarDataSize(i, tmpVarDataSize + GetDataSize(TDataType.POINTERTOK)); if GetTypeAtIndex(IdentifierAt(BlockIdentIndex).ObjectIndex).Field[ParamIndex].Kind = TFieldKind.OBJECTVARIABLE then @@ -17198,7 +17293,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; Inc(ConstVal, GetDataSize(GetTypeAtIndex(IdentifierAt(BlockIdentIndex).ObjectIndex).Field[ ParamIndex].DataType)); - SetVarDataSize(tmpVarDataSize); + SetVarDataSize(i, tmpVarDataSize); end; end; @@ -18266,7 +18361,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; SaveToDataSegment(idx, GetVarDataSize, TTokenKind.DATAORIGINOFFSET); Inc(idx, 2); - IncVarDataSize(NestedNumAllocElements); + IncVarDataSize(i, NestedNumAllocElements); end; end @@ -18278,7 +18373,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; SaveToDataSegment(idx, GetVarDataSize, TTokenKind.DATAORIGINOFFSET); Inc(idx, 2); - IncVarDataSize(NestedNumAllocElements); + IncVarDataSize(i, NestedNumAllocElements); end; end; @@ -18307,7 +18402,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; if isAbsolute and (open_array = False) then - SetVarDataSize(tmpVarDataSize) + SetVarDataSize(i, tmpVarDataSize) else @@ -18479,7 +18574,7 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; IdentifierAt(NumIdent).NumAllocElements := NumAllocElements; end; - IncVarDataSize(NumAllocElements * GetDataSize(IdentifierAt(NumIdent).AllocElementType)); + IncVarDataSize(i, NumAllocElements * GetDataSize(IdentifierAt(NumIdent).AllocElementType)); end else @@ -18719,10 +18814,10 @@ function CompileBlock(i: Integer; BlockIdentIndex: Integer; NumParams: Integer; i := j + 1; GenerateReturn(IsNestedFunction, - IdentifierAt(ForwardIdentIndex).isInterrupt, - IdentifierAt(ForwardIdentIndex).isInline, - IdentifierAt(ForwardIdentIndex).isOverload - ); + IdentifierAt(ForwardIdentIndex).isInterrupt, + IdentifierAt(ForwardIdentIndex).isInline, + IdentifierAt(ForwardIdentIndex).isOverload + ); if OutputDisabled then OutputDisabled := False; @@ -19097,7 +19192,7 @@ procedure CompileProgram(const pass: TPass); common.optimize.use := False; - SetVarDataSize(0); + SetVarDataSize(0, 0); tmp := ''; diff --git a/src/CompilerTypes.pas b/src/CompilerTypes.pas index 6b25f5000..bc99e26d6 100644 --- a/src/CompilerTypes.pas +++ b/src/CompilerTypes.pas @@ -171,7 +171,7 @@ TField = record end; - TTypeIndex = integer; + TTypeIndex = Integer; TType = record Block: Integer; @@ -476,8 +476,11 @@ function TToken.GetSourceFileLineString: String; function TToken.GetSourceFileLocationString: String; begin - Result := SourceLocation.SourceFile.Path + ' ( line ' + IntToStr(SourceLocation.Line) + - ', column ' + IntToStr(SourceLocation.Column) + ')'; + if SourceLocation.SourceFile <> nil then + begin + Result := SourceLocation.SourceFile.Path + ' ( line ' + IntToStr(SourceLocation.Line) + + ', column ' + IntToStr(SourceLocation.Column) + ')'; + end; end; function TToken.GetSpelling: TString; diff --git a/src/Parser.pas b/src/Parser.pas index b2b5bf7e0..7e21f9966 100644 --- a/src/Parser.pas +++ b/src/Parser.pas @@ -143,11 +143,12 @@ function GetIdentIndex(S: TString): TIdentIndex; // Check if it can be found in the current WITH context if High(WithName) > 0 then - for TempIndex:=0 to High(WithName) do begin - Result := Search(WithName[TempIndex] + '.' + S, ActiveSourceFile); + for TempIndex := 0 to High(WithName) do + begin + Result := Search(WithName[TempIndex] + '.' + S, ActiveSourceFile); - if Result > 0 then exit; - end; + if Result > 0 then exit; + end; Result := Search(S, ActiveSourceFile); @@ -194,7 +195,7 @@ function ObjectRecordSize(i: Cardinal): Integer; for j := 1 to GetTypeAtIndex(i).NumFields do begin - FieldType :=GetTypeAtIndex(i).Field[j].DataType; + FieldType := GetTypeAtIndex(i).Field[j].DataType; if FieldType <> TDataType.RECORDTOK then Inc(Result, GetDataSize(FieldType)); @@ -236,10 +237,10 @@ function RecordSize(IdentIndex: Integer; field: String = ''): Integer; for j := 1 to GetTypeAtIndex(i).NumFields do begin - FieldType :=GetTypeAtIndex(i).Field[j].DataType; - NumAllocElements :=GetTypeAtIndex(i).Field[j].NumAllocElements and $FFFF; - NumAllocElements_ :=GetTypeAtIndex(i).Field[j].NumAllocElements shr 16; - AllocElementType :=GetTypeAtIndex(i).Field[j].AllocElementType; + FieldType := GetTypeAtIndex(i).Field[j].DataType; + NumAllocElements := GetTypeAtIndex(i).Field[j].NumAllocElements and $FFFF; + NumAllocElements_ := GetTypeAtIndex(i).Field[j].NumAllocElements shr 16; + AllocElementType := GetTypeAtIndex(i).Field[j].AllocElementType; if AllocElementType in [TDataType.FORWARDTYPE, TDataType.PROCVARTOK] then begin @@ -257,16 +258,18 @@ function RecordSize(IdentIndex: Integer; field: String = ''): Integer; end; if FieldType <> TDataType.RECORDTOK then - if (FieldType in Pointers) and (NumAllocElements > 0) then begin - if AllocElementType = RECORDTOK then begin - AllocElementType := POINTERTOK; - NumAllocElements := _TypeArray[i].Field[j].NumAllocElements shr 16; - NumAllocElements_ := 0; - end; - if NumAllocElements_ > 0 then - Inc(Result, NumAllocElements * NumAllocElements_ * GetDataSize(AllocElementType)) - else - Inc(Result, NumAllocElements * GetDataSize(AllocElementType)) + if (FieldType in Pointers) and (NumAllocElements > 0) then + begin + if AllocElementType = RECORDTOK then + begin + AllocElementType := POINTERTOK; + NumAllocElements := _TypeArray[i].Field[j].NumAllocElements shr 16; + NumAllocElements_ := 0; + end; + if NumAllocElements_ > 0 then + Inc(Result, NumAllocElements * NumAllocElements_ * GetDataSize(AllocElementType)) + else + Inc(Result, NumAllocElements * GetDataSize(AllocElementType)); end else Inc(Result, GetDataSize(FieldType)); @@ -284,16 +287,18 @@ function RecordSize(IdentIndex: Integer; field: String = ''): Integer; IdentIndex := GetIdentIndex(base); for i := 1 to GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).NumFields do - if pos(Name, base + '.' +GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].Name) > 0 then + if pos(Name, base + '.' + GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].Name) > 0 then if GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].DataType <> TDataType.RECORDTOK then begin - FieldType :=GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].DataType; - NumAllocElements :=GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].NumAllocElements and $ffff; - NumAllocElements_ :=GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].NumAllocElements shr 16; - AllocElementType :=GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].AllocElementType; - - if FieldType = TDataType.ENUMTOK then FieldType := AllocElementType; + FieldType := GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].DataType; + NumAllocElements := GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].NumAllocElements + and $ffff; + NumAllocElements_ := GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].NumAllocElements + shr 16; + AllocElementType := GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].AllocElementType; + + if FieldType = TDataType.ENUMTOK then FieldType := AllocElementType; if GetTypeAtIndex(IdentifierAt(IdentIndex).NumAllocElements).Field[i].Name = field then begin @@ -302,17 +307,20 @@ function RecordSize(IdentIndex: Integer; field: String = ''): Integer; end; if FieldType <> TDataType.RECORDTOK then - if (FieldType in Pointers) and (NumAllocElements > 0) then begin - if AllocElementType = RECORDTOK then begin - AllocElementType := POINTERTOK; - NumAllocElements := _TypeArray[i].Field[j].NumAllocElements shr 16; - NumAllocElements_ := 0; - end; + if (FieldType in Pointers) and (NumAllocElements > 0) then + begin + if AllocElementType = RECORDTOK then + begin + AllocElementType := POINTERTOK; + NumAllocElements := _TypeArray[i].Field[j].NumAllocElements shr 16; + NumAllocElements_ := 0; + end; if NumAllocElements_ > 0 then - Inc(Result, NumAllocElements * NumAllocElements_ * GetDataSize(AllocElementType)) + Inc(Result, NumAllocElements * NumAllocElements_ * GetDataSize(AllocElementType)) else - Inc(Result, NumAllocElements * GetDataSize(AllocElementType)) - end else + Inc(Result, NumAllocElements * GetDataSize(AllocElementType)); + end + else Inc(Result, GetDataSize(FieldType)); end; @@ -333,6 +341,7 @@ function RecordSize(IdentIndex: Integer; field: String = ''): Integer; procedure SaveToDataSegment(index: Integer; Value: Int64; valueDataType: TDataType); begin + // LogTrace(Format('SaveToDataSegment(index=%d, value=%d, valueDataType=%d', [index, value, valueDataType])); if (index < 0) or (index > $FFFF) then begin @@ -977,7 +986,7 @@ function CompileConstFactor(i: TTokenIndex; out ConstVal: Int64; out ConstValTyp else ConstVal := IdentifierAt(IdentIndex).Value; - // Writeln(IdentifierAt(identindex).name,',',ConstValType,',',IdentifierAt(identindex).kind) + // Writeln(IdentifierAt(identindex).name,',',ConstValType,',',IdentifierAt(identindex).kind) if ConstValType = ENUMTYPE then begin @@ -1022,8 +1031,8 @@ function CompileConstFactor(i: TTokenIndex; out ConstVal: Int64; out ConstValTyp VARIABLE: if IdentifierAt(IdentIndex).isAbsolute then begin // wyjatek gdy ABSOLUTE - if (IdentifierAt(IdentIndex).Value and $ff = 0) and - (Byte((IdentifierAt(IdentIndex).Value shr 24) and $7f) in [1..127]) or + if (IdentifierAt(IdentIndex).Value and $ff = 0) and (Byte( + (IdentifierAt(IdentIndex).Value shr 24) and $7f) in [1..127]) or ((IdentifierAt(IdentIndex).DataType in Pointers) and (IdentifierAt(IdentIndex).AllocElementType <> TDataType.UNTYPETOK) and (IdentifierAt(IdentIndex).NumAllocElements in [0..1])) then @@ -1561,8 +1570,8 @@ function CompileConstExpression(i: Integer; out ConstVal: Int64; out ConstValTyp procedure DefineIdent(const tokenIndex: TTokenIndex; Name: TIdentifierName; Kind: TTokenKind; - DataType: TDataType; NumAllocElements: TNumAllocElements; AllocElementType: TDataType; Data: Int64; - IdType: TDataType = TDataType.IDENTTOK); + DataType: TDataType; NumAllocElements: TNumAllocElements; AllocElementType: TDataType; + Data: Int64; IdType: TDataType = TDataType.IDENTTOK); var identIndex: Integer; identifier: TIdentifier; @@ -1650,7 +1659,7 @@ procedure DefineIdent(const tokenIndex: TTokenIndex; Name: TIdentifierName; Kind if not OutputDisabled then begin - IncVarDataSize(GetDataSize(DataType)); + IncVarDataSize(tokenIndex, GetDataSize(DataType)); end; identifier.NumAllocElements := NumAllocElements; // Number of array elements (0 for single variable) @@ -1663,17 +1672,17 @@ procedure DefineIdent(const tokenIndex: TTokenIndex; Name: TIdentifierName; Kind if (DataType = TDataType.POINTERTOK) and (AllocElementType in [TDataType.RECORDTOK, TDataType.OBJECTTOK]) and (NumAllocElements_ = 0) then - IncVarDataSize(GetDataSize(TDataType.POINTERTOK)) + IncVarDataSize(tokenIndex, GetDataSize(TDataType.POINTERTOK)) else if DataType in [ENUMTYPE] then - IncVarDataSize(1) + IncVarDataSize(tokenIndex, 1) else if (DataType in [TDataType.RECORDTOK, TDataType.OBJECTTOK]) and (NumAllocElements > 0) then - IncVarDataSize(0) + IncVarDataSize(tokenIndex, 0) else if (DataType in [TDataType.FILETOK, TDataType.TEXTFILETOK]) and (NumAllocElements > 0) then - IncVarDataSize(12) + IncVarDataSize(tokenIndex, 12) else begin @@ -1690,13 +1699,13 @@ procedure DefineIdent(const tokenIndex: TTokenIndex; Name: TIdentifierName; Kind end; elementCount := Integer(Elements(NumIdent)); elementSize := GetDataSize(AllocElementType); - IncVarDataSize(elementCount * elementSize); + IncVarDataSize(tokenIndex, elementCount * elementSize); end; end; - if NumAllocElements > 0 then IncVarDataSize(-GetDataSize(DataType)); + if NumAllocElements > 0 then IncVarDataSize(tokenIndex, -GetDataSize(DataType)); end; @@ -2285,7 +2294,7 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen // Add new field Inc(_TypeArray[RecType].NumFields); - x :=GetTypeAtIndex(RecType).NumFields; + x := GetTypeAtIndex(RecType).NumFields; if x >= MAXFIELDS then Error(i, TMessage.Create(TErrorCode.OutOfResources, 'Out of resources, MAXFIELDS')); @@ -2300,28 +2309,21 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen // Add new field - _TypeArray[RecType].Field[x].Name := Name; - _TypeArray[RecType].Field[x].DataType := FieldType; - _TypeArray[RecType].Field[x].Value := Data; - _TypeArray[RecType].Field[x].AllocElementType := AllocElementType; - _TypeArray[RecType].Field[x].NumAllocElements := NumAllocElements; + _TypeArray[RecType].Field[x].Name := Name; + _TypeArray[RecType].Field[x].DataType := FieldType; + _TypeArray[RecType].Field[x].Value := Data; + _TypeArray[RecType].Field[x].AllocElementType := AllocElementType; + _TypeArray[RecType].Field[x].NumAllocElements := NumAllocElements; // writeln('>> ',Name,',',FieldType,',',AllocElementType,',',NumAllocElements); - if FieldType = TDataType.ENUMTOK then FieldType := AllocElementType; - if not (FieldType in [TDataType.RECORDTOK, TDataType.OBJECTTOK]) then begin if FieldType in Pointers then begin - - if AllocElementType = TDataType.RECORDTOK then begin - AllocElementType := POINTERTOK; - NumAllocElements := NumAllocElements shr 16; - end; if (FieldType = TDataType.POINTERTOK) and (AllocElementType = TDataType.FORWARDTYPE) then Inc(_TypeArray[RecType].Size, GetDataSize(TDataType.POINTERTOK)) @@ -2340,7 +2342,7 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen else Inc(_TypeArray[RecType].Size, GetDataSize(FieldType)); - _TypeArray[RecType].Field[x].Kind := TFieldKind.UNTYPETOK; + _TypeArray[RecType].Field[x].Kind := TFieldKind.UNTYPETOK; end; @@ -2478,8 +2480,8 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen Inc(i); - _TypeArray[RecType].Field[0].Name := Name; - _TypeArray[RecType].NumFields := 0; + _TypeArray[RecType].Field[0].Name := Name; + _TypeArray[RecType].NumFields := 0; ConstVal := 0; LowerBound := 0; @@ -2552,7 +2554,7 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen FieldInListName[FieldInListIndex].Value); end; - _TypeArray[RecType].Block := BlockStack[BlockStackTop]; + _TypeArray[RecType].Block := BlockStack[BlockStackTop]; AllocElementType := DataType; @@ -2642,8 +2644,8 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen Inc(i); - _TypeArray[RecType].NumFields := 0; - _TypeArray[RecType].Field[0].Name := Name; + _TypeArray[RecType].NumFields := 0; + _TypeArray[RecType].Field[0].Name := Name; if (TokenAt(i).Kind in [TTokenKind.PROCEDURETOK, TTokenKind.FUNCTIONTOK, TTokenKind.CONSTRUCTORTOK, TTokenKind.DESTRUCTORTOK]) then @@ -2726,13 +2728,14 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen for k := 1 to GetTypeAtIndex(NumAllocElements).NumFields do begin DeclareField(FieldInListName[FieldInListIndex].Name + '.' + - GetTypeAtIndex(NumAllocElements).Field[k].Name, - GetTypeAtIndex(NumAllocElements).Field[k].DataType, - GetTypeAtIndex(NumAllocElements).Field[k].NumAllocElements, - GetTypeAtIndex(NumAllocElements).Field[k].AllocElementType + GetTypeAtIndex(NumAllocElements).Field[k].Name, + GetTypeAtIndex(NumAllocElements).Field[k].DataType, + GetTypeAtIndex(NumAllocElements).Field[k].NumAllocElements, + GetTypeAtIndex(NumAllocElements).Field[k].AllocElementType ); - _TypeArray[RecType].Field[GetTypeAtIndex(RecType).NumFields].Kind := TFieldKind.OBJECTVARIABLE; + _TypeArray[RecType].Field[GetTypeAtIndex(RecType).NumFields].Kind := + TFieldKind.OBJECTVARIABLE; // writeln('>> ',FieldInListName[FieldInListIndex].Name + '.' + Types[NumAllocElements).Field[k].Name,',', Types[NumAllocElements).Field[k].NumAllocElements); end; @@ -2790,7 +2793,7 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen CheckTok(i, TTokenKind.ENDTOK); - _TypeArray[RecType].Block := BlockStack[BlockStackTop]; + _TypeArray[RecType].Block := BlockStack[BlockStackTop]; DataType := TDataType.OBJECTTOK; NumAllocElements := RecType; // ndex to the Types array @@ -2821,9 +2824,9 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen Inc(i); - _TypeArray[RecType].Size := 0; - _TypeArray[RecType].NumFields := 0; - _TypeArray[RecType].Field[0].Name := Name; + _TypeArray[RecType].Size := 0; + _TypeArray[RecType].NumFields := 0; + _TypeArray[RecType].Field[0].Name := Name; repeat NumFieldsInList := 0; @@ -2865,10 +2868,10 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen //for FieldInListIndex := 1 to NumFieldsInList do // for k := 1 to GetTypeAtIndex(NumAllocElements).NumFields do DeclareField(FieldInListName[FieldInListIndex].Name + '.' + - GetTypeAtIndex(NumAllocElements).Field[k].Name, - GetTypeAtIndex(NumAllocElements).Field[k].DataType, - GetTypeAtIndex(NumAllocElements).Field[k].NumAllocElements, - GetTypeAtIndex(NumAllocElements).Field[k].AllocElementType); + GetTypeAtIndex(NumAllocElements).Field[k].Name, + GetTypeAtIndex(NumAllocElements).Field[k].DataType, + GetTypeAtIndex(NumAllocElements).Field[k].NumAllocElements, + GetTypeAtIndex(NumAllocElements).Field[k].AllocElementType); end; @@ -2888,7 +2891,7 @@ function CompileType(i: TTokenIndex; out DataType: TDataType; out NumAllocElemen CheckTok(i, TTokenKind.ENDTOK); - _TypeArray[RecType].Block := BlockStack[BlockStackTop]; + _TypeArray[RecType].Block := BlockStack[BlockStackTop]; DataType := TDataType.RECORDTOK; NumAllocElements := RecType; // index to the Types array diff --git a/src/mp.pas b/src/mp.pas index eb1c9c149..60d2f5e9d 100644 --- a/src/mp.pas +++ b/src/mp.pas @@ -188,9 +188,9 @@ SysUtils, {$IFDEF WINDOWS} Windows, - {$ENDIF} {$IFDEF SIMULATED_CONSOLE} + {$ENDIF} {$IFDEF SIMULATED_CONSOLE} browserconsole, - {$ENDIF} + {$ENDIF} Common, Compiler, CompilerTypes, @@ -529,14 +529,12 @@ OutFile := TFileSystem.CreateTextFile; - if ExtractFileName(outputFilePath) <> '' then + if ExtractFileName(outputFilePath) = '' then begin - OutFile.Assign(outputFilePath); - end - else - begin - OutFile.Assign(ChangeFileExt(programUnit.Name, '.a65')); + outputFilePath := ChangeFileExt(programUnit.Name, '.a65'); end; + + OutFile.Assign(outputFilePath); try OutFile.Rewrite; @@ -552,6 +550,24 @@ end; end; + {$IFDEF USETRACEFILE} + traceFile := TFileSystem.CreateTextFile; + traceFile.Assign(ChangeFileExt(outputFilePath, '.log')); + try + traceFile.Rewrite(); + except + on e: EInOutError do + begin + Console.TextColor(Console.LightRed); + WriteLn(Format('ERROR: Cannot open trace file file "%s" for writing. %s.', + [traceFile.GetAbsoluteFilePath(), e.Message])); + Console.NormVideo; + Result := THaltException.COMPILING_NOT_STARTED; + Exit(); + end; + end; + {$ENDIF} + StartTime := GetTickCount64; try @@ -567,11 +583,13 @@ end; end; -{$IFDEF USEOPTFILE} - - OptFile.Close; + {$IFDEF USETRACEFILE} + TraceFile.Close; + {$ENDIF} -{$ENDIF} + {$IFDEF USEOPTFILE} + OptFile.Close; + {$ENDIF} // Diagnostics