pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

fpspreadsheet: More calculation of rpn formulas, add TestCalcRPNFormulas cases to formulatests. Boolean results not working yet. And implementation only for BIFF8, so far.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3249 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-06-28 19:40:28 +00:00
parent 9bcb71a1fc
commit cd9e686804
7 changed files with 587 additions and 107 deletions
Download Patch File Download Diff File Expand all files Collapse all files

275
components/fpspreadsheet/fpsmath.pas
View File

@ -9,7 +9,6 @@ uses
type
TsArgumentType = (atNumber, atString, atBool, atError);
TsArgumentError = (aeOK, aeWrongType, aeDivideByZero, aeFuncNotDefined);
TsArgument = record
IsMissing: Boolean;
@ -17,7 +16,7 @@ type
atNumber : (NumberValue: Double);
atString : (StringValue: String);
atBool : (BoolValue: Boolean);
atError : (ErrorValue: TsArgumentError);
atError : (ErrorValue: TsErrorValue);
end;
PsArgument = ^TsArgument;
@ -34,20 +33,37 @@ type
procedure Delete(AIndex: Integer);
end;
procedure CheckMissingBool (var Arg: TsArgument; ABool: Boolean);
procedure CheckMissingNumber(var Arg: TsArgument; ANumber: Double);
procedure CheckMissingString(var Arg: TsArgument; AString: String);
procedure FixMissingBool (var Arg: TsArgument; ABool: Boolean);
procedure FixMissingNumber(var Arg: TsArgument; ANumber: Double);
procedure FixMissingString(var Arg: TsArgument; AString: String);
function CreateBool(AValue: Boolean): TsArgument;
function CreateNumber(AValue: Double): TsArgument;
function CreateString(AValue: String): TsArgument;
function CreateError(AError: TsErrorValue): TsArgument;
{
These are the functions called when calculating an RPN formula.
}
type
TsFormulaFunc = function(Args: TsArgumentStack): TsArgument;
function fpsAdd(Args: TsArgumentStack): TsArgument;
function fpsSub(Args: TsArgumentStack): TsArgument;
function fpsMul(Args: TsArgumentStack): TsArgument;
function fpsDiv(Args: TsArgumentStack): TsArgument;
function fpsAdd (Args: TsArgumentStack): TsArgument;
function fpsSub (Args: TsArgumentStack): TsArgument;
function fpsMul (Args: TsArgumentStack): TsArgument;
function fpsDiv (Args: TsArgumentStack): TsArgument;
function fpsPercent(Args: TsArgumentStack): TsArgument;
function fpsPower (Args: TsArgumentStack): TsArgument;
function fpsUMinus (Args: TsArgumentStack): TsArgument;
function fpsUPlus (Args: TsArgumentStack): TsArgument;
function fpsConcat (Args: TsArgumentStack): TsArgument;
function fpsEqual (Args: TsArgumentStack): TsArgument;
implementation
uses
Math;
{ TsArgumentStack }
@ -142,7 +158,7 @@ end;
@param Arg Argument to be considered
@param ABool Replacement for the missing value
}
procedure CheckMissingBool(var Arg: TsArgument; ABool: Boolean);
procedure FixMissingBool(var Arg: TsArgument; ABool: Boolean);
begin
if Arg.IsMissing then Arg.BoolValue := ABool;
end;
@ -152,7 +168,7 @@ end;
@param Arg Argument to be considered
@param ANumber Replacement for the missing value
}
procedure CheckMissingNumber(var Arg: TsArgument; ANumber: Double);
procedure FixMissingNumber(var Arg: TsArgument; ANumber: Double);
begin
if Arg.IsMissing then Arg.NumberValue := ANumber;
end;
@ -162,7 +178,7 @@ end;
@param Arg Argument to be considered
@param AString Replacement for the missing value
}
procedure CheckMissingString(var Arg: TsArgument; AString: String);
procedure FixMissingString(var Arg: TsArgument; AString: String);
begin
if Arg.IsMissing then Arg.StringValue := AString;
end;
@ -170,95 +186,254 @@ end;
{ Preparing arguments }
function GetNumberFromArgument(Arg: TsArgument; var ANumber: Double): TsArgumentError;
function GetBoolFromArgument(Arg: TsArgument; var AValue: Boolean): TsErrorValue;
begin
Result := aeOK;
case Arg.ArgumentType of
atBool : begin
AValue := Arg.BoolValue;
Result := errOK;
end;
else Result := errWrongType;
end;
end;
function GetNumberFromArgument(Arg: TsArgument; var ANumber: Double): TsErrorValue;
begin
Result := errOK;
case Arg.ArgumentType of
atNumber : ANumber := Arg.NumberValue;
atString : if not TryStrToFloat(arg.StringValue, ANumber) then Result := aeWrongType;
atString : if not TryStrToFloat(arg.StringValue, ANumber) then Result := errWrongType;
atBool : if Arg.BoolValue then ANumber := 1.0 else ANumber := 0.0;
end;
end;
function GetStringFromArgument(Arg: TsArgument; var AString: String): TsErrorValue;
begin
case Arg.ArgumentType of
atString : begin
AString := Arg.StringValue;
Result := errOK;
end;
else Result := errWrongType;
end;
end;
function CreateBool(AValue: Boolean): TsArgument;
begin
Result.ArgumentType := atBool;
Result.Boolvalue := AValue;
end;
function CreateNumber(AValue: Double): TsArgument;
begin
Result.ArgumentType := atNumber;
Result.NumberValue := AValue;
end;
function CreateString(AValue: String): TsArgument;
begin
Result.ArgumentType := atString;
Result.StringValue := AValue;
end;
function CreateError(AError: TsArgumentError): TsArgument;
function CreateError(AError: TsErrorValue): TsArgument;
begin
Result.ArgumentType := atError;
Result.ErrorValue := AError;
end;
function Pop_1Bool(Args: TsArgumentStack; out a: Boolean): TsErrorValue;
begin
Result := GetBoolFromArgument(Args.Pop, a);
end;
function Pop_1Float(Args: TsArgumentStack; out a: Double): TsErrorValue;
begin
Result := GetNumberFromArgument(Args.Pop, a);
end;
function Pop_1String(Args: TsArgumentStack; out a: String): TsErrorvalue;
begin
Result := GetStringFromArgument(Args.Pop, a);
end;
function Pop_2Bools(Args: TsArgumentStack; out a, b: Boolean): TsErrorValue;
var
erra, errb: TsErrorValue;
begin
// Pop the data in reverse order they were pushed! Otherwise they will be
// applied to the function in the wrong order.
errb := GetBoolFromArgument(Args.Pop, b);
erra := GetBoolFromArgument(Args.Pop, a);
if erra <> errOK then
Result := erra
else if errb <> errOK then
Result := errb
else
Result := errOK;
end;
function Pop_2Floats(Args: TsArgumentStack; out a, b: Double): TsErrorValue;
var
erra, errb: TsErrorValue;
begin
// Pop the data in reverse order they were pushed! Otherwise they will be
// applied to the function in the wrong order.
errb := GetNumberFromArgument(Args.Pop, b);
erra := GetNumberFromArgument(Args.Pop, a);
if erra <> errOK then
Result := erra
else if errb <> errOK then
Result := errb
else
Result := errOK;
end;
function Pop_2Strings(Args: TsArgumentStack; out a, b: String): TsErrorValue;
var
erra, errb: TsErrorValue;
begin
// Pop the data in reverse order they were pushed! Otherwise they will be
// applied to the function in the wrong order.
errb := GetStringFromArgument(Args.Pop, b);
erra := GetStringFromArgument(Args.Pop, a);
if erra <> errOK then
Result := erra
else if errb <> errOK then
Result := errb
else
Result := errOK;
end;
{ Operations }
function fpsAdd(Args: TsArgumentStack): TsArgument;
var
a, b: Double;
erra, errb: TsArgumentError;
err: TsErrorValue;
begin
errb := GetNumberFromArgument(Args.Pop, b);
erra := GetNumberFromArgument(Args.Pop, a);
if erra <> aeOK then
Result := CreateError(erra)
else if errb <> aeOK then
Result := CreateError(errb)
err := Pop_2Floats(Args, a, b);
if err = errOK then
Result := CreateNumber(a + b)
else
Result := CreateNumber(a + b);
Result := CreateError(err);
end;
function fpsSub(Args: TsArgumentStack): TsArgument;
var
a, b: Double;
erra, errb: TsArgumentError;
err: TsErrorValue;
begin
// Pop the data in reverse order they were pushed!
errb := GetNumberFromArgument(Args.Pop, b);
erra := GetNumberFromArgument(Args.Pop, a);
if erra <> aeOK then
Result := CreateError(erra)
else if errb <> aeOK then
Result := CreateError(errb)
err := Pop_2Floats(Args, a, b);
if err = errOK then
Result := CreateNumber(a - b)
else
Result := CreateNumber(a - b);
Result := CreateError(err);
end;
function fpsMul(Args: TsArgumentStack): TsArgument;
var
a, b: Double;
erra, errb: TsArgumentError;
err: TsErrorValue;
begin
errb := GetNumberFromArgument(Args.Pop, b);
erra := GetNumberFromArgument(Args.Pop, a);
if erra <> aeOK then
Result := CreateError(erra)
else if errb <> aeOK then
Result := CreateError(errb)
err := Pop_2Floats(Args, a, b);
if err = errOK then
Result := CreateNumber(a * b)
else
Result := CreateNumber(a * b);
Result := CreateError(err);
end;
function fpsDiv(Args: TsArgumentStack): TsArgument;
var
a, b: Double;
erra, errb: TsArgumentError;
err: TsErrorValue;
begin
// Pop the data in reverse order they were pushed!
errb := GetNumberFromArgument(Args.Pop, b);
erra := GetNumberFromArgument(Args.Pop, a);
if erra <> aeOK then
Result := CreateError(erra)
else if errb <> aeOK then
Result := CreateError(errb)
err := Pop_2Floats(Args, a, b);
if err <> errOK then
Result := CreateError(err)
else if b = 0 then
Result := CreateError(aeDivideByZero)
Result := CreateError(errDivideByZero)
else
Result := CreateNumber(a / b);
end;
function fpsPercent(Args: TsArgumentStack): TsArgument;
var
a: Double;
err: TsErrorValue;
begin
err := Pop_1Float(Args, a);
if err = errOK then
Result := CreateNumber(a * 0.01)
else
Result := CreateError(err);
end;
function fpsPower(Args: TsArgumentStack): TsArgument;
var
a, b: Double;
err: TsErrorValue;
begin
err := Pop_2Floats(Args, a, b);
if err = errOK then begin
try
Result := CreateNumber(power(a, b));
except on E: EInvalidArgument do
Result := CreateError(errOverflow);
// this could happen, e.g., for "power( (neg value), (non-integer) )"
end;
end else
Result := CreateError(err);
end;
function fpsUMinus(Args: TsArgumentStack): TsArgument;
var
a: Double;
err: TsErrorValue;
begin
err := Pop_1Float(Args, a);
if err = errOK then
Result := CreateNumber(-a)
else
Result := CreateError(err);
end;
function fpsUPlus(Args: TsArgumentStack): TsArgument;
var
a: Double;
err: TsErrorValue;
begin
err := Pop_1Float(Args, a);
if err = errOK then
Result := CreateNumber(a)
else
Result := CreateError(err);
end;
function fpsConcat(Args: TsArgumentStack): TsArgument;
var
a, b: String;
err: TsErrorValue;
begin
err := Pop_2Strings(Args, a, b);
if err = errOK then
Result := CreateString(a + b)
else
Result := CreateError(err);
end;
function fpsEqual(Args: TsArgumentStack): TsArgument;
var
a, b: Boolean;
err: TsErrorValue;
begin
err := Pop_2Bools(Args, a, b);
if err = errOK then
Result := CreateBool(a = b)
else
Result := CreateError(err);
end;
end.

90
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -1093,32 +1093,32 @@ type
const
FEProps: array[TFEKind] of TFEProp = (
{ Operands }
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCell
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellRef
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellRange
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellNum
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellInteger
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellString
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellBool
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellErr
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellMissingArg
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCell
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellRef
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellRange
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellNum
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellInteger
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellString
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellBool
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellErr
(Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCellMissingArg
{ Basic operations }
(Symbol:'+'; MinParams:2; MaxParams:2; Func:fpsAdd), // fekAdd
(Symbol:'-'; MinParams:2; MaxParams:2; Func:fpsSub), // fekSub
(Symbol:'*'; MinParams:2; MaxParams:2; Func:fpsMul), // fekMul
(Symbol:'/'; MinParams:2; MaxParams:2; Func:fpsDiv), // fekDiv
(Symbol:'%'; MinParams:1; MaxParams:1; Func:nil), // fekPercent
(Symbol:'^'; MinParams:2; MaxParams:2; Func:nil), // fekPower
(Symbol:'-'; MinParams:1; MaxParams:1; Func:nil), // fekUMinus
(Symbol:'+'; MinParams:1; MaxParams:1; Func:nil), // fekUPlus
(Symbol:'&'; MinParams:2; MaxParams:2; Func:nil), // fekConcat (string concatenation)
(Symbol:'='; MinParams:2; MaxParams:2; Func:nil), // fekEqual
(Symbol:'>'; MinParams:2; MaxParams:2; Func:nil), // fekGreater
(Symbol:'>='; MinParams:2; MaxParams:2; Func:nil), // fekGreaterEqual
(Symbol:'<'; MinParams:2; MaxParams:2; Func:nil), // fekLess
(Symbol:'<='; MinParams:2; MaxParams:2; Func:nil), // fekLessEqual
(Symbol:'<>'; MinParams:2; MaxParams:2; Func:nil), // fekNotEqual
(Symbol:''; MinParams:1; MaxParams:1; Func:nil), // fekParen
(Symbol:'+'; MinParams:2; MaxParams:2; Func:fpsAdd), // fekAdd
(Symbol:'-'; MinParams:2; MaxParams:2; Func:fpsSub), // fekSub
(Symbol:'*'; MinParams:2; MaxParams:2; Func:fpsMul), // fekMul
(Symbol:'/'; MinParams:2; MaxParams:2; Func:fpsDiv), // fekDiv
(Symbol:'%'; MinParams:1; MaxParams:1; Func:fpsPercent), // fekPercent
(Symbol:'^'; MinParams:2; MaxParams:2; Func:fpsPower), // fekPower
(Symbol:'-'; MinParams:1; MaxParams:1; Func:fpsUMinus), // fekUMinus
(Symbol:'+'; MinParams:1; MaxParams:1; Func:fpsUPlus), // fekUPlus
(Symbol:'&'; MinParams:2; MaxParams:2; Func:fpsConcat), // fekConcat (string concatenation)
(Symbol:'='; MinParams:2; MaxParams:2; Func:nil), // fekEqual
(Symbol:'>'; MinParams:2; MaxParams:2; Func:nil), // fekGreater
(Symbol:'>='; MinParams:2; MaxParams:2; Func:nil), // fekGreaterEqual
(Symbol:'<'; MinParams:2; MaxParams:2; Func:nil), // fekLess
(Symbol:'<='; MinParams:2; MaxParams:2; Func:nil), // fekLessEqual
(Symbol:'<>'; MinParams:2; MaxParams:2; Func:nil), // fekNotEqual
(Symbol:''; MinParams:1; MaxParams:1; Func:nil), // fekParen
{ math }
(Symbol:'ABS'; MinParams:1; MaxParams:1; Func:nil), // fekABS
(Symbol:'ACOS'; MinParams:1; MaxParams:1; Func:nil), // fekACOS
@ -1458,15 +1458,11 @@ begin
if not Assigned(func) then begin
// calculation of function not implemented
exit;
end; {
if args.Count < FEProps[fe.ElementKind].MinParams then begin
end;
if args.Count < fe.ParamsNum then begin
// not enough parameters
exit;
end;
if args.Count > FEProps[fe.ElementKind].MaxParams then begin
// too many parameters
exit;
end; }
// Result of function
val := func(args);
// Push valid result on stack, exit in case of error
@ -1474,7 +1470,10 @@ begin
atNumber, atString, atBool:
args.Push(val);
atError:
exit;
begin
WriteErrorValue(ACell, val.ErrorValue);
exit;
end;
end;
end; // case
end; // for
@ -1485,8 +1484,18 @@ begin
atBool : WriteNumber(ACell, 1.0*ord(val.BoolValue));
atString: WriteUTF8Text(ACell, val.StringValue);
end;
{
case val.ArgumentType of
atNumber: ACell^.NumberValue := val.NumberValue; //WriteNumber(ACell, val.NumberValue);
atBool : ACell^.NumberValue := 1.0 * ord(val.BoolValue); //WriteNumber(ACell, 1.0*ord(val.BoolValue));
atString: ACell^.UTF8StringValue := val.StringValue; //(ACell, val.StringValue);
end;
}
end else
WriteErrorValue(ACell, errArgError);
// This case is a program error --> raise an exception
raise Exception.CreateFmt('Incorrect argument count of the formula in cell %s', [
GetCellString(ACell^.Row, ACell^.Col, [])
]);
finally
args.Free;
end;
@ -5118,13 +5127,16 @@ end;
}
procedure TsCustomSpreadWriter.WriteCellCallback(ACell: PCell; AStream: TStream);
begin
if Length(ACell^.RPNFormulaValue) > 0 then
WriteRPNFormula(AStream, ACell^.Row, ACell^.Col, ACell^.RPNFormulaValue, ACell)
else
case ACell.ContentType of
cctEmpty: WriteBlank(AStream, ACell^.Row, ACell^.Col, ACell);
cctDateTime: WriteDateTime(AStream, ACell^.Row, ACell^.Col, ACell^.DateTimeValue, ACell);
cctNumber: WriteNumber(AStream, ACell^.Row, ACell^.Col, ACell^.NumberValue, ACell);
cctUTF8String: WriteLabel(AStream, ACell^.Row, ACell^.Col, ACell^.UTF8StringValue, ACell);
cctFormula: WriteFormula(AStream, ACell^.Row, ACell^.Col, ACell^.FormulaValue, ACell);
cctRPNFormula: WriteRPNFormula(AStream, ACell^.Row, ACell^.Col, ACell^.RPNFormulaValue, ACell);
cctEmpty : WriteBlank(AStream, ACell^.Row, ACell^.Col, ACell);
cctDateTime : WriteDateTime(AStream, ACell^.Row, ACell^.Col, ACell^.DateTimeValue, ACell);
cctNumber : WriteNumber(AStream, ACell^.Row, ACell^.Col, ACell^.NumberValue, ACell);
cctUTF8String : WriteLabel(AStream, ACell^.Row, ACell^.Col, ACell^.UTF8StringValue, ACell);
cctFormula : WriteFormula(AStream, ACell^.Row, ACell^.Col, ACell^.FormulaValue, ACell);
// cctRPNFormula: WriteRPNFormula(AStream, ACell^.Row, ACell^.Col, ACell^.RPNFormulaValue, ACell);
end;
end;

106
components/fpspreadsheet/tests/formulatests.pas
View File

@ -2,13 +2,19 @@ unit formulatests;
{$mode objfpc}{$H+}
{ Deactivate this define in order to bypass tests which will raise an exception
when the corresponding rpn formula is calculated. }
{.$DEFINE ENABLE_CALC_RPN_EXCEPTIONS}
interface
uses
// Not using Lazarus package as the user may be working with multiple versions
// Instead, add .. to unit search path
Classes, SysUtils, fpcunit, testutils, testregistry,
fpsallformats, fpspreadsheet, xlsbiff8 {and a project requirement for lclbase for utf8 handling},
fpsallformats, fpspreadsheet, fpsmath,
xlsbiff8 {and a project requirement for lclbase for utf8 handling},
testsutility;
type
@ -22,6 +28,8 @@ type
procedure TearDown; override;
// Test formula strings
procedure TestWriteReadFormulaStrings(AFormat: TsSpreadsheetFormat);
// Test calculation of rpn formulas
procedure TestCalcRPNFormulas(AFormat: TsSpreadsheetformat);
published
// Writes out numbers & reads back.
@ -32,12 +40,16 @@ type
procedure TestWriteRead_BIFF5_FormulaStrings;
{ BIFF8 Tests }
procedure TestWriteRead_BIFF8_FormulaStrings;
// Writes out and calculates formulas, read back
{ BIFF8 Tests }
procedure TestWriteRead_BIFF8_CalcRPNFormula;
end;
implementation
uses
fpsUtils, rpnFormulaUnit;
math, typinfo, fpsUtils, rpnFormulaUnit;
{ TSpreadWriteReadFormatTests }
@ -115,6 +127,96 @@ begin
TestWriteReadFormulaStrings(sfExcel8);
end;
{ Test calculation of rpn formulas }
procedure TSpreadWriteReadFormulaTests.TestCalcRPNFormulas(AFormat: TsSpreadsheetFormat);
const
SHEET = 'Sheet1';
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
Row: Integer;
TempFile: string; //write xls/xml to this file and read back from it
actual: TsArgument;
expected: TsArgument;
cell: PCell;
sollValues: array of TsArgument;
a, b: Double;
begin
TempFile := GetTempFileName;
// Create test workbook
MyWorkbook := TsWorkbook.Create;
MyWorkSheet:= MyWorkBook.AddWorksheet(SHEET);
MyWorkSheet.Options := MyWorkSheet.Options + [soCalcBeforeSaving];
// Calculation of rpn formulas must be activated expicitely!
{ Write out test formulas.
This include file creates various rpn formulas and stores the expected
results in array "sollValues".
The test file contains the text representation in column A, and the
formula in column B. }
Row := 0;
{$I testcases_calcrpnformula.inc}
MyWorkBook.WriteToFile(TempFile, AFormat, true);
MyWorkbook.Free;
// Open the workbook
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(TempFile, AFormat);
if AFormat = sfExcel2 then
MyWorksheet := MyWorkbook.GetFirstWorksheet
else
MyWorksheet := GetWorksheetByName(MyWorkBook, SHEET);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
for Row := 0 to MyWorksheet.GetLastRowIndex do begin
cell := MyWorksheet.FindCell(Row, 1);
if (cell = nil) then
fail('Error in test code: Failed to get cell ' + CellNotation(MyWorksheet, Row, 1));
case cell^.ContentType of
cctBool : actual := CreateBool(cell^.NumberValue <> 0);
cctNumber : actual := CreateNumber(cell^.NumberValue);
cctError : actual := CreateError(cell^.ErrorValue);
cctUTF8String : actual := CreateString(cell^.UTF8StringValue);
else fail('ContentType not supported');
end;
expected := SollValues[row];
CheckEquals(ord(expected.ArgumentType), ord(actual.ArgumentType),
'Test read calculated formula data type mismatch, cell '+CellNotation(MyWorkSheet,Row,1));
case actual.ArgumentType of
atBool:
CheckEquals(BoolToStr(expected.BoolValue), BoolToStr(actual.BoolValue),
'Test read calculated formula result mismatch, cell '+CellNotation(MyWorkSheet,Row,1));
atNumber:
CheckEquals(expected.NumberValue, actual.NumberValue,
'Test read calculated formula result mismatch, cell '+CellNotation(MyWorkSheet,Row,1));
atString:
CheckEquals(expected.StringValue, actual.StringValue,
'Test read calculated formula result mismatch, cell '+CellNotation(MyWorkSheet,Row,1));
atError:
CheckEquals(
GetEnumName(TypeInfo(TsErrorValue), ord(expected.ErrorValue)),
GetEnumname(TypeInfo(TsErrorValue), ord(actual.ErrorValue)),
'Test read calculated formula error value mismatch, cell '+CellNotation(MyWorkSheet,Row,1));
end;
end;
// Finalization
MyWorkbook.Free;
DeleteFile(TempFile);
end;
procedure TSpreadWriteReadFormulaTests.TestWriteRead_BIFF8_CalcRPNFormula;
begin
TestCalcRPNFormulas(sfExcel8);
end;
initialization
// Register so these tests are included in a full run
RegisterTest(TSpreadWriteReadFormulaTests);

15
components/fpspreadsheet/tests/spreadtestgui.lpi
View File

@ -47,9 +47,6 @@
<UseExternalDbgSyms Value="True"/>
</Debugging>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</Item2>
</BuildModes>
@ -88,7 +85,6 @@
<Unit2>
<Filename Value="stringtests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="stringtests"/>
</Unit2>
<Unit3>
<Filename Value="numberstests.pas"/>
@ -98,42 +94,34 @@
<Unit4>
<Filename Value="manualtests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="manualtests"/>
</Unit4>
<Unit5>
<Filename Value="testsutility.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testsutility"/>
</Unit5>
<Unit6>
<Filename Value="internaltests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="internaltests"/>
</Unit6>
<Unit7>
<Filename Value="formattests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="formattests"/>
</Unit7>
<Unit8>
<Filename Value="colortests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="colortests"/>
</Unit8>
<Unit9>
<Filename Value="fonttests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fonttests"/>
</Unit9>
<Unit10>
<Filename Value="optiontests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="optiontests"/>
</Unit10>
<Unit11>
<Filename Value="numformatparsertests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="numformatparsertests"/>
</Unit11>
<Unit12>
<Filename Value="rpnformulaunit.pas"/>
@ -168,9 +156,6 @@
<OptimizationLevel Value="0"/>
</Optimizations>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="6">

147
components/fpspreadsheet/tests/testcases_calcrpnformula.inc Normal file
View File

@ -0,0 +1,147 @@
{ include file for "formulatests.pas", containing the test cases for the
calcrpnformula test. }
// Addition
Row := 0;
MyWorksheet.WriteUTF8Text(Row, 0, '=1+1');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(1.0,
RPNNumber(1.0,
RPNFunc(fekAdd, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(1.0+1.0);
// Subtraction
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=1-10');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(1,
RPNNumber(10,
RPNFunc(fekSub, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(1-10);
// Multiplication
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=10*-3');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(10,
RPNNumber(-3,
RPNFunc(fekMul, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(10*(-3));
// Multiplication w/Parenthesis
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=10*(-3)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(10,
RPNNumber(-3,
RPNParenthesis(
RPNFunc(fekMul, nil))))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(10*(-3));
// Division
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=10/200');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(10,
RPNNumber(200,
RPNFunc(fekDiv, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(10/200);
// Division: Error case - divide by zero
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=10/0');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(10,
RPNNumber(0,
RPNFunc(fekDiv, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateError(errDivideByZero);
// Percentage
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=10%');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(10,
RPNFunc(fekPercent, nil))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(10*0.01);
// Power
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=power(2.0, 0.5)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(2.0,
RPNNumber(0.5,
RPNFunc(fekPower, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(power(2, 0.5));
{$IFDEF ENABLE_CALC_RPN_EXCEPTIONS}
// Power: Error case "power( (negative number), (fractional number) )"
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=power(-2.0, 0.5)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(-2.0,
RPNNumber(0.5,
RPNFunc(fekPower, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateError(errOverflow);
{$ENDIF}
// Unary minus
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=-(-1)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(-1,
RPNParenthesis(
RPNFunc(fekUMinus, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(1);
// Unary plus
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=+(-1)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(-1,
RPNParenthesis(
RPNFunc(fekUPlus, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(-1);
// String concatenation
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '="Hallo"&" world"');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNString('Hallo',
RPNString(' world',
RPNFunc(fekConcat, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateString('Hallo' + ' world');
(*
// Equal (strings)
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=("Hallo"="world")');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNString('Hallo',
RPNString('world',
RPNParenthesis(
RPNFunc(fekConcat, nil))))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateBool('Hallo' = 'world');
// Equal (numbers)
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=(1=1)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(1.0,
RPNNumber(1.0,
RPNParenthesis(
RPNFunc(fekEqual, nil))))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateBool(1=1);
*)

59
components/fpspreadsheet/xlsbiff8.pas
View File

@ -125,6 +125,7 @@ type
const AValue: string; ACell: PCell); override;
procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Cardinal;
const AFormula: TsRPNFormula; ACell: PCell); override;
procedure WriteStringRecord(AStream: TStream; AString: string);
procedure WriteStyle(AStream: TStream);
procedure WriteWindow2(AStream: TStream; ASheet: TsWorksheet);
procedure WriteXF(AStream: TStream; AFontIndex: Word;
@ -798,6 +799,7 @@ procedure TsSpreadBIFF8Writer.WriteRPNFormula(AStream: TStream; const ARow,
ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell);
var
FormulaResult: double;
FormulaResultWords: array[0..3] of word absolute FormulaResult;
i: Integer;
len: Integer;
RPNLength: Word;
@ -809,6 +811,38 @@ var
begin
RPNLength := 0;
FormulaResult := 0.0;
case ACell^.ContentType of
cctNumber:
FormulaResult := ACell^.NumberValue;
cctDateTime:
FormulaResult := ACell^.DateTimeValue;
cctUTF8String:
begin
if ACell^.UTF8StringValue = '' then
FormulaResultWords[0] := 3;
FormulaResultWords[3] := $FFFF;
end;
cctBool:
begin
FormulaResultWords[0] := 1;
FormulaResultWords[1] := word(ACell^.NumberValue <> 0);
FormulaResultWords[3] := $FFFF;
end;
cctError:
begin
FormulaResultWords[0] := 2;
case ACell^.ErrorValue of
errEmptyIntersection: FormulaResultWords[1] := ERR_INTERSECTION_EMPTY;// #NULL!
errDivideByZero : FormulaResultWords[1] := ERR_DIVIDE_BY_ZERO; // #DIV/0!
errWrongType : FormulaResultWords[1] := ERR_WRONG_TYPE_OF_OPERAND; // #VALUE!
errIllegalRef : FormulaResultWords[1] := ERR_ILLEGAL_REFERENCE; // #REF!
errWrongName : FormulaResultWords[1] := ERR_WRONG_NAME; // #NAME?
errOverflow : FormulaResultWords[1] := ERR_OVERFLOW; // #NUM!
errArgError : FormulaResultWords[1] := ERR_ARG_ERROR; // #N/A;
end;
FormulaResultWords[3] := $FFFF;
end;
end;
{ BIFF Record header }
AStream.WriteWord(WordToLE(INT_EXCEL_ID_FORMULA));
@ -950,6 +984,31 @@ begin
AStream.Position := RecordSizePos;
AStream.WriteWord(WordToLE(22 + RPNLength));
AStream.position := FinalPos;
{ Write following STRING record if formula result is a non-empty string }
if (ACell^.ContentType = cctUTF8String) and (ACell^.UTF8StringValue <> '') then
WriteStringRecord(AStream, ACell^.UTF8StringValue);
end;
procedure TsSpreadBIFF8Writer.WriteStringRecord(AStream: TStream;
AString: String);
var
wideStr: widestring;
len: Integer;
begin
wideStr := AString;
len := Length(wideStr);
{ BIFF Record header }
AStream.WriteWord(WordToLE(INT_EXCEL_ID_STRING));
AStream.WriteWord(WordToLE(3 + len*SizeOf(widechar)));
{ Write widestring length }
AStream.WriteWord(WordToLE(len));
{ Widestring flags, 1=regular unicode LE string }
AStream.WriteByte(1);
{ Write characters }
AStream.WriteBuffer(WideStringToLE(wideStr)[1], len * SizeOf(WideChar));
end;
{*******************************************************************

2
components/fpspreadsheet/xlscommon.pas
View File

@ -37,7 +37,7 @@ const
INT_EXCEL_ID_BLANK = $0201; // BIFF2: $0001
INT_EXCEL_ID_NUMBER = $0203; // BIFF2: $0003
INT_EXCEL_ID_LABEL = $0204; // BIFF2: $0004
INT_EXCEL_ID_STRING = $0207; // BIFF2: $0007;
INT_EXCEL_ID_STRING = $0207; // BIFF2: $0007
INT_EXCEL_ID_ROW = $0208; // BIFF2: $0008
INT_EXCEL_ID_INDEX = $020B; // BIFF2: $000B
INT_EXCEL_ID_WINDOW2 = $023E; // BIFF2: $003E