paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 13:19:35 +02:00
Code Issues Packages Projects Releases Wiki Activity
4285e99853
fpc/ide/fpcalc.pas
pierre 6769598ff4 * fix wrong sign change handling 
+ add 'H' to view current value as hexadecimal
2002-01-22 14:56:37 +00:00

650 lines
16 KiB
ObjectPascal
Raw Blame History

{
$Id$
This file is part of the Free Pascal Integrated Development Environment
Copyright (c) 1998 by Berczi Gabor
Calculator object for the IDE
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$I globdir.inc}
unit FPCalc;
interface
uses
Drivers,Objects,Views,Dialogs,App,
{$ifdef FVISION}
FVConsts,
{$else}
Commands,
{$endif}
WViews,
FPViews;
const
MaxDecimals = 10;
MaxDigits = 30;
type
TCalcState = (csFirst, csValid, csError);
PCalcButton = ^TCalcButton;
TCalcButton = object(TButton)
procedure HandleEvent(var Event: TEvent); virtual;
end;
PCalcDisplay = ^TCalcDisplay;
TCalcDisplay = object(TView)
Status: TCalcState;
Number: string[MaxDigits];
Sign: Char;
_Operator: Char;
Operand: extended;
Memory: extended;
DispNumber: extended;
HexShown : boolean;
constructor Init(var Bounds: TRect);
constructor Load(var S: TStream);
function CalcKey(Key: string): boolean;
procedure Clear;
procedure Draw; virtual;
function GetPalette: PPalette; virtual;
procedure HandleEvent(var Event: TEvent); virtual;
procedure Store(var S: TStream);
private
procedure GetDisplay(var R: extended);
procedure SetDisplay(R: extended;ShouldKeepZeroes : boolean);
procedure Error;
end;
PCalculator = ^TCalculator;
TCalculator = object(TCenterDialog)
CD : PCalcDisplay;
constructor Init;
procedure HandleEvent(var Event: TEvent); virtual;
procedure Show; {virtual;}
procedure Close; virtual;
constructor Load(var S: TStream);
procedure Store(var S: TStream);
end;
{$ifndef NOOBJREG}
const
RCalcButton: TStreamRec = (
ObjType: 10139;
VmtLink: Ofs(TypeOf(TCalcButton)^);
Load: @TCalcButton.Load;
Store: @TCalcButton.Store
);
RCalcDisplay: TStreamRec = (
ObjType: 10140;
VmtLink: Ofs(TypeOf(TCalcDisplay)^);
Load: @TCalcDisplay.Load;
Store: @TCalcDisplay.Store
);
RCalculator: TStreamRec = (
ObjType: 10141;
VmtLink: Ofs(TypeOf(TCalculator)^);
Load: @TCalculator.Load;
Store: @TCalculator.Store
);
{$endif}
procedure RegisterFPCalc;
implementation
uses
{$ifdef Unix}
{$ifdef VER1_0}
linux,
{$else}
unix,
{$endif}
{$endif}
{$ifdef go32v2}
dpmiexcp,
{$endif}
{$ifdef win32}
signals,
{$endif}
FPString,FPUtils,FPConst,WUtils;
const
cmCalcButton = 100;
cmPressButton = 101;
procedure TCalcButton.HandleEvent(var Event: TEvent);
var
Call : boolean;
i : Sw_Word;
begin
Call:=true;
case Event.What of
evKeyDown :
case Event.KeyCode of
kbEnter : Call:=false;
end;
evBroadcast :
case Event.Command of
cmDefault : Call:=false;
cmPressButton :
begin
if (PString(Event.InfoPtr)^=Title^) or
((PString(Event.InfoPtr)^='^') and (Title^='x^y')) then
begin
Select;
DrawState(true);
i:=GetDosTicks+2;
repeat
until GetDosTicks>i;
DrawState(false);
ClearEvent(Event);
end;
end;
end;
end;
if Call then
inherited HandleEvent(Event);
end;
constructor TCalcDisplay.Init(var Bounds: TRect);
begin
inherited Init(Bounds);
Options := Options or ofSelectable;
EventMask := evKeyDown + evBroadcast;
Clear;
HelpCtx:={hcCalculatorLine}0;
HexShown:=false;
end;
constructor TCalcDisplay.Load(var S: TStream);
begin
inherited Load(S);
S.Read(Status, SizeOf(Status) + SizeOf(Number) + SizeOf(Sign) +
SizeOf(_Operator) + SizeOf(Operand));
HexShown:=false;
end;
procedure TCalcDisplay.GetDisplay(var R: extended);
begin
{ Val(Sign + Number, R, E);}
R:=DispNumber;
end;
procedure TCalcDisplay.SetDisplay(R: extended;ShouldKeepZeroes : boolean);
var
S: string[MaxDigits];
i,KeepZeroes : byte;
begin
DispNumber:=R;
KeepZeroes:=0;
if ShouldKeepZeroes and (pos('.',Number)>0) then
for i:=length(Number) downto pos('.',Number)+1 do
if Number[i]='0' then
inc(KeepZeroes)
else
break;
Str(R: 0: MaxDecimals, S);
if Pos('.',S)<>0 then
while (length(S)>1) and (S[length(S)]='0') do Dec(S[0]);
if KeepZeroes>0 then
for i:=1 to KeepZeroes do
S:=S+'0';
if S[1] <> '-' then Sign := ' ' else
begin
Delete(S, 1, 1);
Sign := '-';
end;
if Length(S) > MaxDigits + 1 + MaxDecimals then Error
else
begin
if S[Length(S)] = '.' then Dec(S[0]);
Number := S;
end;
end;
procedure TCalcDisplay.Error;
begin
Status := csError;
Number := 'Error';
Sign := ' ';
DrawView;
end;
{$ifdef HasSignal}
var
{$ifndef go32v2}
CalcSigJmp : Jmp_Buf;
{$else : go32v2}
CalcSigJmp : dpmi_jmp_buf;
{$endif go32v2}
const
fpucw : word = $1332;
{$ifdef Unix}
Procedure CalcSigFPE(sig : longint);cdecl;
{$else}
function CalcSigFPE(sig : longint) : longint;
{$endif}
begin
{$ifdef CPUI386}
asm
fninit
fldcw fpucw
end;
{$endif}
{ ErrorBox('Error while computing math expression',nil);
was only there for debugging PM }
{$ifdef go32v2}
Dpmi_LongJmp(CalcSigJmp,1);
{$else : not go32v2}
LongJmp(CalcSigJmp,1);
{$endif go32v2}
{$ifndef Unix}
{ Just here to avoid compiler warnings PM }
CalcSigFPE:=0;
{$endif}
end;
{$endif HasSignal}
function TCalcDisplay.CalcKey(Key: string): boolean;
var
R,D: extended;
X : cardinal;
procedure CheckFirst;
begin
if Status = csFirst then
begin
Status := csValid;
SetDisplay(0,false);
end;
end;
{$ifdef HasSignal}
var
StoreSigFPE : SignalHandler;
{$endif HasSignal}
begin
CalcKey:=true;
Key := UpCaseStr(Key);
{$ifdef HasSignal}
{$ifdef CPUI386}
asm
fstcw fpucw
end;
{$endif}
{$ifdef go32v2}
if Dpmi_SetJmp(CalcSigJmp)=0 then
{$else : not go32v2}
if SetJmp(CalcSigJmp)=0 then
{$endif go32v2}
{$endif HasSignal}
begin
{$ifdef HasSignal}
StoreSigFPE:=Signal(SIGFPE,@CalcSigFPE);
{$endif HasSignal}
if (Status = csError) and (Key <> 'C') then Key := ' ';
if HexShown then
begin
GetDisplay(R);
SetDisplay(R,false);
HexShown := false;
if Key = 'H' then
Key := ' ';
end;
if Key='X^Y' then Key:='^';
if length(Key)>1 then
begin
{ if Status = csFirst then}
begin
{ Status := csValid;}
GetDisplay(R);
if Key='1/X' then begin if R=0 then Error else SetDisplay(1/R,false) end else
if Key='SQR' then begin if R<0 then Error else SetDisplay(sqrt(R),false) end else
if Key='LOG' then begin if R<=0 then Error else SetDisplay(ln(R),false) end else
if Key='X^2' then SetDisplay(R*R,false) else
if Key='M+' then Memory:=Memory+R else
if Key='M-' then Memory:=Memory-R else
if Key='M'#26 then SetDisplay(Memory,false) else
if Key='M'#27 then Memory:=R else
if Key='M'#29 then begin D:=Memory; Memory:=R; SetDisplay(D,false); end;
end;
end
else
case Key[1] of
'0'..'9':
if Length(Number)<MaxDigits then
begin
CheckFirst;
if Number = '0' then Number := '';
Number := Number + Key;
SetDisplay(StrToExtended(Number),true);
end;
'.':
begin
CheckFirst;
if Pos('.', Number) = 0 then Number := Number + '.';
end;
#8, #27:
begin
CheckFirst;
if Length(Number) = 1 then Number := '0' else Dec(Number[0]);
SetDisplay(StrToExtended(Number),true); { !!! }
end;
'H':
begin
GetDisplay(R);
X:=trunc(abs(R));
Number:=HexStr(X,8);
HexShown:=true;
end;
'_', #241:
begin
if Sign = ' ' then Sign := '-' else Sign := ' ';
GetDisplay(R);
SetDisplay(-R,true);
end;
'+', '-', '*', '/', '=', '%', #13, '^':
begin
if Status = csValid then
begin
Status := csFirst;
GetDisplay(R);
if Key = '%' then
case _Operator of
'+', '-': R := Operand * R / 100;
'*', '/': R := R / 100;
end;
case _Operator of
'^': SetDisplay(Power(Operand,R),false);
'+': SetDisplay(Operand + R,false);
'-': SetDisplay(Operand - R,false);
'*': SetDisplay(Operand * R,false);
'/': if R = 0 then Error else SetDisplay(Operand / R,false);
end;
end;
_Operator := Key[1];
GetDisplay(Operand);
end;
'C':
Clear;
else CalcKey:=false;
end;
{$ifdef HasSignal}
Signal(SIGFPE,StoreSigFPE);
{$endif HasSignal}
DrawView;
{$ifdef HasSignal}
end
else { LongJmp called }
begin
ErrorBox('Error while computing '+Key,nil);
CalcKey:=true;
{$endif HasSignal}
end;
end;
procedure TCalcDisplay.Clear;
begin
Status := csFirst;
Number := '0';
Sign := ' ';
_Operator := '=';
end;
procedure TCalcDisplay.Draw;
var
Color: Byte;
I: Integer;
B: TDrawBuffer;
begin
Color := GetColor(1);
I := Size.X - Length(Number) - 2;
MoveChar(B, ' ', Color, Size.X);
MoveChar(B[I], Sign, Color, 1);
MoveStr(B[I + 1], Number, Color);
WriteBuf(0, 0, Size.X, 1, B);
end;
function TCalcDisplay.GetPalette: PPalette;
const
P: string[1] = #19;
begin
GetPalette := @P;
end;
procedure TCalcDisplay.HandleEvent(var Event: TEvent);
var S: string[3];
begin
inherited HandleEvent(Event);
case Event.What of
evKeyDown:
if Owner<>nil then
if (Owner^.State and sfSelected)<>0 then
begin
S:=Event.CharCode;
Message(Owner,evBroadcast,cmPressButton,@S);
if CalcKey(Event.CharCode) then
ClearEvent(Event);
end;
evBroadcast:
if Event.Command = cmCalcButton then
begin
CalcKey(PButton(Event.InfoPtr)^.Title^);
ClearEvent(Event);
end;
end;
end;
procedure TCalcDisplay.Store(var S: TStream);
begin
TView.Store(S);
S.Write(Status, SizeOf(Status) + SizeOf(Number) + SizeOf(Sign) +
SizeOf(_Operator) + SizeOf(Operand));
end;
{ TCalculator }
constructor TCalculator.Init;
const
Keys: array[0..29] of string[3] =
('M+', 'x^y','C' ,#27 ,'%' ,#241 ,
'M-', 'x^2','7' ,'8' ,'9' ,'/' ,
'M'#26,'1/x','4' ,'5' ,'6' ,'*' ,
'M'#27,'sqr','1' ,'2' ,'3' ,'-' ,
'M'#29,'log','0' ,'.' ,'=' ,'+' );
var
I: Integer;
P: PView;
R: TRect;
begin
R.Assign(5, 3, 43, 18);
inherited Init(R, dialog_Calculator);
Options := Options or ofFirstClick or ofTopSelect;
HelpCtx:=hcCalcWindow;
for I := 0 to 29 do
begin
R.A.X := (I mod 6) * 5 + 2;
R.A.Y := (I div 6) * 2 + 4;
R.B.X := R.A.X + 5;
R.B.Y := R.A.Y + 2;
if (I mod 6)=0 then Inc(R.B.X,1) else
if (I mod 6)=1 then begin R.Move(1,0); Inc(R.B.X,2) end else
R.Move(3,0);
P := New(PCalcButton, Init(R, Keys[I], cmCalcButton,
bfNormal + bfBroadcast+bfGrabFocus));
P^.Options := P^.Options {and not ofSelectable};
Insert(P);
end;
R.Assign(3, 2, 35, 3);
New(CD, Init(R));
CD^.Options:=CD^.Options or ofSelectable;
Insert(CD);
end;
procedure TCalculator.HandleEvent(var Event: TEvent);
var R: extended;
{ Re: real;}
begin
if (State and sfSelected)<>0 then
case Event.What of
evCommand :
case Event.Command of
cmCalculatorPaste :
Message(@Self,evKeyDown,kbCtrlEnter,nil);
end;
evKeyDown :
case Event.KeyCode of
kbEnter :
begin
Event.KeyCode:=0;
Event.CharCode:='=';
end;
kbCtrlEnter :
begin
ClearEvent(Event);
CD^.GetDisplay(R); {Re:=R;}
Close;
CalcClipboard:=R;
Message(Application,evBroadcast,cmCalculatorPaste,nil);
end;
kbEsc :
begin
CD^.GetDisplay(R);
if R<>0 then begin
CD^.SetDisplay(0,false);
CD^.DrawView;
end
else Close;
ClearEvent(Event);
end;
end;
end;
{ lets CD try to handle this }
if Event.What=evKeyDown then
Message(CD,Event.What,Event.KeyCode,Event.InfoPtr);
inherited HandleEvent(Event);
end;
procedure TCalculator.Show;
begin
{ if GetState(sfVisible)=false then CD^.Clear;}
inherited Show;
end;
procedure TCalculator.Close;
begin
Hide;
end;
constructor TCalculator.Load(var S: TStream);
begin
inherited Load(S);
GetSubViewPtr(S,CD);
end;
procedure TCalculator.Store(var S: TStream);
begin
inherited Store(S);
PutSubViewPtr(S,CD);
end;
procedure RegisterFPCalc;
begin
{$ifndef NOOBJREG}
RegisterType(RCalcButton);
RegisterType(RCalcDisplay);
RegisterType(RCalculator);
{$endif}
end;
end.
{
$Log$
Revision 1.5 2002-01-22 14:56:37 pierre
* fix wrong sign change handling
+ add 'H' to view current value as hexadecimal
Revision 1.4 2002/01/22 13:56:04 pierre
* fix multiple FPU excpetion trapping problem for unix
Revision 1.3 2001/11/14 23:55:38 pierre
* fix bug 1680 for go32v2 and hopefully for linux
Revision 1.2 2001/08/05 02:01:47 peter
* FVISION define to compile with fvision units
Revision 1.1 2001/08/04 11:30:22 peter
* ide works now with both compiler versions
Revision 1.1.2.1 2000/11/13 16:59:08 pierre
* some function in double removed from fputils unit
Revision 1.1 2000/07/13 09:48:34 michael
+ Initial import
Revision 1.10 2000/05/02 08:42:26 pierre
* new set of Gabor changes: see fixes.txt
Revision 1.9 2000/04/18 11:42:36 pierre
lot of Gabor changes : see fixes.txt
Revision 1.8 2000/03/21 23:34:10 pierre
adapted to wcedit addition by Gabor
Revision 1.7 1999/09/13 16:24:42 peter
+ clock
* backspace unident like tp7
Revision 1.6 1999/09/07 09:20:52 pierre
* traling zero after . could not be inserted
* load/store was missing => CD not set on loading.
* log function was not implemented : ln is used,
should it rather be decimal logarithm ?
Revision 1.5 1999/06/28 19:25:35 peter
* fixes from gabor
Revision 1.4 1999/04/07 21:55:41 peter
+ object support for browser
* html help fixes
* more desktop saving things
* NODEBUG directive to exclude debugger
Revision 1.3 1999/03/01 15:41:49 peter
+ Added dummy entries for functions not yet implemented
* MenuBar didn't update itself automatically on command-set changes
* Fixed Debugging/Profiling options dialog
* TCodeEditor converts spaces to tabs at save only if efUseTabChars is
set
* efBackSpaceUnindents works correctly
+ 'Messages' window implemented
+ Added '$CAP MSG()' and '$CAP EDIT' to available tool-macros
+ Added TP message-filter support (for ex. you can call GREP thru
GREP2MSG and view the result in the messages window - just like in TP)
* A 'var' was missing from the param-list of THelpFacility.TopicSearch,
so topic search didn't work...
* In FPHELP.PAS there were still context-variables defined as word instead
of THelpCtx
* StdStatusKeys() was missing from the statusdef for help windows
+ Topic-title for index-table can be specified when adding a HTML-files
Revision 1.1 1998/12/22 14:27:54 peter
* moved
Revision 1.2 1998/12/22 10:39:39 peter
+ options are now written/read
+ find and replace routines
}
Reference in New Issue View Git Blame Copy Permalink