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

jvcllaz: Add TJvInterpreter units in JvPascalInterpreter package, including two demos.

Browse Source 
Change MIME type of all package files to text/xml.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7246 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2020-01-07 13:08:59 +00:00
parent e138543a0b
commit bfc363b3a4
24 changed files with 11662 additions and 220 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
components/jvcllaz/design/JvPascalInterpreter/images/images.txt Normal file
View File

@ -0,0 +1,2 @@
tjvinterpreterprogram.bmp
tjvinterpreterfm.bmp

1
components/jvcllaz/design/JvPascalInterpreter/images/make_res.bat Normal file
View File

@ -0,0 +1 @@
lazres ../../../resource/jvpascalinterpreterreg.res @images.txt

BIN
components/jvcllaz/design/JvPascalInterpreter/images/tjvinterpreterfm.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
components/jvcllaz/design/JvPascalInterpreter/images/tjvinterpreterprogram.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

25
components/jvcllaz/design/JvPascalInterpreter/jvpascalinterpreterreg.pas Normal file
View File

@ -0,0 +1,25 @@
unit JvPascalInterpreterReg;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
procedure Register;
implementation
{$R ..\..\resource\jvpascalinterpreterreg.res}
uses
JvDsgnConsts, JvInterpreter;
procedure Register;
begin
RegisterComponents(RsPaletteJvclVisual, [TJvInterpreterProgram]); //, TJvInterpreterFm]);
end;
end.

83
components/jvcllaz/examples/JvInterpreterDemos/JvInterpreterCallFunction/JvInterpreterCallFunction.lpi Normal file
View File

@ -0,0 +1,83 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<Title Value="JvInterpreterCallFunction"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes>
<Item Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<RequiredPackages>
<Item>
<PackageName Value="SynEdit"/>
</Item>
<Item>
<PackageName Value="JvPascalInterpreterR"/>
</Item>
<Item>
<PackageName Value="LCL"/>
</Item>
</RequiredPackages>
<Units>
<Unit>
<Filename Value="JvInterpreterCallFunction.lpr"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="JvInterpreterCallFunctionFm.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="..\..\..\bin\$(TargetCPU)-$(TargetOS)\JvInterpreterCallFunction"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions>
<Item>
<Name Value="EAbort"/>
</Item>
<Item>
<Name Value="ECodetoolError"/>
</Item>
<Item>
<Name Value="EFOpenError"/>
</Item>
</Exceptions>
</Debugging>
</CONFIG>

14
components/jvcllaz/examples/JvInterpreterDemos/JvInterpreterCallFunction/JvInterpreterCallFunction.lpr Normal file
View File

@ -0,0 +1,14 @@
program JvInterpreterCallFunction;
uses
Interfaces, Forms,
JvInterpreterCallFunctionFm in 'JvInterpreterCallFunctionFm.pas' {Form1};
{$R *.res}
begin
Application.Scaled:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

192
components/jvcllaz/examples/JvInterpreterDemos/JvInterpreterCallFunction/JvInterpreterCallFunctionFm.lfm Normal file
View File

@ -0,0 +1,192 @@
object Form1: TForm1
Left = 450
Height = 690
Top = 165
Width = 965
Caption = 'Form1'
ClientHeight = 690
ClientWidth = 965
Color = clBtnFace
Font.Color = clWindowText
OnShow = FormShow
LCLVersion = '2.1.0.0'
object Label1: TLabel
AnchorSideLeft.Control = Button2
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Edit1
AnchorSideTop.Side = asrCenter
Left = 456
Height = 15
Top = 13
Width = 35
BorderSpacing.Left = 200
Caption = 'Result:'
ParentColor = False
end
inline JvHLEditor1: TSynEdit
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Button2
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = Owner
AnchorSideBottom.Side = asrBottom
Left = 12
Height = 637
Top = 41
Width = 941
BorderSpacing.Left = 12
BorderSpacing.Top = 8
BorderSpacing.Right = 12
BorderSpacing.Bottom = 12
Anchors = [akTop, akLeft, akRight, akBottom]
Font.Height = -13
Font.Name = 'Courier New'
Font.Pitch = fpFixed
Font.Quality = fqCleartype
ParentColor = False
ParentFont = False
TabOrder = 0
Gutter.Width = 57
Gutter.MouseActions = <>
RightGutter.Width = 0
RightGutter.MouseActions = <>
Highlighter = SynPasSyn1
Keystrokes = <>
MouseActions = <>
MouseTextActions = <>
MouseSelActions = <>
Lines.Strings = (
'unit UserFunctions;'
''
'// sample of a user-created-library of jvinterpreter functions that your compiled'
'// program might access:'
''
''
'// notice that there is no interface/implementation section in this '
'// interpreter-only unit.'
''
'function MyFunction(B:String):Integer;'
'begin'
' result := Length(B);'
'end;'
''
'function MyFunction2(A,B:Integer):Integer;'
'begin'
' result := A+B;'
'end;'
''
''
'end.'
)
VisibleSpecialChars = [vscSpace, vscTabAtLast]
SelectedColor.BackPriority = 50
SelectedColor.ForePriority = 50
SelectedColor.FramePriority = 50
SelectedColor.BoldPriority = 50
SelectedColor.ItalicPriority = 50
SelectedColor.UnderlinePriority = 50
SelectedColor.StrikeOutPriority = 50
BracketHighlightStyle = sbhsBoth
BracketMatchColor.Background = clNone
BracketMatchColor.Foreground = clNone
BracketMatchColor.Style = [fsBold]
FoldedCodeColor.Background = clNone
FoldedCodeColor.Foreground = clGray
FoldedCodeColor.FrameColor = clGray
MouseLinkColor.Background = clNone
MouseLinkColor.Foreground = clBlue
LineHighlightColor.Background = clNone
LineHighlightColor.Foreground = clNone
inline SynLeftGutterPartList1: TSynGutterPartList
object SynGutterMarks1: TSynGutterMarks
Width = 24
MouseActions = <>
end
object SynGutterLineNumber1: TSynGutterLineNumber
Width = 17
MouseActions = <>
MarkupInfo.Background = clBtnFace
MarkupInfo.Foreground = clNone
DigitCount = 2
ShowOnlyLineNumbersMultiplesOf = 1
ZeroStart = False
LeadingZeros = False
end
object SynGutterChanges1: TSynGutterChanges
Width = 4
MouseActions = <>
ModifiedColor = 59900
SavedColor = clGreen
end
object SynGutterSeparator1: TSynGutterSeparator
Width = 2
MouseActions = <>
MarkupInfo.Background = clWhite
MarkupInfo.Foreground = clGray
end
object SynGutterCodeFolding1: TSynGutterCodeFolding
MouseActions = <>
MarkupInfo.Background = clNone
MarkupInfo.Foreground = clGray
MouseActionsExpanded = <>
MouseActionsCollapsed = <>
end
end
end
object Button1: TButton
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Owner
Left = 12
Height = 25
Top = 8
Width = 113
AutoSize = True
BorderSpacing.Left = 12
BorderSpacing.Top = 8
Caption = 'Call MyFunction'
OnClick = Button1Click
TabOrder = 1
end
object Button2: TButton
AnchorSideLeft.Control = Button1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Button1
Left = 137
Height = 25
Top = 8
Width = 119
AutoSize = True
BorderSpacing.Left = 12
Caption = 'Call MyFunction2'
OnClick = Button2Click
TabOrder = 2
end
object Edit1: TEdit
AnchorSideLeft.Control = Label1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Button1
AnchorSideTop.Side = asrCenter
Left = 503
Height = 23
Top = 9
Width = 121
BorderSpacing.Left = 12
ReadOnly = True
TabOrder = 3
end
object JvInterpreterProgram1: TJvInterpreterProgram
OnGetValue = JvInterpreterProgram1GetValue
left = 328
top = 96
end
object SynPasSyn1: TSynPasSyn
Enabled = False
CommentAttri.Foreground = clTeal
CompilerMode = pcmDelphi
NestedComments = False
TypeHelpers = True
left = 325
top = 272
end
end

103
components/jvcllaz/examples/JvInterpreterDemos/JvInterpreterCallFunction/JvInterpreterCallFunctionFm.pas Normal file
View File

@ -0,0 +1,103 @@
unit JvInterpreterCallFunctionFm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
StdCtrls, Dialogs, SynEdit, SynHighlighterPas, //JvComponentBase,
JvInterpreter, JvExControls;
// JvEditorCommon, JvEditor, JvHLEditor;
type
{ TForm1 }
TForm1 = class(TForm)
JvHLEditor1: TSynEdit; //JvHLEditor;
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Label1: TLabel;
JvInterpreterProgram1: TJvInterpreterProgram;
SynPasSyn1: TSynPasSyn;
procedure Button1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure JvInterpreterProgram1GetValue(Sender: TObject;
Identifier: String; var Value: Variant; Args: TJvInterpreterArgs;
var Done: Boolean);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
procedure TForm1.Button1Click(Sender: TObject);
var
Args:TJvInterpreterArgs;
begin
{ before we get here, JvInterpreterProgram1.Pas is already set to show the text in the HLEditor. }
Assert(JvInterpreterProgram1.Pas.Count>0);
{ THIS IS ONLY ONE POSSIBLE WAY TO CALL CallFunction! Look at both ways please. }
{Args is a temporary argument data holder object}
Args := TJvInterpreterArgs.Create;
try
Args.Count := 1;
Args.Values[0] := 'SomeText';
JvInterpreterProgram1.CallFunction( 'MyFunction', Args, []);
{ show result to user:}
Edit1.Text := VarToStr( JvInterpreterProgram1.VResult );
finally
Args.Free;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
{ move program text over to interpreter! }
JvInterpreterProgram1.Pas.Assign( JvHLEditor1.Lines );
end;
procedure TForm1.JvInterpreterProgram1GetValue(Sender: TObject;
Identifier: String; var Value: Variant; Args: TJvInterpreterArgs;
var Done: Boolean);
begin
Identifier := UpperCase(Identifier);
if (Identifier='LENGTH') and (ARgs.Count=1) and (VarIsStr(Args.Values[0])) then
begin
Value := Length(ARgs.Values[0]);
Done := true;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Param1,Param2,Param3:Variant;
begin
{ before we get here, JvInterpreterProgram1.Pas is already set to show the text in the HLEditor. }
Assert(JvInterpreterProgram1.Pas.Count>0);
{ Alternative method without creating/freeing JvInterpreter args is to use Params instead, but not Args:}
Param1 := 10;
Param2 := 20;
JvInterpreterProgram1.CallFunction( 'MyFunction2', nil, [Param1,Param2] );
{ show result to user:}
Edit1.Text := VarToStr( JvInterpreterProgram1.VResult );
end;
end.

84
components/jvcllaz/examples/JvInterpreterDemos/JvInterpreterSimple/JvInterpreterSimpleExpression.lpi Normal file
View File

@ -0,0 +1,84 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<Title Value="JvInterpreterSimpleExpression"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes>
<Item Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<RequiredPackages>
<Item>
<PackageName Value="JvCustomLazR"/>
</Item>
<Item>
<PackageName Value="JvPascalInterpreterR"/>
<MaxVersion Major="1" Release="6"/>
</Item>
<Item>
<PackageName Value="LCL"/>
</Item>
</RequiredPackages>
<Units>
<Unit>
<Filename Value="JvInterpreterSimpleExpression.lpr"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="JvInterpreterSimpleExpressionFm.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="..\..\..\bin\$(TargetCPU)-$(TargetOS)\JvInterpreterSimpleExpression"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions>
<Item>
<Name Value="EAbort"/>
</Item>
<Item>
<Name Value="ECodetoolError"/>
</Item>
<Item>
<Name Value="EFOpenError"/>
</Item>
</Exceptions>
</Debugging>
</CONFIG>

16
components/jvcllaz/examples/JvInterpreterDemos/JvInterpreterSimple/JvInterpreterSimpleExpression.lpr Normal file
View File

@ -0,0 +1,16 @@
program JvInterpreterSimpleExpression;
{$mode objfpc}{$H+}
uses
Interfaces, Forms,
JvInterpreterSimpleExpressionFm in 'JvInterpreterSimpleExpressionFm.pas' {Form1};
{$R *.res}
begin
Application.Scaled := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

184
components/jvcllaz/examples/JvInterpreterDemos/JvInterpreterSimple/JvInterpreterSimpleExpressionFm.lfm Normal file
View File

@ -0,0 +1,184 @@
object Form1: TForm1
Left = 192
Height = 177
Top = 66
Width = 397
AutoSize = True
Caption = 'Simple Expressions in JvInterpreter'
ClientHeight = 177
ClientWidth = 397
Color = clBtnFace
Font.Color = clWindowText
LCLVersion = '2.1.0.0'
object Label1: TLabel
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Edit1
AnchorSideTop.Side = asrCenter
Left = 12
Height = 15
Top = 10
Width = 56
BorderSpacing.Left = 12
Caption = 'Expression'
ParentColor = False
end
object Label2: TLabel
AnchorSideLeft.Control = Edit2
AnchorSideTop.Control = EditA
AnchorSideTop.Side = asrCenter
Left = 76
Height = 15
Top = 64
Width = 8
Caption = 'A'
ParentColor = False
end
object Label3: TLabel
AnchorSideLeft.Control = Label2
AnchorSideTop.Control = EditB
AnchorSideTop.Side = asrCenter
Left = 76
Height = 15
Top = 89
Width = 7
Caption = 'B'
ParentColor = False
end
object Label4: TLabel
AnchorSideLeft.Control = Label2
AnchorSideTop.Control = EditC
AnchorSideTop.Side = asrCenter
Left = 76
Height = 15
Top = 114
Width = 8
Caption = 'C'
ParentColor = False
end
object Label5: TLabel
AnchorSideLeft.Control = Label1
AnchorSideTop.Control = Edit2
AnchorSideTop.Side = asrCenter
Left = 12
Height = 15
Top = 34
Width = 32
Caption = 'Result'
ParentColor = False
end
object Button1: TButton
AnchorSideLeft.Control = Edit1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Edit1
AnchorSideTop.Side = asrCenter
Left = 241
Height = 25
Top = 5
Width = 129
AutoSize = True
BorderSpacing.Left = 12
BorderSpacing.Right = 12
Caption = 'Evaluate Expression'
OnClick = Button1Click
TabOrder = 0
end
object Edit1: TEdit
AnchorSideLeft.Control = Label1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Owner
Left = 76
Height = 22
Top = 6
Width = 153
BorderSpacing.Left = 8
BorderSpacing.Top = 6
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
ParentFont = False
TabOrder = 1
Text = 'A + MAX(B,C)'
end
object EditA: TJvValidateEdit
AnchorSideLeft.Control = Label2
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Edit2
AnchorSideTop.Side = asrBottom
Left = 96
Height = 23
Top = 60
Width = 73
BorderSpacing.Left = 12
BorderSpacing.Top = 8
CriticalPoints.MaxValue = 0
CriticalPoints.MinValue = 0
CriticalPoints.MaxValueIncluded = False
CriticalPoints.MinValueIncluded = False
EditText = '100'
MaxValue = 0
MinValue = 0
TabOrder = 2
end
object EditB: TJvValidateEdit
AnchorSideLeft.Control = EditA
AnchorSideTop.Control = EditA
AnchorSideTop.Side = asrBottom
Left = 96
Height = 23
Top = 85
Width = 73
BorderSpacing.Top = 2
CriticalPoints.MaxValue = 0
CriticalPoints.MinValue = 0
CriticalPoints.MaxValueIncluded = False
CriticalPoints.MinValueIncluded = False
EditText = '50'
MaxValue = 0
MinValue = 0
TabOrder = 3
end
object EditC: TJvValidateEdit
AnchorSideLeft.Control = EditA
AnchorSideTop.Control = EditB
AnchorSideTop.Side = asrBottom
Left = 96
Height = 23
Top = 110
Width = 73
BorderSpacing.Top = 2
BorderSpacing.Bottom = 12
CriticalPoints.MaxValue = 0
CriticalPoints.MinValue = 0
CriticalPoints.MaxValueIncluded = False
CriticalPoints.MinValueIncluded = False
EditText = '60'
MaxValue = 0
MinValue = 0
TabOrder = 4
end
object Edit2: TEdit
AnchorSideLeft.Control = Edit1
AnchorSideTop.Control = Edit1
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Edit1
AnchorSideRight.Side = asrBottom
Left = 76
Height = 22
Top = 30
Width = 153
BorderSpacing.Top = 2
Color = clBtnFace
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
ParentFont = False
ReadOnly = True
TabOrder = 5
end
object JvInterpreterProgram1: TJvInterpreterProgram
OnGetValue = JvInterpreterProgram1GetValue
OnSetValue = JvInterpreterProgram1SetValue
left = 280
top = 80
end
end

135
components/jvcllaz/examples/JvInterpreterDemos/JvInterpreterSimple/JvInterpreterSimpleExpressionFm.pas Normal file
View File

@ -0,0 +1,135 @@
unit JvInterpreterSimpleExpressionFm;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, JvValidateEdit, JvInterpreter;
type
TForm1 = class(TForm)
JvInterpreterProgram1: TJvInterpreterProgram;
Button1: TButton;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
EditA: TJvValidateEdit;
EditB: TJvValidateEdit;
Label3: TLabel;
EditC: TJvValidateEdit;
Label4: TLabel;
Label5: TLabel;
Edit2: TEdit;
procedure Button1Click(Sender: TObject);
procedure JvInterpreterProgram1GetValue(Sender: TObject;
Identifier: String; var Value: Variant; Args: TJvInterpreterArgs;
var Done: Boolean);
procedure JvInterpreterProgram1SetValue(Sender: TObject;
Identifier: String; const Value: Variant; Args: TJvInterpreterArgs;
var Done: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
uses
Math;
procedure TForm1.Button1Click(Sender: TObject);
begin
{ BEGIN
RESULT := <EXPRESSION>;
END
Note: Any time a variable or function name is invoked, the GetValue event is fired....
}
JvInterpreterProgram1.Source := 'begin'+Chr(13)+
'result := '+ Edit1.Text+';'+Chr(13)+
'end;';
JvInterpreterProgram1.Run;
Edit2.Text := VarToStr( JvInterpreterProgram1.VResult);
end;
procedure TForm1.JvInterpreterProgram1GetValue(Sender: TObject;
Identifier: String; var Value: Variant; Args: TJvInterpreterArgs;
var Done: Boolean);
begin
Identifier := UpperCase(Identifier);
{ This event is fired by JvInterpreter not only to get variable names (A=5)
but also to evaluate expressions like Foo(3), where Foo might be a function
defined by you, with parameters. Args contains those parameters. }
{ you would not typically do a brute-force block of if-else statements here in a
real program, but would do some kind of more elegant lookup in a table of your
own named data objects that are used for your logic, to look up variables
and function names. }
if Identifier='A' then
begin
Value := EditA.Value;
Done := true; {VERY IMPORTANT!}
end
else
if Identifier='B' then
begin
Value := EditB.Value;
Done := true; {VERY IMPORTANT!}
end
else
if Identifier='C' then
begin
Value := EditC.Value;
Done := true; {VERY IMPORTANT!}
end
else { FUNCTION DEMO! }
if (Identifier='MAX') then begin
if (Args.Count=2) and
VarIsNumeric(Args.Values[0]) and
VarIsNumeric(Args.Values[1])
then begin
Value := Max(double(Args.Values[0]), double(Args.Values[1]));
Done := true; {VERY IMPORTANT!}
end else begin
{ You can raise exceptions if invalid parameters are provided, or just let the default
'not found' error get raised.}
JvInterpreterError(ieIncompatibleTypes,0); // or ieNotEnoughParams, or others.
end;
end;
end;
procedure TForm1.JvInterpreterProgram1SetValue(Sender: TObject;
Identifier: String; const Value: Variant; Args: TJvInterpreterArgs;
var Done: Boolean);
begin
if VarIsNumeric(Value) then begin
if Identifier='A' then
begin
EditA.Value := Value;
Done := true;
end
else
if Identifier='B' then
begin
EditB.Value := Value;
Done := true;
end
else if Identifier='C' then
begin
EditC.Value := Value;
Done := true;
end;
end;
end;
end.

401
components/jvcllaz/examples/jvcllaz_all_examples.lpg
View File

@ -1,179 +1,232 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectGroup FileVersion="1">
<Targets Count="43">
<Target0 FileName="JvBmpAnimator\BmpAnimDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target0>
<Target1 FileName="JvCheckBox\JvCheckBoxDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target1>
<Target2 FileName="JvComboListBox\JvComboListBoxDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target2>
<Target3 FileName="JvDBLookup\JvDBLookupDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target3>
<Target4 FileName="JvDBLookupTreeView\JvDBLookupTreeViewDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target4>
<Target5 FileName="JvDBSearchEdit\JvSearchEditDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target5>
<Target6 FileName="JvDBTreeView\JVDBTreeViewDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target6>
<Target7 FileName="JvDesigner\jvDesignerDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target7>
<Target8 FileName="JvDialButton\JvDialButtonDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target8>
<Target9 FileName="JvFormAnimations\JvFormAnimations_Demo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target9>
<Target10 FileName="JvFormWallper\JvFormWallpaper_Demo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target10>
<Target11 FileName="JvFullColorCircleDialog\JvFullColorCircleDialogPrj.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target11>
<Target12 FileName="JvFullColorDialog\JvFullColorDialogPrj.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target12>
<Target13 FileName="JvHTControls\JvHTCtrlsDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target13>
<Target14 FileName="JvHTML\JvHTMLTest.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target14>
<Target15 FileName="JvHTMLParser\JvHtmlParserProj.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target15>
<Target16 FileName="JvID3v1\JvID3v1Demo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target16>
<Target17 FileName="JvID3v2\JvId3v2Demo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target17>
<Target18 FileName="JvInstallLabel\Install2LabelDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target18>
<Target19 FileName="JvItemViewer\JvItemViewerDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target19>
<Target20 FileName="JvLED\JvLEDDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target20>
<Target21 FileName="JvLookupAutoComplete\JvLookupAutoCompleteDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target21>
<Target22 FileName="JvMarkup\MarkupDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target22>
<Target23 FileName="JvNavigationPane\JvNavPaneDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="default"/>
</Target23>
<Target24 FileName="JvOutlookBar\OLBarDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target24>
<Target25 FileName="JvOutlookBarCustomDraw\JvOutlookBarCustomDrawDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target25>
<Target26 FileName="JvPicClip\JvPicClipDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target26>
<Target27 FileName="JvProfiler32\ProfilerDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target27>
<Target28 FileName="JvRollOut\JvRollOutDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target28>
<Target29 FileName="JvSimScope\JvSimScopeDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target29>
<Target30 FileName="JvSpecialProgress\specialprogress_demo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target30>
<Target31 FileName="JvSpellChecker\JvSpellCheckerDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target31>
<Target32 FileName="JvTabBar\JvTabBarDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target32>
<Target33 FileName="JvTabBar_NotebookPages\JvTabBarDemo_NotebookPages.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target33>
<Target34 FileName="JvThumbnail\JvThumbnailDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target34>
<Target35 FileName="JVTimeLine\TimeLineDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target35>
<Target36 FileName="JvTMTimeLine\SimpleTLTest1.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target36>
<Target37 FileName="JvValidateEdit\JvFormatEditDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target37>
<Target38 FileName="JvValidators\JvValidatorsDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target38>
<Target39 FileName="JvWizard\JvWizardDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target39>
<Target40 FileName="JvXPBar\XPBarDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target40>
<Target41 FileName="JvXPCtrls\SimpleDemo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target41>
<Target42 FileName="JvYearGrid\YearGrid_Demo.lpi">
<BuildModes Count="1"/>
<Mode1 Name="Default"/>
</Target42>
<ProjectGroup FileVersion="2">
<Targets>
<Target FileName="JvBmpAnimator\BmpAnimDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvCheckBox\JvCheckBoxDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvComboListBox\JvComboListBoxDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvDBLookup\JvDBLookupDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvDBLookupTreeView\JvDBLookupTreeViewDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvDBSearchEdit\JvSearchEditDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvDBTreeView\JVDBTreeViewDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvDesigner\jvDesignerDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvDialButton\JvDialButtonDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvFormAnimations\JvFormAnimations_Demo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvFormWallper\JvFormWallpaper_Demo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvFullColorCircleDialog\JvFullColorCircleDialogPrj.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvFullColorDialog\JvFullColorDialogPrj.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvHTControls\JvHTCtrlsDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvHTML\JvHTMLTest.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvHTMLParser\JvHtmlParserProj.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvID3v1\JvID3v1Demo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvID3v2\JvId3v2Demo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvInstallLabel\Install2LabelDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvItemViewer\JvItemViewerDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvLED\JvLEDDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvLookupAutoComplete\JvLookupAutoCompleteDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvMarkup\MarkupDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvNavigationPane\JvNavPaneDemo.lpi">
<BuildModes>
<Mode Name="default"/>
</BuildModes>
</Target>
<Target FileName="JvOutlookBar\OLBarDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvOutlookBarCustomDraw\JvOutlookBarCustomDrawDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvPicClip\JvPicClipDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvProfiler32\ProfilerDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvRollOut\JvRollOutDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvSimScope\JvSimScopeDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvSpecialProgress\specialprogress_demo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvSpellChecker\JvSpellCheckerDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvTabBar\JvTabBarDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvTabBar_NotebookPages\JvTabBarDemo_NotebookPages.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvThumbnail\JvThumbnailDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JVTimeLine\TimeLineDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvTMTimeLine\SimpleTLTest1.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvValidateEdit\JvFormatEditDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvValidators\JvValidatorsDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvWizard\JvWizardDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvXPBar\XPBarDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvXPCtrls\SimpleDemo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvYearGrid\YearGrid_Demo.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvInterpreterDemos\JvInterpreterCallFunction\JvInterpreterCallFunction.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
<Target FileName="JvInterpreterDemos\JvInterpreterSimple\JvInterpreterSimpleExpression.lpi">
<BuildModes>
<Mode Name="Default"/>
</BuildModes>
</Target>
</Targets>
</ProjectGroup>
</CONFIG>

74
components/jvcllaz/packages/jvcllaz_all.lpg
View File

@ -1,41 +1,43 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectGroup FileVersion="1">
<Targets Count="34">
<Target0 FileName="jvcorelazr.lpk"/>
<Target1 FileName="jvcorelazd.lpk"/>
<Target2 FileName="jvctrlslazr.lpk"/>
<Target3 FileName="jvctrlslazd.lpk"/>
<Target4 FileName="jvstdctrlslazr.lpk"/>
<Target5 FileName="jvstdctrlslazd.lpk"/>
<Target6 FileName="jvdblazr.lpk"/>
<Target7 FileName="jvdblazd.lpk"/>
<Target8 FileName="jvpagecompsr.lpk"/>
<Target9 FileName="jvpagecompsd.lpk"/>
<Target10 FileName="jvcustomlazr.lpk"/>
<Target11 FileName="jvcustomlazd.lpk"/>
<Target12 FileName="jvcmpr.lpk"/>
<Target13 FileName="jvcmpd.lpk"/>
<Target14 FileName="jvappfrmlazr.lpk"/>
<Target15 FileName="jvappfrmlazd.lpk"/>
<Target16 FileName="jvhmilazr.lpk"/>
<Target17 FileName="jvhmilazd.lpk"/>
<Target18 FileName="jvjanslazr.lpk"/>
<Target19 FileName="jvjanslazd.lpk"/>
<Target20 FileName="jvmmlazr.lpk"/>
<Target21 FileName="jvmmlazd.lpk"/>
<Target22 FileName="jvnetlazr.lpk"/>
<Target23 FileName="jvnetlazd.lpk"/>
<Target24 FileName="jvruntimedesignlazr.lpk"/>
<Target25 FileName="jvruntimedesignlazd.lpk"/>
<Target26 FileName="jvvalidatorslazr.lpk"/>
<Target27 FileName="jvvalidatorslazd.lpk"/>
<Target28 FileName="jvwizardlazr.lpk"/>
<Target29 FileName="jvwizardlazd.lpk"/>
<Target30 FileName="jvxpctrlslazr.lpk"/>
<Target31 FileName="jvxpctrlslazd.lpk"/>
<Target32 FileName="jvtimeframeworklazr.lpk"/>
<Target33 FileName="jvtimeframeworklazd.lpk"/>
<ProjectGroup FileVersion="2">
<Targets>
<Target FileName="jvcorelazr.lpk"/>
<Target FileName="jvcorelazd.lpk"/>
<Target FileName="jvctrlslazr.lpk"/>
<Target FileName="jvctrlslazd.lpk"/>
<Target FileName="jvstdctrlslazr.lpk"/>
<Target FileName="jvstdctrlslazd.lpk"/>
<Target FileName="jvdblazr.lpk"/>
<Target FileName="jvdblazd.lpk"/>
<Target FileName="jvpagecompsr.lpk"/>
<Target FileName="jvpagecompsd.lpk"/>
<Target FileName="jvcustomlazr.lpk"/>
<Target FileName="jvcustomlazd.lpk"/>
<Target FileName="jvcmpr.lpk"/>
<Target FileName="jvcmpd.lpk"/>
<Target FileName="jvappfrmlazr.lpk"/>
<Target FileName="jvappfrmlazd.lpk"/>
<Target FileName="jvhmilazr.lpk"/>
<Target FileName="jvhmilazd.lpk"/>
<Target FileName="jvjanslazr.lpk"/>
<Target FileName="jvjanslazd.lpk"/>
<Target FileName="jvmmlazr.lpk"/>
<Target FileName="jvmmlazd.lpk"/>
<Target FileName="jvnetlazr.lpk"/>
<Target FileName="jvnetlazd.lpk"/>
<Target FileName="jvruntimedesignlazr.lpk"/>
<Target FileName="jvruntimedesignlazd.lpk"/>
<Target FileName="jvvalidatorslazr.lpk"/>
<Target FileName="jvvalidatorslazd.lpk"/>
<Target FileName="jvwizardlazr.lpk"/>
<Target FileName="jvwizardlazd.lpk"/>
<Target FileName="jvxpctrlslazr.lpk"/>
<Target FileName="jvxpctrlslazd.lpk"/>
<Target FileName="jvtimeframeworklazr.lpk"/>
<Target FileName="jvtimeframeworklazd.lpk"/>
<Target FileName="jvpascalinterpreterr.lpk"/>
<Target FileName="jvpascalinterpreterd.lpk"/>
</Targets>
</ProjectGroup>
</CONFIG>

40
components/jvcllaz/packages/jvpascalinterpreterd.lpk Normal file
View File

@ -0,0 +1,40 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="5">
<PathDelim Value="\"/>
<Name Value="JvPascalInterpreterD"/>
<Type Value="RunAndDesignTime"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\design\JvPascalInterpreter"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="6"/>
<Files Count="1">
<Item1>
<Filename Value="..\design\JvPascalInterpreter\jvpascalinterpreterreg.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="JvPascalInterpreterReg"/>
</Item1>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="JvCoreLazD"/>
</Item1>
<Item2>
<PackageName Value="jvpascalinterpreterr"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
</Package>
</CONFIG>

50
components/jvcllaz/packages/jvpascalinterpreterr.lpk Normal file
View File

@ -0,0 +1,50 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="5">
<PathDelim Value="\"/>
<Name Value="JvPascalInterpreterR"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\run\JvPascalInterpreter"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="6"/>
<Files Count="4">
<Item1>
<Filename Value="..\run\JvPascalInterpreter\JvInterpreter.pas"/>
<UnitName Value="JvInterpreter"/>
</Item1>
<Item2>
<Filename Value="..\run\JvPascalInterpreter\JvInterpreterConst.pas"/>
<UnitName Value="JvInterpreterConst"/>
</Item2>
<Item3>
<Filename Value="..\run\JvPascalInterpreter\JvInterpreterParser.pas"/>
<UnitName Value="JvInterpreterParser"/>
</Item3>
<Item4>
<Filename Value="..\run\JvPascalInterpreter\JvInterpreterFm.pas"/>
<UnitName Value="JvInterpreterFm"/>
</Item4>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="JvCoreLazR"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
</Package>
</CONFIG>

BIN
components/jvcllaz/resource/jvpascalinterpreterreg.res Normal file
View File

Binary file not shown.

54
components/jvcllaz/run/JvCore/jvjclutils.pas
View File

@ -78,6 +78,8 @@ type
{$ENDIF}
EJvConvertError = Class(EConvertError); { subclass EConvertError raised by some non-Def versions of floating point conversion routine }
TDynByteArray = array of byte;
(******************** NOT CONVERTED
{$IFDEF UNIX}
TFileTime = Integer;
@ -116,6 +118,7 @@ function StrToFloatUSDef(const Text: string; Default: Extended): Extended;
function VarIsInt(Value: Variant): Boolean;
// VarIsInt returns VarIsOrdinal-[varBoolean]
****************************)
{ PosIdx returns the index of the first appearance of SubStr in Str. The search
starts at index "Index". }
@ -123,6 +126,8 @@ function PosIdx(const SubStr, S: string; Index: Integer = 0): Integer;
{$IFNDEF CLR}
function PosIdxW(const SubStr, S: WideString; Index: Integer = 0): Integer;
{$ENDIF !CLR}
(*****************************
function PosLastCharIdx(Ch: Char; const S: string; Index: Integer = 0): Integer;
{ GetWordOnPos returns Word from string, S, on the cursor position, P}
@ -146,9 +151,10 @@ procedure GetEndPosCaretW(const Text: WideString; CaretX, CaretY: Integer;
var X, Y: Integer);
{ GetEndPosCaret returns the caret position of the last char. For the position
after the last char of Text you must add 1 to the returned X value. }
***********************)
{ SubStrBySeparator returns substring from string, S, separated with Separator string}
function SubStrBySeparator(const S: string; const Index: Integer; const Separator: string; StartIndex: Integer = 1): string;
(*************************
{$IFNDEF CLR}
function SubStrBySeparatorW(const S: WideString; const Index: Integer; const Separator: WideString; StartIndex: Integer = 1): WideString;
{$ENDIF !CLR}
@ -161,9 +167,13 @@ function SubWord(P: string; var P2: string): string;
function SubWord(P: PChar; var P2: PChar): string;
{$ENDIF CLR}
// function CurrencyByWord(Value: Currency): string;
****************************)
{ GetLineByPos returns the Line number, there
the symbol Pos is pointed. Lines separated with #13 symbol }
function GetLineByPos(const S: string; const Pos: Integer): Integer;
(********************
{ GetXYByPos is same as GetLineByPos, but returns X position in line as well}
procedure GetXYByPos(const S: string; const Pos: Integer; var X, Y: Integer);
procedure GetXYByPosW(const S: WideString; const Pos: Integer; var X, Y: Integer);
@ -291,13 +301,19 @@ function HasSubFolder(APath: TFileName): Boolean;
{ IsEmptyFolder returns True, if there are no files or
folders in given folder, APath}
function IsEmptyFolder(APath: TFileName): Boolean;
**************************)
{ AddSlash returns string with added slash Char to Dir parameter, if needed }
function AddSlash(const Dir: TFileName): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}
function AddSlash(const Dir: TFileName): string; inline;
(**********************************
{ AddPath returns FileName with Path, if FileName not contain any path }
function AddPath(const FileName, Path: TFileName): TFileName;
function AddPaths(const PathList, Path: string): string;
function ParentPath(const Path: TFileName): TFileName;
********************)
function FindInPath(const FileName, PathList: string): TFileName;
(************************
{ DeleteReadOnlyFile clears R/O file attribute and delete file }
function DeleteReadOnlyFile(const FileName: TFileName): Boolean;
{ HasParam returns True, if program running with specified parameter, Param }
@ -412,9 +428,13 @@ function ResSaveToString(Instance: HINST; const Typ, Name: string;
This function reads ALL strings from specified section.
Note: TIninFile.ReadSection function reads only strings with '=' symbol.}
function IniReadSection(const IniFileName: TFileName; const Section: string; Ss: TStrings): Boolean;
****************************)
{ LoadTextFile load text file, FileName, into string }
function LoadTextFile(const FileName: TFileName): string;
procedure SaveTextFile(const FileName: TFileName; const Source: string);
(****************************
{ ReadFolder reads files list from disk folder, Folder,
that are equal to mask, Mask, into strings, FileList}
function ReadFolder(const Folder, Mask: TFileName; FileList: TStrings): Integer;
@ -470,8 +490,11 @@ procedure ClipBoardToMemStream(MemStream: TMemoryStream; const Format: Word);
function GetPropType(Obj: TObject; const PropName: string): TTypeKind;
function GetPropStr(Obj: TObject; const PropName: string): string;
function GetPropOrd(Obj: TObject; const PropName: string): Integer;
***********************)
function GetPropMethod(Obj: TObject; const PropName: string): TMethod;
(***********************
procedure PrepareIniSection(Ss: TStrings);
{ following functions are not documented because
they are don't work properly, so don't use them }
@ -1277,7 +1300,7 @@ function FindUnusedFileName(FileName: string; const FileExt: string; NumberPrefi
implementation
uses
Math, Variants, LazFileUtils, LclStrConsts,
Math, Variants, LazFileUtils, typinfo, LclStrConsts,
JvConsts;
(******************** NOT CONVERTED
@ -1313,12 +1336,11 @@ const
resourcestring
RsEPivotLessThanZero = 'JvJCLUtils.MakeYear4Digit: Pivot < 0';
(******************* NOT CONVERTED ****
// (p3) duplicated from JvConsts since this unit should not rely on JVCL at all
RsEPropertyNotExists = 'Property "%s" does not exist';
RsEInvalidPropertyType = 'Property "%s" has invalid type';
(******************* NOT CONVERTED ****
{$IFDEF NO_JCL}
// These are the replacement functions for the JCL.
@ -1713,6 +1735,7 @@ begin
{$ENDIF COMPILER6_UP}
varSmallint, varInteger];
end;
***********************************)
function PosIdx(const SubStr, S: string; Index: Integer = 0): Integer;
{$IFDEF CLR}
@ -1831,6 +1854,7 @@ begin
end;
{$ENDIF CLR}
(******************************
function PosLastCharIdx(Ch: Char; const S: string; Index: Integer = 0): Integer;
begin
if (Index = 0) or (Index > Length(S)) then
@ -1840,7 +1864,7 @@ begin
Exit;
Result := 0;
end;
***********************************)
function GetLineByPos(const S: string; const Pos: Integer): Integer;
var
@ -1861,6 +1885,7 @@ begin
end;
end;
(*********************************
procedure GetXYByPos(const S: string; const Pos: Integer; var X, Y: Integer);
var
I, iB: Integer;
@ -2171,7 +2196,7 @@ begin
Dec(X);
Inc(Y, CaretY);
end;
*********************)
function SubStrBySeparator(const S: string; const Index: Integer; const Separator: string; StartIndex: Integer): string;
{ Returns a substring. Substrings are divided by a separator character }
var
@ -2204,6 +2229,7 @@ begin
Result := '';
end;
(**********************
{$IFNDEF CLR}
function SubStrBySeparatorW(const S: WideString; const Index: Integer; const Separator: WideString; StartIndex: Integer): WideString;
{ Returns a substring. Substrings are divided by a separator character }
@ -2725,6 +2751,7 @@ begin
Result := IntToStr(D) + ' ' + Day[D2D[StrToInt(IntToStr(D)[Length(IntToStr(D))])]] + ' �����' // ago
end;
end;
*****************************)
function AddSlash(const Dir: TFileName): string;
begin
@ -2733,6 +2760,7 @@ begin
Result := Dir + PathDelim;
end;
(****************************
function AddPath(const FileName, Path: TFileName): TFileName;
begin
if ExtractFileDrive(FileName) = '' then
@ -2764,6 +2792,7 @@ begin
Delete(Result, Length(Result), 1);
Result := ExtractFilePath(Result);
end;
***************************)
function FindInPath(const FileName, PathList: string): TFileName;
var
@ -2783,6 +2812,7 @@ begin
Result := '';
end;
(************************
{$IFNDEF CLR}
{$IFDEF MSWINDOWS}
function GetComputerID: string;
@ -3548,6 +3578,7 @@ begin
Free;
end;
end;
***************************)
procedure SaveTextFile(const FileName: TFileName; const Source: string);
begin
@ -3571,6 +3602,7 @@ begin
end;
end;
(********************************
function ReadFolder(const Folder, Mask: TFileName; FileList: TStrings): Integer;
var
SearchRec: TSearchRec;
@ -4238,16 +4270,16 @@ begin
end;
end;
{$ENDIF !CLR}
*******************)
function GetPropTypeKind(PropInf: PPropInfo): TTypeKind;
begin
{$IFDEF CLR}
Result := PropInf.TypeKind;
{$ELSE}
Result := PropInf.PropType^.Kind;
Result := PropInf^.PropType^.Kind;
{$ENDIF CLR}
end;
(***************************
function GetPropType(Obj: TObject; const PropName: string): TTypeKind;
var
PropInf: PPropInfo;
@ -4298,6 +4330,7 @@ begin
{$ENDIF CLR}
Result := GetOrdProp(Obj, PropInf);
end;
**************************)
function GetPropMethod(Obj: TObject; const PropName: string): TMethod;
var
@ -4319,6 +4352,7 @@ begin
Result := GetMethodProp(Obj, PropInf);
end;
(***********************
procedure PrepareIniSection(Ss: TStrings);
var
I: Integer;

2
components/jvcllaz/run/JvCore/jvresources.pas
View File

@ -355,6 +355,7 @@ resourcestring
RsENotifyErrorFmt = '%0:s:' + sLineBreak + '%1:s';
//=== JvChart.pas ============================================================
(************************ NOT CONVERTED ***
resourcestring
RsChartDesigntimeLabel = ': JEDI JVCL Charting Component';
RsNoData = 'No data. (Data.ValueCount=0)';
@ -374,6 +375,7 @@ resourcestring
RsEChartOptionsPenCountPenCountOutOf = 'JvChart.Options.PenCount - PenCount out of range';
RsEChartOptionsXStartOffsetValueOutO = 'JvChart.Options.XStartOffset - value out of range';
RsEUnableToGetCanvas = 'Unable to get canvas';
************************)
//=== JvCheckedMaskEdit.pas ==================================================
resourcestring

8768
components/jvcllaz/run/JvPascalInterpreter/JvInterpreter.pas Normal file
View File

File diff suppressed because it is too large Load Diff

120
components/jvcllaz/run/JvPascalInterpreter/JvInterpreterConst.pas Normal file
View File

@ -0,0 +1,120 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvInterpreterConst.PAS, released on 2002-07-04.
The Initial Developers of the Original Code are: Andrei Prygounkov <a dott prygounkov att gmx dott de>
Copyright (c) 1999, 2002 Andrei Prygounkov
All Rights Reserved.
Contributor(s):
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Description : Language specific constant for English
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
unit JvInterpreterConst;
{$mode Delphi}
interface
uses
JvResources;
const
{JvInterpreterParser}
StIdSymbols = ['_', '0'..'9', 'A'..'Z', 'a'..'z'];
StIdFirstSymbols = ['_', 'A'..'Z', 'a'..'z'];
StConstSymbols = ['0'..'9', 'A'..'F', 'a'..'f'];
StConstSymbols10 = ['0'..'9'];
StConstE=['E','e'];
StConstPlusSub=['+','-'];
StConstSymbols10e = ['0'..'9','E','e','+','-','.'];
StSeparators = ['(', ')', ',', '.', ';'];
type
TJvInterpreterErrorsDescr = record
ID: Integer;
Description: string;
end;
const
JvInterpreterErrors: array [0..52] of TJvInterpreterErrorsDescr =
((ID: 0; Description: RsEInterpreter0),
(ID: 1; Description: RsEInterpreter1),
(ID: 2; Description: RsEInterpreter2),
(ID: 3; Description: RsEInterpreter3),
(ID: 4; Description: RsEInterpreter4),
(ID: 5; Description: RsEInterpreter5),
(ID: 6; Description: RsEInterpreter6),
(ID: 7; Description: RsEInterpreter7),
(ID: 8; Description: RsEInterpreter8),
(ID: 31; Description: RsEInterpreter31),
(ID: 52; Description: RsEInterpreter52),
(ID: 53; Description: RsEInterpreter53),
(ID: 55; Description: RsEInterpreter55),
(ID: 56; Description: RsEInterpreter56),
(ID: 57; Description: RsEInterpreter57),
(ID: 58; Description: RsEInterpreter58),
(ID: 101; Description: RsEInterpreter101),
(ID: 103; Description: RsEInterpreter103),
(ID: 104; Description: RsEInterpreter104),
(ID: 105; Description: RsEInterpreter105),
(ID: 106; Description: RsEInterpreter106),
(ID: 107; Description: RsEInterpreter107),
(ID: 108; Description: RsEInterpreter108),
(ID: 109; Description: RsEInterpreter109),
(ID: 110; Description: RsEInterpreter110),
(ID: 111; Description: RsEInterpreter111),
(ID: 171; Description: RsEInterpreter171),
(ID: 172; Description: RsEInterpreter172),
(ID: 173; Description: RsEInterpreter173),
(ID: 174; Description: RsEInterpreter174),
(ID: 175; Description: RsEInterpreter175),
(ID: 176; Description: RsEInterpreter176),
(ID: 181; Description: RsEInterpreter181),
(ID: 182; Description: RsEInterpreter182),
(ID: 183; Description: RsEInterpreter183),
(ID: 184; Description: RsEInterpreter184),
(ID: 185; Description: RsEInterpreter185),
(ID: 186; Description: RsEInterpreter186),
(ID: 187; Description: RsEInterpreter187),
(ID: 188; Description: RsEInterpreter188),
(ID: 189; Description: RsEInterpreter189),
(ID: 190; Description: RsEInterpreter190),
(ID: 201; Description: RsEInterpreter201),
(ID: 301; Description: RsEInterpreter301),
(ID: 302; Description: RsEInterpreter302),
(ID: 303; Description: RsEInterpreter303),
(ID: 304; Description: RsEInterpreter304),
(ID: 305; Description: RsEInterpreter305),
(ID: 306; Description: RsEInterpreter306),
(ID: 307; Description: RsEInterpreter307),
(ID: 308; Description: RsEInterpreter308),
(ID: 309; Description: RsEInterpreter309),
(ID: 401; Description: RsEInterpreter401));
implementation
end.

736
components/jvcllaz/run/JvPascalInterpreter/JvInterpreterFm.pas Normal file
View File

@ -0,0 +1,736 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvInterpreterFm.PAS, released on 2002-07-04.
The Initial Developers of the Original Code are: Andrei Prygounkov <a dott prygounkov att gmx dott de>
Copyright (c) 1999, 2002 Andrei Prygounkov
All Rights Reserved.
Contributor(s): Ivan Ravin (ivan_ra)
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Description : JVCL Interpreter version 2
Component : form runner for JvInterpreter
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
{ history (JVCL Library versions):
1.10:
- first release;
1.12:
- more smart interface-part reducementer -
method MakeCompatibleUnit;
1.31.3 (JVCL Library 1.31 with update 3):
- support for Delphi5 text DFM files.
1.52:
- fixed memory bug;
1.52.4:
- previous memory bug fix was moved to JvInterpreter.pas unit;
1.60:
- forms, placed in used units, are supported;
- method MakeCompatibleUnit has been removed;
1.61:
- fixed bug: local variables in methods overrieded by form memebers;
this bug prevented MDI forms from "Action := caFree" code to work
(thanks to Ivan Ravin);
2.00:
- loading of inherited forms added by Cerny Robert;
}
unit JvInterpreterFm;
{$mode Delphi}
interface
uses
SysUtils, Classes, Controls, Forms,
JvInterpreter, JvJVCLUtils, JvComponent;
type
TJvInterpreterGetDfmFileName = procedure(Sender: TObject; UnitName: string;
var FileName: string; var Done: Boolean) of object;
TJvInterpreterCreateDfmStream = procedure(Sender: TObject; UnitName: string;
var Stream: TStream; var Done: Boolean) of object;
TJvInterpreterFreeDfmStream = procedure(Sender: TObject; Stream: TStream) of object;
TJvInterpreterFm = class;
TJvInterpreterForm = class(TForm) //TJvForm)
private
FJvInterpreterFm: TJvInterpreterFm;
FMethodList: TList;
FFieldList: TJvInterpreterVarList;
FFreeJvInterpreterFm: Boolean;
FClassIdentifier: string;
FUnitName: string;
procedure FixupMethods;
protected
procedure ReadState(Reader: TReader); override;
property MethodList: TList read FMethodList;
property ClassIdentifier: string read FClassIdentifier;
{$WARNINGS OFF} // Delphi 2009+ has a class function UnitName
property UnitName: string read FUnitName;
{$WARNINGS ON}
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
destructor Destroy; override;
property JvInterpreterFm: TJvInterpreterFm read FJvInterpreterFm write FJvInterpreterFm;
end;
TJvInterpreterFm = class(TJvInterpreterProgram)
private
FForm: TJvInterpreterForm;
FFileName: string;
FInterfaceUses: Boolean;
FOnGetDfmFileName: TJvInterpreterGetDfmFileName;
FOnCreateDfmStream: TJvInterpreterCreateDfmStream;
FOnFreeDfmStream: TJvInterpreterFreeDfmStream;
procedure LoadForm(AForm: TJvInterpreterForm);
protected
function GetValue(const Identifier: string; var Value: Variant;
var Args: TJvInterpreterArgs): Boolean; override;
function SetValue(const Identifier: string; const Value: Variant;
var Args: TJvInterpreterArgs): Boolean; override;
function GetUnitSource(const UnitName: string; var Source: string): Boolean; override;
procedure CreateDfmStream(const UnitName: string; var Stream: TStream); dynamic;
procedure FreeDfmStream(Stream: TStream); dynamic;
public
procedure Run; override;
function MakeForm(const FileName: TFileName): TForm;
function MakeInheritedForm(F: TJvInterpreterForm; const FileName: TFileName): TForm;
function RunForm(const FileName: TFileName): TForm;
function RunFormModal(const FileName: TFileName): TModalResult;
function RunUnit(const FileName: TFileName): Variant;
procedure RunReportPreview(const FileName: string);
property Form: TJvInterpreterForm read FForm;
property FileName: string read FFileName;
published
property OnGetDfmFileName: TJvInterpreterGetDfmFileName read FOnGetDfmFileName write FOnGetDfmFileName;
property OnCreateDfmStream: TJvInterpreterCreateDfmStream read FOnCreateDfmStream write FOnCreateDfmStream;
property OnFreeDfmStream: TJvInterpreterFreeDfmStream read FOnFreeDfmStream write FOnFreeDfmStream;
property InterfaceUses: Boolean read FInterfaceUses write FInterfaceUses default False;
end;
function JvInterpreterRunFormModal(const AFileName: TFileName): TModalResult;
function JvInterpreterRunForm(const AFileName: TFileName): TForm;
function JvInterpreterMakeForm(const AFileName: TFileName): TForm;
function JvInterpreterRunUnit(const AFileName: TFileName): Variant;
procedure JvInterpreterRunReportPreview(const AFileName: string);
procedure JvInterpreterRunReportPreview2(const AFileName: string; JvInterpreterProgram: TJvInterpreterFm);
procedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);
const
ieImplementationNotFound = 401;
var
JvInterpreterRunReportPreviewProc: procedure(const FileName: string);
JvInterpreterRunReportPreview2Proc: procedure(const FileName: string; JvInterpreterProgram: TJvInterpreterFm);
implementation
uses
TypInfo, LazFileUtils,
JvResources, JvTypes, JvJCLUtils;
//=== { TJvInterpreterReader } ===============================================
type
TJvInterpreterReader = class(TReader)
protected
function FindMethod(Root: TComponent; const MethodName: string): Pointer;
override;
end;
TJvInterpreterAdapterAccessProtected = class(TJvInterpreterAdapter);
function TJvInterpreterReader.FindMethod(Root: TComponent; const MethodName: string): Pointer;
var
Len: Integer;
begin
// (rom) explicit allocation instead of deprecated NewStr
Len := Length(MethodName) + 1;
GetMem(Result, Len * SizeOf(Char));
Move(PChar(MethodName)^, Result^, Len * SizeOf(Char));
TJvInterpreterForm(Root).FMethodList.Add(Result);
end;
//=== { TJvInterpreterForm } =================================================
constructor TJvInterpreterForm.CreateNew(AOwner: TComponent; Dummy: Integer = 0);
begin
FMethodList := TList.Create;
FFieldList := TJvInterpreterVarList.Create; // class fields suport
{$IFDEF DELPHI}
inherited CreateNew(AOwner);
{$ELSE}
inherited CreateNew(AOwner, Dummy);
{$ENDIF DELPHI}
end;
destructor TJvInterpreterForm.Destroy;
var
I: Integer;
begin
for I := 0 to FMethodList.Count - 1 do
FreeMem(FMethodList[I]);
FMethodList.Free;
FFieldList.Free; // class fields suport
inherited Destroy;
if FFreeJvInterpreterFm then
FJvInterpreterFm.Free;
end;
procedure TJvInterpreterForm.FixupMethods;
procedure ReadProps(Com: TComponent);
var
TypeInf: PTypeInfo;
TypeData: PTypeData;
PropList: PPropList;
NumProps: Word;
I: Integer;
F: Integer;
Method: TMethod;
begin
TypeInf := Com.ClassInfo;
TypeData := GetTypeData(TypeInf);
NumProps := TypeData^.PropCount;
GetMem(PropList, NumProps * SizeOf(Pointer));
try
GetPropInfos(TypeInf, PropList);
for I := 0 to NumProps - 1 do
if PropList^[I].PropType^.Kind = tkMethod then
begin
Method := GetMethodProp(Com, PropList^[I]);
if Method.Data = Self then
begin
F := FMethodList.IndexOf(Method.Code);
if F > -1 then
begin
SetMethodProp(Com, PropList^[I],
TMethod(FJvInterpreterFm.NewEvent(FUnitName,
PChar(FMethodList[F]),
{$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropList^[I]^.PropType^.Name),
Self,
{$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropList^[I]^.Name))));
end;
end;
end;
finally
FreeMem(PropList);
end;
end;
var
I: Integer;
begin
if FJvInterpreterFm = nil then
Exit; {+RWare}
ReadProps(Self);
for I := 0 to ComponentCount - 1 do
ReadProps(Components[I]);
end;
procedure TJvInterpreterForm.ReadState(Reader: TReader);
begin
inherited ReadState(Reader);
FixupMethods;
end;
function JvInterpreterReadComponentRes(var Stream: TStream;
Instance: TComponent): TComponent;
var
JvInterpreterReader: TJvInterpreterReader;
TmpStream: TMemoryStream;
begin
(**************** NOT CONVERTED ****
if TestStreamFormat(Stream) = sofText then
begin
***********************************)
TmpStream := TMemoryStream.Create;
ObjectTextToResource(Stream, TmpStream);
Stream.Free;
Stream := TmpStream;
Stream.Position := 0;
(*****************
end;
******************)
Stream.ReadResHeader;
JvInterpreterReader := TJvInterpreterReader.Create(Stream, 4096);
try
Result := JvInterpreterReader.ReadRootComponent(Instance);
finally
JvInterpreterReader.Free;
end;
end;
//=== { TJvInterpreterFm } ===================================================
function TJvInterpreterFm.MakeForm(const FileName: TFileName): TForm;
var
S: string;
UnitName: string;
begin
FFileName := FileName;
UnitName := ChangeFileExt(ExtractFileName(FFileName), '');
if not (GetUnitSource(FFileName, S) or GetUnitSource(UnitName, S)) then
JvInterpreterErrorN(ieUnitNotFound, -1, UnitName);
Source := S;
Compile;
FForm := TJvInterpreterForm.CreateNew(Application);
FForm.FUnitName := UnitName;
LoadForm(FForm);
Result := FForm;
end; { MakeForm }
function TJvInterpreterFm.MakeInheritedForm(F: TJvInterpreterForm; const FileName: TFileName): TForm;
var
S: string;
UnitName: string;
begin
FFileName := FileName;
UnitName := ChangeFileExt(ExtractFileName(FFileName), '');
if not (GetUnitSource(FFileName, S) or GetUnitSource(UnitName, S)) then
JvInterpreterErrorN(ieUnitNotFound, -1, UnitName);
Source := S;
Compile;
FForm := F;
FForm.FUnitName := UnitName;
LoadForm(FForm);
Result := FForm;
end;
procedure TJvInterpreterFm.CreateDfmStream(const UnitName: string; var Stream: TStream);
var
Done: Boolean;
DfmFile: string;
begin
Done := False;
if Assigned(FOnCreateDfmStream) then
FOnCreateDfmStream(Self, UnitName, Stream, Done);
if not Done then
begin
if Assigned(FOnGetDfmFileName) then
FOnGetDfmFileName(Self, UnitName, DfmFile, Done);
if not Done then
DfmFile := FindInPath(ChangeFileExt(UnitName, '.dfm'), ExtractFilePath(FFileName));
Done := FileExists(DfmFile);
if Done then
Stream := TFileStream.Create(DfmFile, fmOpenRead);
end;
if not Done then
JvInterpreterErrorN(ieDfmNotFound, -1, UnitName);
end;
procedure TJvInterpreterFm.FreeDfmStream(Stream: TStream);
begin
if Assigned(FOnFreeDfmStream) then
FOnFreeDfmStream(Self, Stream)
else
Stream.Free;
end;
procedure TJvInterpreterFm.LoadForm(AForm: TJvInterpreterForm);
var
Stream: TStream;
SrcClass: TJvInterpreterIdentifier; // Class Fields support
i: integer;
begin
FForm := AForm;
Form.FJvInterpreterFm := Self;
CreateDfmStream(FForm.FUnitName, Stream);
try
JvInterpreterReadComponentRes(Stream, Form);
finally
FreeDfmStream(Stream);
end;
// find form class
if AForm.FClassIdentifier = '' then
for i:=0 to Adapter.SrcClassList.Count-1 do
if cmp(TJvInterpreterIdentifier(Adapter.SrcClassList[i]).UnitName,FForm.FUnitName) then
begin
FForm.FClassIdentifier := TJvInterpreterIdentifier(Adapter.SrcClassList[i]).Identifier;
Break;
end;
// Class Fields support begin
// copy form fields from pattern
SrcClass := TJvInterpreterAdapterAccessProtected(Adapter).GetSrcClass(
AForm.FClassIdentifier);
if assigned(SrcClass) then
AForm.FFieldList.Assign(TJvInterpreterClass(SrcClass).ClassFields);
// Class Fields support end
try
if Assigned(Form.OnCreate) then
Form.OnCreate(Form);
except
Application.HandleException(Form);
end;
if Form.FormStyle <> fsMDIChild then
Form.Visible := False;
end;
function TJvInterpreterFm.GetValue(const Identifier: string; var Value: Variant;
var Args: TJvInterpreterArgs): Boolean;
var
JvInterpreterSrcClass: TJvInterpreterIdentifier;
JvInterpreterForm: TJvInterpreterForm;
LocalArgs: TJvInterpreterArgs;
function GetFromForm(Form: TJvInterpreterForm): Boolean;
var
Com: TComponent;
begin
if Cmp(Identifier, 'Self') then
begin
Value := O2V(Form);
Result := True;
Exit;
end;
Com := Form.FindComponent(Identifier);
if Com = nil then
begin
if (LocalVars <> nil) and (LocalVars.FindVar('', Identifier) <> nil) then
begin
Result := LocalVars.GetValue(Identifier, Value, Args);
Exit;
end;
// Class Fields support begin
with Form.FFieldList do
if FindVar('', Identifier) <> nil then
begin
Args.Obj:=nil;
Result := GetValue(Identifier, Value, Args);
Exit;
end;
// Class Fields support end
{ may be TForm method or published property }
Args.Obj := Form;
Args.ObjTyp := varObject;
try
Result := inherited GetValue(Identifier, Value, Args);
finally
Args.Obj := nil;
Args.ObjTyp := 0;
end;
end
else
begin
Value := O2V(Com);
Result := True;
end;
end;
begin
if (Args.Obj = nil) and (CurInstance is TJvInterpreterForm) then
Result := GetFromForm(CurInstance as TJvInterpreterForm)
else
if (Args.Obj <> nil) and (Args.ObjTyp = varObject) and
(Args.Obj is TJvInterpreterForm) then
begin
{ run-time form creation }
if Cmp(Identifier, 'Create') then
begin
// setting form's Owner from expression 'create(newOwner)'
// when Identifier = 'Create' then Token = 'newOwner'
JvInterpreterForm := Args.Obj as TJvInterpreterForm;
LocalArgs := TJvInterpreterArgs.Create;
try
LocalArgs.Obj:=Args.Obj;
LocalArgs.ObjTyp:=Args.ObjTyp;
GetValue(Token, Value, LocalArgs);
finally
LocalArgs.Free;
end;
if V2O(Value)<>JvInterpreterForm.Owner then begin
if JvInterpreterForm.Owner<>nil then
JvInterpreterForm.Owner.RemoveComponent(JvInterpreterForm);
if V2O(Value)<>nil then
TComponent(V2O(Value)).InsertComponent(JvInterpreterForm);
end;
JvInterpreterSrcClass := TJvInterpreterAdapterAccessProtected(Adapter).GetSrcClass(
JvInterpreterForm.FClassIdentifier);
JvInterpreterForm.FUnitName := JvInterpreterSrcClass.UnitName;
LoadForm(JvInterpreterForm);
Value := O2V(Args.Obj);
Result := True;
Exit;
end
else
Result := GetFromForm(Args.Obj as TJvInterpreterForm)
end
else
Result := False;
if Result then
Exit;
{ run-time form creation }
JvInterpreterSrcClass := TJvInterpreterAdapterAccessProtected(Adapter).GetSrcClass(Identifier);
if JvInterpreterSrcClass <> nil then
begin
JvInterpreterForm := TJvInterpreterForm.CreateNew(Application);
JvInterpreterForm.FClassIdentifier := Identifier;
Value := O2V(JvInterpreterForm);
Result := True;
Exit;
end;
Result := Result or inherited GetValue(Identifier, Value, Args);
end;
function TJvInterpreterFm.SetValue(const Identifier: string; const Value: Variant;
var Args: TJvInterpreterArgs): Boolean;
// Class Fields support begin
var
JvInterpreterForm: TJvInterpreterForm;
function SetFormValue(Form: TJvInterpreterForm): Boolean;
begin
Result := False;
with Form.FFieldList do
if FindVar('', Identifier) <> nil then begin
Args.Obj := nil;
Result := SetValue(Identifier, Value, Args);
end;
end;
// Class Fields support end
begin
if (Args.Obj = nil) and (CurInstance is TJvInterpreterForm) then
begin
if (LocalVars <> nil) and (LocalVars.FindVar('', Identifier) <> nil) then
begin
Result := LocalVars.SetValue(Identifier, Value, Args);
Exit;
end;
// Class Fields support begin
{ may be TForm field }
Result := SetFormValue(TJvInterpreterForm(CurInstance));
if not Result then
begin
// Class Fields support end
{ may be TForm method or published property }
Args.Obj := CurInstance;
Args.ObjTyp := varObject;
try
Result := inherited SetValue(Identifier, Value, Args);
finally
Args.Obj := nil;
Args.ObjTyp := 0;
end;
end;
end
// Class Fields support begin
else
if (Args.Obj <> nil) and (Args.ObjTyp = varObject) and
(Args.Obj is TJvInterpreterForm) then
begin
JvInterpreterForm := TJvInterpreterForm(Args.Obj);
try
Args.Obj := nil;
Result := SetFormValue(JvInterpreterForm);
finally
Args.Obj := JvInterpreterForm;
end;
end
// Class Fields support end
else
Result := False;
Result := Result or inherited SetValue(Identifier, Value, Args);
end;
function TJvInterpreterFm.GetUnitSource(const UnitName: string; var Source: string): Boolean;
var
FN: TFileName;
begin
if not FInterfaceUses and (UnitSection = usInterface) then
begin
Source := 'unit ' + UnitName + '; end.';
Result := True;
end
else
begin
Result := inherited GetUnitSource(UnitName, Source);
if not Result then
begin
if ExtractFileExt(UnitName) = '' then
FN := UnitName + '.pas'
else
FN := UnitName;
Result := FileExists(FN);
if not Result then
begin
FN := FindInPath(ExtractFileName(FN), ExtractFilePath(FFileName));
Result := FileExists(FN);
end;
if Result then
Source := LoadTextFile(FN)
end;
end;
end;
procedure TJvInterpreterFm.Run;
begin
inherited Run;
end;
function TJvInterpreterFm.RunForm(const FileName: TFileName): TForm;
begin
Result := MakeForm(FileName);
Result.Show;
end;
function TJvInterpreterFm.RunFormModal(const FileName: TFileName): TModalResult;
begin
with MakeForm(FileName) do
try
Result := ShowModal;
finally
Free;
end;
end;
function TJvInterpreterFm.RunUnit(const FileName: TFileName): Variant;
var
UnitName: string;
S: string;
begin
FFileName := FileName;
try
UnitName := ChangeFileExt(ExtractFileName(FFileName), '');
if not (GetUnitSource(FFileName, S) or GetUnitSource(UnitName, S)) then
JvInterpreterErrorN(ieUnitNotFound, -1, UnitName);
Source := S;
except
JvInterpreterErrorN(ieUnitNotFound, -1, FFileName);
end;
Run;
end;
procedure TJvInterpreterFm.RunReportPreview(const FileName: string);
begin
JvInterpreterRunReportPreview2(FileName, Self);
end;
function JvInterpreterRunFormModal(const AFileName: TFileName): TModalResult;
var
TmpInterpreterFm: TJvInterpreterFm;
begin
TmpInterpreterFm := TJvInterpreterFm.Create(Application);
try
Result := TmpInterpreterFm.RunFormModal(AFileName);
finally
TmpInterpreterFm.Free;
end;
end;
function JvInterpreterRunForm(const AFileName: TFileName): TForm;
var
TmpInterpreterFm: TJvInterpreterFm;
begin
TmpInterpreterFm := TJvInterpreterFm.Create(Application);
begin
Result := TmpInterpreterFm.RunForm(AFileName);
(Result as TJvInterpreterForm).FFreeJvInterpreterFm := True;
end;
end;
function JvInterpreterMakeForm(const AFileName: TFileName): TForm;
var
TmpInterpreterFm: TJvInterpreterFm;
begin
TmpInterpreterFm := TJvInterpreterFm.Create(Application);
begin
Result := TmpInterpreterFm.MakeForm(AFileName);
(Result as TJvInterpreterForm).FFreeJvInterpreterFm := True;
end;
end;
function JvInterpreterRunUnit(const AFileName: TFileName): Variant;
var
TmpInterpreterFm: TJvInterpreterFm;
begin
TmpInterpreterFm := TJvInterpreterFm.Create(Application);
try
Result := TmpInterpreterFm.RunUnit(AFileName);
finally
TmpInterpreterFm.Free;
end;
end;
{ adapter to self }
{ function JvInterpreterRunFormModal(const FileName: TFileName): TModalResult; }
procedure JvInterpreter_JvInterpreterRunFormModal(var Value: Variant; Args: TJvInterpreterArgs);
begin
Value := JvInterpreterRunFormModal(Args.Values[0]);
end;
{ function JvInterpreterRunForm(const FileName: TFileName): TForm; }
procedure JvInterpreter_JvInterpreterRunForm(var Value: Variant; Args: TJvInterpreterArgs);
begin
Value := O2V(JvInterpreterRunForm(Args.Values[0]));
end;
{ function JvInterpreterMakeForm(const FileName: TFileName): TForm; }
procedure JvInterpreter_JvInterpreterMakeForm(var Value: Variant; Args: TJvInterpreterArgs);
begin
Value := O2V(JvInterpreterMakeForm(Args.Values[0]));
end;
{ function JvInterpreterRunUnit(const FileName: TFileName): Variant }
procedure JvInterpreter_JvInterpreterRunUnit(var Value: Variant; Args: TJvInterpreterArgs);
begin
Value := JvInterpreterRunUnit(Args.Values[0]);
end;
procedure JvInterpreterRunReportPreview(const AFileName: string);
begin
if not Assigned(JvInterpreterRunReportPreviewProc) then
raise EJVCLException.CreateRes(@RsENoReportProc);
JvInterpreterRunReportPreviewProc(AFileName);
end;
procedure JvInterpreterRunReportPreview2(const AFileName: string; JvInterpreterProgram: TJvInterpreterFm);
begin
if not Assigned(JvInterpreterRunReportPreview2Proc) then
raise EJVCLException.CreateRes(@RsENoReportProc2);
JvInterpreterRunReportPreview2Proc(AFileName, JvInterpreterProgram);
end;
procedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);
const
cJvInterpreterFm = 'JvInterpreterFm';
begin
with JvInterpreterAdapter do
begin
AddFunction(cJvInterpreterFm, 'JvInterpreterRunFormModal', JvInterpreter_JvInterpreterRunFormModal, 1, [varString],
varEmpty);
AddFunction(cJvInterpreterFm, 'JvInterpreterRunForm', JvInterpreter_JvInterpreterRunForm, 1, [varString], varEmpty);
AddFunction(cJvInterpreterFm, 'JvInterpreterMakeForm', JvInterpreter_JvInterpreterMakeForm, 1, [varString], varEmpty);
AddFunction(cJvInterpreterFm, 'JvInterpreterRunUnit', JvInterpreter_JvInterpreterRunUnit, 1, [varString], varEmpty);
end;
end;
end.

798
components/jvcllaz/run/JvPascalInterpreter/JvInterpreterParser.pas Normal file
View File

@ -0,0 +1,798 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvInterpreterParser.PAS, released on 2002-07-04.
The Initial Developers of the Original Code are: Andrei Prygounkov <a dott prygounkov att gmx dott de>
Copyright (c) 1999, 2002 Andrei Prygounkov
All Rights Reserved.
Contributor(s): Peter Schraut (http://www.console-de.de)
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Description : Parser for JVCL Interpreter version 2
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
{ history (JVCL Library versions):
Upcoming JVCL 3.00
- peter schraut added shl, shr and xor support
}
unit JvInterpreterParser;
{$mode objfpc}{$H+}
interface
uses
SysUtils;
type
TTokenKind = type Integer;
TJvInterpreterParser = class(TObject)
private
FSource: string;
FPCPos: PChar; { current parse position }
procedure SetSource(const Value: string);
function GetPos: Integer;
procedure SetPos(Value: Integer);
public
{ Token - returns next token }
function Token: string;
procedure Init;
property Source: string read FSource write SetSource;
property PCPos: PChar read FPCPos write FPCPos;
property Pos: Integer read GetPos write SetPos;
end;
//JvInterpreterError = class(Exception)
//
//end;
TPriorLevel = 0..8;
{ tokenizer }
function TokenTyp(const Token: string): TTokenKind;
{ return operation priority }
function Prior(const TTyp: TTokenKind): TPriorLevel;
function TypToken(const TTyp: TTokenKind): string;
{ Token types }
const
ttUnknown = -1; { unknown error - internal error in most cases - for debugging }
ttEmpty = 0; { end of file - eof }
ttIdentifier = 10; { Identifier }
ttInteger = 11; { Integer constant }
ttDouble = 12; { double constant }
ttString = 13; { string constant }
ttBoolean = 14; { boolean - variable type }
ttLB = 40; { ( }
ttRB = 41; { ) }
ttCol = 42; { , }
ttPoint = 43; { . }
ttColon = 44; { : }
ttSemicolon = 45; { ; }
ttLS = 46; { [ }
ttRS = 47; { ] }
ttDoublePoint = 48; {..}
ttDoubleQuote = 49; {"}
ttFalse = 63; { false }
ttTrue = 65; { true }
ttBegin = 66; { begin }
ttEnd = 67; { end }
ttIf = 68; { if }
ttThen = 69; { then }
ttElse = 70; { else }
ttWhile = 71; { while }
ttDo = 72; { do }
ttRepeat = 73; { repeat }
ttUntil = 74; { until }
ttProcedure = 75; { procedure }
ttFunction = 76; { function }
ttFor = 77; { for }
ttTo = 78; { to }
ttBreak = 79; { break }
ttContinue = 80; { continue }
ttVar = 81; { var }
ttTry = 82; { try }
ttFinally = 83; { finally }
ttExcept = 84; { except }
ttOn = 85; { on }
ttRaise = 86; { raise }
ttExternal = 87; { external }
ttUnit = 88; { unit }
ttUses = 89; { uses }
ttConst = 90; { Const }
ttPublic = 91; { Public }
ttPrivate = 92; { Private }
ttProtected = 93; { Protected }
ttPublished = 94; { Published }
ttProperty = 95; { Property }
ttClass = 96; { Class }
ttType = 97; { Type }
ttInterface = 98; { Interface }
ttImplementation = 99; { Implementation }
ttExit = 100; { Exit }
ttArray = 101; { Array }
ttOf = 102; { Of }
ttCase = 103; { Case }
ttProgram = 104; { Program }
ttIn = 105; { In }
ttRecord = 106; { Record }
ttDownTo = 107; { DownTo }
{ priority 8 - highest }
ttNot = 21; { not }
{ priority 6 }
ttMul = 22; { * }
ttDiv = 23; { / }
ttIntDiv = 24; { div }
ttMod = 25; { mod }
{ priority 5 }
ttAnd = 26; { and }
{ priority 4 }
ttPlus = 27; { + }
ttMinus = 28; { - }
ttOr = 29; { or }
{ priority 3 }
ttEqu = 30; { = }
ttGreater = 31; { > }
ttLess = 32; { < }
ttNotEqu = 33; { <> }
{ priority 2 }
ttEquGreater = 34; { >= }
ttEquLess = 35; { <= }
{ priority 6 }
ttShl = 36; { shl } // [peter schraut: added on 2005/08/14]
ttShr = 37; { shr } // [peter schraut: added on 2005/08/14]
{ priority 3 }
ttXor = 38; { xor } // [peter schraut: added on 2005/08/14]
{ priority 1 - lowest }
{ nothing }
priorNot = 8;
priorMul = 6;
priorDiv = 6;
priorIntDiv = 6;
priorMod = 6;
priorAnd = 5;
priorPlus = 4;
priorMinus = 4;
priorOr = 4;
priorEqu = 3;
priorGreater = 3;
priorLess = 3;
priorNotEqu = 3;
priorEquGreater = 2;
priorEquLess = 2;
priorShl = 6; // [peter schraut: added on 2005/08/14]
priorShr = 6; // [peter schraut: added on 2005/08/14]
priorXor = 3; // [peter schraut: added on 2005/08/14]
ttFirstExpression = 10; { tokens for expression }
ttLastExpression = 59; { }
{ keywords }
kwTRUE = 'true';
kwFALSE = 'false';
kwOR = 'or';
kwAND = 'and';
kwNOT = 'not';
kwDIV = 'div';
kwMOD = 'mod';
kwBEGIN = 'begin';
kwEND = 'end';
kwIF = 'if';
kwTHEN = 'then';
kwELSE = 'else';
kwWHILE = 'while';
kwDO = 'do';
kwREPEAT = 'repeat';
kwUNTIL = 'until';
kwPROCEDURE = 'procedure';
kwFUNCTION = 'function';
kwFOR = 'for';
kwTO = 'to';
kwBREAK = 'break';
kwCONTINUE = 'continue';
kwVAR = 'var';
kwTRY = 'try';
kwFINALLY = 'finally';
kwEXCEPT = 'except';
kwON = 'on';
kwRAISE = 'raise';
kwEXTERNAL = 'external';
kwUNIT = 'unit';
kwUSES = 'uses';
kwCONST = 'const';
kwPUBLIC = 'public';
kwPRIVATE = 'private';
kwPROTECTED = 'protected';
kwPUBLISHED = 'published';
kwPROPERTY = 'property';
kwCLASS = 'class';
kwTYPE = 'type';
kwINTERFACE = 'interface';
kwIMPLEMENTATION = 'implementation';
kwEXIT = 'exit';
kwARRAY = 'array';
kwOF = 'of';
kwCASE = 'case';
kwPROGRAM = 'program';
kwIN = 'in';
kwRECORD = 'record';
kwDOWNTO = 'downto';
kwNIL = 'nil';
kwSHL = 'shl'; // [peter schraut: added on 2005/08/14]
kwSHR = 'shr'; // [peter schraut: added on 2005/08/14]
kwXOR = 'xor'; // [peter schraut: added on 2005/08/14]
{ directives }
drNAME = 'name';
drINDEX = 'index';
implementation
uses
{$IFNDEF COMPILER12_UP}
JvJCLUtils,
{$ENDIF ~COMPILER12_UP}
JvInterpreter, JvInterpreterConst, JvConsts, Windows;
const
K = '''';
{*********************** tokenizer ***********************}
{ modified algorithm from mozilla source }
type
TTokenTag = record
// (rom) changed to PChar to get rid of hidden initialization section
Token: PChar;
TTyp: TTokenKind;
end;
const
P_UNKNOWN = -1;
MIN_WORD_LENGTH = 2;
MAX_WORD_LENGTH = 14; { = length('implementation') }
// [peter schraut: added on 2005/08/14]
// Created new HashTable to avoid collisions
// with added keywords such as shl, shr and xor
// Mantis 3333 (ivan_ra): optimized version
AssoIndices: array [0..31] of Integer = (
{ 0 1 2 3 4 5 6 7 8 9 }
{00} 50, 80, 25, 13, 92, 71, 87, 61, 91, 99,
{10} 73, 95, 27, 7, 16, 1, 96, 41, 91, 99,
{20} 19, 15, 72, 1, 50, 30, 9, 6, 45, 27,
{30} 79, 61);
AssoValues: array [0..255] of Integer = (
{ 0 1 2 3 4 5 6 7 8 9 }
{00} -1, -1, -1, -1, -1, -1, 44, 10, -1, -1,
{10} 37, -1, -1, -1, -1, 7, -1, -1, -1, -1,
{20} -1, -1, -1, 27, -1, -1, -1, -1, -1, -1,
{30} -1, 41, 26, -1, -1, 20, -1, -1, -1, 28,
{40} -1, 30, 39, -1, -1, -1, -1, 13, -1, -1,
{50} -1, -1, -1, -1, -1, -1, -1, 1, -1, -1,
{60} -1, -1, -1, -1, -1, 12, -1, -1, -1, -1,
{70} -1, -1, 6, -1, -1, -1, -1, -1, -1, -1,
{80} 34, -1, -1, -1, -1, -1, 3, -1, -1, 49,
{90} -1, -1, 45, -1, -1, -1, -1, -1, -1, -1,
{100} 2, -1, 51, -1, -1, -1, -1, 46, -1, -1,
{110}-1, -1, 17, -1, -1, -1, 36, -1, 11, -1,
{120}-1, -1, 35, 48, -1, -1, -1, -1, 8, -1,
{130}-1, 32, -1, 19, -1, -1, -1, 5, -1, -1,
{140}40, -1, -1, -1, -1, -1, -1, -1, 21, -1,
{150}22, -1, 31, -1, -1, -1, -1, -1, -1, 16,
{160}43, -1, -1, -1, -1, -1, -1, -1, -1, -1,
{170}-1, -1, 18, -1, -1, -1, -1, 47, -1, -1,
{180}-1, -1, -1, -1, -1, -1, -1, 42, -1, -1,
{190}-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
{200}-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
{210}-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
{220}29, -1, -1, 25, 4, 15, 24, -1, -1, -1,
{230}-1, -1, 33, -1, -1, 9, -1, 50, -1, 14,
{240}-1, -1, -1, 23, -1, -1, 38, -1, -1, -1,
{250}-1, -1, -1, -1, -1, 0);
WordList: array [0..51] of TTokenTag = (
(Token: kwTRUE; TTyp: ttTrue),
(Token: kwFALSE; TTyp: ttFalse),
(Token: kwOR; TTyp: ttOr),
(Token: kwAND; TTyp: ttAnd),
(Token: kwNOT; TTyp: ttNot),
(Token: kwDIV; TTyp: ttIntDiv),
(Token: kwMOD; TTyp: ttMod),
(Token: kwBEGIN; TTyp: ttBegin),
(Token: kwEND; TTyp: ttEnd),
(Token: kwIF; TTyp: ttIf),
(Token: kwTHEN; TTyp: ttThen),
(Token: kwELSE; TTyp: ttElse),
(Token: kwWHILE; TTyp: ttWhile),
(Token: kwDO; TTyp: ttDo),
(Token: kwREPEAT; TTyp: ttRepeat),
(Token: kwUNTIL; TTyp: ttUntil),
(Token: kwPROCEDURE; TTyp: ttProcedure),
(Token: kwFUNCTION; TTyp: ttFunction),
(Token: kwFOR; TTyp: ttFor),
(Token: kwTO; TTyp: ttTo),
(Token: kwBREAK; TTyp: ttBreak),
(Token: kwCONTINUE; TTyp: ttContinue),
(Token: kwVAR; TTyp: ttVar),
(Token: kwTRY; TTyp: ttTry),
(Token: kwFINALLY; TTyp: ttFinally),
(Token: kwEXCEPT; TTyp: ttExcept),
(Token: kwON; TTyp: ttOn),
(Token: kwRAISE; TTyp: ttRaise),
(Token: kwEXTERNAL; TTyp: ttExternal),
(Token: kwUNIT; TTyp: ttUnit),
(Token: kwUSES; TTyp: ttUses),
(Token: kwCONST; TTyp: ttConst),
(Token: kwPUBLIC; TTyp: ttPublic),
(Token: kwPRIVATE; TTyp: ttPrivate),
(Token: kwPROTECTED; TTyp: ttProtected),
(Token: kwPUBLISHED; TTyp: ttPublished),
(Token: kwPROPERTY; TTyp: ttProperty),
(Token: kwCLASS; TTyp: ttClass),
(Token: kwTYPE; TTyp: ttType),
(Token: kwINTERFACE; TTyp: ttInterface),
(Token: kwIMPLEMENTATION; TTyp: ttImplementation),
(Token: kwEXIT; TTyp: ttExit),
(Token: kwARRAY; TTyp: ttArray),
(Token: kwOF; TTyp: ttOf),
(Token: kwCASE; TTyp: ttCase),
(Token: kwPROGRAM; TTyp: ttProgram),
(Token: kwIN; TTyp: ttIn),
(Token: kwRECORD; TTyp: ttRecord),
(Token: kwDOWNTO; TTyp: ttDownTo),
(Token: kwSHL; TTyp: ttShl), // [peter schraut: added on 2005/08/14]
(Token: kwSHR; TTyp: ttShr), // [peter schraut: added on 2005/08/14]
(Token: kwXOR; TTyp: ttXor) // [peter schraut: added on 2005/08/14]
);
{ convert string into token number using hash tables }
// [peter schraut: added on 2005/08/14]
// Made a few changes to PaTokenizeTag to work with new hashtable.
// Mantis 3333 (ivan_ra): optimized version
function PaTokenizeTag(const TokenStr: string): TTokenKind;
var
Len, I: Integer;
HVal: Integer;
begin
Result := P_UNKNOWN;
HVal := -1;
Len := Length(TokenStr);
if (MIN_WORD_LENGTH <= Len) and (Len <= MAX_WORD_LENGTH) then
begin
HVal := Len;
for I:=1 to Len do
begin
HVal := HVal + AssoIndices[(Byte(TokenStr[I]) - Byte('a')) and $1F];
if I = 3 then
Break;
end;
HVal := HVal + AssoIndices[(Byte(TokenStr[Len]) - Byte('a')) and $1F];
HVal := HVal and 255; {High(AssoValues)}
HVal := AssoValues[HVal];
end;
if HVal <> -1 then
if Cmp(WordList[HVal].Token, TokenStr) then
Result := WordList[HVal].TTyp;
end;
const
{ !"#$%&'()*+,-./0123456789:;<=>? }
Asso1Values: array [' '..'?'] of Integer =
(-1, -1, -1, -1, -1, -1, -1, -1,
ttLB, ttRB, ttMul, ttPlus, ttCol, ttMinus, ttPoint, ttDiv,
ttInteger, ttInteger, ttInteger, ttInteger, ttInteger,
ttInteger, ttInteger, ttInteger, ttInteger, ttInteger,
ttColon, ttSemicolon, ttLess, ttEqu, ttGreater, -1);
{######################## tokenizer ########################}
function TokenTyp(const Token: string): TTokenKind;
var
I: Integer;
L1: Integer;
T1: Char;
Ci: Char;
Point: Boolean;
IsScientificNotation: Boolean;
label { Sorry about labels and gotos - for speed-ups only }
Any, NotNumber;
begin
L1 := Length(Token);
if L1 = 0 then
begin
Result := ttEmpty;
Exit;
end;
T1 := Token[1];
if L1 = 1 then
begin
{ Result := pa_tokenize_1tag(Token[1]);
if Result = -1 then goto Any; }
if CharInSet(T1, ['('..'>']) then { #40..#62 }
Result := Asso1Values[T1]
else
if T1 = '[' then
Result := ttLS
else
if T1 = ']' then
Result := ttRS
else
if T1 = '"' then
Result := ttDoubleQuote
else
goto Any;
end
else
case T1 of
'.':
{ may be '..' }
begin
if Token[2] = '.' then
Result := ttDoublePoint
else
goto Any;
end;
'$':
{ may be hex constant }
begin
for I := 2 to L1 do
if not CharInSet(Token[I], StConstSymbols) then
goto Any;
Result := ttInteger;
end;
'<':
if L1 = 2 then
case Token[2] of
'=': Result := ttEquLess;
'>': Result := ttNotEqu;
else
goto Any;
end
else
goto Any;
'>':
if (L1 = 2) and (Token[2] = '=') then
Result := ttEquGreater
else
goto Any;
else
begin
Any: { !!LABEL!! }
Point := False;
IsScientificNotation := False;
for I := 1 to L1 do
begin
Ci := Token[I];
if CharInSet(Ci, StConstE) then
IsScientificNotation := True;
if Ci = '.' then
if Point then
goto NotNumber {two Points in lexem}
else
Point := True
else
if not CharInSet(Ci, StConstSymbols10e) then
goto NotNumber { not number }
end;
if Point or IsScientificNotation then
Result := ttDouble
else
Result := ttInteger;
Exit;
NotNumber: { !!LABEL!! }
if (L1 >= 2) and (Token[1] = '''') and (Token[L1] = '''') then
Result := ttString
else
begin
{ keywords }
Result := PaTokenizeTag(Token);
if Result <> -1 then
begin
end
else
{ may be Identifier } // National symbols for OLE automation
if not (CharInSet(T1, StIdFirstSymbols) or IsCharAlpha(T1)) then
Result := ttUnknown
else
begin
for I := 2 to L1 do
if not (CharInSet(Token[I], StIdSymbols) or IsCharAlpha(Token[I])) then
begin
Result := ttUnknown;
Exit;
end;
Result := ttIdentifier;
end;
end;
end;
end;
end;
function TypToken(const TTyp: TTokenKind): string;
begin
Result := '?? not implemented !!'; { DEBUG !! }
end;
function Prior(const TTyp: TTokenKind): TPriorLevel;
const
Priors: array [ttNot..ttXor] of TPriorLevel =
(priorNot, priorMul, priorDiv, priorIntDiv, priorMod, priorAnd, priorPlus,
priorMinus, priorOr, priorEqu, priorGreater, priorLess,
priorNotEqu, priorEquGreater, priorEquLess,
priorShl, priorShr, priorXor); // [peter schraut: added priorShl, priorShr, priorXor on 2005/08/14]
begin
//if TTyp in [ttNot..ttEquLess] then
if TTyp in [ttNot..ttXor] then // [peter schraut: expanded to ttXor on 2005/08/14]
Result := Priors[TTyp]
else
Result := 0;
end;
//=== { TJvInterpreterParser } ===============================================
procedure TJvInterpreterParser.SetSource(const Value: string);
begin
FSource := Value;
Init;
end;
procedure TJvInterpreterParser.Init;
begin
FPCPos := PChar(FSource);
end;
function TJvInterpreterParser.Token: string;
var
P, F: PChar;
F1: PChar;
I: Integer;
PrevPoint: Boolean;
PointOccurred, ExponentOccurred: Boolean;
procedure Skip;
begin
case P[0] of
'{':
begin
F := StrScan(P + 1, '}');
if F = nil then
JvInterpreterError(ieBadRemark, P - PChar(FSource));
P := F + 1;
end;
'(':
if P[1] = '*' then
begin
F := P + 2;
while True do
begin
F := StrScan(F, '*');
if F = nil then
JvInterpreterError(ieBadRemark, P - PChar(FSource));
if F[1] = ')' then
begin
Inc(F);
Break;
end;
Inc(F);
end;
P := F + 1;
end;
'}':
JvInterpreterError(ieBadRemark, P - PChar(FSource));
'*':
if (P[1] = ')') then
JvInterpreterError(ieBadRemark, P - PChar(FSource));
'/':
if (P[1] = '/') then
while not CharInSet(P[0], [Lf, Cr, #0]) do
Inc(P);
end;
while CharInSet(P[0], [' ', Lf, Cr, Tab]) do
Inc(P);
end;
begin
PointOccurred := False;
ExponentOccurred := False;
{ New Token }
F := FPCPos;
P := FPCPos;
PrevPoint:=false;
if (P > PChar(FSource))
and (P[-1] = '.')
then
PrevPoint := true;
{ Firstly skip spaces and remarks }
repeat
F1 := P;
Skip;
until F1 = P;
F := P; // National symbols for OLE automation
if CharInSet(P[0], StIdFirstSymbols) or PrevPoint and IsCharAlpha(P[0]) then
{ token }
begin
while CharInSet(P[0], StIdSymbols) or PrevPoint and IsCharAlpha(P[0]) do
Inc(P);
SetString(Result, F, P - F);
end
else
if CharInSet(P[0], StConstSymbols10) then
{ number }
begin
while CharInSet(P[0], StConstSymbols10e) or (P[0] = '.') do
begin
if P[0] = '.' then
begin
if PointOccurred or // radix point can occur zero or one time
not CharInSet(P[-1], StConstSymbols10) or // radix point must be behind a number
(P[1] = '.') then
Break;
PointOccurred:=True;
end
else
begin
if CharInSet(P[0], StConstE) then
begin
if ExponentOccurred // only one time, at most
or not CharInSet(P[-1], StConstSymbols10) then // must be behind a number
Break;
ExponentOccurred := True;
end
else
begin
if CharInSet(P[0],StConstPlusSub) then
begin
if not CharInSet(P[-1],StConstE) then // +/- must be behind E
Break;
end;
end;
end;
Inc(P);
end;
SetString(Result, F, P - F);
end
else
if ((P[0] = '$') and
CharInSet(P[1], StConstSymbols)) then
{ hex number }
begin
Inc(P);
while CharInSet(P[0], StConstSymbols) do
Inc(P);
SetString(Result, F, P - F);
end
else
if P[0] = '''' then
{ string constant }
begin
Inc(P);
while not CharInSet(P[0], [Lf, Cr, #0]) do
begin
if P[0] = '''' then
if P[1] = '''' then
Inc(P)
else
Break;
Inc(P);
end;
Inc(P);
SetString(Result, F, P - F);
I := 2;
while I < Length(Result) - 1 do
begin
if Result[I] = '''' then
Delete(Result, I, 1);
Inc(I);
end;
end
else
if ((P[0] = '#') and
CharInSet(P[1], StConstSymbols10)) then
{ Char constant }
begin
Inc(P);
while CharInSet(P[0], StConstSymbols10) do
Inc(P);
SetString(Result, F + 1, P - F - 1);
Result := '''' + Chr(StrToInt(Result)) + '''';
end
else
if CharInSet(P[0], ['>', '=', '<', '.']) then
begin
if (P[0] = '.') and (P[1] = '.') then
begin
Result := '..';
Inc(P, 2);
end
else
if (P[0] = '>') and (P[1] = '=') then
begin
Result := '>=';
Inc(P, 2);
end
else
if (P[0] = '<') and (P[1] = '=') then
begin
Result := '<=';
Inc(P, 2);
end
else
if (P[0] = '<') and (P[1] = '>') then
begin
Result := '<>';
Inc(P, 2);
end
else
begin
Result := P[0];
Inc(P);
end;
end
else
if P[0] = #0 then
Result := ''
else
begin
Result := P[0];
Inc(P);
end;
FPCPos := P;
end;
function TJvInterpreterParser.GetPos: Integer;
begin
Result := FPCPos - PChar(FSource);
end;
procedure TJvInterpreterParser.SetPos(Value: Integer);
begin
FPCPos := PChar(FSource) + Value;
end;
end.